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 os dados 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*----------------------------------------------------------------*
000000
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).
000039 01 WS-VARIAVEIS-DB2.
000040 03 WS-GR-CURSOR.
000041 49 WS-ID-TAMANHO-CURSOR PIC S9(004) COMP VALUE ZEROES.
000042 49 WS-DE-CURSOR PIC X(2000) VALUE SPACES.
000035 01 WS-AREA-ENTRADA.
000039 05 PRM-NU-CONTA-E PIC 9(004).
000035 01 WS-AREA-SAIDA.
000036 03 PRM-QTDE-CONTA PIC 9(004).
000037 03 PRM-ARRAY-SAIDA OCCURS 1 TO 100 TIMES
000038 DEPENDING ON PRM-QTDE-CONTA.
000039 05 PRM-NU-CONTA PIC 9(004).
000040 05 PRM-NO-CONTA PIC X(040).
000040 05 PRM-NO-ENDERECO PIC X(070).
000040 05 PRM-NO-CIDADE PIC X(050).
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*------------------------------------
000000
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*--------------------
000000
000105 MOVE LK-CONTEUDO(1:LK-CONTEUDO-TAM) TO WS-AREA-ENTRADA.
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*----------------------
000000
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 = 100
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*---------------
000000
000136 INITIALIZE WS-GR-CURSOR.
000137 MOVE 1 TO WS-ID-TAMANHO-CURSOR.
000000 MOVE PRM-NU-CONTA-E TO NU-CONTA.
000138
000139 STRING
000140 'SELECT NU_CONTA , NO_CONTA , NO_ENDERECO , NO_CIDADE '
000000 'FROM DCL.TABELA01_CONTA '
000141 DELIMITED BY SIZE INTO WS-DE-CURSOR
000142 WITH POINTER WS-ID-TAMANHO-CURSOR
000000 END-STRING.
000000
000000 IF NU-CONTA NOT EQUAL ZEROES
000139 STRING
000140 'WHERE NU_CONTA >= ' :NU-CONTA
000141 DELIMITED BY SIZE INTO WS-DE-CURSOR
000142 WITH POINTER WS-ID-TAMANHO-CURSOR
000000 END-STRING
000000 END-IF.
000000
000225 EXEC SQL
000226 PREPARE CONSULTA FROM :WS-GR-CURSOR
000227 END-EXEC.
000228
000229 IF SQLCODE NOT EQUAL +0
000230 MOVE 1 TO LK-ERRO-CICS
000231 MOVE SQLCODE TO LK-NU-SQLCODE
000232 PERFORM R999-PROCEDIMENTOS-FINAIS
000233 END-IF.
000234
000235 EXEC SQL
000236 DECLARE CUR001 CURSOR FOR CONSULTA
000237 END-EXEC.
000238
000239 IF SQLCODE NOT EQUAL +0
000240 MOVE 1 TO LK-ERRO-CICS
000241 MOVE SQLCODE TO LK-NU-SQLCODE
000242 PERFORM R999-PROCEDIMENTOS-FINAIS
000243 END-IF
000244
000245 EXEC SQL
000246 OPEN CUR001
000247 END-EXEC.
000248
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.
000000
000151 R200-FIM.
000152 EXIT.
000153
000154 R210-LE-CONTA.
000155*-------------
000000
000156 EXEC SQL
000157 FETCH CUR001
000158 INTO :NU-CONTA
000159 , :NO-CONTA
000159 , :NO-ENDERECO
000159 , :NO-CIDADE
000160 END-EXEC.
000000
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.
000000
000180 R210-FIM.
000181 EXIT.
000182
000183 R220-MONTA-CONTA.
000184*----------------
000000
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).
000186 MOVE NO-ENDERECO TO PRM-NO-ENDERECO (PRM-QTDE-CONTA).
000187 MOVE NO-CIDADE TO PRM-NO-CIDADE (PRM-QTDE-CONTA).
000000
000188 R220-FIM.
000189 EXIT.
000190
000191 R230-FECHA-CONTA.
000192*----------------
000000
000193 EXEC SQL
000194 CLOSE CUR001
000195 END-EXEC.
000000
000196 R230-FIM.
000197 EXIT.
000198
000199 R999-PROCEDIMENTOS-FINAIS.
000200*-------------------------
000000
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.
000000
000209 P999-FIM.
000210 EXIT.
000211*----------------- F I M D O C O D I G O --------------------*
|
