Montagem do XML em COBOL - COBOL/CICS/DB2
Desenvolvido por DORNELLES Carlos Alberto - Analista de Sistemas - Brasília DF. - cad_cobol@hotmail.com
Segundo exemplo
*----------------------------------------------------------------* IDENTIFICATION DIVISION. *--------------------------------------------------------------* PROGRAM-ID. CADPO002. AUTHOR. CARLOS ALBERTO DORNELLES. * SISTEMA : SICAD * PROGRAMA : CADPO002 * OBJETIVO : LISTAR TODOS OS USUARIOS E CAIXA POSTAL * ANALISTA : CARLOS ALBERTO DORNELLES * VERSAO : V.001 * DATA : 06/10/2003 * LINGUAGEM : COBOL CICS/DB2 *--------------------------------------------------------------* * MANUTENCAO * *--------------------------------------------------------------* * VRS DD.MM.AA AUTOR DESCRICAO *--------------------------------------------------------------* *----------------------------------------------------------------* ENVIRONMENT DIVISION. *----------------------------------------------------------------* CONFIGURATION SECTION. SPECIAL-NAMES. DECIMAL-POINT IS COMMA. *----------------------------------------------------------------* DATA DIVISION. *----------------------------------------------------------------* WORKING-STORAGE SECTION. *----------------------------------------------------------------* 01 WS-AUXILIARES. 05 WS-LETRA PIC X(001) VALUE SPACES. 05 WS-NO-USUARIO-BAN PIC X(040) VALUE SPACES. 05 WS-DT-VIGENCIA PIC X(026) VALUE SPACES. 05 WS-CONRO PIC 9(005) VALUE ZEROES. 05 WS-COUNT PIC S9(05) COMP. 05 WS-PERMISSAO PIC X(001) VALUE SPACES. 05 WS-FIM-CURSOR01 PIC X(001) VALUE SPACES. 05 WS-FIM-CURSOR02 PIC X(001) VALUE SPACES. 05 WS-FIM-CURSOR03 PIC X(001) VALUE SPACES. 05 WS-NU-SEQ-AUTORIZACAO PIC 9(004) VALUE ZEROES. 01 WS-AREA-SAIDA. 05 WS-ID-SAIDA PIC 9(005) VALUE ZEROES. 05 WS-GR-SAIDA PIC X(20000) VALUE SPACES. *----------------------------------------------------------------* * INCLUDE PARA ACESSO A DB2 * *----------------------------------------------------------------* EXEC SQL INCLUDE SQLCA END-EXEC. EXEC SQL INCLUDE CADTB013 END-EXEC. EXEC SQL INCLUDE CADTB015 END-EXEC. EXEC SQL INCLUDE CADTB017 END-EXEC. EXEC SQL INCLUDE CADVW001 END-EXEC. EXEC SQL INCLUDE CADVW002 END-EXEC. *-------------------------------------------------------------* * DECLARACAO DO CURSOR CURSOR01 * *-------------------------------------------------------------* EXEC SQL DECLARE CURSOR01 CURSOR FOR SELECT 'A' , T013.NU_SEQ_AUTORIZACAO , T013.TS_AUTORIZACAO , VALUE(T013.CO_USRO_PRMSO,' ') , VALUE(T013.CO_USUARIO,' ') , VALUE(V001.NO_USUARIO,' ') , VALUE(V001.IC_SITUACAO,' ') , VALUE(T013.NO_CXA_PSTL_UNDDE,' ') , TB013.DT_VIGENCIA FROM CAD.CADTB013_ATRZO AS T013 , CAD.CADVW001_CDST_USRO AS V001 , (SELECT NU_SEQ_AUTORIZACAO , MAX(TS_AUTORIZACAO) AS DT_VIGENCIA FROM CAD.CADTB013_ATRZO GROUP BY NU_SEQ_AUTORIZACAO ) AS TB013 WHERE T013.TS_AUTORIZACAO = TB013.DT_VIGENCIA AND T013.NU_SEQ_AUTORIZACAO = TB013.NU_SEQ_AUTORIZACAO AND T013.CO_USUARIO = V001.CO_USUARIO AND EXISTS ( SELECT 1 FROM CAD.CADTB015_PERMISSAO B015 , CAD.CADTB017_ATRZ_PRMS B017 WHERE B015.NU_PERMISSAO = B017.NU_PERMISSAO AND B017.TS_AUTORIZACAO = T013.TS_AUTORIZACAO ) UNION ALL SELECT 'B' , T013.NU_SEQ_AUTORIZACAO , T013.TS_AUTORIZACAO , VALUE(T013.CO_USRO_PRMSO,' ') , VALUE(T013.CO_USUARIO,' ') , VALUE(V001.NO_USUARIO,' ') , VALUE(V001.IC_SITUACAO,' ') , VALUE(T013.NO_CXA_PSTL_UNDDE,' ') , TB013.DT_VIGENCIA FROM CAD.CADTB013_ATRZO AS T013 , CAD.CADVW001_CDST_USRO AS V001 , (SELECT NU_SEQ_AUTORIZACAO , MAX(TS_AUTORIZACAO) AS DT_VIGENCIA FROM CAD.CADTB013_ATRZO GROUP BY NU_SEQ_AUTORIZACAO ) AS TB013 WHERE T013.TS_AUTORIZACAO = TB013.DT_VIGENCIA AND T013.NU_SEQ_AUTORIZACAO = TB013.NU_SEQ_AUTORIZACAO AND T013.CO_USUARIO = V001.CO_USUARIO AND NOT EXISTS ( SELECT 1 FROM CAD.CADTB015_PERMISSAO B015 , CAD.CADTB017_ATRZ_PRMS B017 WHERE B015.NU_PERMISSAO = B017.NU_PERMISSAO AND B017.TS_AUTORIZACAO = T013.TS_AUTORIZACAO ) ORDER BY 1,2 END-EXEC. EXEC SQL DECLARE CURSOR02 CURSOR FOR SELECT NU_PERMISSAO , NO_PERMISSAO , IC_PERMISSAO FROM CAD.CADTB015_PERMISSAO END-EXEC. EXEC SQL DECLARE CURSOR03 CURSOR FOR SELECT NU_PERMISSAO , NO_PERMISSAO , IC_PERMISSAO FROM CAD.CADTB015_PERMISSAO WHERE IC_PERMISSAO= 'S' END-EXEC. *----------------------------------------------------------------* LINKAGE SECTION. *----------------------------------------------------------------* 01 DFHCOMMAREA. 03 LK-EXCECAO. 05 LK-ERRO-CICS PIC 9(003). 05 LK-NU-MENSAGEM PIC 9(004). 05 LK-NO-MENSAGEM PIC X(078). 05 LK-CO-SQLCODE PIC 9(004). 03 LK-IDENTIFICACAO. 05 LK-IN-NOME-PGM PIC X(008). 05 LK-IN-CO-USUARIO PIC X(008). 05 LK-IN-CO-FUNCAO PIC X(002). 03 LK-ENTRADA-SAIDA. 05 LK-CONTEUDO-TAM PIC 9(005). 05 LK-CONTEUDO. 07 FILLER PIC X(001) OCCURS 1 TO 20000 DEPENDING ON LK-CONTEUDO-TAM. *----------------------------------------------------------------* PROCEDURE DIVISION USING DFHCOMMAREA. *----------------------------------------------------------------* PERFORM P000-PROCED-INICIAIS THRU P000-FIM. PERFORM P100-PROCED-PRINCIPAIS THRU P100-FIM. PERFORM P999-PROCED-FINAIS THRU P999-FIM. *----------------------------------------------------------------* P000-PROCED-INICIAIS. *----------------------------------------------------------------* MOVE SPACES TO LK-CONTEUDO(1:20000) MOVE ZEROES TO LK-CONTEUDO-TAM INITIALIZE LK-EXCECAO. P000-FIM. EXIT. *----------------------------------------------------------------* P100-PROCED-PRINCIPAIS. *----------------------------------------------------------------* EXEC SQL OPEN CURSOR01 END-EXEC. IF SQLCODE NOT EQUAL +0 MOVE 'ERRO DE DB2' TO LK-NO-MENSAGEM PERFORM P800-ERRO-DB2 THRU P800-FIM END-IF. PERFORM P200-LER-CURSOR01 THRU P200-FIM. MOVE 1 TO WS-ID-SAIDA STRING * '<?XML VERSION="1.0" ENCONDIG="ISO=8859-1" ?>' '<CLASS>' DELIMITED BY SIZE INTO WS-GR-SAIDA WITH POINTER WS-ID-SAIDA END-STRING. PERFORM UNTIL WS-FIM-CURSOR01 EQUAL 'F' ADD 1 TO WS-CONRO STRING '<CONJU>' '<CONRO>' WS-CONRO '</CONRO>' DELIMITED BY SIZE INTO WS-GR-SAIDA WITH POINTER WS-ID-SAIDA END-STRING PERFORM P230-MOVE-DADOS THRU P230-FIM IF CO-USRO-PRMSO NOT EQUAL SPACES EXEC SQL OPEN CURSOR02 END-EXEC PERFORM UNTIL WS-FIM-CURSOR02 EQUAL 'F' PERFORM P210-LER-CURSOR02 THRU P210-FIM IF WS-FIM-CURSOR02 NOT EQUAL 'F' PERFORM P270-MONTA-PERMISSAO THRU P270-FIM END-IF END-PERFORM EXEC SQL CLOSE CURSOR02 END-EXEC MOVE SPACES TO WS-FIM-CURSOR02 END-IF IF CO-USRO-PRMSO EQUAL SPACES AND NO-CXA-PSTL-UNDDE NOT EQUAL SPACES EXEC SQL OPEN CURSOR03 END-EXEC PERFORM UNTIL WS-FIM-CURSOR03 EQUAL 'F' PERFORM P220-LER-CURSOR03 THRU P220-FIM IF WS-FIM-CURSOR03 NOT EQUAL 'F' PERFORM P270-MONTA-PERMISSAO THRU P270-FIM END-IF END-PERFORM EXEC SQL CLOSE CURSOR03 END-EXEC MOVE SPACES TO WS-FIM-CURSOR03 END-IF STRING '</CONJU>' DELIMITED BY SIZE INTO WS-GR-SAIDA WITH POINTER WS-ID-SAIDA END-STRING PERFORM P200-LER-CURSOR01 THRU P200-FIM END-PERFORM. STRING '</CLASS>' DELIMITED BY SIZE INTO WS-GR-SAIDA WITH POINTER WS-ID-SAIDA END-STRING. EXEC SQL CLOSE CURSOR01 END-EXEC. IF SQLCODE NOT EQUAL +0 MOVE 'ERRO DE DB2' TO LK-NO-MENSAGEM PERFORM P800-ERRO-DB2 THRU P800-FIM END-IF. P100-FIM. EXIT. *----------------------------------------------------------------* P200-LER-CURSOR01. *----------------------------------------------------------------* EXEC SQL FETCH CURSOR01 INTO :WS-LETRA , :CADTB013.NU-SEQ-AUTORIZACAO , :CADTB013.TS-AUTORIZACAO , :CADTB013.CO-USRO-PRMSO , :CADTB013.CO-USUARIO , :CADVW001.NO-USUARIO , :CADVW001.IC-SITUACAO , :CADTB013.NO-CXA-PSTL-UNDDE , :WS-DT-VIGENCIA END-EXEC. IF SQLCODE NOT EQUAL +0 AND +100 MOVE 'ERRO DE DB2' TO LK-NO-MENSAGEM PERFORM P800-ERRO-DB2 THRU P800-FIM END-IF. IF SQLCODE EQUAL +100 MOVE 'F' TO WS-FIM-CURSOR01 END-IF. P200-FIM. EXIT. *----------------------------------------------------------------* P210-LER-CURSOR02. *----------------------------------------------------------------* EXEC SQL FETCH CURSOR02 INTO :CADTB015.NU-PERMISSAO , :CADTB015.NO-PERMISSAO , :CADTB015.IC-PERMISSAO END-EXEC. IF SQLCODE NOT EQUAL +0 AND +100 MOVE 'ERRO DE DB2' TO LK-NO-MENSAGEM PERFORM P800-ERRO-DB2 THRU P800-FIM END-IF. IF SQLCODE EQUAL +100 MOVE 'F' TO WS-FIM-CURSOR02 END-IF. P210-FIM. EXIT. *----------------------------------------------------------------* P220-LER-CURSOR03. *----------------------------------------------------------------* EXEC SQL FETCH CURSOR03 INTO :CADTB015.NU-PERMISSAO , :CADTB015.NO-PERMISSAO , :CADTB015.IC-PERMISSAO END-EXEC. IF SQLCODE NOT EQUAL +0 AND +100 MOVE 'ERRO DE DB2' TO LK-NO-MENSAGEM PERFORM P800-ERRO-DB2 THRU P800-FIM END-IF. IF SQLCODE EQUAL +100 MOVE 'F' TO WS-FIM-CURSOR03 END-IF. P220-FIM. EXIT. *----------------------------------------------------------------* P230-MOVE-DADOS. *----------------------------------------------------------------* PERFORM P250-BUSCA-NO-USUARIO THRU P250-FIM. PERFORM P260-BUSCA-IC-POSTAL THRU P260-FIM. MOVE NU-SEQ-AUTORIZACAO OF CADTB013 TO WS-NU-SEQ-AUTORIZACAO STRING '<NUSEQ>' WS-NU-SEQ-AUTORIZACAO '</NUSEQ>' '<DELET>' WS-LETRA '</DELET>' '<CAIXA>' NO-CXA-PSTL-UNDDE '</CAIXA>' '<SITUA>' IC-ULTIMA-SITUACAO '</SITUA>' '<COUSU>' CO-USRO-PRMSO OF CADTB013 '</COUSU>' '<NOCAD>' NO-USUARIO OF CADVW001 '</NOCAD>' '<NOUSU>' WS-NO-USUARIO-BAN '</NOUSU>' '<TSAUT>' WS-DT-VIGENCIA '</TSAUT>' '<ICSIT>' IC-SITUACAO OF CADVW001 '</ICSIT>' DELIMITED BY SIZE INTO WS-GR-SAIDA WITH POINTER WS-ID-SAIDA END-STRING. P230-FIM. EXIT. *----------------------------------------------------------------* P240-VER-PERMISSAO. *----------------------------------------------------------------* EXEC SQL SELECT COUNT(*) INTO :WS-COUNT FROM CAD.CADTB015_PERMISSAO B015 , CAD.CADTB017_ATRZ_PRMS B017 WHERE B017.NU_PERMISSAO = :CADTB015.NU-PERMISSAO AND B017.TS_AUTORIZACAO = :CADTB013.TS-AUTORIZACAO END-EXEC. IF WS-COUNT EQUAL ZEROES MOVE 'N' TO WS-PERMISSAO ELSE MOVE 'S' TO WS-PERMISSAO END-IF. P240-FIM. EXIT. *----------------------------------------------------------------* P250-BUSCA-NO-USUARIO. *----------------------------------------------------------------* EXEC SQL SELECT NO_USUARIO , IC_SITUACAO INTO :WS-NO-USUARIO-BAN , :IC-SITUACAO FROM CAD.CADVW001_CDST_USRO WHERE CO_USUARIO = :CADTB013.CO-USRO-PRMSO END-EXEC. IF SQLCODE NOT EQUAL +0 AND +100 MOVE 'ERRO DE DB2' TO LK-NO-MENSAGEM PERFORM P800-ERRO-DB2 THRU P800-FIM END-IF. IF SQLCODE EQUAL +100 MOVE SPACES TO WS-NO-USUARIO-BAN END-IF. P250-FIM. EXIT. *----------------------------------------------------------------* P260-BUSCA-IC-POSTAL. *----------------------------------------------------------------* * EXEC SQL * SELECT VALUE(IC_ULTIMA_SITUACAO,' ') * INTO :IC-ULTIMA-SITUACAO * FROM CAD.CADVW002_CXA_PSTL * WHERE CO_COMUNICACAO = :CADTB013.NO-CXA-PSTL-UNDDE * END-EXEC. IF SQLCODE NOT EQUAL +0 AND +100 MOVE 'ERRO DE DB2' TO LK-NO-MENSAGEM PERFORM P800-ERRO-DB2 THRU P800-FIM END-IF. MOVE 'AT' TO IC-ULTIMA-SITUACAO IF SQLCODE EQUAL +100 MOVE 'AT' TO IC-ULTIMA-SITUACAO END-IF. P260-FIM. EXIT. *----------------------------------------------------------------* P270-MONTA-PERMISSAO. *----------------------------------------------------------------* PERFORM P240-VER-PERMISSAO THRU P240-FIM. STRING '<PERMI>' '<NOPER>' NO-PERMISSAO OF CADTB015 '</NOPER>' '<NUPER>' WS-PERMISSAO '</NUPER>' '</PERMI>' DELIMITED BY SIZE INTO WS-GR-SAIDA WITH POINTER WS-ID-SAIDA END-STRING. P270-FIM. EXIT. *----------------------------------------------------------------* P800-ERRO-DB2. *----------------------------------------------------------------* MOVE 1 TO LK-ERRO-CICS MOVE SQLCODE TO LK-CO-SQLCODE MOVE 'CADPO002' TO LK-IN-NOME-PGM PERFORM P999-PROCED-FINAIS THRU P999-FIM. P800-FIM. EXIT. *----------------------------------------------------------------* P999-PROCED-FINAIS. *----------------------------------------------------------------* MOVE WS-ID-SAIDA TO LK-CONTEUDO-TAM MOVE WS-GR-SAIDA TO LK-CONTEUDO EXEC CICS RETURN END-EXEC. P999-FIM. EXIT.
