*==============================> FALTA CONCLUIR
1 2 3 4 5 6 7
123456789012345678901234567890123456789012345678901234567890123456789012
000001*----------------- I N I C I O D O C O D I G O --------------*
000002 IDENTIFICATION DIVISION.
000003*-----------------------
000004 PROGRAM-ID. SELECT05.
000005
000006* Sistema : EXEMPLO
000007* Programa : SELECT05
000008* Objetivo : Buscar a CONTA corrente
000009* Analista : CARLOS ALBERTO DORNELLES
000010* Desenvolvedor: CARLOS ALBERTO DORNELLES
000011* Data : 31/12/2002
000012* Linguagem : COBOL / DB2 / CICS
000013* Manutencoes :
000014*----------------------------------------------------------------*
000015* Desenvolvedor Responsavel Data
000016* ------------- ----------- ----
000017*
000018* xxxxxxxxxxxxxxxxxxxxxxxxx xxxxxxxxxxxxxxxxxxxxxxxxxx xx/xx/xxxx
000019* descrição xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
000020*----------------------------------------------------------------*
000021 ENVIRONMENT DIVISION.
000022*---------------------
000023 CONFIGURATION SECTION.
000024*---------------------
000025 SPECIAL-NAMES.
000026 DECIMAL-POINT IS COMMA.
000027
000028 DATA DIVISION.
000029*-------------
000030 WORKING-STORAGE SECTION.
000031*-----------------------
000032 77 WS-SQLCODE-EDT PIC ----9.
000033 01 AREAS-DE-TRABALHO.
000034 03 WS-TAM PIC 9(005).
000035 01 WS-AREA-SAIDA.
000039 05 PRM-NU-CONTA PIC 9(004).
000040 05 PRM-NO-CONTA PIC X(040).
000039 01 WS-AREA-ERROS.
000040 03 PRM-QTDE-ERROS PIC 9(003).
000041 03 PRM-ARRAY-ERROS OCCURS 1 TO 094 TIMES
000042 DEPENDING ON PRM-QTDE-ERROS.
000043 05 PRM-NUMERO-MENSAGEM PIC X(004).
000044 05 PRM-PROGRAMA PIC X(008).
000045 05 PRM-INFORMACOES PIC X(200).
000046
000047* Definicao de tabelas e areas na DCLGEN *
000048*----------------------------------------------------------------*
000049 EXEC SQL INCLUDE SQLCA END-EXEC.
000050 EXEC SQL INCLUDE TABELA01 END-EXEC.
000051
000052 LINKAGE SECTION.
000053*---------------
000054 01 DFHCOMMAREA.
000055 03 LKS-EXCECAO.
000056 05 LKS-ERRO-CICS PIC 9(003).
000057 05 LKS-NU-MENSAGEM PIC 9(004).
000058 05 LKS-NO-MENSAGEM PIC X(078).
000059 05 LKS-NU-SQLCODE PIC 9(004).
000060 03 LKS-IDENTIFICACAO.
000061 05 LKS-IN-NOME-PGM PIC X(008).
000062 05 LKS-IN-CO-USUARIO PIC X(008).
000063 05 LKS-IN-CO-FUNCAO PIC X(002).
000064 03 LKS-ENTRADA-SAIDA.
000065 05 LKS-CONTEUDO-TAM PIC 9(005).
000066 05 LKS-CONTEUDO.
000067 07 FILLER PIC X(001) OCCURS 1 TO 20000
000068 DEPENDING ON LKS-CONTEUDO-TAM.
000069
000070 PROCEDURE DIVISION USING DFHCOMMAREA.
000071*------------------------------------
000072 PERFORM R000-PROCED-INICIAIS THRU R000-FIM.
000073 PERFORM R100-PROCED-PRINCIPAIS THRU R100-FIM.
000074 PERFORM R999-PROCEDIMENTOS-FINAIS THRU P999-FIM.
000075
000076 R000-PROCED-INICIAIS.
000077*--------------------
000078 INITIALIZE LKS-EXCECAO.
000079 MOVE SPACES TO LKS-CONTEUDO(1:20000).
000080 MOVE ZEROES TO LKS-CONTEUDO-TAM
000082 PRM-QTDE-ERROS.
000083 R000-FIM.
000084 EXIT.
000085
000086 R100-PROCED-PRINCIPAIS.
000087*----------------------
000198
000137 INITIALIZE WS-GR-CURSOR.
000138 MOVE 1 TO WS-ID-TAMANHO-CURSOR.
000139
000140 STRING
000141 'SELECT MAX('
000142 DELIMITED BY SIZE INTO WS-DE-CURSOR
000143 WITH POINTER WS-ID-TAMANHO-CURSOR
END-STRING
000226 EXEC SQL
000227 PREPARE CONSULTA FROM :WS-GR-CURSOR
000228 END-EXEC.
000229
000230 IF SQLCODE NOT = +0
000231 MOVE 1 TO LK-ERRO-CICS
000232 MOVE SQLCODE TO LK-NU-SQLCODE
000233 PERFORM P999-PROCED-FINAIS
000234 END-IF.
000235
000236 EXEC SQL
000237 DECLARE CUR001 CURSOR FOR CONSULTA
000238 END-EXEC.
000239
000240 IF SQLCODE NOT = +0
000241 MOVE 1 TO LK-ERRO-CICS
000242 MOVE SQLCODE TO LK-NU-SQLCODE
000243 PERFORM P999-PROCED-FINAIS
000244 END-IF.
000245
000246 EXEC SQL
000247 OPEN CUR001
000248 END-EXEC.
000249
000250 IF SQLCODE NOT = +0
000251 MOVE 1 TO LK-ERRO-CICS
000252 ADD 1 TO PRM-QTDE-ERROS
000253 MOVE SPACES TO PRM-INFORMACOES (PRM-QTDE-ERROS)
000254 MOVE SQLCODE TO WS-ED-SQLCODE
000255 STRING 'Erro de acesso a base SQLCODE: '
000256 WS-ED-SQLCODE
000257 ' ERRMC: '
000258 SQLERRMC
000259 ' - Tabela utilizada -> ' WS-PRM-TABELA
000260 DELIMITED BY SIZE
000261 INTO PRM-INFORMACOES (PRM-QTDE-ERROS)
END-STRING
000262 MOVE '0003' TO PRM-NUMERO-MENSAGEM(PRM-QTDE-ERROS)
000263 MOVE 'EMPPO556' TO PRM-PROGRAMA (PRM-QTDE-ERROS)
000264 PERFORM P999-PROCED-FINAIS
000265 END-IF.
000266
000272 EXEC SQL
000273 FETCH CUR001
000274 INTO :EMPTB004.NU-ENTIDADE
000275 END-EXEC.
000276
000277 IF SQLCODE NOT = +0 AND +100
000278 MOVE 1 TO LK-ERRO-CICS
000279 ADD 1 TO PRM-QTDE-ERROS
000280 MOVE SPACES TO PRM-INFORMACOES (PRM-QTDE-ERROS)
000281 MOVE SQLCODE TO WS-ED-SQLCODE
000282 STRING 'Erro de acesso a base SQLCODE: '
000283 WS-ED-SQLCODE
000284 ' ERRMC: '
000285 SQLERRMC
000286 ' - Tabela utilizada -> ' WS-PRM-TABELA
000287 DELIMITED BY SIZE
000288 INTO PRM-INFORMACOES (PRM-QTDE-ERROS)
END-STRING
000289 MOVE '0003' TO PRM-NUMERO-MENSAGEM (PRM-QTDE-ERROS)
000290 MOVE 'EMPPO556' TO PRM-PROGRAMA (PRM-QTDE-ERROS)
000291 PERFORM P999-PROCED-FINAIS
000292 END-IF.
000000 R100-FIM.
000000 EXIT.
000000
000199 R999-PROCEDIMENTOS-FINAIS.
000200*-------------------------
000201 IF LKS-ERRO-CICS = 1
000202 MOVE LENGTH OF WS-AREA-ERROS TO LKS-CONTEUDO-TAM
000203 MOVE WS-AREA-ERROS TO LKS-CONTEUDO (1:LKS-CONTEUDO-TAM)
000205 END-IF.
000206 EXEC CICS
000207 RETURN
000208 END-EXEC.
000209 P999-FIM.
000210 EXIT.
000211*----------------- F I M D O C O D I G O --------------------*
|
