COBOL - BALANCE LINE de duas tabelas DB2 - www.cadcobol.com.br


clique aqui para imprimir esta página

Volta a página anterior

Volta ao Menu Principal


Desenvolvido por DORNELLES Carlos Alberto - Analista de Sistemas - Brasília DF. - cad_cobol@hotmail.com

COBOL - BALANCE LINE de duas tabelas DB2
O programa abaixo listado tem por finalidade demonstrar a execução de um BALANCE LINE entre duas tabelas DB2.

Código
         1         2         3         4         5         6         7         8   
12345678901234567890123456789012345678901234567890123456789012345678901234567890

      *-----------------------------------------------------------------
       IDENTIFICATION DIVISION.
      *-----------------------------------------------------------------
       PROGRAM-ID.      CADBAL01.
       AUTHOR.          CARLOS ALBERTO DORNELLES.
      *-----------------------------------------------------------------
      * SISTEMA       : SICAD
      * PROGRAMA      : CADBAL01
      * OBJETIVO      : ATUALIZA A TABELA CAD.CADTB000_CLSFOEXTO 
      *               : A PARTIR DA BET.BETTB000_CLSFOEXTO 
      * ANALISTA(S)   : CARLOS ALBERTO DORNELLES
      * DESENVOVLERDOR: CARLOS ALBERTO DORNELLES
      * LINGUAGEM     : COBOL 85 (II) / DB2
      * MODO OPERACAO : BATCH
      *-----------------------------------------------------------------
      * COD-VER   DD.MM.AAAA  HISTORCAD/AUTOR
      * -------   ----------  ---------------
      *  V.001    13.06.2008  PROGRAMA INICIAL
      *
      *-----------------------------------------------------------------

      *-----------------------------------------------------------------
       ENVIRONMENT DIVISION.
      *-----------------------------------------------------------------
       CONFIGURATION SECTION.
       SPECIAL-NAMES.
                        DECIMAL-POINT IS COMMA.

      *-----------------------------------------------------------------
       DATA DIVISION.
      *-----------------------------------------------------------------

      *-----------------------------------------------------------------
       WORKING-STORAGE SECTION.
      *-----------------------------------------------------------------
       01  WS-AREAS-AUXILIARES.
           05 WS-LIDOS-DES               PIC 9(009) VALUE ZEROES.
           05 WS-LIDOS-PRD               PIC 9(009) VALUE ZEROES.
           05 WS-GRAVADOS                PIC 9(009) VALUE ZEROES.
           05 WS-ALTERADOS               PIC 9(009) VALUE ZEROES.
           05 WS-REJEITADOS              PIC 9(009) VALUE ZEROES.
           05 WS-SQLCODE                 PIC -----9 VALUE ZEROES.
           05 WS-MENSAGEM                PIC X(078) VALUE SPACES.
           05 WS-PARAGRAFO               PIC X(078) VALUE SPACES.
           05 WS-CURRENT-DATE-I          PIC X(010) VALUE SPACES.
           05 WS-CURRENT-TIME-I          PIC X(008) VALUE SPACES.
           05 WS-CURRENT-DATE-F          PIC X(010) VALUE SPACES.
           05 WS-CURRENT-TIME-F          PIC X(008) VALUE SPACES.
           05 WS-VERSAO-PG               PIC 9(003) VALUE 001.          .
           05 WS-CHAVE-DES               PIC 9(004) VALUE ZEROES.
           05 WS-CHAVE-PRD               PIC 9(004) VALUE ZEROES.
           05 FLAG-ALTERACAO             PIC X(001) VALUE 'S'.
              88 SIM-ALTERA                         VALUE 'S'.
              88 NAO-ALTERA                         VALUE 'N'.

      *-----------------------------------------------------------------
       LOCAL-STORAGE SECTION.
      *-----------------------------------------------------------------
           EXEC SQL INCLUDE SQLCA    END-EXEC.
           EXEC SQL INCLUDE CADTB000 END-EXEC.
           EXEC SQL INCLUDE BETTB000 END-EXEC.

           EXEC SQL
                DECLARE CURSOR_CADDES CURSOR FOR
                SELECT NU_CLSFO_EXTNO
                ,      DE_CLSFO_EXTNO
                ,VALUE(NU_TIPO_CLSFO_U49,0)
                FROM   CAD.CADTB000_CLSFOEXTO
                ORDER  BY
                       NU_CLSFO_EXTNO
           END-EXEC.

           EXEC SQL
                DECLARE CURSOR_BETPRD CURSOR FOR
                SELECT NU_CLSFO_EXTNO
                ,      DE_CLSFO_EXTNO
                ,VALUE(NU_TIPO_CLSFO_U49,0)
                FROM   BET.BETTB000_CLSFOEXTO
                ORDER  BY
                       NU_CLSFO_EXTNO
           END-EXEC.

      *-----------------------------------------------------------------
       PROCEDURE DIVISION.
      *-----------------------------------------------------------------

           PERFORM P1000-INICIAL
           PERFORM P2000-PRINCIPAL
           PERFORM P3000-FINAL
           GOBACK.

      *-----------------------------------------------------------------
       P1000-INICIAL.
      *-----------------------------------------------------------------
           MOVE 'P1000-INICIAL  '           TO  WS-PARAGRAFO.
           EXEC SQL OPEN CURSOR_CADDES END-EXEC.
           IF SQLCODE NOT EQUAL +000
              MOVE 'ERRO NA ABERTURA DO CURSOR_CADDES' TO WS-MENSAGEM
              PERFORM P8000-ERRO-DB2 THRU P8000-FIM
           END-IF.
           MOVE 'P1000-INICIAL  '           TO  WS-PARAGRAFO.
           EXEC SQL OPEN CURSOR_BETPRD END-EXEC.
           IF SQLCODE NOT EQUAL +000
              MOVE 'ERRO NA ABERTURA DO CURSOR_BETPRD' TO WS-MENSAGEM
              PERFORM P8000-ERRO-DB2 THRU P8000-FIM
           END-IF.
           EXEC SQL
                SELECT CURRENT DATE
                INTO  :WS-CURRENT-DATE-I
                FROM   SYSIBM.SYSDUMMY1
           END-EXEC
           EXEC SQL
                SELECT CURRENT TIME
                INTO  :WS-CURRENT-TIME-I
                FROM   SYSIBM.SYSDUMMY1
           END-EXEC.
       P1000-FIM.
           EXIT.

      *-----------------------------------------------------------------
       P2000-PRINCIPAL.
      *-----------------------------------------------------------------
           MOVE 'P2000-PRINCIPAL'           TO  WS-PARAGRAFO.
           PERFORM P2400-LER-CAD-DES THRU P2400-FIM.
           PERFORM P2500-LER-BET-PRD THRU P2500-FIM.
           PERFORM UNTIL WS-CHAVE-PRD EQUAL 9999 AND
                         WS-CHAVE-DES EQUAL 9999
              EVALUATE TRUE
                  WHEN WS-CHAVE-PRD LESS THAN    WS-CHAVE-DES
                       PERFORM P2230-INCLUSAO-DES        THRU P2230-FIM
                       PERFORM P2500-LER-BET-PRD         THRU P2500-FIM
                  WHEN WS-CHAVE-PRD EQUAL        WS-CHAVE-DES
                       PERFORM P2250-ALTERACAO-DES       THRU P2250-FIM
                       PERFORM P2400-LER-CAD-DES         THRU P2400-FIM
                       PERFORM P2500-LER-BET-PRD         THRU P2500-FIM
                  WHEN WS-CHAVE-PRD GREATER THAN WS-CHAVE-DES
                       PERFORM P2400-LER-CAD-DES         THRU P2400-FIM
              END-EVALUATE
           END-PERFORM.
       P2000-FIM.
           EXIT.

      *-----------------------------------------------------------------
       P2230-INCLUSAO-DES.
      *-----------------------------------------------------------------
           MOVE 'P2230-INCLUSAO-DES'  TO  WS-PARAGRAFO.
           EXEC SQL
                INSERT INTO CAD.CADTB000_CLSFOEXTO
                      (NU_CLSFO_EXTNO
                ,      DE_CLSFO_EXTNO
                ,      NU_TIPO_CLSFO_U49)
                VALUES
                      (:BETTB000.NU-CLSFO-EXTNO
                ,      :BETTB000.DE-CLSFO-EXTNO
                ,      :BETTB000.NU-TIPO-CLSFO-U49)
           END-EXEC.
           EVALUATE SQLCODE
              WHEN  +000
                    ADD 1 TO WS-GRAVADOS
              WHEN  -530
                    ADD 1 TO WS-REJEITADOS
              WHEN  OTHER
                    MOVE 'ERRO NO INSERT DESENVOLVIMENTO' TO WS-MENSAGEM
                    PERFORM P8000-ERRO-DB2            THRU P8000-FIM
           END-EVALUATE.
       P2230-FIM.
           EXIT.

      *-----------------------------------------------------------------
       P2250-ALTERACAO-DES.
      *-----------------------------------------------------------------
           MOVE 'P2250-ALTERACAO-DES' TO WS-PARAGRAFO.
           SET NAO-ALTERA TO TRUE.
           EVALUATE TRUE
               WHEN DE-CLSFO-EXTNO     OF CADTB000 NOT EQUAL
                    DE-CLSFO-EXTNO     OF BETTB000
                    SET SIM-ALTERA TO TRUE
               WHEN NU-TIPO-CLSFO-U49  OF CADTB000 NOT EQUAL
                    NU-TIPO-CLSFO-U49  OF BETTB000
                    SET SIM-ALTERA TO TRUE
           END-EVALUATE.
           IF SIM-ALTERA
              PERFORM 2800-UPDATE-DES THRU 2800-99-FIM
           END-IF.
       P2250-FIM.
           EXIT.

      *-----------------------------------------------------------------
       P2400-LER-CAD-DES.
      *-----------------------------------------------------------------
           MOVE 'P2400-LER-CAD-DES'  TO  WS-PARAGRAFO.
           INITIALIZE CADTB000
           EXEC SQL
                FETCH CURSOR_CADDES
                      INTO :CADTB000.NU-CLSFO-EXTNO
                      ,    :CADTB000.DE-CLSFO-EXTNO
                      ,    :CADTB000.NU-TIPO-CLSFO-U49
           END-EXEC.
           EVALUATE SQLCODE
              WHEN  +000
                    ADD 1                               TO WS-LIDOS-DES
                    MOVE NU-CLSFO-EXTNO OF CADTB000     TO WS-CHAVE-DES
              WHEN  +100
                    MOVE 9999                           TO WS-CHAVE-DES
              WHEN  OTHER
                    MOVE 'ERRO NO FETCH DO CURSOR_CADDES' TO WS-MENSAGEM
                    PERFORM P8000-ERRO-DB2            THRU P8000-FIM
           END-EVALUATE.
       P2400-FIM.
           EXIT.

      *-----------------------------------------------------------------
       P2500-LER-BET-PRD.
      *-----------------------------------------------------------------
           MOVE 'P2500-LER-BET-PRD' TO WS-PARAGRAFO.
           INITIALIZE BETTB000.
           EXEC SQL
                FETCH CURSOR_BETPRD
                      INTO :BETTB000.NU-CLSFO-EXTNO
                      ,    :BETTB000.DE-CLSFO-EXTNO
                      ,    :BETTB000.NU-TIPO-CLSFO-U49
           END-EXEC.
           EVALUATE SQLCODE
              WHEN  +000
                    ADD 1                               TO WS-LIDOS-PRD
                    MOVE NU-CLSFO-EXTNO OF BETTB000     TO WS-CHAVE-PRD
              WHEN  +100
                    MOVE 9999                           TO WS-CHAVE-PRD
              WHEN  OTHER
                    MOVE 'ERRO NO FETCH DO CURSOR_BETPRD' TO WS-MENSAGEM
                    PERFORM P8000-ERRO-DB2            THRU P8000-FIM
           END-EVALUATE.
       P2500-FIM.
           EXIT.

      *-----------------------------------------------------------------
       2800-UPDATE-DES.
      *-----------------------------------------------------------------
           MOVE '2800-UPDATE-DES'           TO  WS-PARAGRAFO.
           EXEC SQL
                UPDATE CAD.CADTB000_CLSFOEXTO
                SET    DE_CLSFO_EXTNO     = :BETTB000.DE-CLSFO-EXTNO
                ,      NU_TIPO_CLSFO_U49  = :BETTB000.NU-TIPO-CLSFO-U49
                WHERE  NU_CLSFO_EXTNO     = :BETTB000.NU-CLSFO-EXTNO
           END-EXEC.
           EVALUATE SQLCODE
              WHEN  +000
                    ADD 1                               TO WS-ALTERADOS
              WHEN  -530
                    ADD 1                               TO WS-REJEITADOS
              WHEN  OTHER
                    MOVE 'ERRO NO UPDATE DESENVOLVIMENTO' TO WS-MENSAGEM
                    PERFORM P8000-ERRO-DB2            THRU P8000-FIM
           END-EVALUATE.
       2800-99-FIM.
           EXIT.

      *-----------------------------------------------------------------
       P3000-FINAL.
      *-----------------------------------------------------------------
           MOVE 'P3000-FINAL'               TO  WS-PARAGRAFO.
           EXEC SQL CLOSE CURSOR_CADDES END-EXEC.
           IF SQLCODE NOT EQUAL +0
              MOVE 'ERRO NA FECHAMENTO DO CURSOR_CADDES' TO WS-MENSAGEM
              PERFORM P8000-ERRO-DB2 THRU P8000-FIM
           END-IF.
           EXEC SQL CLOSE CURSOR_BETPRD END-EXEC.
           IF SQLCODE NOT EQUAL +0
              MOVE 'ERRO NA FECHAMENTO DO CURSOR_BETPRD' TO WS-MENSAGEM
              PERFORM P8000-ERRO-DB2 THRU P8000-FIM
           END-IF.
           EXEC SQL COMMIT END-EXEC.
           EXEC SQL
                SELECT CURRENT DATE
                INTO  :WS-CURRENT-DATE-F
                FROM   SYSIBM.SYSDUMMY1
           END-EXEC
           EXEC SQL
                SELECT CURRENT TIME
                INTO  :WS-CURRENT-TIME-F
                FROM   SYSIBM.SYSDUMMY1
           END-EXEC
           DISPLAY '------------------------------------------------'
           DISPLAY ' PROGRAMA CADBAL01 ........ - TERMINO OK        '
           DISPLAY ' VERSAO ................... - ' WS-VERSAO-PG
           DISPLAY '                                                '
           DISPLAY ' DATA INICIAL ............. - ' WS-CURRENT-DATE-I
           DISPLAY ' HORA INICIAL ............. - ' WS-CURRENT-TIME-I
           DISPLAY '                                                '
           DISPLAY ' DATA FINAL ............... - ' WS-CURRENT-DATE-F
           DISPLAY ' HORA FINAL ............... - ' WS-CURRENT-TIME-F
           DISPLAY '                                                '
           DISPLAY ' TOTAL REG. LIDOS PRODUCAO  - ' WS-LIDOS-PRD
           DISPLAY ' TOTAL REG. LIDOS DESENVOL  - ' WS-LIDOS-DES
           DISPLAY ' TOTAL REG. GRAVADOS ...... - ' WS-GRAVADOS
           DISPLAY ' TOTAL REG. ALTERADOS ..... - ' WS-ALTERADOS
           DISPLAY ' TOTAL REG. REJEITADOS .... - ' WS-REJEITADOS
           DISPLAY '                                                '
           DISPLAY '------------------------------------------------'
           IF WS-REJEITADOS NOT EQUAL ZEROES
              DISPLAY ' OS REGISTROS FORAM REJEITADOS PORQUE A TABELA'
              DISPLAY ' CADTBU49  NAO  FOI  ATUALIZADA  ANTES   DESTA'
              DISPLAY ' EXECUCAO.                                    '
              DISPLAY ' EXECUTAR O PROGRAMA:                         '
              DISPLAY ' CADPB682  - ATUALIZA A TABELA CADTBU49       '
              DISPLAY '------------------------------------------------'
           END-IF
           .
       P3000-FIM.
           EXIT.

      *-----------------------------------------------------------------
       P8000-ERRO-DB2.
      *-----------------------------------------------------------------
           MOVE SQLCODE TO WS-SQLCODE
           DISPLAY '------------------------------------------------'
           DISPLAY ' CADBAL01 - ERRO DE ACESSO AO DB2   ----------  '
           DISPLAY '------------------------------------------------'
           DISPLAY ' MENSAGEM - ' WS-PARAGRAFO
           DISPLAY ' SQLCODE  - ' WS-SQLCODE
           DISPLAY ' MENSAGEM - ' WS-MENSAGEM
           DISPLAY '------------------------------------------------'
           MOVE 99 TO RETURN-CODE
           GOBACK.
       P8000-FIM.
           EXIT.