Quellcode-Bibliothek

^© Kompilation durch diese Firma

[Weder Korrektheit noch Funktionsfähigkeit der Software werden zugesichert.]

Datei: hpcobol.cbl Sprache: Cobol

Original von: verschiedene^©

      *$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.

¤ Dauer der Verarbeitung: 0.4 Sekunden (vorverarbeitet) ¤

Download des Quellennavigators
Download des sprechenden Kalenders
in der Quellcodebibliothek suchen

Haftungshinweis

Die Informationen auf dieser Webseite wurden nach bestem Wissen sorgfältig zusammengestellt. Es wird jedoch weder Vollständigkeit, noch Richtigkeit, noch Qualität der bereit gestellten Informationen zugesichert.

Bemerkung:

Die farbliche Syntaxdarstellung ist noch experimentell.