$CONTROL LIST, MAP, VERBS
IDENTIFICATION DIVISION.
PROGRAM-ID. COBOL-EXAMPLE.
*****
***** This application collects employee payroll deduction
***** transactions and places the edited transactions into
***** a file.
*****
***** For this application: Enter key = edit and file
***** transaction;
*****
***** f8 = exit application;
*****
***** all other f keys = redo transaction.
*****
***** Each transaction entered by the operator is subjected to the
***** data edits embedded within the input form.
*****
***** The application continues to collect transactions until either
***** the operator signals to exit or a system error is detected.
*****
ENVIRONMENT DIVISION.
INPUT-OUTPUT SECTION.
FILE-CONTROL.
SELECT TXN-ENTRY ASSIGN TO "PAYTXN".
DATA DIVISION.
FILE SECTION.
FD TXN-ENTRY
RECORD CONTAINS 200 CHARACTERS
DATA RECORDS ARE TXN-REC.
01 TXN-REC.
05 FILLER PIC X(200).
WORKING-STORAGE SECTION.
01 COMAREA.
05 CSTATUS PIC S9(4) COMP VALUE 0.
05 LANGUAGE PIC S9(4) COMP VALUE 0.
05 COMAREALEN PIC S9(4) COMP VALUE 0.
05 USERBUFLEN PIC S9(4) COMP VALUE 0.
05 CMODE PIC S9(4) COMP VALUE 0.
05 LASTKEY PIC S9(4) COMP VALUE 0.
05 NUMERRS PIC S9(4) COMP VALUE 0.
05 WINDOWENH PIC S9(4) COMP VALUE 0.
05 MULTIUSAGE PIC S9(4) COMP VALUE 0.
05 LABELOPTIONS PIC S9(4) COMP VALUE 0.
05 CFNAME PIC X(16) VALUE SPACES.
05 NFNAME PIC X(16) VALUE SPACES.
05 REPEATAPP PIC S9(4) COMP VALUE 0.
05 FREEZEAPP PIC S9(4) COMP VALUE 0.
05 CFNUMLINES PIC S9(4) COMP VALUE 0.
05 DBUFLEN PIC S9(4) COMP VALUE 0.
05 FILLER PIC S9(4) COMP VALUE 0.
05 LOOKAHEAD PIC S9(4) COMP VALUE 0.
05 DELETEFLAG PIC S9(4) COMP VALUE 0.
05 SHOWCONTROL PIC S9(4) COMP VALUE 0.
05 FILLER PIC S9(4) COMP VALUE 0.
05 PRINTFILENUM PIC S9(4) COMP VALUE 0.
05 FILERRNUM PIC S9(4) COMP VALUE 0.
05 ERRFILENUM PIC S9(4) COMP VALUE 0.
05 FORMSTORESIZE PIC S9(4) COMP VALUE 0.
05 FILLER PIC S9(4) COMP VALUE 0.
05 FILLER PIC S9(4) COMP VALUE 0.
05 FILLER PIC S9(4) COMP VALUE 0.
05 NUMRECS PIC S9(8) COMP VALUE 0.
05 RECNUM PIC S9(8) COMP VALUE 0.
05 FILLER PIC S9(4) COMP VALUE 0.
05 FILLER PIC S9(4) COMP VALUE 0.
05 TERMFILEN PIC S9(4) COMP VALUE 0.
05 FILLER PIC S9(4) COMP VALUE 0.
05 FILLER PIC S9(4) COMP VALUE 0.
05 FILLER PIC S9(4) COMP VALUE 0.
05 FILLER PIC S9(4) COMP VALUE 0.
05 FILLER PIC S9(4) COMP VALUE 0.
05 RETRIES PIC S9(4) COMP VALUE 0.
05 TERMOPTIONS PIC S9(4) COMP VALUE 0.
05 ENVIRON PIC S9(4) COMP VALUE 0.
05 USERTIME PIC S9(4) COMP VALUE 0.
05 IDENTIFIER PIC S9(4) COMP VALUE 0.
05 LABELINFO PIC S9(4) COMP VALUE 0.
01 FIELDINFO.
05 NUM-ENTRIES PIC S9(4) COMP.
05 ENTRY-LEN PIC S9(4) COMP.
05 FORM-NAME PIC X(16).
05 FIELD-ENTRY OCCURS 3 TIMES.
10 FIELD-NAME PIC X(16).
10 SCREEN-ORDER PIC S9(4) COMP.
01 FIELDSPECS.
05 SPEC-ENTRY OCCURS 3 TIMES.
10 FIELD-ID PIC S9(4) COMP.
10 CHANGE-TYPE PIC S9(4) COMP.
10 CHANGE-SPEC PIC X(4).
01 DATABUF PIC X(200).
01 DATABUFLEN PIC S9(4) COMP.
01 DONE-WITH-TRANSACTIONS PIC X.
01 ERROR-LOCATION PIC X(70).
01 FILENAME PIC X(86).
01 FOUND-DATA-ERRORS PIC X.
01 INFOBUFLEN PIC S9(4) COMP.
01 MSGBUF PIC X(150).
01 MSGBUFLEN PIC S9(4) COMP.
01 ERRMSGLEN PIC S9(4) COMP.
01 NBR-TXN-COLLECTED PIC 9(4).
01 NUMSPECS PIC S9(4) COMP.
01 STOP-NOW PIC X.
PROCEDURE DIVISION.
A-000-START-PROGRAM.
MOVE "N" TO STOP-NOW
DONE-WITH-TRANSACTIONS.
MOVE ZERO TO NBR-TXN-COLLECTED.
PERFORM A-100-SETUP-FOR-WORK.
PERFORM A-500-COLLECT-TRANSACTIONS
UNTIL STOP-NOW = "Y"
OR DONE-WITH-TRANSACTIONS = "Y".
PERFORM A-900-CLEANUP-AFTER-WORK.
DISPLAY " ".
DISPLAY "Deduction transactions collected this session = "
NBR-TXN-COLLECTED.
IF STOP-NOW = "Y"
PERFORM Z-900-DISPLAY-SYSTEM-ERROR.
STOP RUN.
A-100-SETUP-FOR-WORK.
*****
***** Finish Comarea initialization.
*****
***** (Note Comarea value clauses.)
*****
*****
***** Set Language for COBOL.
*****
MOVE ZERO TO LANGUAGE OF COMAREA.
*****
***** Set Comarealen to 60 words (120 bytes).
*****
MOVE 60 TO COMAREALEN OF COMAREA.
*****
***** Activate function key labeling.
*****
MOVE 1 TO LABELOPTIONS OF COMAREA.
*****
***** Disable form background loading on Vreadfields.
*****
MOVE ZERO TO LOOKAHEAD OF COMAREA.
*****
***** Set size of local form storage directory.
*****
MOVE 4 TO FORMSTORESIZE OF COMAREA.
*****
***** Open the Transaction File
*****
OPEN OUTPUT TXN-ENTRY.
*****
***** Open the Forms File.
*****
MOVE "PAYROLL.WORK.ADMIN" TO FILENAME.
CALL "VOPENFORMF" USING COMAREA
FILENAME.
IF CSTATUS OF COMAREA NOT = 0
MOVE "Y" TO STOP-NOW
MOVE
"**** Paragraph: A-100-SETUP-FOR-WORK - Forms File Open"
TO ERROR-LOCATION
PERFORM Z-100-GET-ERROR-MESSAGE.
IF STOP-NOW NOT = "Y"
*****
***** Open the Terminal.
*****
MOVE "HPTERM" TO FILENAME
CALL "VOPENTERM" USING COMAREA
FILENAME
IF CSTATUS OF COMAREA NOT = 0
MOVE "Y" TO STOP-NOW
MOVE
"**** Paragraph: A-100-SETUP-FOR-WORK - Terminal Setu
"p"
TO ERROR-LOCATION
PERFORM Z-100-GET-ERROR-MESSAGE.
IF STOP-NOW NOT = "Y"
*****
***** Translate field names to screen orders.
*****
***** Three of the fields in the form used by this
***** application need to be toggled from "display
***** only" to "input allowed". In order to do this,
***** we first translate field names to screen orders.
*****
MOVE 3 TO NUM-ENTRIES OF FIELDINFO
MOVE 9 TO ENTRY-LEN OF FIELDINFO
MOVE "DEDUCTION" TO FORM-NAME OF FIELDINFO
*****
***** The value 8224, which is moved to Screen Order in
***** the following statements is equal to two ASCII blanks.
*****
MOVE "BADGE_NUMBER" TO FIELD-NAME
OF FIELD-ENTRY (1)
MOVE 8224 TO SCREEN-ORDER
OF FIELD-ENTRY (1)
MOVE "LAST-NAME" TO FIELD-NAME
OF FIELD-ENTRY (2)
MOVE 8224 TO SCREEN-ORDER
OF FIELD-ENTRY (2)
MOVE "SUR NAME" TO FIELD-NAME
OF FIELD-ENTRY (3)
MOVE 8224 TO SCREEN-ORDER
OF FIELD-ENTRY (3)
*****
***** Now determine the length of the entire Fieldinfo
***** Buffer.
*****
MULTIPLY NUM-ENTRIES OF FIELDINFO
BY ENTRY-LEN OF FIELDINFO
GIVING INFOBUFLEN
ADD 10 TO INFOBUFLEN
CALL "VGETFIELDINFO" USING COMAREA
FIELDINFO
INFOBUFLEN
IF CSTATUS OF COMAREA NOT = 0
MOVE "Y" TO STOP-NOW
MOVE
"**** Paragraph: A-100-SETUP-FOR-WORK - Field Informa
"tion Retrieval"
TO ERROR-LOCATION
PERFORM Z-100-GET-ERROR-MESSAGE.
A-500-COLLECT-TRANSACTIONS.
*****
***** Setup for and get transaction data entry form.
*****
MOVE ZERO TO REPEATAPP OF COMAREA
FREEZEAPP OF COMAREA.
MOVE "DEDUCTION" TO NFNAME OF COMAREA.
CALL "VGETNEXTFORM" USING COMAREA.
IF CSTATUS OF COMAREA NOT = 0
MOVE "Y" TO STOP-NOW
MOVE
"***** Paragraph: A-500-COLLECTION-TRANSACTIONS - Form R
"etrieval"
TO ERROR-LOCATION
PERFORM Z-100-GET-ERROR-MESSAGE.
IF STOP-NOW NOT = "Y"
*****
***** Toggle three fields in form to "input allowed".
*****
***** Screen order is indicated to field change
***** intrinsic as negative number.
*****
***** Change field type is indicated by a 5.
*****
***** "Input allowed" is indicated by an "O"
***** (for input/output).
*****
MULTIPLY SCREEN-ORDER OF FIELD-ENTRY (1)
BY -1
GIVING FIELD-ID OF SPEC-ENTRY (1)
MOVE 5 TO CHANGE-TYPE OF SPEC-ENTRY (1)
MOVE "O" TO CHANGE-SPEC OF SPEC-ENTRY (1)
MULTIPLY SCREEN-ORDER OF FIELD-ENTRY (2)
BY -1
GIVING FIELD-ID OF SPEC-ENTRY (2)
MOVE 5 TO CHANGE-TYPE OF SPEC-ENTRY (2)
MOVE "O" TO CHANGE-SPEC OF SPEC-ENTRY (2)
MULTIPLY SCREEN-ORDER OF FIELD-ENTRY (3)
BY -1
GIVING FIELD-ID OF SPEC-ENTRY (3)
MOVE 5 TO CHANGE-TYPE OF SPEC-ENTRY (3)
MOVE "O" TO CHANGE-SPEC OF SPEC-ENTRY (3)
MOVE 3 TO NUMSPECS
CALL "VCHANGEFIELD" USTNG COMAREA
FIELDSPES
NUMSPECS
IF CSTATUS OF COMAREA NOT = 0
MOVE "Y" TO STOP-NOW
MOVE
"**** Paragraph: A-500-COLLECT-TRANSACTIONS - Field
"Type Updates"
TO ERROR-LOCATION
PERFORM Z-100-GET-ERROR-MESSAGE.
IF STOP-NOW NOT = "Y"
*****
***** Load window message.
*****
MOVE 79 TO MSGBUFLEN
MOVE
"Fill in Deduction Transaction according to worksheet."
TO MSGBUF
CALL "VPUTWINDOW" USING COMAREA
MSGBUF
MSGUFLEN
IF CSTATUS OF COMAREA NOT = 0
MOVE "Y" TO STOP-NOW
MOVE
"**** Paragraph: A-500-COLLECT-TRANSACTIONS - Window
<...sc><...x>
<ex><esc>
"Load"
TO ERROR-LOCATION
PERFORM Z-100-GET-ERROR-MESSAGE.
IF STOP-NOW NOT = "Y"
*****
***** Initialize form.
*****
CALL "VINITFORM" USING COMAREA
IF CSTATUS OF COMAREA NOT = 0
MOVE "Y" TO STOP-NOW
MOVE
"**** Paragraph: A-500-COLLECT-TRANSACTIONS - Form I
"nit "
TO ERROR-LOCATION
PERFORM Z-100-GET-ERROR-MESSAGE.
IF STOP-NOW NOT = "Y"
*****
***** Show form.
*****
CALL "VSHOWFORM" USING COMAREA
IF CSTATUS OF COMAREA NOT = 0
MOVE "Y" TO STOP-NOW
MOVE
"**** Paragraph: A-500-COLLECT-TRANSACTIONS - Form D
"isplay"
TO ERROR-LOCATION
PERFORM Z-100-GET-ERROR-MESSAGE.
IF STOP-NOW NOT = "Y"
*****
***** Setup and loop on transaction until it can be filed.
*****
MOVE "Y" TO FOUND-DATA-ERRORS
PERFORM B-100-READ-EDIT-AND-FILE
UNTIL FOUND-DATA-ERRORS = "N"
OR STOP-NOW = "Y"
OR DONE-WITH-TRANSACTIONS = "Y".
B-100-READ-EDIT-AND-FILE.
*****
***** Read form.
*****
CALL "VREADFIELDS" USING COMAREA.
IF CSTATUS OF COMAREA NOT = 0
MOVE "Y" TO STOP-NOW
MOVE
"**** Paragraph: B-100-READ-EDIT-AND-FILE - Terminal Rea
"d"
TO ERROR-LOCATION
PERFORM Z-100-GET-ERROR-MESSAGE.
IF STOP-NOW NOT = "Y"
*****
***** Determine if operator wants to stop transaction collection.
*****
IF LASTKEY OF COMAREA = 1
MOVE "Y" TO DONE-WITH-TRANSACTIONS.
IF STOP-NOW NOT = "Y"
AND DONE-WITH-TRANSACTIONS NOT = "Y"
*****
***** Edit data read from terminal
*****
CALL "VFIELDEDITS" USING COMAREA
IF CSTATUS OF COMAREA NOT = 0
MOVE "Y" TO STOP-NOW
MOVE
"**** Paragraph: B-100-READ-EDIT-AND-FILE - Data Edit
" "
TO ERROR-LOCATION
PERFORM Z-100-GET-ERROR-MESSAGE
ELSE
*****
***** Determine if edit errors detected.
*****
IF NUMERRS OF COMAREA < 1
MOVE "N" TO FOUND-DATA-ERRORS.
IF STOP-NOW NOT = "Y"
AND DONE-WITH-TRANSACTIONS NOT = "Y"
AND FOUND-DATA-ERRORS NOT = "Y"
*****
***** Finish form data.
*****
CALL "VFINISHFORM" USING COMAREA
IF CSTATUS OF COMAREA NOT = 0
MOVE "Y" TO STOP-NOW
MOVE
"**** Paragraph: B-100-READ-EDIT-AND-FILE - Data Fini
"shing"
TO ERROR-LOCATION
PERFORM Z-100-GET-ERROR-MESSAGE
ELSE
*****
***** Determine if data finishing errors detected.
*****
IF NUMERRS OF COMAREA > 0
MOVE "Y" TO FOUND-DATA-ERRORS.
IF STOP-NOW NOT = "Y"
AND DONE-WITH-TRANSACTIONS NOT = "Y"
*****
***** Do we have a transaction that can be filed?
*****
IF FOUND-DATA-ERRORS NOT = "Y"
IF LASTKEY OF COMAREA = 0
*****
***** Get transaction from form and file it.
*****
MOVE SPACES TO DATABUF
MOVE 200 TO DATABUFLEN
CALL "VGETBUFFER" USING COMAREA
DATABUF
DATABUFLEN
IF CSTATUS OF COMAREA NOT = 0
MOVE "Y" TO STOP-NOW
MOVE
"**** Paragraph: B-100-READ-EDIT-AND-FILE - Dat
"a Get"
TO ERROR-LOCATION
PERFORM Z-100-GET-ERROR-MESSAGE
ELSE
WRITE TXN-REC FROM DATABUF
ADD 1 TO NBR-TXN-COLLECTED.
IF STOP-NOW NOT = "Y"
AND DONE-WITH-TRANSACTIONS NOT = "Y"
*****
***** Do we need to prompt the operator to correct errors?
*****
IF FOUND-DATA-ERRORS = "Y"
IF LASTKEY OF COMAREA = 0
PERFORM B-200-PROMPT-OPERATOR.
IF STOP-NOW NOT = "Y"
AND DONE-WITH-TRANSACTIONS NOT = "Y"
*****
***** Do we need to refresh the display?
*****
IF FOUND-DATA-ERRORS = "Y"
IF LASTKEY OF COMAREA NOT = 0
*****
***** The operator pressed some key other than Enter
***** or Exit so clear data error flag to break loop.
*****
MOVE "N" TO FOUND-DATA-ERRORS.
B-200-PROMPT-OPERATOR.
*****
***** Get message text associated with first field flagged
***** with a data error.
*****
PERFORM Z-100-GET-ERROR-MESSAGE.
CALL "VPUTWINDOW" USING COMAREA
MSGBUF
ERRMSGLEN.
IF CSTATUS OF COMAREA NOT = 0
MOVE "Y" TO STOP-NOW
MOVE
"**** Paragraph: B-200-PROMPT-OPERATOR - Window Load"
TO ERROR-LOCATION
PERFORM Z-100-GET-ERROR-MESSAGE.
IF STOP-NOW NOT = "Y"
*****
***** Display highlighted form and updated window message.
*****
CALL "VSHOWFORM" USING COMAREA.
IF CSTATUS OF COMAREA NOT = 0
MOVE "Y" TO STOP-NOW
MOVE
"**** Paragraph: B-200-PROMPT-OPERATOR - Display Upd
"ates"
TO ERROR-LOCATION
PERFORM Z-100-GET-ERROR-MESSAGE.
A-900-CLEANUP-AFTER-WORK.
*****
***** Note that this paragraph unconditionally attempts to
***** close the Forms File and Terminal.
*****
CLOSE TXN-ENTRY.
MOVE 0 to CSTATUS OF COMAREA.
CALL "VCLOSEFORMF" USING COMAREA.
MOVE 0 to CSTATUS OF COMAREA.
CALL "VCLOSETERM" USING COMAREA.
Z-100-GET-ERROR-MESSAGE.
MOVE SPACES TO MSGBUF.
MOVE 150 TO MSGBUFLEN.
CALL "VERRMSG" USING COMAREA
MSGBUF
MSGBUFLEN
ERRMSGLEN
Z-900-DISPLAY-SYSTEM-ERROR.
DISPLAY "**** Transaction entry facility detected system erro
"r at:".
DISPLAY ERROR-LOCATION.
DISPLAY "**** The error message returned is:".
DISPLAY "**** "
MSGBUF.
