extext

目前,国内运用COBOL语言的公司很少,导致目前国内懂cobol的程序员甚少.我这里提供几个由简入深的例子,希望对大家能够有用

      *
       T200-OPEN-DBTABL02.
      *
           EXEC SQL
                OPEN  CSR-DBTABL02
           END-EXEC.
      *
           MOVE SQLCODE                        TO DB2-RTCD.
           EVALUATE  TRUE
              WHEN   DB2-NORMAL
                 CONTINUE
              WHEN   OTHER
                 DISPLAY 'FAILED OPEN OF       CSR-DBTABL02'
                 SET MISERR01-FATAL-ERROR-FOUND
                                               TO TRUE
                 MOVE K-PGM-ID                 TO UTDB2ER-CALL-PROG
                 MOVE SQLCA                    TO UTDB2ER-SQLCA
                 SET UTDB2ER-LOG-ERROR         TO TRUE
                 PERFORM Z000-CLOSE-FILE
                 CALL PGM-UTDB2ER USING        UTDB2ER-CALL-AREA
           END-EVALUATE.
      *
           EXIT.
      *
      *****************************************************************
      *    FETCH CURSOR CSR-DBTABL02 ROUTINE                          *
      *****************************************************************
      *
       T200-FETCH-DBTABL02.
      *
           EXEC SQL
                FETCH CSR-DBTABL02 INTO :DBCTBL02
           END-EXEC.
           MOVE SQLCODE                        TO DB2-RTCD.
           EVALUATE  TRUE
              WHEN   DB2-NORMAL
                 CONTINUE
              WHEN   DB2-NOTFND
                 SET WS-DBTABL02-EOF          TO TRUE
              WHEN   OTHER
                 DISPLAY 'FAILED FETCH OF     CSR-DBTABL02'
                 SET MISERR01-FATAL-ERROR-FOUND
                                               TO TRUE
                 MOVE K-PGM-ID                 TO UTDB2ER-CALL-PROG
                 MOVE SQLCA                    TO UTDB2ER-SQLCA
                 SET UTDB2ER-LOG-ERROR         TO TRUE
                 PERFORM Z000-CLOSE-FILE
                 CALL PGM-UTDB2ER USING        UTDB2ER-CALL-AREA
           END-EVALUATE.
           EXIT.
      *
      *****************************************************************
      *    CLOSE CURSOR CSR-DBTABL02 ROUTINE                          *
      *****************************************************************
       T299-CLOSE-CSR-DBTABL02.
      *
           EXEC SQL
                CLOSE CSR-DBTABL02
           END-EXEC.
           MOVE SQLCODE                        TO DB2-RTCD.
           EVALUATE  TRUE
              WHEN   DB2-NORMAL
                 CONTINUE
              WHEN   OTHER
                 DISPLAY 'FAILED CLOSE OF     CSR-DBTABL02'
                 SET MISERR01-FATAL-ERROR-FOUND
                                               TO TRUE
                 MOVE K-PGM-ID                 TO UTDB2ER-CALL-PROG
                 MOVE SQLCA                    TO UTDB2ER-SQLCA
                 SET UTDB2ER-LOG-ERROR         TO TRUE
                 PERFORM Z000-CLOSE-FILE
                 CALL PGM-UTDB2ER USING        UTDB2ER-CALL-AREA
           END-EVALUATE.
           EXIT.
      *
      *****************************************************************
      *    OPEN CURSOR CSR-DBTABL03 ROUTINE                           *
      *****************************************************************
      *
       T300-OPEN-DBTABL03.
      *
           EXEC SQL
                OPEN  CSR-DBTABL03
           END-EXEC.
      *
           MOVE SQLCODE                        TO DB2-RTCD.
           EVALUATE  TRUE
              WHEN   DB2-NORMAL
                 CONTINUE
              WHEN   OTHER
                 DISPLAY 'FAILED OPEN OF       CSR-DBTABL03'
                 SET MISERR01-FATAL-ERROR-FOUND
                                               TO TRUE
                 MOVE K-PGM-ID                 TO UTDB2ER-CALL-PROG
                 MOVE SQLCA                    TO UTDB2ER-SQLCA
                 SET UTDB2ER-LOG-ERROR         TO TRUE
                 PERFORM Z000-CLOSE-FILE
                 CALL PGM-UTDB2ER USING        UTDB2ER-CALL-AREA
           END-EVALUATE.
      *
           EXIT.
      *
      *****************************************************************
      *    FETCH CURSOR CSR-DBTABL03 ROUTINE                          *
      *****************************************************************
      *
       T300-FETCH-DBTABL03.
      *
           EXEC SQL
                FETCH CSR-DBTABL03 INTO :DBCTBL03
           END-EXEC.
           MOVE SQLCODE                        TO DB2-RTCD.
           EVALUATE  TRUE
              WHEN   DB2-NORMAL
                 CONTINUE
              WHEN   DB2-NOTFND
                 SET WS-DBTABL03-EOF          TO TRUE
              WHEN   OTHER
                 DISPLAY 'FAILED FETCH OF     CSR-DBTABL03'
                 SET MISERR01-FATAL-ERROR-FOUND
                                               TO TRUE
                 MOVE K-PGM-ID                 TO UTDB2ER-CALL-PROG
                 MOVE SQLCA                    TO UTDB2ER-SQLCA
                 SET UTDB2ER-LOG-ERROR         TO TRUE
                 PERFORM Z000-CLOSE-FILE
                 CALL PGM-UTDB2ER USING        UTDB2ER-CALL-AREA
           END-EVALUATE.
           EXIT.
      *
      *****************************************************************
      *    CLOSE CURSOR CSR-DBTABL03 ROUTINE                          *
      *****************************************************************
       T399-CLOSE-CSR-DBTABL03.
      *
           EXEC SQL
                CLOSE CSR-DBTABL03
           END-EXEC.
           MOVE SQLCODE                        TO DB2-RTCD.
           EVALUATE  TRUE
              WHEN   DB2-NORMAL
                 CONTINUE
              WHEN   OTHER
                 DISPLAY 'FAILED CLOSE OF     CSR-DBTABL03'
                 SET MISERR01-FATAL-ERROR-FOUND
                                               TO TRUE
                 MOVE K-PGM-ID                 TO UTDB2ER-CALL-PROG
                 MOVE SQLCA                    TO UTDB2ER-SQLCA
                 SET UTDB2ER-LOG-ERROR         TO TRUE
                 PERFORM Z000-CLOSE-FILE
                 CALL PGM-UTDB2ER USING        UTDB2ER-CALL-AREA
           END-EVALUATE.
           EXIT.
      *
      *
       Y000-DISP-STATIS.
      *
           MOVE  WS-FILNAM1-READ-CNT          TO WS-FILNAM1-TOTAL-READ
           DISPLAY     WS-PGM-HEAD               WS-FILNAM1-TOTAL-ST
           MOVE  WS-FILNAM2-READ-CNT          TO WS-FILNAM2-TOTAL-READ
           DISPLAY     WS-PGM-HEAD               WS-FILNAM2-TOTAL-ST
           MOVE  WS-FNAME1-WRITE-CNT          TO WS-FNAME1-SUCC-WRITE
           DISPLAY     WS-PGM-HEAD               WS-FNAME1-SUCCESS-ST
           MOVE  WS-NAMEFF-WRITE-CNT          TO WS-NAMEFF-SUCC-WRITE
           DISPLAY     WS-PGM-HEAD               WS-NAMEFF-SUCCESS-ST
      *
           .
           EXIT.
      *
       Z000-CLOSE-FILE.
      *
           SET         STUS-ACTION-CLOSE      TO TRUE
           CLOSE                                 FILNAM1
                                                 FILNAM2
                                                 FNAME1
                                                 NAMEFF
      *
           PERFORM     Y000-DISP-STATIS
           .
           EXIT.
      *
      *****************************************************************
      *    PROGRAM EXIT                                               *
      *****************************************************************
      *
       Z099-PGM-END.
      *
           EVALUATE  TRUE
              WHEN   MISERR01-SEVERE-WARNING-FOUND
              WHEN   MISERR01-ERROR-FOUND
              WHEN   MISERR01-FATAL-ERROR-FOUND
                 MOVE  K-RETURN-ABNORMAL       TO RETURN-CODE
                 SET   WS-ABNORMAL-END         TO TRUE
                 PERFORM Z200-ABNORMAL-END
              WHEN   MISERR01-WARNING-FOUND
                 MOVE  K-RETURN-WARNING        TO RETURN-CODE
                 SET   WS-ABNORMAL-END         TO TRUE
                 PERFORM Z200-ABNORMAL-END
              WHEN   OTHER
                 MOVE  K-RETURN-NORMAL         TO RETURN-CODE
                 SET   WS-NORMAL-END           TO TRUE
                 PERFORM Z100-NORMAL-END
           END-EVALUATE.
      *
           DISPLAY     WS-PGM-HEAD             WS-PGM-MSG
      *
           DISPLAY     WS-STATISTICS
           .
           EXIT.
      *
        Z100-NORMAL-END.
      *
           PERFORM     Z000-CLOSE-FILE
           MOVE     K-RETURN-NORMAL           TO RETURN-CODE
      *
           SET         WS-NORMAL-END          TO TRUE
           DISPLAY     WS-PGM-HEAD            WS-PGM-MSG
           .
           EXIT.
      *
       Z200-ABNORMAL-END.
      *
           PERFORM     Z000-CLOSE-FILE
           SET         WS-ABNORMAL-END        TO TRUE
           DISPLAY     WS-PGM-HEAD               WS-PGM-MSG
           MOVE        K-RETURN-ABNORMAL      TO RETURN-CODE
           GOBACK
           .
           EXIT.
      *------------------------------------------------------------------
      *  COMMON SYSTEM ERROR PROCESS                                    *
      *------------------------------------------------------------------
      *    COMMOM PROCESS ROUTINE FOR DB2 ERROR                         *
      *------------------------------------------------------------------
      *    COPY DB2BSERR.
      *------------------------------------------------------------------
      *    COMMOM PROCESS ROUTINE FOR FILE ERROR                        *
      *------------------------------------------------------------------
      *    COPY FILESERR.
      *
      **********************
      *END PROGRAM EXTEXT  .
      **********************