CICS - TS - Temporary storage queues - Programa exemplo


Volta ao Menu Principal


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


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

      *---------------------------------------------------------------  
       IDENTIFICATION DIVISION.                                         
      *---------------------------------------------------------------  
       PROGRAM-ID.   PROGRATS.                                            
       AUTHOR.       DORNELLES CARLOS ALBERTO.
      *---------------------------------------------------------------  
      * SISTEMA    : SICAD         
      * PROGRAMA   : PROGRATS                                        
      * OBJETIVO   : TESTE COM ALOCAÇÃO DE TS               
      * ANALISTA   : DORNELLES CARLOS ALBERTO                
      * PROGRAMADOR: DORNELLES CARLOS ALBERTO                
      * DATA       : OUTUBRO/2004                                    
      * LINGUAGEM  : COBOL / DB2 / CICS  
      *                          
      * MANUTENCOES/VERSOES:                                         
      * VERSAO PROGRAMADOR   RESPONSAVEL    DATA    DESCRICAO    
      * 	  
      *   XXX  XXXXXXXXXXX   XXXXXXXXXXX  XXXXXXXX  XXXXXXXXXXXXXXXXXX         
      *---------------------------------------------------------------  

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

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

      *---------------------------------------------------------------  
       WORKING-STORAGE SECTION. 
      *---------------------------------------------------------------  
                                        
       01  WS-AUXILIARES.
           05 WS-IND                    PIC  9(003) VALUE 0.
           05 WS-ITEM                   PIC S9(004) COMP VALUE +0.
           05 WS-POS-INI                PIC  9(003) VALUE 1.
           05 WS-TAM-TS                 PIC S9(004) COMP VALUE +107.

       01  WS-AREA-ENTRADA-SAIDA.
           03  WS-QTD-ITENS-INF         PIC  9(005).
           03  WS-QTD-ITENS-TOT         PIC  9(005).
           03  WS-NOME-TS               PIC  X(008).
           03  WS-FIM-TS                PIC  X(003).

       01  TS-CADTB323.
           03  323-NU-PLANO-DETALHADO   PIC  9(010).
           03  323-CO-TIPO-PLANO        PIC  X(001).
           03  323-CO-USUARIO           PIC  X(008).
           03  323-CO-SITUACAO-PO       PIC  X(003).
           03  323-NU-UNE-GSA-INA-018   PIC  9(004).
           03  323-NU-NTL-GSA-INA-018   PIC  9(009).
           03  323-NU-UNIDADE-018       PIC  9(004).
           03  323-NU-NATURAL-018       PIC  9(009).
           03  323-AA-PLANO-325         PIC  9(004).
           03  323-NU-ACAO-325          PIC  9(004).
           03  323-NU-CONTROLE-325      PIC  9(004).
           03  323-NU-UNIDADE-325       PIC  9(004).
           03  323-NU-NATURAL-325       PIC  9(009).
           03  323-AA-PLANO-324         PIC  9(004).
           03  323-NU-CONTROLE-324      PIC  9(004).
           03  323-NU-INA-324           PIC  9(004).
           03  323-NU-ACAO-324          PIC  9(004).
           03  323-NU-GRUPO-322         PIC  9(004).
           03  323-NU-SUBGRUPO-322      PIC  9(004).
           03  323-NU-ITEM-322          PIC  9(004).
           03  323-NU-RUBRICA-322       PIC  9(004).
           03  323-CO-PROJETO-322       PIC  X(002).
                                                                        
       01  WS-TMP-NOME.                                                 
           03  WS-TMP-TERMID            PIC  X(002).                    
           03  WS-TMP-MM                PIC  9(006).                    
                                                                        
       01  IND-FIM-CURSOR               PIC  9(001) VALUE 0.
           88 CND-FIM-CURSOR                        VALUE 1.

      *---------------------------------------------------------------  
       LOCAL-STORAGE SECTION.                           
      *---------------------------------------------------------------  
                                                                        
      *---------------------------------------------------------------  
      *              DEFINICAO DE TABELAS E AREAS NA DCLGEN          
      *---------------------------------------------------------------  

           EXEC SQL INCLUDE SQLCA    END-EXEC.
           EXEC SQL INCLUDE CADTB323 END-EXEC.

      *---------------------------------------------------------------  
      *              DEFINICAO DE CURSORES                           
      *---------------------------------------------------------------  

           EXEC SQL
                DECLARE C-PLANO-DTO CURSOR FOR
                SELECT       NU_PLANO_DETALHADO       
                       VALUE(CO_TIPO_PLANO      , ' ')
                ,      VALUE(CO_USUARIO         , ' ')
                ,      VALUE(CO_SITUACAO_PO     , ' ')
                ,      VALUE(NU_UNE_GSA_INA_018 , 0  )
                ,      VALUE(NU_NTL_GSA_INA_018 , 0  )
                ,      VALUE(NU_UNIDADE_018     , 0  )
                ,      VALUE(NU_NATURAL_018     , 0  )
                ,      VALUE(AA_PLANO_325       , 0  )
                ,      VALUE(NU_ACAO_325        , 0  )
                ,      VALUE(NU_CONTROLE_325    , 0  )
                ,      VALUE(NU_UNIDADE_325     , 0  )
                ,      VALUE(NU_NATURAL_325     , 0  )
                ,      VALUE(AA_PLANO_324       , 0  )
                ,      VALUE(NU_CONTROLE_324    , 0  )
                ,      VALUE(NU_INA_324         , 0  )
                ,      VALUE(NU_ACAO_324        , 0  )
                ,      VALUE(NU_GRUPO_322       , 0  )
                ,      VALUE(NU_SUBGRUPO_322    , 0  )
                ,      VALUE(NU_ITEM_322        , 0  )
                ,      VALUE(NU_RUBRICA_322     , 0  )
                ,      VALUE(CO_PROJETO_322     , ' ')
                FROM   CAD.CADTB323_PLANO_DTO TB323
                ORDER  BY NU_PLANO_DETALHADO
           END-EXEC.

      *---------------------------------------------------------------  
       LINKAGE SECTION.                                                 
      *---------------------------------------------------------------  
                                                                        
       01  DFHCOMMAREA.                                                 
           03  LK-GR-PARAMETRO.
               05  LK-GR-EXCESSAO.
                   07  LK-NU-ERRO-CICS  PIC 9(003).
                   07  LK-NU-MENSAGEM   PIC 9(004).
                   07  LK-DE-MENSAGEM   PIC X(078).
                   07  LK-NU-SQLCODE    PIC -9(03).
               05  LK-GR-IDENTIFICACAO.
                   07  LK-NO-PROGRAMA   PIC X(008).
                   07  LK-CO-USUARIO    PIC X(008).
                   07  LK-CO-FUNCAO     PIC X(002).
               05  LK-VR-TAMANHO        PIC 9(005).
               05  LK-GR-DADOS.
                   07  LK-VR-CONTEUDO   PIC X(001)
                       OCCURS 0 TO 22000 DEPENDING ON LK-VR-TAMANHO.

      *---------------------------------------------------------------  
       PROCEDURE DIVISION USING DFHCOMMAREA.                            
      *---------------------------------------------------------------  
                                                                        
           PERFORM P0100-PROCEDIMENTOS-INICIAIS        
           PERFORM P0200-PROCEDIMENTOS-PRINCIPAIS        
           PERFORM P0900-PROCEDIMENTOS-FINAIS.       
                                                                        
      *---------------------------------------------------------------  
       P0100-PROCEDIMENTOS-INICIAIS.                                    
      *---------------------------------------------------------------  
                                                                        
           EXEC CICS
                HANDLE CONDITION
                ITEMERR(P0300-FIM-TS)
           END-EXEC
                                                                        
           INITIALIZE LK-GR-EXCESSAO
                      LK-GR-IDENTIFICACAO                               
                                                                        
           MOVE LENGTH OF WS-AREA-ENTRADA-SAIDA TO LK-VR-TAMANHO       
           MOVE LK-GR-DADOS(1:LK-VR-TAMANHO) TO WS-AREA-ENTRADA-SAIDA. 

       P0100-FIM. 
           EXIT.                                                 

      *---------------------------------------------------------------  
       P0200-PROCEDIMENTOS-PRINCIPAIS.                                  
      *---------------------------------------------------------------  
                                                                        
           IF WS-QTD-ITENS-INF EQUAL ZEROS
              MOVE 'TS'        TO WS-TMP-TERMID
              MOVE EIBTASKN    TO WS-TMP-MM
              MOVE WS-TMP-NOME TO WS-NOME-TS
              PERFORM P0201-TRATA-CURSOR
           ELSE
              PERFORM P0300-TRATA-TS
           END-IF.
                                                                        
       P0200-FIM. 
           EXIT.

      *---------------------------------------------------------------  
       P0201-TRATA-CURSOR.
      *---------------------------------------------------------------  

           EXEC SQL
                OPEN C-PLANO-DTO
           END-EXEC

           PERFORM P0201A-LER-CURSOR

           PERFORM UNTIL CND-FIM-CURSOR
                   PERFORM P0201B-MONTA-TS
                   PERFORM P0201A-LER-CURSOR
           END-PERFORM

           PERFORM P0300-TRATA-TS

           EXEC SQL
                CLOSE C-PLANO-DTO
           END-EXEC.
                                                                        
       P0201-FIM. 
           EXIT.

      *---------------------------------------------------------------  
       P0201A-LER-CURSOR.
      *---------------------------------------------------------------  

           EXEC SQL
                FETCH  C-PLANO-DTO
                INTO  :NU-PLANO-DETALHADO 
                ,     :CO-TIPO-PLANO      
                ,     :CO-USUARIO         
                ,     :CO-SITUACAO-PO     
                ,     :NU-UNE-GSA-INA-018 
                ,     :NU-NTL-GSA-INA-018 
                ,     :NU-UNIDADE-018     
                ,     :NU-NATURAL-018     
                ,     :AA-PLANO-325       
                ,     :NU-ACAO-325        
                ,     :NU-CONTROLE-325    
                ,     :NU-UNIDADE-325     
                ,     :NU-NATURAL-325     
                ,     :AA-PLANO-324       
                ,     :NU-CONTROLE-324    
                ,     :NU-INA-324         
                ,     :NU-ACAO-324        
                ,     :NU-GRUPO-322       
                ,     :NU-SUBGRUPO-322    
                ,     :NU-ITEM-322        
                ,     :NU-RUBRICA-322     
                ,     :CO-PROJETO-322
           END-EXEC

           IF SQLCODE NOT EQUAL +0
              IF SQLCODE EQUAL +100
                 MOVE 1 TO IND-FIM-CURSOR
              ELSE
                 MOVE 'HAHAHAHAHAHAHAH ERRO DE DB2' TO LK-DE-MENSAGEM
                 MOVE 216 TO LK-NU-MENSAGEM
                 PERFORM P0900-PROCEDIMENTOS-FINAIS
              END-IF
           END-IF.

       P0201A-FIM. 
           EXIT.

      *---------------------------------------------------------------  
       P0201B-MONTA-TS.
      *---------------------------------------------------------------  

           ADD  1                    TO WS-QTD-ITENS-TOT
           MOVE CADTB323             TO TS-CADTB323                                 
           MOVE NU-PLANO-DETALHADO   TO 323-NU-PLANO-DETALHADO
           MOVE CO-TIPO-PLANO        TO 323-CO-TIPO-PLANO
           MOVE CO-USUARIO           TO 323-CO-USUARIO
           MOVE CO-SITUACAO-PO       TO 323-CO-SITUACAO-PO
           MOVE NU-UNE-GSA-INA-018   TO 323-NU-UNE-GSA-INA-018
           MOVE NU-NTL-GSA-INA-018   TO 323-NU-NTL-GSA-INA-018
           MOVE NU-UNIDADE-018       TO 323-NU-UNIDADE-018
           MOVE NU-NATURAL-018       TO 323-NU-NATURAL-018
           MOVE AA-PLANO-325         TO 323-AA-PLANO-325
           MOVE NU-ACAO-325          TO 323-NU-ACAO-325
           MOVE NU-CONTROLE-325      TO 323-NU-CONTROLE-325
           MOVE NU-UNIDADE-325       TO 323-NU-UNIDADE-325
           MOVE NU-NATURAL-325       TO 323-NU-NATURAL-325
           MOVE AA-PLANO-324         TO 323-AA-PLANO-324
           MOVE NU-CONTROLE-324      TO 323-NU-CONTROLE-324
           MOVE NU-INA-324           TO 323-NU-INA-324
           MOVE NU-ACAO-324          TO 323-NU-ACAO-324
           MOVE NU-GRUPO-322         TO 323-NU-GRUPO-322
           MOVE NU-SUBGRUPO-322      TO 323-NU-SUBGRUPO-322
           MOVE NU-ITEM-322          TO 323-NU-ITEM-322
           MOVE NU-RUBRICA-322       TO 323-NU-RUBRICA-322
           MOVE CO-PROJETO-322       TO 323-CO-PROJETO-322

           EXEC CICS
                WRITEQ QUEUE(WS-TMP-NOME)
                       FROM(TS-CADTB323)
                       LENGTH(WS-TAM-TS)
           END-EXEC.

       P0201B-FIM. 
           EXIT.

      *---------------------------------------------------------------  
       P0300-TRATA-TS.
      *---------------------------------------------------------------  

           MOVE WS-NOME-TS TO WS-TMP-NOME
           COMPUTE WS-ITEM = WS-QTD-ITENS-INF + 1
           INITIALIZE TS-CADTB323
           EXEC CICS
                READQ QUEUE(WS-TMP-NOME)
                      INTO(TS-CADTB323)
                      LENGTH(WS-TAM-TS)
                      ITEM(WS-ITEM)
           END-EXEC

           MOVE 22 TO WS-POS-INI

      *--- Bytes para retorno da área de entrada/saida

           MOVE TS-CADTB323 TO LK-GR-DADOS(WS-POS-INI:WS-TAM-TS)
           ADD WS-TAM-TS    TO WS-POS-INI

           PERFORM VARYING WS-IND FROM 1 BY 1
                   UNTIL WS-IND EQUAL 5
              ADD 1 TO WS-ITEM
              INITIALIZE TS-CADTB323
              EXEC CICS
                   READQ QUEUE(WS-TMP-NOME)
                         INTO(TS-CADTB323)
                         LENGTH(WS-TAM-TS)
                         ITEM(WS-ITEM)
              END-EXEC
              MOVE TS-CADTB323 TO LK-GR-DADOS(WS-POS-INI:WS-TAM-TS)
              ADD WS-TAM-TS TO WS-POS-INI
           END-PERFORM.

      *---------------------------------------------------------------  
       P0300-FIM-TS.
      *---------------------------------------------------------------  

           COMPUTE WS-QTD-ITENS-INF = WS-QTD-ITENS-INF + WS-IND
           MOVE WS-POS-INI TO LK-VR-TAMANHO

           IF WS-ITEM NOT LESS WS-QTD-ITENS-TOT
              MOVE 'SIM' TO WS-FIM-TS
              EXEC CICS
                   DELETEQ QUEUE(WS-TMP-NOME)
              END-EXEC
           ELSE
              MOVE 'NAO' TO WS-FIM-TS
           END-IF

           MOVE WS-AREA-ENTRADA-SAIDA TO LK-GR-DADOS(1:21).

       P0300-FIM. 
           EXIT.

      *---------------------------------------------------------------  
       P0900-PROCEDIMENTOS-FINAIS.                                      
      *---------------------------------------------------------------  

           IF LK-NU-MENSAGEM NOT EQUAL ZEROS
              MOVE 100 TO LK-NU-SQLCODE
           END-IF

           EXEC CICS RETURN END-EXEC.                                                    

       P0900-FIM. 
           EXIT.