onldemo.cob

用COBOL基于IBM大型机操作DB2及CICS的样例。

       IDENTIFICATION  DIVISION.
       PROGRAM-ID      COBDEMO.
       DATA            DIVISION.
       WORKING-STORAGE SECTION.
           EXEC SQL                           INCLUDE SQLCA   END-EXEC.
           EXEC SQL                           INCLUDE SAVBOOK END-EXEC.
       01  RESP-CODE                          PIC S9(8)  COMP.
       01  RESP2-CODE                         PIC S9(8)  COMP.
       01  ACCT-PIC                           PIC 9(10).
       01 DB2-ERR-MESSAGE.
          03 DB2-ERR-MESG-LEN                 PIC S9(04) COMP VALUE +560.
          03 DB2-ERR-MESG1                    PIC X(80).
          03 DB2-ERR-MESG2                    PIC X(80).
          03 DB2-ERR-MESG3                    PIC X(80).
          03 DB2-ERR-MESG4                    PIC X(80).
          03 DB2-ERR-MESG5                    PIC X(80).
          03 DB2-ERR-MESG6                    PIC X(80).
          03 DB2-ERR-MESG7                    PIC X(80).
       01 DB2-ERRMESG-LINE-LEN                PIC S9(09) COMP VALUE +80.
       LINKAGE         SECTION.
       PROCEDURE       DIVISION.
       0000-MAIN-PROC.
           IF          EIBCALEN = 0
           THEN
             PERFORM   1000-SHOW-MAP
             EXEC      CICS
               RETURN  TRANSID(EIBTRNID)
                       COMMAREA(MY-COMMAREA) LENGTH(100)
             END-EXEC
           ELSE
              PERFORM  2000-RECEIVE-INPUT
              PERFORM  3000-CHECK-INPUT
              PERFORM  5000-WITHDRAW-PROC
              PERFORM  6000-NORMAL-OUTPUT
              EXEC     CICS RETURN            END-EXEC
           END-IF
           .
           GOBACK.
      *
       1000-SHOW-MAP.
           MOVE        LOW-VALUE              TO INPUTO
           EXEC        CICS
             SEND      MAP('INPUT') MAPSET('MAPWIT')
                       ERASE FREEKB
           END-EXEC
           .
           EXIT.
      *
       2000-RECEIVE-INPUT.
           EXEC        CICS
             RECEIVE   MAP('INPUT') MAPSET('MAPWIT')
           END-EXEC
           IF          IEBRESP = DFHRESP(MAPFAIL)
           THEN
             MOVE      'NO VALID DATA INPUT'  TO  ERRMSGO
             PERFORM   9000-ERR-OUT
           END-IF
           .
           EXIT.
      *
       5000-WITHDRAW-PROC.
           COMPUTE     WK-BAL = WK-BAL - IMONEYI
           EXEC        SQL
             UPDATE    SAVING
             SET       BAL=:WK-BAL
             WHERE     PASSWD=:WK-PASSWD
               AND     ACCT=:WK-ACCT AND STAT='0'
           END-EXEC
           IF          SQLCODE NOT = 0
           THEN
             STRING    'WITHDRAW ERROR:',SQLCODE
                                              INTO ERRMSGO
             PERFORM   9000-ERR-OUT
           END-IF
           .
           EXIT.
      *
       6000-NORMAL-OUTPUT.
           MOVE        WK-ACCT                TO OACCTO
           MOVE        WK-CUSTNM              TO ONAMEO
           MOVE        WK-BAL                 TO OMONEYO
           EXEC        CICS
             SEND      MAP('SUCCD') MAPSET('MAPWIT')
                       ERASE
                       FREEKB
           END-EXEC
           .
           EXIT.
      *
       3000-CHECK-INPUT.
           IF          IMONEYI < 0
           THEN
             MOVE      'MONEY MUST > 0'       TO  ERRMSGO
             PERFORM   9000-ERR-OUT
           END-IF
      *    CHECK WHETHER THE USER ALREADY HAVE AN ACCOUNT
           MOVE        IPWD1I                 TO WK-PASSWD
           MOVE        IACCTI                 TO WK-ACCT
           MOVE        0                      TO SQLCODE
           EXEC        SQL
             SELECT    ACCT,STAT,CUSTNM,BAL
             INTO     :WK-ACCT,:WK-STAT,:WK-CUSTNM,:WK-BAL
             FROM      SAVING
             WHERE     PASSWD=:WK-PASSWD AND ACCT=:WK-ACCT
           END-EXEC
           EXEC        CICS ENTER TRACENUM(1) FROM(SQLCODE) END-EXEC
           EVALUATE    TRUE
             WHEN      SQLCODE  = 100
               STRING  'USER' WK-CUSTNM ' HAVE NOT OPEN ACCOUNT'
                 DELIMITED BY SIZE INTO ERRMSGO
               PERFORM 9000-ERR-OUT
             WHEN      SQLCODE = ZERO
               CONTINUE
             WHEN      OTHER
               STRING  'THE ACCOUNT WRONG OR THE PASSWD WRONG'
                 DELIMITED BY SIZE            INTO ERRMSGO
               PERFORM 9000-ERR-OUT
           END-EVALUATE
           IF          WK-STAT = 9
           THEN
             STRING    'THE ACCOUNT HAS BEEN DISCARDED.'
               DELIMITED BY SIZE              INTO ERRMSGO
             PERFORM   9000-ERR-OUT
           END-IF
           IF          WK-BAL < IMONEYI
           THEN
             MOVE      'NOT ENOUGH BALANCE'   TO ERRMSGO
             PERFORM   9000-ERR-OUT
           END-IF
           .
           EXIT.
      *
       9000-ERR-OUT.
           CALL        'DSNTIAR'              USING SQLCA
                       DB2-ERR-MESSAGE  DB2-ERRMESG-LINE-LEN.
           STRING      DB2-ERR-MESG1
             DELIMITED BY SIZE                INTO ERRMSG1O.
           STRING      DB2-ERR-MESG2
             DELIMITED BY SIZE                INTO ERRMSG2O.
           STRING      DB2-ERR-MESG3
             DELIMITED BY SIZE                INTO ERRMSG3O.
           STRING      DB2-ERR-MESG4
             DELIMITED BY SIZE                INTO ERRMSG4O.
           STRING      DB2-ERR-MESG5
             DELIMITED BY SIZE                INTO ERRMSG5O.
           STRING      DB2-ERR-MESG6
             DELIMITED BY SIZE                INTO ERRMSG6O.
           EXEC        CICS
             SEND      MAP('FAIL') MAPSET('MAPWIT')
                       ERASE FREEKB
           END-EXEC
           EXEC        CICS RETURN            END-EXEC
           .
           EXIT.