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. SELECT02.
000005
000006* Sistema : EXEMPLO
000007* Programa : SELECT02
000008* Objetivo : Buscar o nome do Cliente cfe 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
000022 ENVIRONMENT DIVISION.
000023*---------------------
000024 CONFIGURATION SECTION.
000025*---------------------
000026 SPECIAL-NAMES.
000027 DECIMAL-POINT IS COMMA.
000028
000029 DATA DIVISION.
000030*-------------
000031 WORKING-STORAGE SECTION.
000032*-----------------------
000033 77 WS-SQLCODE-EDT PIC ----9.
000034 01 AREAS-DE-TRABALHO.
000035 03 WS-TAM PIC 9(005).
000036 01 WS-AREA-ENTRADA.
000037 05 PRM-NU-CONTA PIC 9(004).
000038 01 WS-AREA-SAIDA.
000039 05 PRM-NO-CONTA PIC X(040).
000040 01 WS-AREA-ERROS.
000041 03 PRM-QTDE-ERROS PIC 9(003).
000042 03 PRM-ARRAY-ERROS OCCURS 1 TO 094 TIMES
000043 DEPENDING ON PRM-QTDE-ERROS.
000044 05 PRM-NUMERO-MENSAGEM PIC X(004).
000045 05 PRM-PROGRAMA PIC X(008).
000046 05 PRM-INFORMACOES PIC X(200).
000047
000048* Definicao de tabelas e areas na DCLGEN *
000049*----------------------------------------------------------------*
000050
000051 EXEC SQL INCLUDE SQLCA END-EXEC.
000052 EXEC SQL INCLUDE TABELA01 END-EXEC.
000053
000054 LINKAGE SECTION.
000055*---------------
000056 01 DFHCOMMAREA.
000057 03 LKS-EXCECAO.
000058 05 LKS-ERRO-CICS PIC 9(003).
000059 05 LKS-NU-MENSAGEM PIC 9(004).
000060 05 LKS-NO-MENSAGEM PIC X(078).
000061 05 LKS-NU-SQLCODE PIC 9(004).
000062 03 LKS-IDENTIFICACAO.
000063 05 LKS-IN-NOME-PGM PIC X(008).
000064 05 LKS-IN-CO-USUARIO PIC X(008).
000065 05 LKS-IN-CO-FUNCAO PIC X(002).
000066 03 LKS-ENTRADA-SAIDA.
000067 05 LKS-CONTEUDO-TAM PIC 9(005).
000068 05 LKS-CONTEUDO.
000069 07 FILLER PIC X(001) OCCURS 1 TO 20000
000070 DEPENDING ON LKS-CONTEUDO-TAM.
000071
000072 PROCEDURE DIVISION USING DFHCOMMAREA.
000073*------------------------------------
000074
000075 PERFORM R000-PROCED-INICIAIS THRU R000-FIM.
000076 PERFORM R100-PROCED-PRINCIPAIS THRU R100-FIM.
000077 PERFORM R999-PROCEDIMENTOS-FINAIS THRU P999-FIM.
000078
000079 R000-PROCED-INICIAIS.
000080*--------------------
000081
000082 INITIALIZE LKS-EXCECAO.
000083 MOVE SPACES TO LKS-CONTEUDO(1:20000).
000084 MOVE ZEROES TO LKS-CONTEUDO-TAM
000085 PRM-QTDE-ERROS.
000086 R000-FIM.
000087 EXIT.
000088
000089 R100-PROCED-PRINCIPAIS.
000090*----------------------
000091
000092 MOVE PRM-NU-CONTA TO NU-CONTA.
000093 EXEC SQL
000094 SELECT NO_CONTA
000095 INTO NO-CONTA
000096 FROM DCL.TABELA01_CONTA
000097 WHERE NU_CONTA = :NU-CONTA
000098 END-EXEC.
000099
000100 IF SQLCODE EQUAL +100
000101 MOVE 1 TO LKS-ERRO-CICS
000102 ADD 1 TO PRM-QTDE-ERROS
000103 MOVE SPACES TO PRM-INFORMACOES (PRM-QTDE-ERROS)
000104 MOVE SQLCODE TO LKS-NU-SQLCODE
000105 MOVE SQLCODE TO WS-SQLCODE-EDT
000106 STRING 'Nenhum registro encontrado na tabela TABELA01.'
000107 DELIMITED BY SIZE
000108 INTO PRM-INFORMACOES (PRM-QTDE-ERROS)
000109 MOVE '0001' TO PRM-NUMERO-MENSAGEM (PRM-QTDE-ERROS)
000110 MOVE 'SELECT02' TO PRM-PROGRAMA (PRM-QTDE-ERROS)
000111 PERFORM R999-PROCEDIMENTOS-FINAIS
000112 END-IF.
000113
000114 IF SQLCODE NOT EQUAL +0
000115 MOVE 1 TO LKS-ERRO-CICS
000116 ADD 1 TO PRM-QTDE-ERROS
000117 MOVE SPACES TO PRM-INFORMACOES (PRM-QTDE-ERROS)
000118 MOVE SQLCODE TO LKS-NU-SQLCODE
000119 MOVE SQLCODE TO WS-SQLCODE-EDT
000120 STRING 'Erro de acesso a base de dados. SQLCODE: '
000121 WS-SQLCODE-EDT ' ErrMc: ' SQLERRMC
000122 ' - Tabela utilizada -> TABELA01'
000123 DELIMITED BY SIZE
000124 INTO PRM-INFORMACOES (PRM-QTDE-ERROS)
000125 MOVE '0001' TO PRM-NUMERO-MENSAGEM (PRM-QTDE-ERROS)
000126 MOVE 'SELECT02' TO PRM-PROGRAMA (PRM-QTDE-ERROS)
000127 PERFORM R999-PROCEDIMENTOS-FINAIS
000128 END-IF.
000129
000000 MOVE NO-CONTA TO PRM-NO-CONTA.
000130 MOVE LENGTH OF WS-AREA-SAIDA TO LKS-CONTEUDO-TAM.
000131 MOVE WS-AREA-SAIDA TO LKS-CONTEUDO (1:LKS-CONTEUDO-TAM).
000132
000133 R100-FIM.
000134 EXIT.
000135
000136 R999-PROCEDIMENTOS-FINAIS.
000137*-------------------------
000138
000139 IF LKS-ERRO-CICS = 1
000140 MOVE LENGTH OF WS-AREA-ERROS TO LKS-CONTEUDO-TAM
000141 MOVE WS-AREA-ERROS TO LKS-CONTEUDO (1:LKS-CONTEUDO-TAM)
000142 END-IF.
000143
000144 EXEC CICS
000145 RETURN
000146 END-EXEC.
000147
000148 P999-FIM.
000149 EXIT.
000150*----------------- F I M D O C O D I G O --------------------*
|
