Quelle  hpcobol.cbl

      *$CONTROL CROSSREF,SYMDEBUG
001100*----------------------------------------------------*
001200  IDENTIFICATION DIVISION.
001300*----------------------------------------------------*
001400 PROGRAM-ID. HP.
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.