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. SELECT01.
000005
000006* Sistema : EXEMPLO
000007* Programa : SELECT01
000008* Objetivo : Listar numero e nome da 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.
000036 03 PRM-QTDE-CONTA PIC 9(004).
000037 03 PRM-ARRAY-SAIDA OCCURS 1 TO 454 TIMES
000038 DEPENDING ON PRM-QTDE-CONTA.
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
000081 PRM-QTDE-CONTA
000082 PRM-QTDE-ERROS.
000083 R000-FIM.
000084 EXIT.
000085
000086 R100-PROCED-PRINCIPAIS.
000087*----------------------
000088 PERFORM R200-ABRE-CONTA THRU R200-FIM.
000089 PERFORM R210-LE-CONTA THRU R210-FIM.
000090 IF SQLCODE EQUAL +100
000091 MOVE 1 TO LKS-ERRO-CICS
000092 ADD 1 TO PRM-QTDE-ERROS
000093 MOVE SPACES TO PRM-INFORMACOES (PRM-QTDE-ERROS)
000094 MOVE SQLCODE TO LKS-NU-SQLCODE
000095 MOVE SQLCODE TO WS-SQLCODE-EDT
000096 STRING 'Nenhum registro encontrado na tabela TABELA01.'
000102 DELIMITED BY SIZE
000103 INTO PRM-INFORMACOES (PRM-QTDE-ERROS)
END-STRING
000104 MOVE '0001' TO PRM-NUMERO-MENSAGEM (PRM-QTDE-ERROS)
000105 MOVE 'SELECT01' TO PRM-PROGRAMA (PRM-QTDE-ERROS)
000106 PERFORM R999-PROCEDIMENTOS-FINAIS
000107 END-IF.
000108 PERFORM UNTIL SQLCODE = +100
000109 PERFORM R220-MONTA-CONTA THRU R220-FIM
000110 PERFORM R210-LE-CONTA THRU R210-FIM
000111 IF PRM-QTDE-CONTA = 454
000112 MOVE +100 TO SQLCODE
000113 END-IF
000114 END-PERFORM.
000115 PERFORM R230-FECHA-CONTA THRU R230-FIM.
000116 MOVE LENGTH OF WS-AREA-SAIDA TO LKS-CONTEUDO-TAM.
000118 MOVE WS-AREA-SAIDA TO LKS-CONTEUDO (1:LKS-CONTEUDO-TAM).
000119
000120 R100-FIM.
000121 EXIT.
000122
000123 R200-ABRE-CONTA.
000124*---------------
000125 EXEC SQL DECLARE CUR001 CURSOR FOR
000126 SELECT NU_CONTA
000000 , NO_CONTA
000127 FROM DCL.TABELA01_CONTA
000128 END-EXEC.
000129
000130 EXEC SQL
000131 OPEN CUR001
000132 END-EXEC.
000133 IF SQLCODE NOT EQUAL +0
000134 MOVE 1 TO LKS-ERRO-CICS
000135 ADD 1 TO PRM-QTDE-ERROS
000136 MOVE SPACES TO PRM-INFORMACOES (PRM-QTDE-ERROS)
000137 MOVE SQLCODE TO LKS-NU-SQLCODE
000138 MOVE SQLCODE TO WS-SQLCODE-EDT
000139 STRING 'Erro de acesso a base de dados. SQLCODE: '
000140 WS-SQLCODE-EDT ' ErrMc: ' SQLERRMC
000143 ' - Tabela utilizada -> TABELA01'
000145 DELIMITED BY SIZE
000146 INTO PRM-INFORMACOES (PRM-QTDE-ERROS)
000147 MOVE '0001' TO PRM-NUMERO-MENSAGEM (PRM-QTDE-ERROS)
000148 MOVE 'SELECT01' TO PRM-PROGRAMA (PRM-QTDE-ERROS)
000149 PERFORM R999-PROCEDIMENTOS-FINAIS
END-STRING
000150 END-IF.
000151 R200-FIM.
000152 EXIT.
000153
000154 R210-LE-CONTA.
000155*-------------
000156 EXEC SQL
000157 FETCH CUR001
000158 INTO :NU-CONTA
000159 , :NO-CONTA
000160 END-EXEC.
000161 IF SQLCODE NOT EQUAL +0 AND +100
000162 MOVE 1 TO LKS-ERRO-CICS
000163 ADD 1 TO PRM-QTDE-ERROS
000164 MOVE SPACES TO PRM-INFORMACOES (PRM-QTDE-ERROS)
000165 MOVE SQLCODE TO LKS-NU-SQLCODE
000166 MOVE SQLCODE TO WS-SQLCODE-EDT
000167 STRING 'Erro de acesso a base. SQLCODE: '
000168 WS-SQLCODE-EDT ' ErrMc: ' SQLERRMC
000171 ' - Tabela utilizada -> TABELA01'
000173 DELIMITED BY SIZE
000174 INTO PRM-INFORMACOES (PRM-QTDE-ERROS)
END-STRING
000175 MOVE '0002' TO PRM-NUMERO-MENSAGEM (PRM-QTDE-ERROS)
000176 MOVE 'SELECT01' TO PRM-PROGRAMA (PRM-QTDE-ERROS)
000177 PERFORM R230-FECHA-CONTA THRU R230-FIM
000178 PERFORM R999-PROCEDIMENTOS-FINAIS
000179 END-IF.
000180 R210-FIM.
000181 EXIT.
000182
000183 R220-MONTA-CONTA.
000184*----------------
000185 ADD 1 TO PRM-QTDE-CONTA.
000186 MOVE NU-CONTA TO PRM-NU-CONTA (PRM-QTDE-CONTA).
000187 MOVE NO-CONTA TO PRM-NO-CONTA (PRM-QTDE-CONTA).
000188 R220-FIM.
000189 EXIT.
000190
000191 R230-FECHA-CONTA.
000192*----------------
000193 EXEC SQL
000194 CLOSE CUR001
000195 END-EXEC.
000196 R230-FIM.
000197 EXIT.
000198
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 --------------------*
|
