 |
» |
|
|
|
Figure B-2 “Structure of Example COBOL II Program” is a chart of the program structure
for the COBOL II TP that runs on the HP 3000. Figure B-2 Structure of Example COBOL II Program 001000$CONTROL CROSSREF,SYMDEBUG
001100*----------------------------------------------------*
001200 IDENTIFICATION DIVISION.
001300*----------------------------------------------------*
001400 PROGRAM-ID.
001500 AUTHOR.
001600 INSTALLATION.
001700 DATE-WRITTEN.
001800 DATE-COMPILED.
001900*
002000 REMARKS.
002100*
002200*----------------------------------------------------*
002300 ENVIRONMENT DIVISION.
002400*----------------------------------------------------*
002500 CONFIGURATION SECTION.
002600 SOURCE-COMPUTER. HP 3000.
002700 OBJECT-COMPUTER. HP 3000.
002800 SPECIAL-NAMES.
002900 CONDITION-CODE IS CCODE.
003000*
003100*----------------------------------------------------*
003200 DATA DIVISION.
003300*----------------------------------------------------*
003400*
003500*----------------------------------------------------*
003600 WORKING-STORAGE SECTION.
003700*----------------------------------------------------*
003800*
003900 01 INTRINSIC-COMP.
004000 05 TPID PIC S9(4) COMP.
004100 05 TRACEON PIC S9(4) COMP VALUE +1.
004200 05 LENGTH-REMOTE-TP-NAME PIC S9(4) COMP VALUE +4.
004300 05 RESOURCE-ID PIC S9(4) COMP.
004400 05 TRANS-LENGTH PIC S9(4) COMP VALUE +30.
004500 05 RECEIVE-LENGTH PIC S9(4) COMP.
004600 05 WHAT-RECEIVED PIC S9(4) COMP.
004700 05 FULL-RECORD PIC S9(4) COMP VALUE +80.
004800 05 REQ-TO-SEND-REC PIC S9(4) COMP.
004900 05 DATA-COMPLETE PIC S9(4) COMP VALUE +1.
005000 05 SEND-RECEIVED PIC S9(4) COMP VALUE +4.005100 05 DEALLOCATE-TYPE PIC S9(4) COMP VALUE +0.
005200 05 TRANSLATE-TO-EBCDIC PIC S9(4) COMP VALUE +2.
005300 05 TRANSLATE-TO-ASCII PIC S9(4) COMP VALUE +1.
005400*
005500 01 INTRINSIC-STATUS PIC S9(8) COMP.
005600 01 INTRINSIC-STATUS-ALL REDEFINES INTRINSIC-STATUS.
005700 05 INTRINSIC-STATUS-INFO PIC S9(4) COMP.
005800 05 INTRINSIC-STATUS-SUBSYS PIC S9(4) COMP.
005900*
006000 01 RETURN-CODE.
006100 05 ALLOCATE-RTRNCD PIC X(5).
006200 05 DEALLOCATE-RTRNCD PIC X(5).
006300 05 ENDED-RTRNCD PIC X(5).
006400 05 SENDDATA-RTRNCD PIC X(5).
006500 05 TPSTART-RTRNCD PIC X(5).
006600 05 RCVANDWAIT-RTRNCD PIC X(5).
006700*
006800 01 DISPLAY-WHAT-RECEIVED PIC X(5).
006900*
007000 01 API-PARAMETERS.
007100 05 TPSTARTED-PARAMETERS.
007200 10 LOCAL-TP-NAME PIC X(8) VALUE "USERTP ".
007300 05 ALLOCATE-PARAMETERS.
007400 10 SESSION-TYPE PIC X(8) VALUE "DISOSS1 ".
007500 05 REMOTE-TP-NAME.
007600 10 REMOTE-TP-NAME-EBCDIC PIC X(4) VALUE SPACES.
007700 10 REMOTE-TP-NAME-ASCII PIC X(4) VALUE "Z027".
007800*
007900 01 DEBUGGING-ERROR-MESSAGES.
008000 05 STARTED-ERR-MSG PIC X(20) VALUE 'TP STARTED ERROR'.
008100 05 ALLOCATE-ERR-MSG PIC X(20) VALUE 'ALLOCATE ERROR'.
008200 05 SENDDATA-ERR-MSG PIC X(20) VALUE 'SEND DATA ERROR'.
008300 05 DEALLOCATE-ERR-MSG PIC X(20) VALUE 'DEALLOCATE ERROR'.
008400 05 ENDED-ERR-MSG PIC X(20) VALUE 'ENDED ERROR'.
008500 05 CTRANSLATE-ERR-MSG PIC X(20) VALUE 'CTRANSLATE ERROR'.
008600 05 RCVANDWAIT-ERR-MSG PIC X(20) VALUE 'RCVANDWAIT ERROR'.
008700 05 WHAT-RECEIVED-MSG PIC X(20) VALUE 'WHAT RECEIVED ERROR'.
008800* |
008900 01 CONTROL-FLAGS.
009000 05 QUIT-SW PIC X.
009100*
009200 01 TRANSACTION-ERROR-CODES.
009300 05 SYSTEM-ERROR-CD PIC 9(4) VALUE 0003.
009400 05 SOCSEC-ERROR-CD PIC 9(4) VALUE 0001.
009500*
009600 01 CONTROL-VALUES.
009700 05 YES-SW PIC X VALUE 'Y'.
009800 05 NO-SW PIC X VALUE 'N'.
009900*
010000 01 CONSOLE-HEADING PIC X(17) VALUE
010100 "CREDIT RISK CHECK".
010200*
010300 01 ACCEPT-CODE PIC X VALUE "3".
010400*
010500 01 MASTER-DATA.
010600 05 SOCSEC-MASTER.
010700 10 SOCSEC1-MASTER PIC X(3).
010800 10 SOCSEC2-MASTER PIC X(2).
010900 10 SOCSEC3-MASTER PIC X(4).
011000 05 NAME-MASTER.
011100 10 LAST-NAME-MASTER PIC X(10).
011200 10 FIRST-NAME-MASTER PIC X(10).
011300 10 MI-NAME-MASTER PIC X.
011400 05 CREDIT-INFO-MASTER OCCURS 5 TIMES.
011500 10 CO-CODE-MASTER PIC X.
011600 10 BALANCE-MASTER PIC 9(4)V9(2).
011700 05 FILLER PIC X(14).
011800 05 RISK-CODE-MASTER PIC X(1).
011900*
012000 01 ERROR-RECORD REDEFINES MASTER-DATA.
012100 05 ERROR-CODE PIC 9(4).
012200 05 FILLER PIC X(76).
012300* |
012400 01 TRANS-DATA.
012500 05 SOCSEC-TRANS.
012600 10 SOCSEC1-TRANS PIC X(3).
012700 10 SOCSEC2-TRANS PIC X(2).
012800 10 SOCSEC3-TRANS PIC X(4).
012900 05 NAME-TRANS.
013000 10 LAST-NAME-TRANS PIC X(10).
013100 10 FIRST-NAME-TRANS PIC X(10).
013200 10 MI-NAME-TRANS PIC X.
013300*
013400*
013500*----------------------------------------------------*
013600 PROCEDURE DIVISION.
013700*----------------------------------------------------*
013800*
013900*----------------------------------------------------*
014000 000000-MAINLINE SECTION.
014100*----------------------------------------------------*
014200*
014300 PERFORM 101000-BEGIN-HOUSEKEEPING.
014400*
014500 PERFORM 102000-PROCESS-RECORDS
014600 UNTIL QUIT-SW = YES-SW.
014700*
014800 PERFORM 103000-END-HOUSEKEEPING.
014900*
015000 000099-EXIT.
015100 STOP RUN.
015200* |
015300*----------------------------------------------------*
015400 101000-BEGIN-HOUSEKEEPING SECTION.
015500*----------------------------------------------------*
015600* This section calls TPStarted to initialize resources
015700* for the local TP, and then it calls MCAllocate to
015800* allocate a conversation with the remote TP.
015900*
016000 MOVE NO-SW TO QUIT-SW.
016100*
016200 CALL INTRINSIC "TP'STARTED" USING LOCAL-TP-NAME,
016300 TPID,
016400 INTRINSIC-STATUS,
016500 TRACEON.
016600 IF INTRINSIC-STATUS IS NOT EQUAL TO ZERO
016700 MOVE YES-SW TO QUIT-SW
016800 MOVE INTRINSIC-STATUS-INFO TO TPSTART-RTRNCD
016900 DISPLAY STARTED-ERR-MSG,TPSTART-RTRNCD
017000 GO TO 101099-EXIT.
017100*
017200 CALL INTRINSIC "CTRANSLATE" USING TRANSLATE-TO-EBCDIC,
017300 REMOTE-TP-NAME-ASCII,
017400 REMOTE-TP-NAME-EBCDIC,
017500 LENGTH-REMOTE-TP-NAME.
017600 IF CCODE << ZERO
017700 DISPLAY CTRANSLATE-ERR-MSG,
017800 "CCL - REMOTE-TP-NAME NOT TRANSLATED"
017900 MOVE YES-SW TO QUIT-SW
018000 GO TO 101099-EXIT.
018100*
018200 CALL INTRINSIC "MCALLOCATE" USING TPID,
018300 SESSION-TYPE,
018400 REMOTE-TP-NAME-EBCDIC,
018500 LENGTH-REMOTE-TP-NAME,
018600 RESOURCE-ID,
018700 INTRINSIC-STATUS.
018800 IF INTRINSIC-STATUS IS NOT EQUAL TO ZERO
018900 MOVE YES-SW TO QUIT-SW
019000 MOVE INTRINSIC-STATUS-INFO TO ALLOCATE-RTRNCD
019100 DISPLAY ALLOCATE-ERR-MSG,ALLOCATE-RTRNCD
019200 GO TO 101099-EXIT.
019300*
019400 PERFORM 501000-FULL-SCREEN.
019500 101099-EXIT.
019600 EXIT.
019700*
019800*----------------------------------------------------*
019900 102000-PROCESS-RECORDS SECTION.
020000*----------------------------------------------------*
020100* This section calls SEND-DATA and RECEIVE-DATA.
020200*
020300 PERFORM 201000-SEND-DATA.
020400*
020500 IF QUIT-SW IS EQUAL TO YES-SW
020600 GO TO 102099-EXIT.
020700*
020800 PERFORM 202000-RECEIVE-DATA.
020900*
021000 102099-EXIT.
021100 EXIT.
021200*
021300*----------------------------------------------------*
021400 103000-END-HOUSEKEEPING SECTION.
021500*----------------------------------------------------*
021600* This section deallocates the conversation and calls
021700* TPEnded to free the resources used by the local TP.
021800*
021900 CALL INTRINSIC "MCDEALLOCATE" USING RESOURCE-ID,
022000 DEALLOCATE-TYPE,
022100 INTRINSIC-STATUS.
022200 IF INTRINSIC-STATUS IS NOT EQUAL TO ZERO
022300 MOVE INTRINSIC-STATUS-INFO TO DEALLOCATE-RTRNCD
022400 DISPLAY DEALLOCATE-ERR-MSG,DEALLOCATE-RTRNCD.
022500*
022600 CALL INTRINSIC "TPENDED" USING TPID,
022700 INTRINSIC-STATUS.
022800 IF INTRINSIC-STATUS IS NOT EQUAL TO ZERO
022900 MOVE INTRINSIC-STATUS-INFO TO ENDED-RTRNCD
023000 DISPLAY ENDED-ERR-MSG,ENDED-RTRNCD.
023100*
023200 103099-EXIT.
023300 EXIT.
023400* |
023500*----------------------------------------------------*
023600 201000-SEND-DATA SECTION.
023700*----------------------------------------------------*
023800* This section translates the data received from the
023900* user's screen into EBCDIC and sends it to the remote TP.
024000*
024100 CALL INTRINSIC "CTRANSLATE" USING TRANSLATE-TO-EBCDIC,
024200 TRANS-DATA,
024300 TRANS-DATA,
024400 TRANS-LENGTH.
024500 IF CCODE << ZERO
024600 DISPLAY CTRANSLATE-ERR-MSG,
024700 "CCL - TRANS-DATA NOT TRANSLATED"
024800 MOVE YES-SW TO QUIT-SW
024900 GO TO 201099-EXIT.
025000*
025100 CALL INTRINSIC "MCSENDDATA" USING RESOURCE-ID,
025200 TRANS-DATA,
025300 TRANS-LENGTH,
025400 REQ-TO-SEND-REC,
025500 INTRINSIC-STATUS.
025600 IF INTRINSIC-STATUS IS NOT EQUAL TO ZERO
025700 MOVE YES-SW TO QUIT-SW
025800 MOVE INTRINSIC-STATUS-INFO TO SENDDATA-RTRNCD
025900 DISPLAY SENDDATA-ERR-MSG,SENDDATA-RTRNCD.
026000*
026100 201099-EXIT.
026200 EXIT.
026300*
026400*----------------------------------------------------*
026500 202000-RECEIVE-DATA SECTION.
026600*----------------------------------------------------*
026700* This section calls MCRcvAndWait twice: once to
026800* receive a data record from the remote TP and once
026900* to receive the instruction to change to Send state.
027000* If this section receives a complete data record,
027100* it calls CTranslate to translate it to ASCII.
027200* |
027300 MOVE FULL-RECORD TO RECEIVE-LENGTH.
027400*
027500 CALL INTRINSIC "MCRCVANDWAIT" USING RESOURCE-ID,
027600 RECEIVE-LENGTH,
027700 REQ-TO-SEND-REC,
027800 MASTER-DATA,
027900 WHAT-RECEIVED,
028000 INTRINSIC-STATUS.
028100*
028200 IF INTRINSIC-STATUS IS NOT EQUAL TO ZERO
028300 MOVE INTRINSIC-STATUS-INFO TO RCVANDWAIT-RTRNCD
028400 DISPLAY RCVANDWAIT-ERR-MSG,RCVANDWAIT-RTRNCD
028500 MOVE YES-SW TO QUIT-SW
028600 GO TO 202099-EXIT.
028700*
028800 IF WHAT-RECEIVED IS NOT EQUAL TO DATA-COMPLETE
028900 MOVE WHAT-RECEIVED TO DISPLAY-WHAT-RECEIVED
029000 DISPLAY WHAT-RECEIVED-MSG,DISPLAY-WHAT-RECEIVED
029100 MOVE YES-SW TO QUIT-SW
029200 GO TO 202099-EXIT.
029300*
029400 CALL INTRINSIC "MCRCVANDWAIT" USING RESOURCE-ID,
029500 RECEIVE-LENGTH,
029600 REQ-TO-SEND-REC,
029700 MASTER-DATA,
029800 WHAT-RECEIVED,
029900 INTRINSIC-STATUS.
030000*
030100 IF INTRINSIC-STATUS IS NOT EQUAL TO ZERO
030200 MOVE INTRINSIC-STATUS-INFO TO RCVANDWAIT-RTRNCD
030300 DISPLAY RCVANDWAIT-ERR-MSG,RCVANDWAIT-RTRNCD
030400 MOVE YES-SW TO QUIT-SW
030500 GO TO 202099-EXIT.
030600*
030700 IF WHAT-RECEIVED IS NOT EQUAL TO SEND-RECEIVED
030800 MOVE WHAT-RECEIVED TO DISPLAY-WHAT-RECEIVED
030900 DISPLAY WHAT-RECEIVED-MSG,DISPLAY-WHAT-RECEIVED
031000 MOVE YES-SW TO QUIT-SW
031100 GO TO 202099-EXIT.
031200* |
031300 CALL INTRINSIC "CTRANSLATE" USING TRANSLATE-TO-ASCII,
031400 MASTER-DATA,
031500 MASTER-DATA,
031600 RECEIVE-LENGTH.
031700 IF CCODE << ZERO
031800 DISPLAY CTRANSLATE-ERR-MSG,
031900 "CCL - MASTER-DATA NOT TRANSLATED"
032000 MOVE YES-SW TO QUIT-SW
032100 GO TO 202099-EXIT.
032200*
032300 IF RECEIVE-LENGTH IS EQUAL TO FULL-RECORD
032400 PERFORM 301000-DISPLAY-ACCEPTANCE
032500 ELSE
032600 PERFORM 302000-DISPLAY-ERROR-MESSAGE.
032700*
032800 202099-EXIT.
032900 EXIT.
033000*
033100*----------------------------------------------------*
033200 301000-DISPLAY-ACCEPTANCE SECTION.
033300*----------------------------------------------------*
033400* This section evaluates the Risk Code received from
033500* the remote TP to determine whether to approve or deny
033600* credit, and then it writes a message to the user's terminal.
033700*
033800 IF RISK-CODE-MASTER IS LESS THAN ACCEPT-CODE
033900 DISPLAY "CREDIT DENIED"
034000 ELSE
034100 DISPLAY "CREDIT APPROVED".
034200*
034300 PERFORM 401000-QUIT-SCREEN.
034400*
034500 301099-EXIT.
034600 EXIT.
034700* |
034800*----------------------------------------------------*
034900 302000-DISPLAY-ERROR-MESSAGE SECTION.
035000*----------------------------------------------------*
035100* This section evaluates the errorcode returned by the
035200* remote TP and writes an error message to the user's
035300* terminal. The remote TP can return any of 3 error codes:
035400* 001 - The SS# is not in the database.
035500* 002 - The SS# is in the database, but the name does
035600* not match the name sent by the HP 3000.
035700* 003 - Miscellaneous system errors.
035800* Error codes 001 and 002 cause this section to call
035900* QUIT-SCREEN. Error code 003 causes this section to
036000* set QUIT_SW to YES_SW.
036100*
036200 IF ERROR-CODE IS EQUAL TO SYSTEM-ERROR-CD
036300 DISPLAY SYSTEM-ERROR-CD
036400 MOVE YES-SW TO QUIT-SW
036500 GO TO 302099-EXIT.
036600*
036700 IF ERROR-CODE IS EQUAL TO SOCSEC-ERROR-CD
036800 DISPLAY "SS# not on file - CREDIT DENIED"
036900 ELSE
037000 DISPLAY "Invalid Name".
037100*
037200 PERFORM 401000-QUIT-SCREEN.
037300*
037400 302099-EXIT.
037500 EXIT.
037600* |
037700*----------------------------------------------------*
037800 401000-QUIT-SCREEN SECTION.
037900*----------------------------------------------------*
038000* This section asks the user if he or she is ready
038100* to quit. If the user responds 'Y', this section
038200* changes QUIT_SW to YES_SW.
038300*
038400 DISPLAY "READY TO QUIT (Y/N)?".
038500 ACCEPT QUIT-SW FREE.
038600*
038700 IF QUIT-SW IS NOT EQUAL TO YES-SW
038800 PERFORM 501000-FULL-SCREEN.
038900*
039000 401099-EXIT.
039100 EXIT.
039200* |
039300*----------------------------------------------------*
039400 501000-FULL-SCREEN SECTION.
039500*----------------------------------------------------*
039600* This section prompts the user for data and
039700* receives the data from the terminal.
039800*
039900 MOVE SPACE TO TRANS-DATA.
040000 MOVE SPACES TO MASTER-DATA.
040100*
040200 DISPLAY CONSOLE-HEADING.
040300*
040400 DISPLAY "SOCSEC # :".
040500 PERFORM 601000-ACCEPT-SOCSEC
040600 UNTIL SOCSEC-TRANS IS NUMERIC.
040700*
040800 DISPLAY "LASTNAME :".
040900 ACCEPT LAST-NAME-TRANS FREE.
041000*
041100 DISPLAY "FIRSTNAME :".
041200 ACCEPT FIRST-NAME-TRANS FREE.
041300*
041400 DISPLAY "MI :".
041500 ACCEPT MI-NAME-TRANS FREE.
041600*
041700 501099-EXIT.
041800 EXIT.
041900*
042000*----------------------------------------------------*
042100 601000-ACCEPT-SOCSEC SECTION.
042200*----------------------------------------------------*
042300* This section prompts the user for a social security
042400* number and accepts it from the terminal.
042500*
042600 ACCEPT SOCSEC-TRANS FREE.
042700*
042800 IF SOCSEC-TRANS IS EQUAL TO SPACES
042900 DISPLAY "SOCSEC # MUST BE NUMERIC"
043000 DISPLAY "SOCSEC # :"
043100 GO TO 601099-EXIT.
043200*
043300 IF SOCSEC-TRANS IS NOT NUMERIC
043400 DISPLAY "SOCSEC # MUST BE NUMERIC"
043500 DISPLAY "SOCSEC # :".
043600*
043700 601099-EXIT.
043800 EXIT. |
|
