IDENTIFICATION DIVISION.
PROGRAM-ID. Y1CPY1RR.
DATE-COMPILED. 12/02/11
ENVIRONMENT DIVISION.
CONFIGURATION SECTION.
SPECIAL-NAMES.
DECIMAL-POINT IS COMMA.
DATA DIVISION.
SKIP2
WORKING-STORAGE SECTION.
********************************************************
* T E L O N R E L E A S E D A T A *
********************************************************
SKIP1
01 TELON-RELEASE-DATA.
05 TELON-RELEASE-EYECATCH PIC X(10) VALUE 'TELON ID'.
05 TELON-REL-MOD-ID PIC X(6) VALUE '5.1 '.
05 TELON-REL-DATE PIC X(6) VALUE '100531'.
05 TELON-MOD-NO PIC X(4) VALUE '1005'.
05 TELON-MOD-DATE PIC X(6) VALUE '100531'.
05 TELON-PGM-ID PIC X(6) VALUE 'CIC'.
05 TELON-EXECUTION-OPTIONS.
10 TELON-TRACE-OPTION PIC X VALUE 'N'.
10 FILLER PIC X(7) VALUE SPACES.
05 TELON-GEN-DATE PIC X(8) VALUE '12/02/11'.
05 TELON-GEN-TIME PIC X(5) VALUE '14.36'.
05 TELON-CREATE-DATE PIC X(8) VALUE '09/03/02'.
05 TELON-UPDATE-DATE PIC X(8) VALUE '09/26/11'.
05 TELON-UPDATE-TIME PIC X(5) VALUE '14.11'.
05 TELON-UPDATE-USER PIC X(8) VALUE 'U7PTKI'.
05 TELON-PROGRAM-FEATURES.
10 TELON-PGMSTRUCT-FEATURE PIC X VALUE '3'.
10 TELON-LINEOPT-FEATURE PIC X VALUE '1'.
10 TELON-ABNORMALT-FEATURE PIC X VALUE '3'.
10 TELON-COBOL-VERSION PIC X VALUE '3'.
10 TELON-EATTR-FEATURE PIC X VALUE 'Y'.
10 FILLER PIC X(5) VALUE SPACES.
SKIP1
EJECT
********************************************************
* A B N O R M A L T E R M I N A T I O N A R E A *
********************************************************
SKIP1
01 ABNORMAL-TERMINATION-AREA.
05 FILLER PIC X(8) VALUE 'ABT AREA'.
05 ABT-TEST-FACILITY-AREA.
10 ABT-TEST-FACILITY-IND PIC X VALUE 'N'.
88 ABT-TEST-FACILITY-ACTIVE VALUE 'Y'.
88 ABT-TEST-FACILITY-NOT-ACTIVE VALUE 'N'.
10 ABT-TEST-MODE-IND PIC X VALUE 'P'.
88 ABT-TEST-MODE-ABT VALUE 'A'.
88 ABT-TEST-MODE-PGM VALUE 'P'.
* IF THE TELON TEST FACILITY IS ACTIVE
* AND THE ABT-TEST-MODE IS "P"
* THEN THE ABT-CONTROL-INDICATOR WILL BE FORCED TO SPACE.
10 FILLER PIC X(2) VALUE LOW-VALUES.
10 ABT-TEST-FACILITY-RESERVE PIC X(4) VALUE LOW-VALUES.
05 ABT-CONTROL-INFO.
10 ABT-CONTROL-INDICATOR PIC X VALUE 'A'.
88 ABT-DO-ABEND VALUE 'A'.
88 ABT-DO-WRITE VALUE 'E'.
88 ABT-DO-TRANSFER VALUE 'R'.
88 ABT-CONTINUE-PROCESS VALUE ' '.
10 ABT-IN-PROGRESS PIC X VALUE 'N'.
10 ABT-DYNAMIC-CONTROL-PGM PIC X(8) VALUE 'ADCCABT'.
10 ABT-DYNAMIC-CONTROL-RC PIC S9(4) COMP VALUE +0.
10 ABT-NUMBER-OF-STD-PARMS PIC 9(2) COMP VALUE 9.
10 ABT-NUMBER-OF-USER-PARMS PIC 9(2) COMP VALUE 0.
10 ABT-NUMBER-OF-DA-PARMS PIC 9(2) COMP VALUE 0.
10 ABT-PGM-GEN-TYPE PIC X(4) VALUE 'CICS'.
88 ABT-PGM-IS-TSOPGM VALUE 'TSO '.
88 ABT-PGM-IS-IMSDYN VALUE 'IDYN'.
88 ABT-PGM-IS-IMSSTAT VALUE 'ISTA'.
88 ABT-PGM-IS-IMSDRVR VALUE 'IDRV'.
88 ABT-PGM-IS-CICSPGM VALUE 'CICS'.
88 ABT-PGM-IS-BATCHPGM VALUE 'BATC'.
88 ABT-PGM-IS-STORED VALUE 'STPR'.
10 ABT-PGM-GEN-REL-LEVEL PIC X(4) VALUE '5.1 '.
10 ABT-PGM-NAME PIC X(8) VALUE 'Y1CPY1RR'.
10 ABT-PGM-TRAN-CODE PIC X(8) VALUE 'Y1RR'.
10 ABT-PGM-MAP-NAME PIC X(8) VALUE 'Y1ZY1RR'.
10 ABT-NEXT-PROGRAM-NAME.
15 ABT-NEXT-PROGRAM-NAME-HDR PIC X(4) VALUE 'Y1CP'.
15 ABT-NEXT-PROGRAM-NAME-ID PIC X(4) VALUE ' '.
10 ABT-TPO-ERRMSG1-LTH PIC 9(4) COMP VALUE 78.
10 ABT-ERROR-MESSAGE PIC X(80) VALUE SPACES.
10 ABT-SPA-TS-QUEUE-ID PIC X(8) VALUE LOW-VALUES.
SKIP1
05 ABT-PGM-ERROR-DATA.
10 ABT-ERROR-SECTION.
15 ABT-ERROR-SECTION-NAME PIC X(5) VALUE SPACES.
15 ABT-ERROR-SECTION-SUB PIC X(3) VALUE SPACES.
10 ABT-PROGRAM-FUNCTION REDEFINES
ABT-ERROR-SECTION PIC X(8).
* ABT PROGRAM FUNCTION VALUES ARE DOCUMENTED IN THE
* DYNAMICALLY INVOKED ABT ROUTINE.
10 ABT-ERROR-ACTIVITY PIC X(4).
88 ABT-ERROR-IS-TP-IMS VALUE 'IMS '.
88 ABT-ERROR-IS-TP-CICS VALUE 'CICS'.
88 ABT-ERROR-IS-TP-TSO VALUE 'TSO '.
88 ABT-ERROR-IS-SEQ VALUE 'SEQ '.
88 ABT-ERROR-IS-VSAM VALUE 'VSAM'.
88 ABT-ERROR-IS-DLI VALUE 'DLI '.
88 ABT-ERROR-IS-EXECDLI VALUE 'XDLI'.
88 ABT-ERROR-IS-DB2 VALUE 'DB2 '.
88 ABT-ERROR-IS-CQUEUE VALUE 'CQUE'.
88 ABT-ERROR-IS-CJOURNAL VALUE 'CJRL'.
10 ABT-ERROR-ABEND-CODE PIC S9(4) COMP.
10 FILLER PIC X(16) VALUE
LOW-VALUES.
SKIP1
05 ABT-DATA-ACCESS-INFO.
10 ABT-DA-FUNCTION PIC X(8) VALUE SPACES.
10 ABT-DA-FUNCTION-DLI REDEFINES ABT-DA-FUNCTION.
15 ABT-DA-FUNC-DLI PIC X(4).
15 ABT-DA-FUNC-PCB-TYPE PIC X(4).
10 ABT-U100-SUB PIC X(3) VALUE SPACES.
10 FILLER PIC X(1) VALUE LOW-VALUE.
10 ABT-DA-ACCESS-NAME PIC X(8).
10 ABT-DA-GENERIC-STATUS PIC X(3) VALUE SPACES.
88 ABT-DA-OK VALUE 'OK '.
88 ABT-DA-DUPLICATE VALUE 'DUP'.
88 ABT-DA-NOTAVAIL VALUE 'NAV'.
88 ABT-DA-NOTFOUND VALUE 'NFD'.
88 ABT-DA-ENDFILE VALUE 'EOF' 'NFD'.
88 ABT-DA-LOGICERR VALUE 'LOG'.
88 ABT-DA-SECURITY VALUE 'SEC'.
88 ABT-DA-DBMERROR VALUE 'DBM'.
88 ABT-DA-ANYERROR VALUE 'DUP' 'NAV'
'NFD' 'EOF'
'LOG' 'SEC'
'DBM'.
10 FILLER PIC X(1) VALUE LOW-VALUE.
10 ABT-DA-SPECIFIC-STATUS PIC X(6) VALUE LOW-VALUES.
10 FILLER REDEFINES ABT-DA-SPECIFIC-STATUS.
15 ABT-DLI-STATUS PIC X(2).
15 FILLER PIC X(4).
10 FILLER REDEFINES ABT-DA-SPECIFIC-STATUS.
15 ABT-DB2-STATUS PIC S9(9) COMP-4.
15 FILLER PIC X(2).
10 FILLER REDEFINES ABT-DA-SPECIFIC-STATUS.
15 ABT-VSAM-CICS-STATUS PIC X(1).
15 FILLER PIC X(5).
10 FILLER REDEFINES ABT-DA-SPECIFIC-STATUS.
15 ABT-BATCH-STATUS PIC X(2).
15 FILLER PIC X(4).
10 FILLER REDEFINES ABT-DA-SPECIFIC-STATUS.
15 ABT-CQUEUE-CICS-STATUS PIC X(1).
15 FILLER PIC X(5).
10 FILLER REDEFINES ABT-DA-SPECIFIC-STATUS.
15 ABT-CJOURNAL-CICS-STATUS PIC X(1).
15 FILLER PIC X(5).
10 FILLER PIC X(16) VALUE
LOW-VALUES.
EJECT
********************************************************
* T P I N P U T S C R E E N T A B L E *
********************************************************
01 TP-INPUT-TABLE.
05 FILLER PIC X(4) VALUE SPACES.
05 TPI-BOCOM01-LTH PIC 9(4) COMP VALUE 79.
05 TPI-BOCOM02-LTH PIC 9(4) COMP VALUE 79.
05 TPI-BOCOM03-LTH PIC 9(4) COMP VALUE 79.
05 TPI-BOCOM04-LTH PIC 9(4) COMP VALUE 18.
05 TPI-RCONFRJ-LTH PIC 9(4) COMP VALUE 3.
EJECT
********************************************************
* T P L I T E R A L T A B L E *
********************************************************
01 TP-LITERAL-TABLE.
05 FILLER PIC X(8).
05 FILLER PIC X(23) VALUE
'Rejet d"une demande MTP'.
05 FILLER PIC X(4) VALUE
'D.O.'.
05 FILLER PIC X(7) VALUE
'MT Acte'.
05 FILLER PIC X(4) VALUE
'BEN.'.
05 FILLER PIC X(4) VALUE
'Pays'.
05 FILLER PIC X(16) VALUE
'Motif du rejet :'.
05 FILLER PIC X(18) VALUE
'PF3-Retour au menu'.
EJECT
********************************************************
* T P O U T P U T S C R E E N T A B L E *
********************************************************
01 TP-OUTPUT-TABLE.
05 FILLER PIC 9(4) COMP VALUE 34.
05 FILLER PIC X(5).
05 SCT-HELP-CHAR PIC X VALUE LOW-VALUES.
05 SCT-TERM-ROW PIC 9(4) COMP VALUE 24.
05 SCT-TERM-COL PIC 9(4) COMP VALUE 80.
05 FILLER PIC 9(4) COMP VALUE 0.
05 FILLER PIC 9(4) COMP VALUE 18.
05 FILLER PIC 9(4) COMP VALUE 3.
05 SCT-LITERAL-ENTRY.
10 FILLER PIC 9(4) COMP VALUE 5.
10 FILLER PIC 9(4) COMP VALUE 23.
10 FILLER PIC X(4).
10 FILLER PIC 9(3) COMP-3 VALUE 2.
10 FILLER PIC 9(3) COMP-3 VALUE 28.
10 FILLER PIC 9(4) COMP VALUE 248.
10 FILLER PIC X VALUE 'B'.
10 FILLER PIC X VALUE LOW-VALUE.
10 FILLER PIC X VALUE 'A'.
10 FILLER PIC X VALUE LOW-VALUE.
05 SCT-LITERAL-ENTRY.
10 FILLER PIC 9(4) COMP VALUE 5.
10 FILLER PIC 9(4) COMP VALUE 4.
10 FILLER PIC X(4).
10 FILLER PIC 9(3) COMP-3 VALUE 6.
10 FILLER PIC 9(3) COMP-3 VALUE 2.
10 FILLER PIC 9(4) COMP VALUE 248.
10 FILLER PIC X VALUE 'B'.
10 FILLER PIC X VALUE LOW-VALUE.
10 FILLER PIC X VALUE 'A'.
10 FILLER PIC X VALUE LOW-VALUE.
05 SCT-LITERAL-ENTRY.
10 FILLER PIC 9(4) COMP VALUE 5.
10 FILLER PIC 9(4) COMP VALUE 7.
10 FILLER PIC X(4).
10 FILLER PIC 9(3) COMP-3 VALUE 6.
10 FILLER PIC 9(3) COMP-3 VALUE 45.
10 FILLER PIC 9(4) COMP VALUE 248.
10 FILLER PIC X VALUE 'B'.
10 FILLER PIC X VALUE LOW-VALUE.
10 FILLER PIC X VALUE 'A'.
10 FILLER PIC X VALUE LOW-VALUE.
05 SCT-LITERAL-ENTRY.
10 FILLER PIC 9(4) COMP VALUE 5.
10 FILLER PIC 9(4) COMP VALUE 4.
10 FILLER PIC X(4).
10 FILLER PIC 9(3) COMP-3 VALUE 7.
10 FILLER PIC 9(3) COMP-3 VALUE 2.
10 FILLER PIC 9(4) COMP VALUE 248.
10 FILLER PIC X VALUE 'B'.
10 FILLER PIC X VALUE LOW-VALUE.
10 FILLER PIC X VALUE 'A'.
10 FILLER PIC X VALUE LOW-VALUE.
05 SCT-LITERAL-ENTRY.
10 FILLER PIC 9(4) COMP VALUE 5.
10 FILLER PIC 9(4) COMP VALUE 4.
10 FILLER PIC X(4).
10 FILLER PIC 9(3) COMP-3 VALUE 8.
10 FILLER PIC 9(3) COMP-3 VALUE 2.
10 FILLER PIC 9(4) COMP VALUE 248.
10 FILLER PIC X VALUE 'B'.
10 FILLER PIC X VALUE LOW-VALUE.
10 FILLER PIC X VALUE 'A'.
10 FILLER PIC X VALUE LOW-VALUE.
05 SCT-LITERAL-ENTRY.
10 FILLER PIC 9(4) COMP VALUE 5.
10 FILLER PIC 9(4) COMP VALUE 16.
10 FILLER PIC X(4).
10 FILLER PIC 9(3) COMP-3 VALUE 11.
10 FILLER PIC 9(3) COMP-3 VALUE 2.
10 FILLER PIC 9(4) COMP VALUE 248.
10 FILLER PIC X VALUE 'B'.
10 FILLER PIC X VALUE LOW-VALUE.
10 FILLER PIC X VALUE 'A'.
10 FILLER PIC X VALUE LOW-VALUE.
05 SCT-LITERAL-ENTRY.
10 FILLER PIC 9(4) COMP VALUE 5.
10 FILLER PIC 9(4) COMP VALUE 18.
10 FILLER PIC X(4).
10 FILLER PIC 9(3) COMP-3 VALUE 24.
10 FILLER PIC 9(3) COMP-3 VALUE 2.
10 FILLER PIC 9(4) COMP VALUE 240.
10 FILLER PIC X VALUE 'B'.
10 FILLER PIC X VALUE '6'.
10 FILLER PIC X VALUE 'A'.
10 FILLER PIC X VALUE LOW-VALUE.
05 SCT-NOCICS.
10 FILLER PIC 9(4) COMP VALUE 452.
10 TPO-NOCICS-LTH PIC 9(4) COMP VALUE 8.
10 FILLER PIC X(4).
10 FILLER PIC 9(3) COMP-3 VALUE 1.
10 FILLER PIC 9(3) COMP-3 VALUE 2.
10 FILLER PIC 9(4) COMP VALUE 240.
10 FILLER PIC X VALUE 'B'.
10 FILLER PIC X VALUE LOW-VALUE.
10 FILLER PIC X VALUE 'A'.
10 FILLER PIC X VALUE LOW-VALUE.
05 SCT-NOVTAM.
10 FILLER PIC 9(4) COMP VALUE 452.
10 TPO-NOVTAM-LTH PIC 9(4) COMP VALUE 8.
10 FILLER PIC X(4).
10 FILLER PIC 9(3) COMP-3 VALUE 1.
10 FILLER PIC 9(3) COMP-3 VALUE 11.
10 FILLER PIC 9(4) COMP VALUE 240.
10 FILLER PIC X VALUE 'B'.
10 FILLER PIC X VALUE LOW-VALUE.
10 FILLER PIC X VALUE 'A'.
10 FILLER PIC X VALUE LOW-VALUE.
05 SCT-LIBAGEN.
10 FILLER PIC 9(4) COMP VALUE 452.
10 TPO-LIBAGEN-LTH PIC 9(4) COMP VALUE 24.
10 FILLER PIC X(4).
10 FILLER PIC 9(3) COMP-3 VALUE 1.
10 FILLER PIC 9(3) COMP-3 VALUE 27.
10 FILLER PIC 9(4) COMP VALUE 240.
10 FILLER PIC X VALUE 'B'.
10 FILLER PIC X VALUE LOW-VALUE.
10 FILLER PIC X VALUE 'A'.
10 FILLER PIC X VALUE LOW-VALUE.
05 SCT-EDDATE.
10 FILLER PIC 9(4) COMP VALUE 452.
10 TPO-EDDATE-LTH PIC 9(4) COMP VALUE 8.
10 FILLER PIC X(4).
10 FILLER PIC 9(3) COMP-3 VALUE 1.
10 FILLER PIC 9(3) COMP-3 VALUE 62.
10 FILLER PIC 9(4) COMP VALUE 240.
10 FILLER PIC X VALUE 'B'.
10 FILLER PIC X VALUE LOW-VALUE.
10 FILLER PIC X VALUE 'A'.
10 FILLER PIC X VALUE LOW-VALUE.
05 SCT-EDTIME.
10 FILLER PIC 9(4) COMP VALUE 452.
10 TPO-EDTIME-LTH PIC 9(4) COMP VALUE 8.
10 FILLER PIC X(4).
10 FILLER PIC 9(3) COMP-3 VALUE 1.
10 FILLER PIC 9(3) COMP-3 VALUE 73.
10 FILLER PIC 9(4) COMP VALUE 240.
10 FILLER PIC X VALUE 'B'.
10 FILLER PIC X VALUE LOW-VALUE.
10 FILLER PIC X VALUE 'A'.
10 FILLER PIC X VALUE LOW-VALUE.
05 SCT-CODTRX.
10 FILLER PIC 9(4) COMP VALUE 452.
10 TPO-CODTRX-LTH PIC 9(4) COMP VALUE 4.
10 FILLER PIC X(4).
10 FILLER PIC 9(3) COMP-3 VALUE 2.
10 FILLER PIC 9(3) COMP-3 VALUE 2.
10 FILLER PIC 9(4) COMP VALUE 240.
10 FILLER PIC X VALUE 'B'.
10 FILLER PIC X VALUE LOW-VALUE.
10 FILLER PIC X VALUE 'A'.
10 FILLER PIC X VALUE LOW-VALUE.
05 SCT-REFBG.
10 FILLER PIC 9(4) COMP VALUE 452.
10 TPO-REFBG-LTH PIC 9(4) COMP VALUE 12.
10 FILLER PIC X(4).
10 FILLER PIC 9(3) COMP-3 VALUE 4.
10 FILLER PIC 9(3) COMP-3 VALUE 12.
10 FILLER PIC 9(4) COMP VALUE 240.
10 FILLER PIC X VALUE 'B'.
10 FILLER PIC X VALUE LOW-VALUE.
10 FILLER PIC X VALUE 'A'.
10 FILLER PIC X VALUE LOW-VALUE.
05 SCT-REFCO.
10 FILLER PIC 9(4) COMP VALUE 452.
10 TPO-REFCO-LTH PIC 9(4) COMP VALUE 12.
10 FILLER PIC X(4).
10 FILLER PIC 9(3) COMP-3 VALUE 4.
10 FILLER PIC 9(3) COMP-3 VALUE 28.
10 FILLER PIC 9(4) COMP VALUE 240.
10 FILLER PIC X VALUE 'B'.
10 FILLER PIC X VALUE LOW-VALUE.
10 FILLER PIC X VALUE 'A'.
10 FILLER PIC X VALUE LOW-VALUE.
05 SCT-LIBDEM.
10 FILLER PIC 9(4) COMP VALUE 452.
10 TPO-LIBDEM-LTH PIC 9(4) COMP VALUE 23.
10 FILLER PIC X(4).
10 FILLER PIC 9(3) COMP-3 VALUE 4.
10 FILLER PIC 9(3) COMP-3 VALUE 45.
10 FILLER PIC 9(4) COMP VALUE 240.
10 FILLER PIC X VALUE 'B'.
10 FILLER PIC X VALUE LOW-VALUE.
10 FILLER PIC X VALUE 'A'.
10 FILLER PIC X VALUE LOW-VALUE.
05 SCT-DOADR1.
10 FILLER PIC 9(4) COMP VALUE 452.
10 TPO-DOADR1-LTH PIC 9(4) COMP VALUE 35.
10 FILLER PIC X(4).
10 FILLER PIC 9(3) COMP-3 VALUE 6.
10 FILLER PIC 9(3) COMP-3 VALUE 7.
10 FILLER PIC 9(4) COMP VALUE 240.
10 FILLER PIC X VALUE 'B'.
10 FILLER PIC X VALUE LOW-VALUE.
10 FILLER PIC X VALUE 'A'.
10 FILLER PIC X VALUE LOW-VALUE.
05 SCT-DEV01.
10 FILLER PIC 9(4) COMP VALUE 452.
10 TPO-DEV01-LTH PIC 9(4) COMP VALUE 3.
10 FILLER PIC X(4).
10 FILLER PIC 9(3) COMP-3 VALUE 6.
10 FILLER PIC 9(3) COMP-3 VALUE 53.
10 FILLER PIC 9(4) COMP VALUE 240.
10 FILLER PIC X VALUE 'B'.
10 FILLER PIC X VALUE LOW-VALUE.
10 FILLER PIC X VALUE 'A'.
10 FILLER PIC X VALUE LOW-VALUE.
05 SCT-MT01.
10 FILLER PIC 9(4) COMP VALUE 452.
10 TPO-MT01-LTH PIC 9(4) COMP VALUE 16.
10 FILLER PIC X(4).
10 FILLER PIC 9(3) COMP-3 VALUE 6.
10 FILLER PIC 9(3) COMP-3 VALUE 57.
10 FILLER PIC 9(4) COMP VALUE 240.
10 FILLER PIC X VALUE 'B'.
10 FILLER PIC X VALUE LOW-VALUE.
10 FILLER PIC X VALUE 'A'.
10 FILLER PIC X VALUE LOW-VALUE.
05 SCT-BENADR1.
10 FILLER PIC 9(4) COMP VALUE 452.
10 TPO-BENADR1-LTH PIC 9(4) COMP VALUE 35.
10 FILLER PIC X(4).
10 FILLER PIC 9(3) COMP-3 VALUE 7.
10 FILLER PIC 9(3) COMP-3 VALUE 7.
10 FILLER PIC 9(4) COMP VALUE 240.
10 FILLER PIC X VALUE 'B'.
10 FILLER PIC X VALUE LOW-VALUE.
10 FILLER PIC X VALUE 'A'.
10 FILLER PIC X VALUE LOW-VALUE.
05 SCT-DEV02.
10 FILLER PIC 9(4) COMP VALUE 452.
10 TPO-DEV02-LTH PIC 9(4) COMP VALUE 3.
10 FILLER PIC X(4).
10 FILLER PIC 9(3) COMP-3 VALUE 7.
10 FILLER PIC 9(3) COMP-3 VALUE 53.
10 FILLER PIC 9(4) COMP VALUE 240.
10 FILLER PIC X VALUE 'B'.
10 FILLER PIC X VALUE LOW-VALUE.
10 FILLER PIC X VALUE 'A'.
10 FILLER PIC X VALUE LOW-VALUE.
05 SCT-MT02.
10 FILLER PIC 9(4) COMP VALUE 452.
10 TPO-MT02-LTH PIC 9(4) COMP VALUE 16.
10 FILLER PIC X(4).
10 FILLER PIC 9(3) COMP-3 VALUE 7.
10 FILLER PIC 9(3) COMP-3 VALUE 57.
10 FILLER PIC 9(4) COMP VALUE 240.
10 FILLER PIC X VALUE 'B'.
10 FILLER PIC X VALUE LOW-VALUE.
10 FILLER PIC X VALUE 'A'.
10 FILLER PIC X VALUE LOW-VALUE.
05 SCT-CPAYS.
10 FILLER PIC 9(4) COMP VALUE 196.
10 TPO-CPAYS-LTH PIC 9(4) COMP VALUE 2.
10 FILLER PIC X(4).
10 FILLER PIC 9(3) COMP-3 VALUE 8.
10 FILLER PIC 9(3) COMP-3 VALUE 7.
10 FILLER PIC 9(4) COMP VALUE 240.
10 FILLER PIC X VALUE 'B'.
10 FILLER PIC X VALUE LOW-VALUE.
10 FILLER PIC X VALUE 'A'.
10 FILLER PIC X VALUE LOW-VALUE.
05 SCT-LPAYS.
10 FILLER PIC 9(4) COMP VALUE 452.
10 TPO-LPAYS-LTH PIC 9(4) COMP VALUE 30.
10 FILLER PIC X(4).
10 FILLER PIC 9(3) COMP-3 VALUE 8.
10 FILLER PIC 9(3) COMP-3 VALUE 10.
10 FILLER PIC 9(4) COMP VALUE 240.
10 FILLER PIC X VALUE 'B'.
10 FILLER PIC X VALUE LOW-VALUE.
10 FILLER PIC X VALUE 'A'.
10 FILLER PIC X VALUE LOW-VALUE.
05 SCT-DEV03.
10 FILLER PIC 9(4) COMP VALUE 452.
10 TPO-DEV03-LTH PIC 9(4) COMP VALUE 3.
10 FILLER PIC X(4).
10 FILLER PIC 9(3) COMP-3 VALUE 8.
10 FILLER PIC 9(3) COMP-3 VALUE 53.
10 FILLER PIC 9(4) COMP VALUE 240.
10 FILLER PIC X VALUE 'B'.
10 FILLER PIC X VALUE LOW-VALUE.
10 FILLER PIC X VALUE 'A'.
10 FILLER PIC X VALUE LOW-VALUE.
05 SCT-MT03.
10 FILLER PIC 9(4) COMP VALUE 452.
10 TPO-MT03-LTH PIC 9(4) COMP VALUE 16.
10 FILLER PIC X(4).
10 FILLER PIC 9(3) COMP-3 VALUE 8.
10 FILLER PIC 9(3) COMP-3 VALUE 57.
10 FILLER PIC 9(4) COMP VALUE 240.
10 FILLER PIC X VALUE 'B'.
10 FILLER PIC X VALUE LOW-VALUE.
10 FILLER PIC X VALUE 'A'.
10 FILLER PIC X VALUE LOW-VALUE.
05 SCT-DEV04.
10 FILLER PIC 9(4) COMP VALUE 452.
10 TPO-DEV04-LTH PIC 9(4) COMP VALUE 3.
10 FILLER PIC X(4).
10 FILLER PIC 9(3) COMP-3 VALUE 9.
10 FILLER PIC 9(3) COMP-3 VALUE 53.
10 FILLER PIC 9(4) COMP VALUE 240.
10 FILLER PIC X VALUE 'B'.
10 FILLER PIC X VALUE LOW-VALUE.
10 FILLER PIC X VALUE 'A'.
10 FILLER PIC X VALUE LOW-VALUE.
05 SCT-MT04.
10 FILLER PIC 9(4) COMP VALUE 452.
10 TPO-MT04-LTH PIC 9(4) COMP VALUE 16.
10 FILLER PIC X(4).
10 FILLER PIC 9(3) COMP-3 VALUE 9.
10 FILLER PIC 9(3) COMP-3 VALUE 57.
10 FILLER PIC 9(4) COMP VALUE 240.
10 FILLER PIC X VALUE 'B'.
10 FILLER PIC X VALUE LOW-VALUE.
10 FILLER PIC X VALUE 'A'.
10 FILLER PIC X VALUE LOW-VALUE.
05 SCT-BOCOM01.
10 FILLER PIC 9(4) COMP VALUE 966.
10 TPO-BOCOM01-LTH PIC 9(4) COMP VALUE 79.
10 FILLER PIC X(4).
10 FILLER PIC 9(3) COMP-3 VALUE 12.
10 FILLER PIC 9(3) COMP-3 VALUE 2.
10 FILLER PIC 9(4) COMP VALUE 192.
10 FILLER PIC X VALUE 'B'.
10 FILLER PIC X VALUE LOW-VALUE.
10 FILLER PIC X VALUE 'A'.
10 FILLER PIC X VALUE LOW-VALUE.
05 SCT-BOCOM02.
10 FILLER PIC 9(4) COMP VALUE 966.
10 TPO-BOCOM02-LTH PIC 9(4) COMP VALUE 79.
10 FILLER PIC X(4).
10 FILLER PIC 9(3) COMP-3 VALUE 13.
10 FILLER PIC 9(3) COMP-3 VALUE 2.
10 FILLER PIC 9(4) COMP VALUE 192.
10 FILLER PIC X VALUE 'B'.
10 FILLER PIC X VALUE LOW-VALUE.
10 FILLER PIC X VALUE 'A'.
10 FILLER PIC X VALUE LOW-VALUE.
05 SCT-BOCOM03.
10 FILLER PIC 9(4) COMP VALUE 966.
10 TPO-BOCOM03-LTH PIC 9(4) COMP VALUE 79.
10 FILLER PIC X(4).
10 FILLER PIC 9(3) COMP-3 VALUE 14.
10 FILLER PIC 9(3) COMP-3 VALUE 2.
10 FILLER PIC 9(4) COMP VALUE 192.
10 FILLER PIC X VALUE 'B'.
10 FILLER PIC X VALUE LOW-VALUE.
10 FILLER PIC X VALUE 'A'.
10 FILLER PIC X VALUE LOW-VALUE.
05 SCT-BOCOM04.
10 FILLER PIC 9(4) COMP VALUE 966.
10 TPO-BOCOM04-LTH PIC 9(4) COMP VALUE 18.
10 FILLER PIC X(4).
10 FILLER PIC 9(3) COMP-3 VALUE 15.
10 FILLER PIC 9(3) COMP-3 VALUE 2.
10 FILLER PIC 9(4) COMP VALUE 192.
10 FILLER PIC X VALUE 'B'.
10 FILLER PIC X VALUE LOW-VALUE.
10 FILLER PIC X VALUE 'A'.
10 FILLER PIC X VALUE LOW-VALUE.
05 SCT-LCONFRJ.
10 FILLER PIC 9(4) COMP VALUE 452.
10 TPO-LCONFRJ-LTH PIC 9(4) COMP VALUE 31.
10 FILLER PIC X(4).
10 FILLER PIC 9(3) COMP-3 VALUE 21.
10 FILLER PIC 9(3) COMP-3 VALUE 27.
10 FILLER PIC 9(4) COMP VALUE 248.
10 FILLER PIC X VALUE 'B'.
10 FILLER PIC X VALUE LOW-VALUE.
10 FILLER PIC X VALUE 'A'.
10 FILLER PIC X VALUE LOW-VALUE.
05 SCT-RCONFRJ.
10 FILLER PIC 9(4) COMP VALUE 966.
10 TPO-RCONFRJ-LTH PIC 9(4) COMP VALUE 3.
10 FILLER PIC X(4).
10 FILLER PIC 9(3) COMP-3 VALUE 21.
10 FILLER PIC 9(3) COMP-3 VALUE 59.
10 FILLER PIC 9(4) COMP VALUE 192.
10 FILLER PIC X VALUE 'B'.
10 FILLER PIC X VALUE LOW-VALUE.
10 FILLER PIC X VALUE 'A'.
10 FILLER PIC X VALUE LOW-VALUE.
05 SCT-ERRMSG1.
10 FILLER PIC 9(4) COMP VALUE 452.
10 TPO-ERRMSG1-LTH PIC 9(4) COMP VALUE 78.
10 FILLER PIC X(4).
10 FILLER PIC 9(3) COMP-3 VALUE 23.
10 FILLER PIC 9(3) COMP-3 VALUE 2.
10 FILLER PIC 9(4) COMP VALUE 240.
10 FILLER PIC X VALUE 'B'.
10 FILLER PIC X VALUE '2'.
10 FILLER PIC X VALUE 'A'.
10 FILLER PIC X VALUE LOW-VALUE.
05 SCT-END-ENTRY PIC 9(4) COMP VALUE 0.
EJECT
********************************************************
* T P B U F F E R *
********************************************************
01 TP-BUFFER.
02 FILLER PIC X(12).
02 TP-OUTPUT-BUFFER-FIELDS.
05 TPO-NOCICS-ATTR.
10 TPO-NOCICS-F-ATTR PIC XXX.
10 TPO-NOCICS-C-ATTR PIC X.
10 TPO-NOCICS-P-ATTR PIC X.
10 TPO-NOCICS-H-ATTR PIC X.
10 TPO-NOCICS-V-ATTR PIC X.
05 TPO-NOCICS PIC X(8).
05 TPO-NOVTAM-ATTR.
10 TPO-NOVTAM-F-ATTR PIC XXX.
10 TPO-NOVTAM-C-ATTR PIC X.
10 TPO-NOVTAM-P-ATTR PIC X.
10 TPO-NOVTAM-H-ATTR PIC X.
10 TPO-NOVTAM-V-ATTR PIC X.
05 TPO-NOVTAM PIC X(8).
05 TPO-LIBAGEN-ATTR.
10 TPO-LIBAGEN-F-ATTR PIC XXX.
10 TPO-LIBAGEN-C-ATTR PIC X.
10 TPO-LIBAGEN-P-ATTR PIC X.
10 TPO-LIBAGEN-H-ATTR PIC X.
10 TPO-LIBAGEN-V-ATTR PIC X.
05 TPO-LIBAGEN PIC X(24).
05 TPO-EDDATE-ATTR.
10 TPO-EDDATE-F-ATTR PIC XXX.
10 TPO-EDDATE-C-ATTR PIC X.
10 TPO-EDDATE-P-ATTR PIC X.
10 TPO-EDDATE-H-ATTR PIC X.
10 TPO-EDDATE-V-ATTR PIC X.
05 TPO-EDDATE PIC X(8).
05 TPO-EDTIME-ATTR.
10 TPO-EDTIME-F-ATTR PIC XXX.
10 TPO-EDTIME-C-ATTR PIC X.
10 TPO-EDTIME-P-ATTR PIC X.
10 TPO-EDTIME-H-ATTR PIC X.
10 TPO-EDTIME-V-ATTR PIC X.
05 TPO-EDTIME-CHAR PIC X(8).
05 TPO-EDTIME REDEFINES TPO-EDTIME-CHAR
PIC 99.99.99.
05 TPO-CODTRX-ATTR.
10 TPO-CODTRX-F-ATTR PIC XXX.
10 TPO-CODTRX-C-ATTR PIC X.
10 TPO-CODTRX-P-ATTR PIC X.
10 TPO-CODTRX-H-ATTR PIC X.
10 TPO-CODTRX-V-ATTR PIC X.
05 TPO-CODTRX PIC X(4).
05 TPO-REFBG-ATTR.
10 TPO-REFBG-F-ATTR PIC XXX.
10 TPO-REFBG-C-ATTR PIC X.
10 TPO-REFBG-P-ATTR PIC X.
10 TPO-REFBG-H-ATTR PIC X.
10 TPO-REFBG-V-ATTR PIC X.
05 TPO-REFBG PIC X(12).
05 TPO-REFCO-ATTR.
10 TPO-REFCO-F-ATTR PIC XXX.
10 TPO-REFCO-C-ATTR PIC X.
10 TPO-REFCO-P-ATTR PIC X.
10 TPO-REFCO-H-ATTR PIC X.
10 TPO-REFCO-V-ATTR PIC X.
05 TPO-REFCO PIC X(12).
05 TPO-LIBDEM-ATTR.
10 TPO-LIBDEM-F-ATTR PIC XXX.
10 TPO-LIBDEM-C-ATTR PIC X.
10 TPO-LIBDEM-P-ATTR PIC X.
10 TPO-LIBDEM-H-ATTR PIC X.
10 TPO-LIBDEM-V-ATTR PIC X.
05 TPO-LIBDEM PIC X(23).
05 TPO-DOADR1-ATTR.
10 TPO-DOADR1-F-ATTR PIC XXX.
10 TPO-DOADR1-C-ATTR PIC X.
10 TPO-DOADR1-P-ATTR PIC X.
10 TPO-DOADR1-H-ATTR PIC X.
10 TPO-DOADR1-V-ATTR PIC X.
05 TPO-DOADR1 PIC X(35).
05 TPO-DEV01-ATTR.
10 TPO-DEV01-F-ATTR PIC XXX.
10 TPO-DEV01-C-ATTR PIC X.
10 TPO-DEV01-P-ATTR PIC X.
10 TPO-DEV01-H-ATTR PIC X.
10 TPO-DEV01-V-ATTR PIC X.
05 TPO-DEV01 PIC X(3).
05 TPO-MT01-ATTR.
10 TPO-MT01-F-ATTR PIC XXX.
10 TPO-MT01-C-ATTR PIC X.
10 TPO-MT01-P-ATTR PIC X.
10 TPO-MT01-H-ATTR PIC X.
10 TPO-MT01-V-ATTR PIC X.
05 TPO-MT01 PIC X(16).
05 TPO-BENADR1-ATTR.
10 TPO-BENADR1-F-ATTR PIC XXX.
10 TPO-BENADR1-C-ATTR PIC X.
10 TPO-BENADR1-P-ATTR PIC X.
10 TPO-BENADR1-H-ATTR PIC X.
10 TPO-BENADR1-V-ATTR PIC X.
05 TPO-BENADR1 PIC X(35).
05 TPO-DEV02-ATTR.
10 TPO-DEV02-F-ATTR PIC XXX.
10 TPO-DEV02-C-ATTR PIC X.
10 TPO-DEV02-P-ATTR PIC X.
10 TPO-DEV02-H-ATTR PIC X.
10 TPO-DEV02-V-ATTR PIC X.
05 TPO-DEV02 PIC X(3).
05 TPO-MT02-ATTR.
10 TPO-MT02-F-ATTR PIC XXX.
10 TPO-MT02-C-ATTR PIC X.
10 TPO-MT02-P-ATTR PIC X.
10 TPO-MT02-H-ATTR PIC X.
10 TPO-MT02-V-ATTR PIC X.
05 TPO-MT02 PIC X(16).
05 TPO-CPAYS-ATTR.
10 TPO-CPAYS-F-ATTR PIC XXX.
10 TPO-CPAYS-C-ATTR PIC X.
10 TPO-CPAYS-P-ATTR PIC X.
10 TPO-CPAYS-H-ATTR PIC X.
10 TPO-CPAYS-V-ATTR PIC X.
05 TPO-CPAYS PIC X(2).
05 TPO-LPAYS-ATTR.
10 TPO-LPAYS-F-ATTR PIC XXX.
10 TPO-LPAYS-C-ATTR PIC X.
10 TPO-LPAYS-P-ATTR PIC X.
10 TPO-LPAYS-H-ATTR PIC X.
10 TPO-LPAYS-V-ATTR PIC X.
05 TPO-LPAYS PIC X(30).
05 TPO-DEV03-ATTR.
10 TPO-DEV03-F-ATTR PIC XXX.
10 TPO-DEV03-C-ATTR PIC X.
10 TPO-DEV03-P-ATTR PIC X.
10 TPO-DEV03-H-ATTR PIC X.
10 TPO-DEV03-V-ATTR PIC X.
05 TPO-DEV03 PIC X(3).
05 TPO-MT03-ATTR.
10 TPO-MT03-F-ATTR PIC XXX.
10 TPO-MT03-C-ATTR PIC X.
10 TPO-MT03-P-ATTR PIC X.
10 TPO-MT03-H-ATTR PIC X.
10 TPO-MT03-V-ATTR PIC X.
05 TPO-MT03 PIC X(16).
05 TPO-DEV04-ATTR.
10 TPO-DEV04-F-ATTR PIC XXX.
10 TPO-DEV04-C-ATTR PIC X.
10 TPO-DEV04-P-ATTR PIC X.
10 TPO-DEV04-H-ATTR PIC X.
10 TPO-DEV04-V-ATTR PIC X.
05 TPO-DEV04 PIC X(3).
05 TPO-MT04-ATTR.
10 TPO-MT04-F-ATTR PIC XXX.
10 TPO-MT04-C-ATTR PIC X.
10 TPO-MT04-P-ATTR PIC X.
10 TPO-MT04-H-ATTR PIC X.
10 TPO-MT04-V-ATTR PIC X.
05 TPO-MT04 PIC X(16).
05 TPO-BOCOM01-ATTR.
10 TPO-BOCOM01-F-ATTR PIC XXX.
10 TPO-BOCOM01-C-ATTR PIC X.
10 TPO-BOCOM01-P-ATTR PIC X.
10 TPO-BOCOM01-H-ATTR PIC X.
10 TPO-BOCOM01-V-ATTR PIC X.
05 TPO-BOCOM01 PIC X(79).
05 TPO-BOCOM02-ATTR.
10 TPO-BOCOM02-F-ATTR PIC XXX.
10 TPO-BOCOM02-C-ATTR PIC X.
10 TPO-BOCOM02-P-ATTR PIC X.
10 TPO-BOCOM02-H-ATTR PIC X.
10 TPO-BOCOM02-V-ATTR PIC X.
05 TPO-BOCOM02 PIC X(79).
05 TPO-BOCOM03-ATTR.
10 TPO-BOCOM03-F-ATTR PIC XXX.
10 TPO-BOCOM03-C-ATTR PIC X.
10 TPO-BOCOM03-P-ATTR PIC X.
10 TPO-BOCOM03-H-ATTR PIC X.
10 TPO-BOCOM03-V-ATTR PIC X.
05 TPO-BOCOM03 PIC X(79).
05 TPO-BOCOM04-ATTR.
10 TPO-BOCOM04-F-ATTR PIC XXX.
10 TPO-BOCOM04-C-ATTR PIC X.
10 TPO-BOCOM04-P-ATTR PIC X.
10 TPO-BOCOM04-H-ATTR PIC X.
10 TPO-BOCOM04-V-ATTR PIC X.
05 TPO-BOCOM04 PIC X(18).
05 TPO-LCONFRJ-ATTR.
10 TPO-LCONFRJ-F-ATTR PIC XXX.
10 TPO-LCONFRJ-C-ATTR PIC X.
10 TPO-LCONFRJ-P-ATTR PIC X.
10 TPO-LCONFRJ-H-ATTR PIC X.
10 TPO-LCONFRJ-V-ATTR PIC X.
05 TPO-LCONFRJ PIC X(31).
05 TPO-RCONFRJ-ATTR.
10 TPO-RCONFRJ-F-ATTR PIC XXX.
10 TPO-RCONFRJ-C-ATTR PIC X.
10 TPO-RCONFRJ-P-ATTR PIC X.
10 TPO-RCONFRJ-H-ATTR PIC X.
10 TPO-RCONFRJ-V-ATTR PIC X.
05 TPO-RCONFRJ PIC X(3).
05 TPO-ERRMSG1-ATTR.
10 TPO-ERRMSG1-F-ATTR PIC XXX.
10 TPO-ERRMSG1-C-ATTR PIC X.
10 TPO-ERRMSG1-P-ATTR PIC X.
10 TPO-ERRMSG1-H-ATTR PIC X.
10 TPO-ERRMSG1-V-ATTR PIC X.
05 TPO-ERRMSG1 PIC X(78).
SKIP2
********************************************************
* T P O I N P U T F I E L D S *
********************************************************
02 TPO-INPUT-FIELDS REDEFINES TP-OUTPUT-BUFFER-FIELDS.
05 FILLER PIC X(15).
05 FILLER PIC X(15).
05 FILLER PIC X(31).
05 FILLER PIC X(15).
05 FILLER PIC X(15).
05 FILLER PIC X(11).
05 FILLER PIC X(19).
05 FILLER PIC X(19).
05 FILLER PIC X(30).
05 FILLER PIC X(42).
05 FILLER PIC X(10).
05 FILLER PIC X(23).
05 FILLER PIC X(42).
05 FILLER PIC X(10).
05 FILLER PIC X(23).
05 FILLER PIC X(9).
05 FILLER PIC X(37).
05 FILLER PIC X(10).
05 FILLER PIC X(23).
05 FILLER PIC X(10).
05 FILLER PIC X(23).
05 FILLER PIC X(7).
05 TPI-BOCOM01 PIC X(79).
05 FILLER PIC X(7).
05 TPI-BOCOM02 PIC X(79).
05 FILLER PIC X(7).
05 TPI-BOCOM03 PIC X(79).
05 FILLER PIC X(7).
05 TPI-BOCOM04 PIC X(18).
05 FILLER PIC X(38).
05 FILLER PIC X(7).
05 TPI-RCONFRJ PIC X(3).
05 FILLER PIC X(85).
01 TP-OUTPUT-BUFFER REDEFINES TP-BUFFER PIC X(860).
EJECT
********************************************************
* A P P L I C A T I O N W O R K A R E A *
********************************************************
01 APP-WORK-AREA.
05 FILLER PIC X(12) VALUE 'APP WORK'.
COPY Y1WKAREA.
SKIP3
********************************************************
* P R O G R A M W O R K A R E A *
********************************************************
01 PROGRAM-WORK-AREA.
05 FILLER PIC X(12) VALUE 'PGM WORK'.
*TELON--------------------------------------------------------------
*DS: H11 ! COPY WKAREA *
*-------------------------------------------------------------------
*================================================================ *
* CLAUSE COPIES *
*================================================================ *
01 FILLER. *
COPY CYY1031W REPLACING ==:1031W:== BY ==E031==. *
*================================================================ *
01 WK-LIBDEM PIC X(30). *
01 WK-BO-COMMENT01 PIC X(66). *
01 WK-BO-COMMENT02 PIC X(79). *
01 WK-BO-COMMENT03 PIC X(79). *
01 WK-BO-COMMENT04 PIC X(79). *
01 WK-LCONFRJ PIC X(31). *
*----------------------------------------------! END WKAREA ----
SKIP1
COPY WERRDB2.
SKIP1
EJECT
********************************************************
* S Y S T E M W O R K A R E A *
********************************************************
SKIP2
01 SYS-WORK-AREA.
05 FILLER PIC X(12) VALUE 'SYS WORK '.
05 IDENTIFICATION-DATA.
10 CURRENT-PROGRAM-NAME PIC X(8) VALUE 'Y1CPY1RR'.
10 PROGRAM-NAME PIC X(4) VALUE 'Y1RR'.
10 FILLER PIC X(4) VALUE SPACES.
10 NEXT-PROGRAM-NAME.
15 NEXT-PROGRAM-NAME-HDR PIC X(4) VALUE 'Y1CP'.
15 NEXT-PROGRAM-NAME-ID PIC X(4) VALUE 'Y1RR'.
10 PROGRAM-TRANSACTION-CODE PIC X(4) VALUE 'Y1RR'.
SKIP1
SKIP1
* CURSOR-ATTR X'FFFFC0' - CURSOR
* ERROR-ATTR X'FFFFC8' - CURSOR, HIGHLIGHT
* OK-ATTR X'0000C0' - DEFAULT
* PROT-ATTR X'0000F0' - PROT, NUMERIC
* OUTPUT-ATTR X'0000F0' - PROT, NUMERIC
* OUTPUT-BLANK-ATTR X'0000FC' - PROT, NUMERIC, BLANK
* BLANK-ATTR X'0000FC' - PROT, NUMERIC, BLANK
* CURSOR-BLANK-ATTR X'FFFFCC' - CURSOR, BLANK
* INPUT-BLANK-ATTR X'0000CC' - BLANK
* OUTPUT-HIGH-ATTR X'0000F8' - PROT, NUMERIC, HIGLIGHT
* INPUT-HIGH-ATTR X'0000C8' - HIGHLIGHT
SKIP1
05 ATTRIBUTE-VARIABLES.
10 CURSOR-ATTR-X.
15 CURSOR-ATTR-1 PIC S9(9) COMP VALUE +16777152.
15 CURSOR-ATTR-2 PIC X(4) VALUE LOW-VALUES.
10 FILLER REDEFINES CURSOR-ATTR-X.
15 FILLER PIC X.
15 CURSOR-ATTR PIC X(7).
10 ERROR-ATTR-X.
15 FILLER PIC S9(9) COMP VALUE +16777160.
15 ERROR-C-ATTR PIC X VALUE LOW-VALUE.
15 ERROR-P-ATTR PIC X VALUE LOW-VALUE.
15 ERROR-H-ATTR PIC X VALUE LOW-VALUE.
15 ERROR-V-ATTR PIC X VALUE LOW-VALUES.
10 FILLER REDEFINES ERROR-ATTR-X.
15 FILLER PIC X.
15 ERROR-F-ATTR PIC X(3).
15 FILLER PIC X(4).
10 FILLER REDEFINES ERROR-ATTR-X.
15 FILLER PIC X.
15 ERROR-ATTR PIC X(7).
10 OK-ATTR-X.
15 OK-ATTR-1 PIC S9(9) COMP VALUE +4210880.
15 OK-ATTR-2 PIC X(4) VALUE LOW-VALUES.
10 FILLER REDEFINES OK-ATTR-X.
15 FILLER PIC X.
15 OK-ATTR PIC X(7).
10 PROT-ATTR-X.
15 PROT-ATTR-1 PIC S9(9) COMP VALUE +4210928.
15 PROT-ATTR-2 PIC X(4) VALUE LOW-VALUES.
10 FILLER REDEFINES PROT-ATTR-X.
15 FILLER PIC X.
15 PROT-ATTR PIC X(7).
10 FILLER REDEFINES PROT-ATTR-X.
15 FILLER PIC X.
15 OUTPUT-ATTR PIC X(7).
10 BLANK-ATTR-X.
15 BLANK-ATTR-1 PIC S9(9) COMP VALUE +4210940.
15 BLANK-ATTR-2 PIC X(4) VALUE LOW-VALUES.
10 FILLER REDEFINES BLANK-ATTR-X.
15 FILLER PIC X.
15 OUTPUT-BLANK-ATTR PIC X(7).
10 FILLER REDEFINES BLANK-ATTR-X.
15 FILLER PIC X.
15 BLANK-ATTR PIC X(7).
10 CBLANK-ATTR-X.
15 CBLANK-ATTR-1 PIC S9(9) COMP VALUE +16777164.
15 CBLANK-ATTR-2 PIC X(4) VALUE LOW-VALUES.
10 FILLER REDEFINES CBLANK-ATTR-X.
15 FILLER PIC X.
15 CURSOR-BLANK-ATTR PIC X(7).
10 IBLANK-ATTR-X.
15 IBLANK-ATTR-1 PIC S9(9) COMP VALUE +4210892.
15 IBLANK-ATTR-2 PIC X(4) VALUE LOW-VALUES.
10 FILLER REDEFINES IBLANK-ATTR-X.
15 FILLER PIC X.
15 INPUT-BLANK-ATTR PIC X(7).
10 OHIGH-ATTR-X.
15 OHIGH-ATTR-1 PIC S9(9) COMP VALUE +4210936.
15 OHIGH-ATTR-2 PIC X(4) VALUE LOW-VALUES.
10 FILLER REDEFINES OHIGH-ATTR-X.
15 FILLER PIC X.
15 OUTPUT-HIGH-ATTR PIC X(7).
10 IHIGH-ATTR-X.
15 IHIGH-ATTR-1 PIC S9(9) COMP VALUE +4210888.
15 IHIGH-ATTR-2 PIC X(4) VALUE LOW-VALUES.
10 FILLER REDEFINES IHIGH-ATTR-X.
15 FILLER PIC X.
15 INPUT-HIGH-ATTR PIC X(7).
SKIP1
10 DEFAULT-COLOR-ATTR PIC X VALUE LOW-VALUE.
10 BLUE-ATTR PIC X VALUE '1'.
10 RED-ATTR PIC X VALUE '2'.
10 PINK-ATTR PIC X VALUE '3'.
10 GREEN-ATTR PIC X VALUE '4'.
10 TURQUOISE-ATTR PIC X VALUE '5'.
10 YELLOW-ATTR PIC X VALUE '6'.
10 NEUTRAL-ATTR PIC X VALUE '7'.
10 DEFAULT-HIGH-ATTR PIC X VALUE LOW-VALUE.
10 BLINK-ATTR PIC X VALUE '1'.
10 REVERSE-ATTR PIC X VALUE '2'.
10 UNDERLINE-ATTR PIC X VALUE '4'.
SKIP1
SKIP1
EJECT
05 CONTROL-VARIABLES.
*
* THE CONTROL INDICATOR CONTROLS THE PROGRAM FLOW
*
10 CONTROL-INDICATOR PIC X VALUE LOW-VALUE.
88 PROCESS-OUTPUT VALUE 'O'.
88 DO-WRITE VALUE 'E'.
88 PROCESS-INPUT VALUE 'I'.
88 DO-TRANSFER VALUE 'R'.
88 TRANSACTION-COMPLETE VALUE 'C'.
88 CONTINUE-PROCESS VALUE SPACE.
SKIP1
*
* CONTROL INDICATOR ON ENTRY TO PROGRAM
*
10 ENTRY-CONTROL-INDICATOR PIC X VALUE LOW-VALUE.
88 ENTRY-PROCESS-OUTPUT VALUE 'O'.
88 ENTRY-PROCESS-INPUT VALUE 'I'.
SKIP1
*
* LITERALS USED TO SET THE CONTROL INDICATOR
*
10 CONTROL-INDICATOR-LITERALS.
15 PROCESS-OUTPUT-LIT PIC X VALUE 'O'.
15 DO-WRITE-LIT PIC X VALUE 'E'.
15 PROCESS-INPUT-LIT PIC X VALUE 'I'.
15 DO-TRANSFER-LIT PIC X VALUE 'R'.
15 TRANSACTION-COMPLETE-LIT PIC X VALUE 'C'.
15 CONTINUE-PROCESS-LIT PIC X VALUE SPACE.
SKIP1
10 SELECT-DONE PIC X VALUE SPACES.
10 SELECT-COUNT PIC 999 COMP-3 VALUE ZERO.
10 HEX-3F-VALUE PIC 9(4) COMP VALUE 63.
10 HEX-3F-REDEF REDEFINES HEX-3F-VALUE.
15 FILLER PIC X.
15 HEX-3F PIC X.
10 SEGLOOP-CONTROL.
15 SEGLOOP-COUNT PIC 999 COMP-3 VALUE ZERO.
15 SEGLOOP-COUNT-MAX PIC 999 COMP-3 VALUE 0.
15 INPUT-LINE-COUNT PIC 999 COMP-3 VALUE ZERO.
15 INPUT-LINE-EDIT PIC X VALUE SPACE.
88 NO-LINE-ERRORS VALUE ' '.
88 LINE-ERRORS VALUE 'E'.
88 NO-LINE-EDIT VALUE 'N'.
15 SEGLOOP-ERROR-SW PIC X.
88 SEGLOOP-ERROR-FOUND VALUE 'Y'.
15 FINISH-COUNT PIC 999 COMP-3 VALUE ZERO.
15 PAGE-REQUEST-INDICATOR PIC X VALUE LOW-VALUE.
88 PAGE-FORWARD VALUE '1'.
88 PAGE-BACKWARD VALUE '2'.
SKIP1
05 PFKEY-INDICATOR VALUE 00 PIC 99.
88 ENTER-KEY VALUE 00. 88 CLEAR VALUE 93.
88 PA1 VALUE 92. 88 PA2 VALUE 94. 88 PA3 VALUE 91.
88 PFK1 VALUE 1. 88 PFK2 VALUE 2. 88 PFK3 VALUE 3.
88 PFK4 VALUE 4. 88 PFK5 VALUE 5. 88 PFK6 VALUE 6.
88 PFK7 VALUE 7. 88 PFK8 VALUE 8. 88 PFK9 VALUE 9.
88 PFK10 VALUE 10. 88 PFK11 VALUE 11. 88 PFK12 VALUE 12.
88 PFK13 VALUE 13. 88 PFK14 VALUE 14. 88 PFK15 VALUE 15.
88 PFK16 VALUE 16. 88 PFK17 VALUE 17. 88 PFK18 VALUE 18.
88 PFK19 VALUE 19. 88 PFK20 VALUE 20. 88 PFK21 VALUE 21.
88 PFK22 VALUE 22. 88 PFK23 VALUE 23. 88 PFK24 VALUE 24.
88 PFK1-13 VALUE 1 13. 88 PFK2-14 VALUE 2 14.
88 PFK3-15 VALUE 3 15. 88 PFK4-16 VALUE 4 16.
88 PFK5-17 VALUE 5 17. 88 PFK6-18 VALUE 6 18.
88 PFK7-19 VALUE 7 19. 88 PFK8-20 VALUE 8 20.
88 PFK9-21 VALUE 9 21. 88 PFK10-22 VALUE 10 22.
88 PFK11-23 VALUE 11 23. 88 PFK12-24 VALUE 12 24.
SKIP1
********************************************************
* FILE STATUS CODES *
********************************************************
05 FILE-STATUS-CODES.
10 FILLER PIC X(12) VALUE 'STATUS CODES'.
10 DATA-ACCESS-STATUS-LITS.
15 DA-OK-LIT PIC X(3) VALUE 'OK '.
15 DA-DUPLICATE-LIT PIC X(3) VALUE 'DUP'.
15 DA-DUPREC-LIT PIC X(3) VALUE 'DPR'.
15 DA-DUPKEY-LIT PIC X(3) VALUE 'DPK'.
15 DA-NOTAVAIL-LIT PIC X(3) VALUE 'NAV'.
15 DA-NOTFOUND-LIT PIC X(3) VALUE 'NFD'.
15 DA-ENDFILE-LIT PIC X(3) VALUE 'EOF'.
15 DA-LOGICERR-LIT PIC X(3) VALUE 'LOG'.
15 DA-SECURITY-LIT PIC X(3) VALUE 'SEC'.
15 DA-DBMERROR-LIT PIC X(3) VALUE 'DBM'.
15 DA-NOTAUTH-LIT PIC X(3) VALUE 'NAU'.
15 DA-DISABLED-LIT PIC X(3) VALUE 'DIS'.
10 DATA-ACCESS-STATUS.
15 DA-STATUS PIC X(3) VALUE SPACES.
88 DA-OK VALUE 'OK '.
88 DA-DUPLICATE VALUE 'DUP'
'DPR'
'DPK'.
88 DA-DUPREC VALUE 'DPR'.
88 DA-DUPKEY VALUE 'DPK'.
88 DA-NOTAVAIL VALUE 'NAV'
'JNO'.
88 DA-NOTFOUND VALUE 'NFD'.
88 DA-ENDFILE VALUE 'EOF'
'NFD'
'QZR'
'QIT'.
88 DA-LOGICERR VALUE 'LOG'
'QSE'
'QIR'
'QLE'
'JIR'
'JLE'.
88 DA-NOSPACE VALUE 'NOS'.
88 DA-ALREADYOPEN VALUE 'AOP'.
88 DA-ALREADYCLOSE VALUE 'ACL'.
88 DA-EMPTYFILE VALUE 'EMT'.
88 DA-SECURITY VALUE 'SEC'
'QNA'
'JNA'.
88 DA-DBMERROR VALUE 'DBM'.
88 DA-NOTAUTH VALUE 'NAU'.
88 DA-DISABLED VALUE 'DIS'
'QDI'.
88 DA-ANYERROR VALUE 'DUP'
'DPR'
'DPK'
'NAU'
'DIS'
'NAV'
'NFD'
'EOF'
'LOG'
'SEC'
'DBM'.
15 DA-STATUS-FILE PIC X(1) VALUE SPACES.
SKIP2
10 VY102400-STATUS
PIC S9(9) COMP-4 VALUE +0.
10 FY1008W-STATUS PIC X VALUE SPACE.
EJECT
05 WORKFLD-NUMERIC-INSTALL.
10 WORKFLD-NUMERIC-1 PIC S9(16)V9(2).
10 WORKFLD-NUMERIC-2 PIC 9(15).
10 WORKFLD-NUMERIC-3 PIC S9(15).
10 WORKFLD-NUMERIC-4 PIC 9(16)V99.
10 WORKFLD-NUMERIC-5 PIC 9(13)V99.
10 WORKFLD-NUMERIC-6 PIC 9(16).
SKIP2
05 DB2-CONTROL.
10 FILLER PIC X(3) VALUE 'DB2'.
10 CURSOR-OPEN-LIT PIC X(1) VALUE 'Y'.
05 DB2-CURSOR-CONTROL.
10 CURSOR-CLOSED-LIT PIC X(1) VALUE SPACE.
05 DB2-COMMIT-CONTROL.
10 DB2-COMMIT-READ-IND PIC X(1) VALUE SPACE.
10 DB2-COMMIT-CHANGE-IND PIC X(1) VALUE SPACE.
SKIP1
05 TRACE-VARIABLES.
10 SECTION-TABLE.
15 SECTION-NAME-TABLE PIC X(8) OCCURS 9 TIMES
INDEXED BY SEC-INDEX.
10 TRACE-SECTION-AREA.
15 FILLER PIC X(6) VALUE 'TRACE '.
15 FILLER PIC S9(4) COMP VALUE -1286.
15 TRACE-SECTION-NAME PIC X(8) VALUE SPACES.
15 TRACE-SEGMENT-NAME PIC X(8) VALUE SPACES.
15 TRACE-FIELD-NAME PIC X(8) VALUE SPACES.
SKIP1
05 SEGMENT-NAME-TABLE.
10 FILLER PIC X(8) VALUE 'SEGNAMES'.
10 SEGNAME-FY1008W PIC X(8) VALUE 'FY1008W'.
10 SEGNAME-VY102400 PIC X(8) VALUE 'VY102400'.
SKIP1
05 FIELD-EDIT-VARIABLES.
10 FIELD-EDIT-ERROR PIC X(4) VALUE SPACES.
88 FIELD-EDIT-GOOD VALUE SPACES.
10 WORKFLD-INDEX PIC 9(4) COMP VALUE ZERO.
10 WORKFLD-NUMERIC PIC S9(11)V9(7) VALUE ZERO.
10 WORKFLD-WINDOW-YEAR PIC 99 VALUE 50.
10 WORKFLD-VCHAR.
15 WORKFLD-LTH PIC S9(4) COMP VALUE ZERO.
15 WORKFLD-ALPHA PIC X(256) VALUE SPACES.
10 WORKFLD-SEGLTH PIC 9(4) COMP VALUE ZERO.
10 WORKFLD-NUMREC PIC 9(4) COMP VALUE ZERO.
10 WORKFLD-RBA-RRN PIC 9(8) COMP VALUE ZERO.
05 DATASET-RESPONSE-CODES.
* VALUES ARE THE SAME AS THE FIRST BYTE OF THE
* EIBRCODE AFTER A FILE ACCESS CALL
10 DATASET-OK PIC X VALUE LOW-VALUE.
10 DATASET-DSIDERR-VALUE PIC S9(4) COMP
VALUE +001.
10 DATASET-DSIDERR-VALUE-RDF REDEFINES
DATASET-DSIDERR-VALUE.
15 FILLER PIC X.
15 DATASET-DSIDERR PIC X.
10 DATASET-ILLOGIC-VALUE PIC S9(4) COMP
VALUE +002.
10 DATASET-ILLOGIC-VALUE-RDF REDEFINES
DATASET-ILLOGIC-VALUE.
15 FILLER PIC X.
15 DATASET-ILLOGIC PIC X.
10 DATASET-SEGIDERR-VALUE PIC S9(4) COMP
VALUE +004.
10 DATASET-SEGIDERR-VALUE-RDF REDEFINES
DATASET-SEGIDERR-VALUE.
15 FILLER PIC X.
15 DATASET-SEGIDERR PIC X.
10 DATASET-INVREQ-VALUE PIC S9(4) COMP
VALUE +008.
10 DATASET-INVREQ-VALUE-RDF REDEFINES
DATASET-INVREQ-VALUE.
15 FILLER PIC X.
15 DATASET-INVREQ PIC X.
10 DATASET-NOTOPEN-VALUE PIC S9(4) COMP
VALUE +012.
10 DATASET-NOTOPEN-VALUE-RDF REDEFINES
DATASET-NOTOPEN-VALUE.
15 FILLER PIC X.
15 DATASET-NOTOPEN PIC X.
10 DATASET-DISABLED-VALUE PIC S9(4) COMP
VALUE +013.
10 DATASET-DISABLED-RDF REDEFINES
DATASET-DISABLED-VALUE.
15 FILLER PIC X.
15 DATASET-DISABLED PIC X.
10 DATASET-ENDFILE-VALUE PIC S9(4) COMP
VALUE +015.
10 DATASET-ENDFILE-VALUE-RDF REDEFINES
DATASET-ENDFILE-VALUE.
15 FILLER PIC X.
15 DATASET-ENDFILE PIC X.
10 DATASET-IOERR-VALUE PIC S9(4) COMP
VALUE +128.
10 DATASET-IOERR-VALUE-RDF REDEFINES
DATASET-IOERR-VALUE.
15 FILLER PIC X.
15 DATASET-IOERR PIC X.
10 DATASET-NOTFND-VALUE PIC S9(4) COMP
VALUE +129.
10 DATASET-NOTFND-VALUE-RDF REDEFINES
DATASET-NOTFND-VALUE.
15 FILLER PIC X.
15 DATASET-NOTFND PIC X.
10 DATASET-DUPREC-VALUE PIC S9(4) COMP
VALUE +130.
10 DATASET-DUPREC-VALUE-RDF REDEFINES
DATASET-DUPREC-VALUE.
15 FILLER PIC X.
15 DATASET-DUPREC PIC X.
10 DATASET-NOSPACE-VALUE PIC S9(4) COMP
VALUE +131.
10 DATASET-NOSPACE-VALUE-RDF REDEFINES
DATASET-NOSPACE-VALUE.
15 FILLER PIC X.
15 DATASET-NOSPACE PIC X.
10 DATASET-DUPKEY-VALUE PIC S9(4) COMP
VALUE +132.
10 DATASET-DUPKEY-VALUE-RDF REDEFINES
DATASET-DUPKEY-VALUE.
15 FILLER PIC X.
15 DATASET-DUPKEY PIC X.
10 DATASET-SYSIDERR-VALUE PIC S9(4) COMP
VALUE +208.
10 DATASET-SYSIDERR-VALUE-RDF REDEFINES
DATASET-SYSIDERR-VALUE.
15 FILLER PIC X.
15 DATASET-SYSIDERR PIC X.
10 DATASET-ISCINVREQ-VALUE PIC S9(4) COMP
VALUE +209.
10 DATASET-ISCINVREQ-VALUE-RDF REDEFINES
DATASET-ISCINVREQ-VALUE.
15 FILLER PIC X.
15 DATASET-ISCINVREQ PIC X.
10 DATASET-NOTAUTH-VALUE PIC S9(4) COMP
VALUE +214.
10 DATASET-NOTAUTH-VALUE-RDF REDEFINES
DATASET-NOTAUTH-VALUE.
15 FILLER PIC X.
15 DATASET-NOTAUTH PIC X.
10 DATASET-LENGERR-VALUE PIC S9(4) COMP
VALUE +225.
10 DATASET-LENGERR-VALUE-RDF REDEFINES
DATASET-LENGERR-VALUE.
15 FILLER PIC X.
15 DATASET-LENGERR PIC X.
05 OPERATOR-ID PIC X(8) VALUE SPACES.
05 HOLD-AREA-SIZE PIC 9(4) COMP.
05 HOLD-AREA-APPLID-DFLT PIC X(3) VALUE 'Y1C'.
05 UPDATE-PTR POINTER.
05 TP-LENGTH PIC 9(4) COMP VALUE ZERO.
05 CITATIO PIC X(8) VALUE 'CITATIO'.
05 CITATIO-READ PIC XX VALUE 'IN'.
05 CITATIO-WRITE PIC XX VALUE 'OU'.
05 SPA-TS-ITEM PIC 9(4) COMP VALUE 1.
05 FALLOUT-ABEND-CODE PIC 9(4) VALUE 4002.
05 CNTLERR-ABEND-CODE PIC 9(4) VALUE 4001.
* THE FOLLOWING FIELDS ARE DEFINED FOR COMPATIBILITY
* BETWEEN TELON IMS AND TELON CICS PROGRAMS.
05 PROGRAM-TYPE PIC X VALUE 'C'.
05 IO-PCB PIC X VALUE SPACE.
05 XFER-PCB PIC X VALUE SPACE.
05 SOUND-THE-ALARM PIC X VALUE SPACE.
05 TPO-SCA-FIELD PIC X VALUE SPACE.
05 SPA-CMPAT PIC X VALUE SPACE.
SKIP3
EJECT
********************************************************
* D B 2 A R E A S *
********************************************************
EXEC SQL INCLUDE SQLCA
END-EXEC.
SKIP2
********************************************************
* D B 2 D C L G E N A R E A *
********************************************************
SKIP2
EXEC SQL INCLUDE VY102400
END-EXEC.
SKIP2
EJECT
********************************************************
* S E G M E N T I/O A R E A *
********************************************************
01 SEGMENT-IO-AREA.
02 SEGMENT-IO-AREA-HEADER PIC X(12) VALUE 'SEGMENT AREA'.
02 SEGMENT-IO-AREA-END PIC X.
EJECT
********************************************************
* H O L D A R E A B E G I N N I N G *
********************************************************
01 HOLD-AREA.
05 HOLD-AREA-KEY.
10 HOLD-AREA-LTERM PIC X(4).
10 HOLD-AREA-APPLID PIC X(3).
10 HOLD-AREA-TYPE PIC X.
05 HOLD-RESUME-PGM-ID PIC X(4).
05 FILLER PIC X(4).
SKIP2
********************************************************
* S P A A R E A *
********************************************************
01 SPA-AREA PIC X(15000).
01 FILLER REDEFINES SPA-AREA.
02 SPA-HEADER.
05 SPA-LENGTH PIC 9(4) COMP.
05 SPA-NEXT-PROGRAM-NAME PIC X(8).
05 SPA-TRANSACTION-CODE PIC X(4).
05 FILLER PIC XX.
02 SPA-XFER-WORK-AREA.
*TELON--------------------------------------------------------------
*DS: H11 ! COPY XFERWKA *
*-------------------------------------------------------------------
COPY Y1XFERTL. *
COPY Y1XFERM6. *
03 XFER-ZONE-FONCTION PIC X(1500). *
COPY Y1XFERCT. *
03 FILLER-ZONE-PROGRAMME PIC X(1000). *
COPY CYY1031W REPLACING ==:1031W:== BY ==XFER==. *
*----------------------------------------------! END XFERWKA ----
COPY Y1XFERBG.
COPY Y1XFERPG.
02 SCREEN-IMAGE-AREA.
05 SCI-AREA-HEADER.
10 FILLER PIC X.
10 SCI-WRITE-INDICATOR PIC X.
88 SCREEN-HAS-BEEN-WRITTEN VALUE HIGH-VALUES.
88 SCREEN-FIRST-WRITE VALUE LOW-VALUES.
10 SCI-MODIFY-INDICATOR PIC X.
88 FIELD-HAS-BEEN-MODIFIED VALUE HIGH-VALUES.
88 NO-FIELD-MODIFIED VALUE LOW-VALUES.
10 SCI-ALARM-INDICATOR PIC X.
88 SET-ALARM-ON-WRITE VALUE HIGH-VALUES.
88 NO-ALARM-ON-WRITE VALUE LOW-VALUES.
10 FILLER PIC X(8).
05 SCREEN-IMAGE PIC X(848).
05 SCREEN-IMAGE-END PIC X.
LINKAGE SECTION.
EJECT
********************************************************
* L I N K A G E S E C T I O N *
********************************************************
SKIP2
SKIP2
01 DFHCOMMAREA.
05 COM-SPA-AREA PIC X OCCURS 1 TO 32000 TIMES
DEPENDING ON EIBCALEN.
SKIP2
EJECT
EJECT
********************************************************
* *
* P R O C E D U R E D I V I S I O N *
* *
********************************************************
PROCEDURE DIVISION.
SKIP3
MAIN-LINE SECTION.
********************************************************
* M A I N L I N E *
********************************************************
SET SEC-INDEX TO 1.
MOVE 'TELON ID' TO TELON-RELEASE-EYECATCH.
SKIP1
* PROGRAM CUSTOM CONTROL MAINI
COPY INTERDIT.
SKIP1
IF EIBCALEN = 0
PERFORM Q-100-CICS-INIT
MOVE LOW-VALUES TO SPA-TRANSACTION-CODE
MOVE NEXT-PROGRAM-NAME TO SPA-NEXT-PROGRAM-NAME
MOVE 15000 TO SPA-LENGTH
MOVE PROCESS-OUTPUT-LIT TO CONTROL-INDICATOR
ELSE
MOVE DFHCOMMAREA TO SPA-AREA
PERFORM Q-100-CICS-INIT
IF SPA-TRANSACTION-CODE = PROGRAM-TRANSACTION-CODE
MOVE PROCESS-INPUT-LIT TO CONTROL-INDICATOR
PERFORM C-100-TERMIO-READ
ELSE
MOVE PROCESS-OUTPUT-LIT TO CONTROL-INDICATOR.
*
* PROCESS THE TRANSACTION
*
MOVE CONTROL-INDICATOR TO ENTRY-CONTROL-INDICATOR.
PERFORM MAIN-PROCESS UNTIL TRANSACTION-COMPLETE.
MAIN-LINE-RETURN.
SKIP3
********************************************************
* R E T U R N T O C I C S *
********************************************************
RETURN-TO-CICS.
SKIP1
CALL 'ADLAATX' USING DFHEIBLK DFHCOMMAREA.
IF SPA-TRANSACTION-CODE = SPACES
EXEC CICS RETURN END-EXEC
ELSE
MOVE PROGRAM-TRANSACTION-CODE TO SPA-TRANSACTION-CODE
MOVE 15000 TO SPA-LENGTH
EXEC CICS RETURN TRANSID(SPA-TRANSACTION-CODE)
COMMAREA(SPA-AREA)
LENGTH(SPA-LENGTH)
END-EXEC.
GOBACK.
EJECT
SKIP3
MAIN-PROCESS SECTION.
********************************************************
* *
* M A I N P R O C E S S *
* *
* PGMSTRUCT 3 *
* *
* THE FLOW OF THE PROGRAM IS CONTROLLED BY THE *
* VARIABLE NAMED CONTROL-INDICATOR. *
* *
* THERE ARE SIX VALUES WHICH INDICATE ACTION. THE *
* INDICATOR IS TESTED WITH THE 88 LEVEL ITEMS LISTED *
* BELOW. THERE ARE ALSO CORRESPONDING DATA ITEMS *
* WITH THE SUFFIX '-LIT' WHICH ARE USED TO SET THE *
* CONTROL-INDICATOR. *
* *
* 88 LEVEL NAME A C T I O N *
* ------------------- ----------------------- *
* PROCESS-OUTPUT - BUILD A SCREEN FOR OUTPUT *
* DO-WRITE - WRITE A SCREEN *
* PROCESS-INPUT - PROCESS AN INPUT MESSAGE *
* DO-TRANSFER - TRANSFER TO NEXT PROGRAM *
* TRANSACTION-COMPLETE - RETURN CONTROL TO CALLER *
* CONTINUE-PROCESS - PERFORM NEXT ROUTINE *
* *
********************************************************
SKIP1
IF PROCESS-OUTPUT
PERFORM MAIN-OUTPUT
ELSE
IF DO-WRITE
PERFORM C-200-TERMIO-WRITE
ELSE
IF PROCESS-INPUT
PERFORM MAIN-INPUT
ELSE
IF DO-TRANSFER
PERFORM C-300-TERMIO-XFER
ELSE
PERFORM Z-990-PROGRAM-ERROR.
SKIP1
MAIN-PROCESS-RETURN.
EXIT.
EJECT
MAIN-OUTPUT SECTION.
********************************************************
* M A I N O U T P U T *
********************************************************
SKIP1
MOVE SPACE TO CONTROL-INDICATOR.
IF XFER-HOLD-INDICATOR = 'P' OR 'D'
MOVE XFER-HOLD-INDICATOR TO HOLD-AREA-TYPE
PERFORM K-100-HOLD-RESTORE
ELSE
PERFORM A-100-OUTPUT-INIT
IF CONTINUE-PROCESS
PERFORM B-100-OUTPUT-EDITS.
*
* SET DEFAULT ACTION TO DO-WRITE
*
IF CONTINUE-PROCESS
MOVE DO-WRITE-LIT TO CONTROL-INDICATOR.
SKIP1
MAIN-OUTPUT-RETURN.
EXIT.
SKIP3
MAIN-INPUT SECTION.
********************************************************
* M A I N I N P U T *
********************************************************
SKIP1
MOVE SPACE TO CONTROL-INDICATOR.
MOVE PROGRAM-NAME OF SYS-WORK-AREA TO NEXT-PROGRAM-NAME-ID.
PERFORM P-100-PFKEYS.
IF CONTINUE-PROCESS
PERFORM D-100-INPUT-INIT
IF CONTINUE-PROCESS
PERFORM E-100-INPUT-EDITS
IF CONTINUE-PROCESS
PERFORM X-100-CONSIS-EDITS
IF CONTINUE-PROCESS
PERFORM H-100-INPUT-TERM.
*
* SET DEFAULT ACTION TO DO-TRANSFER
*
IF CONTINUE-PROCESS
MOVE DO-TRANSFER-LIT TO CONTROL-INDICATOR.
*
* IF TRANSFER IS TO THE SAME PROGRAM, PROCESS OUTPUT
*
IF DO-TRANSFER
AND (SPA-TRANSACTION-CODE NOT = SPACES)
IF NEXT-PROGRAM-NAME = CURRENT-PROGRAM-NAME
MOVE PROCESS-OUTPUT-LIT TO CONTROL-INDICATOR
ENTRY-CONTROL-INDICATOR.
SKIP1
MAIN-INPUT-RETURN.
EXIT.
EJECT
A-100-OUTPUT-INIT SECTION.
********************************************************
* A - 1 0 0 - O U T P U T - I N I T *
********************************************************
* THIS ROUTINE INITIALIZES ANY FIELDS NECESSARY PRIOR *
* TO OUTPUT PROCESSING AND RETRIEVES OUTPUT/OUTIN *
* DATABASE SEGMENTS. *
* *
* GENERATED - TP-OUTPUT-BUFFER FIELD INITIALIZATION *
* COPY CODE - SCREEN/OINIT1 *
* GENERATED - OUTPUT/OUTIN DATA ACCESS AUTO CALLS *
* COPY CODE - SCREEN/OINIT2 *
********************************************************
SKIP1
MOVE LOW-VALUES TO SCREEN-IMAGE-AREA TP-BUFFER.
SKIP1
* SCREEN/OINIT1 COPY CODE
SKIP1
*TELON--------------------------------------------------------------
*DS: H11 ! COPY OINIT1 *
*-------------------------------------------------------------------
**************************************************************** *
* INIT ET ALIM DE LA TABLE DES ENCHAINEMENTS D'ECRANS * *
* * *
**************************************************************** *
COPY Y1OINIT1. *
*----------------------------------------------! END OINIT1 ----
SKIP1
SKIP1
* SCREEN/OINIT2 COPY CODE
SKIP1
*TELON--------------------------------------------------------------
*DS: H11 ! COPY OINIT2 *
*-------------------------------------------------------------------
**************************************************************** *
* AFFICHAGE DE L'éCRAN * *
* LECTURE DU FICHIER FY1008 POUR RECUP DES INFOS RELATIVES * *
* à LA BG POUR ALIM DE L'éCRAN. * *
**************************************************************** *
IF XFER-CONFIRMATION = '0' *
INITIALIZE E031-ERG-DEMANDE *
MOVE XFER-CLE-DEMANDE TO E031-CLE-DEMANDE *
PERFORM U-100-READ-FY1008W *
*
IF DA-NOTFOUND *
MOVE 'LA REFERENCE BG SELECTIONNEE EST ABSENTE DU REFERENT *
- 'IEL' TO XFER-ERRMSG1 *
MOVE 'Y1R0' TO NEXT-PROGRAM-NAME-ID *
MOVE DO-TRANSFER-LIT TO CONTROL-INDICATOR *
GO TO A-100-OUTPUT-INIT-RETURN *
ELSE *
MOVE E031-ERG-DEMANDE TO XFER-ERG-DEMANDE *
END-IF *
END-IF. *
MOVE SPACES TO WK-LIBDEM *
EVALUATE XFER-TNX-TYPE-CODE *
WHEN '01' *
MOVE 'Demande d''emission' TO WK-LIBDEM *
WHEN '03' *
EVALUATE XFER-SUB-TNX-TYPE-CODE *
WHEN '05' *
MOVE 'Demande de mainlevee' TO WK-LIBDEM *
WHEN OTHER *
MOVE 'Demande de modification' TO WK-LIBDEM *
END-EVALUATE *
END-EVALUATE *
MOVE 'Confirmation du rejet (OUI/NON)' *
TO WK-LCONFRJ *
*----------------------------------------------! END OINIT2 ----
SKIP1
SKIP1
PERFORM N-100-CURSOR-POSITION.
SKIP1
A-100-OUTPUT-INIT-RETURN.
EXIT.
EJECT
B-100-OUTPUT-EDITS SECTION.
********************************************************
* B - 1 0 0 - O U T P U T - E D I T S *
********************************************************
* THIS ROUTINE CONTAINS THE OUTPUT EDIT LOGIC *
* GENERATED FROM THE FIELD STATEMENTS. FIELDS ARE *
* MOVED FROM THE DBNAME FIELD AND EDITED BASED UPON *
* THE FIELD EDIT PARAMETERS SPECIFIED. SPECIAL *
* FLDTYPE EDITS ARE LINKED TO WITH CALL STATEMENTS. *
* *
* GENERATED - FIELD EDIT LOGIC *
* COPY CODE - SCREEN/OUTTERM *
********************************************************
SKIP1
SKIP2
* NOCICS FIELD
SKIP1
MOVE XFER-IDENTIFIANT-CICS TO TPO-NOCICS.
SKIP2
* NOVTAM FIELD
SKIP1
MOVE XFER-IDTF-TERMINAL-PHYSIQUE TO TPO-NOVTAM.
SKIP2
* LIBAGEN FIELD
SKIP1
MOVE XF-M6-LIBUF TO TPO-LIBAGEN.
SKIP2
* EDDATE FIELD
SKIP1
MOVE EIBDATE TO WORKFLD-NUMERIC.
CALL 'OINTLJUL' USING TPO-EDDATE
TPO-EDDATE-LTH
WORKFLD-NUMERIC.
SKIP2
* EDTIME FIELD
SKIP1
MOVE EIBTIME TO TPO-EDTIME.
SKIP2
* CODTRX FIELD
SKIP1
MOVE PROGRAM-TRANSACTION-CODE TO TPO-CODTRX.
SKIP2
* REFBG FIELD
SKIP1
MOVE XFER-REF-BG TO TPO-REFBG.
SKIP2
* REFCO FIELD
SKIP1
MOVE XFER-IDTN-CAUT TO TPO-REFCO.
SKIP2
* LIBDEM FIELD
SKIP1
MOVE WK-LIBDEM TO TPO-LIBDEM.
SKIP2
* DOADR1 FIELD
SKIP1
MOVE XFER-APPLICANT-NAME TO TPO-DOADR1.
SKIP2
* DEV01 FIELD
SKIP1
MOVE XFER-BG-CUR-CODE TO TPO-DEV01.
SKIP2
* MT01 FIELD
SKIP1
MOVE XFER-BG-AMT TO WORKFLD-NUMERIC-3.
CALL 'OBFMONTS' USING TPO-MT01
TPO-MT01-LTH
WORKFLD-NUMERIC-3
XFER-BG-NB-DEC.
SKIP2
* BENADR1 FIELD
SKIP1
MOVE XFER-BENEFICIARY-NAME TO TPO-BENADR1.
SKIP2
* DEV02 FIELD
SKIP1
MOVE XFER-BG-CUR-CODE-2 TO TPO-DEV02.
SKIP2
* MT02 FIELD
SKIP1
MOVE XFER-BG-AMT-2 TO WORKFLD-NUMERIC-3.
CALL 'OBFMONTS' USING TPO-MT02
TPO-MT02-LTH
WORKFLD-NUMERIC-3
XFER-BG-NB-DEC-2.
SKIP2
* CPAYS FIELD
SKIP1
MOVE XFER-BENEFICIARY-COUNTRY TO TPO-CPAYS.
SKIP2
* LPAYS FIELD
SKIP1
MOVE XFER-BENEFICIARY-COUNTRY-NAME TO TPO-LPAYS.
SKIP2
* DEV03 FIELD
SKIP1
MOVE XFER-BG-CUR-CODE-3 TO TPO-DEV03.
SKIP2
* MT03 FIELD
SKIP1
MOVE XFER-BG-AMT-3 TO WORKFLD-NUMERIC-3.
CALL 'OBFMONTS' USING TPO-MT03
TPO-MT03-LTH
WORKFLD-NUMERIC-3
XFER-BG-NB-DEC-3.
SKIP2
* DEV04 FIELD
SKIP1
MOVE XFER-BG-CUR-CODE-4 TO TPO-DEV04.
SKIP2
* MT04 FIELD
SKIP1
MOVE XFER-BG-AMT-4 TO WORKFLD-NUMERIC-3.
CALL 'OBFMONTS' USING TPO-MT04
TPO-MT04-LTH
WORKFLD-NUMERIC-3
XFER-BG-NB-DEC-4.
SKIP2
* BOCOM01 FIELD
SKIP1
MOVE WK-BO-COMMENT01 TO TPO-BOCOM01.
SKIP2
* BOCOM02 FIELD
SKIP1
MOVE WK-BO-COMMENT02 TO TPO-BOCOM02.
SKIP2
* BOCOM03 FIELD
SKIP1
MOVE WK-BO-COMMENT03 TO TPO-BOCOM03.
SKIP2
* BOCOM04 FIELD
SKIP1
MOVE WK-BO-COMMENT04 TO TPO-BOCOM04.
SKIP2
* LCONFRJ FIELD
SKIP1
MOVE WK-LCONFRJ TO TPO-LCONFRJ.
SKIP1
SKIP1
* SCREEN/OUTTERM COPY CODE
SKIP1
*TELON--------------------------------------------------------------
*DS: H11 ! COPY OUTTERM *
*-------------------------------------------------------------------
**************************************************************** *
* POSITIONNEMENT D'ATTRIBUTS SUR CHAMPS * *
* SUIVANT LE DEROULEMENT DU REJET DE LA DEMANDE * *
* * *
**************************************************************** *
EVALUATE XFER-CONFIRMATION *
WHEN '0' *
MOVE BLANK-ATTR TO TPO-LCONFRJ-ATTR *
MOVE BLANK-ATTR TO TPO-RCONFRJ-ATTR *
MOVE '1' TO XFER-CONFIRMATION *
MOVE CURSOR-ATTR TO TPO-BOCOM01-ATTR *
WHEN '1' *
MOVE '2' TO XFER-CONFIRMATION *
MOVE CURSOR-ATTR TO TPO-RCONFRJ-ATTR *
END-EVALUATE. *
*----------------------------------------------! END OUTTERM ----
SKIP1
SKIP1
B-100-OUTPUT-EDITS-RETURN.
EXIT.
EJECT
C-100-TERMIO-READ SECTION.
********************************************************
* C - 1 0 0 - T E R M I O - R E A D *
********************************************************
* THIS SECTION READS THE INPUT MESSAGE FROM THE *
* TERMINAL. *
* *
* GENERATED - ENTIRE SECTION *
********************************************************
SKIP2
C-100-TERMIO-RECEIVE.
********************************************************
* READ FROM TERMINAL *
********************************************************
CALL 'TLRATIO' USING DFHEIBLK
DFHCOMMAREA
CITATIO-READ
TP-OUTPUT-TABLE
TP-OUTPUT-BUFFER-FIELDS
TP-LITERAL-TABLE
PFKEY-INDICATOR
SCREEN-IMAGE-AREA
SCREEN-IMAGE-END.
SKIP1
C-100-TERMIO-READ-RETURN.
EXIT.
EJECT
C-200-TERMIO-WRITE SECTION.
********************************************************
* C - 2 0 0 - T E R M I O - W R I T E *
********************************************************
* THIS SECTION WRITES THE OUTPUT MESSAGE TO THE *
* TERMINAL USING THE TELON TERMINAL I/O ROUTINE *
* THE CONTROL INDICATOR IS ALSO SET TO INDICATE *
* TRANSACTION COMPLETE. *
* *
* GENERATED - ENTIRE SECTION *
********************************************************
SKIP1
IF SPA-TRANSACTION-CODE NOT = SPACE
MOVE PROGRAM-TRANSACTION-CODE TO SPA-TRANSACTION-CODE.
********************************************************
* WRITE TO TERMINAL *
********************************************************
CALL 'TLRATIO' USING DFHEIBLK
DFHCOMMAREA
CITATIO-WRITE
TP-OUTPUT-TABLE
TP-OUTPUT-BUFFER-FIELDS
TP-LITERAL-TABLE
PFKEY-INDICATOR
SCREEN-IMAGE-AREA
SCREEN-IMAGE-END.
SKIP1
MOVE TRANSACTION-COMPLETE-LIT TO CONTROL-INDICATOR.
SKIP1
C-200-TERMIO-WRITE-RETURN.
EXIT.
EJECT
C-300-TERMIO-XFER SECTION.
********************************************************
* C - 3 0 0 - T E R M I O - X F E R *
********************************************************
* THIS SECTION TRANSFERS CONTROL TO THE MODULE TO *
* PROCESS OUTPUT USING THE XCTL COMMAND. IT PASSES *
* THE SPA-AREA IN DFHCOMMAREA. *
* *
* GENERATED - ENTIRE SECTION *
********************************************************
IF SPA-TRANSACTION-CODE NOT = SPACES
MOVE LOW-VALUES TO SPA-TRANSACTION-CODE.
SKIP1
* PROGRAM CUSTOM CONTROL C300I
COPY COMMIT.
SKIP1
SKIP1
SKIP1
IF SPA-TRANSACTION-CODE = SPACES
MOVE TRANSACTION-COMPLETE-LIT TO CONTROL-INDICATOR
GO TO C-300-TERMIO-XFER-RETURN.
SKIP1
CALL 'ADLAATX' USING DFHEIBLK DFHCOMMAREA.
MOVE NEXT-PROGRAM-NAME TO SPA-NEXT-PROGRAM-NAME.
EXEC CICS XCTL PROGRAM(SPA-NEXT-PROGRAM-NAME)
COMMAREA(SPA-AREA)
LENGTH(SPA-LENGTH)
END-EXEC.
SKIP1
C-300-TERMIO-XFER-RETURN.
EXIT.
EJECT
D-100-INPUT-INIT SECTION.
********************************************************
* D - 1 0 0 - I N P U T - I N I T *
********************************************************
* THIS ROUTINE INITIALIZES ANY FIELDS NECESSARY *
* PRIOR TO INPUT PROCESSING AND RETRIEVES INPUT/OUTIN *
* UPDATE DATABASE SEGMENTS. *
* *
* COPY CODE - SCREEN/ININIT1 *
* GENERATED - INPUT/OUTPUT/UPDATE DATABASE AUTO CALLS *
* COPY CODE - SCREEN/ININIT2(ININIT) *
********************************************************
SKIP1
SKIP1
* SCREEN/ININIT1 NOT CODED
SKIP1
SKIP1
SKIP1
* SCREEN/ININIT2 NOT CODED
SKIP1
SKIP1
D-100-INPUT-INIT-RETURN.
EXIT.
EJECT
E-100-INPUT-EDITS SECTION.
********************************************************
* E - 1 0 0 - I N P U T - E D I T S *
********************************************************
* THIS ROUTINE CONTAINS THE INPUT EDIT LOGIC GENERATED*
* FROM THE FIELD STATEMENT PARAMETERS. STANDARD *
* EDITS SUCH AS REQ, CONVERT AND VALUES ARE GENERATED *
* IN THIS SECTION. SPECIAL FLDTYPES ARE LINKED TO *
* WITH CALL STATEMENTS. *
* *
* GENERATED - FIELD EDIT LOGIC *
* COPY CODE - SEGLOOP/ICUST1 (PRE EDIT) *
* COPY CODE - SEGLOOP/ICUST2 *
* COPY CODE - SCREEN/FLDEDIT *
********************************************************
SKIP1
SKIP2
* BOCOM01 FIELD
SKIP1
IF TPI-BOCOM01 NOT = SPACE
MOVE TPI-BOCOM01 TO WK-BO-COMMENT01
ELSE
MOVE SPACES TO WK-BO-COMMENT01.
SKIP2
* BOCOM02 FIELD
SKIP1
IF TPI-BOCOM02 NOT = SPACE
MOVE TPI-BOCOM02 TO WK-BO-COMMENT02
ELSE
MOVE SPACES TO WK-BO-COMMENT02.
SKIP2
* BOCOM03 FIELD
SKIP1
IF TPI-BOCOM03 NOT = SPACE
MOVE TPI-BOCOM03 TO WK-BO-COMMENT03
ELSE
MOVE SPACES TO WK-BO-COMMENT03.
SKIP2
* BOCOM04 FIELD
SKIP1
IF TPI-BOCOM04 NOT = SPACE
MOVE TPI-BOCOM04 TO WK-BO-COMMENT04
ELSE
MOVE SPACES TO WK-BO-COMMENT04.
SKIP1
*
* IF ERROR INDICATED, SET DEFAULT ERROR MESSAGE
*
SKIP1
IF NOT CONTINUE-PROCESS
MOVE ERROR-MESSAGE-HIGHLIGHT TO TPO-ERRMSG1.
SKIP1
* SCREEN/FLDEDIT NOT CODED
SKIP1
SKIP1
E-100-INPUT-EDITS-RETURN.
EXIT.
EJECT
H-100-INPUT-TERM SECTION.
********************************************************
* H - 1 0 0 - I N P U T - T E R M *
********************************************************
* THIS SECTION IS EXECUTED AT THE END OF INPUT *
* PROCESSING. *
* *
* GENERATED - CREATE/UPDATE DATA ACCESS AUTO CALLS *
* COPY CODE - SCREEN/INTERM *
********************************************************
SKIP1
SKIP1
* SCREEN/INTERM COPY CODE
SKIP1
*TELON--------------------------------------------------------------
*DS: H11 ! COPY MAJDEM *
*-------------------------------------------------------------------
**************************************************************** *
* MAJ DE LA DEMANDE MTP * *
**************************************************************** *
* LA MAJ DE LA DEMANDE MTP SE FAIT TOUJOURS SIMULTANEMENT * *
* DANS LE FICHIER FY1008W ET LA TABLE TY1024. * *
* A L'ISSUE DE LA MAJ, UN MESSAGE EST ENVOYé à L'éCRAN LISTE* *
* Y1R0 POUR PRECISION SUR LA REFERENCE BG REJETEE * *
**************************************************************** *
IF XFER-CONFIRMATION = '3' *
MOVE XFER-ERG-DEMANDE TO E031-ERG-DEMANDE *
MOVE '03' TO E031-STATUT-DEMANDE *
STRING WK-BO-COMMENT01 WK-BO-COMMENT02 *
WK-BO-COMMENT03 WK-BO-COMMENT04 *
DELIMITED BY SIZE INTO E031-BO-COMMENT *
PERFORM U-100-UPDATE-FY1008W *
IF DA-NOTFOUND *
MOVE 'AUCUNE REFERENCE BG N''A ETE MISE A JOUR' *
TO XFER-ERRMSG1 *
MOVE PROCESS-INPUT-LIT TO CONTROL-INDICATOR *
MOVE '03' TO PFKEY-INDICATOR *
ELSE *
PERFORM U-100-UPDATE-VY102400 *
IF DA-NOTFOUND *
MOVE 'AUCUNE REFERENCE BG N''A ETE MISE A JOUR' *
TO XFER-ERRMSG1 *
MOVE PROCESS-INPUT-LIT TO CONTROL-INDICATOR *
MOVE '03' TO PFKEY-INDICATOR *
ELSE *
EVALUATE XFER-TNX-TYPE-CODE *
WHEN '01' *
STRING 'DEMANDE D''EMISSION DE LA ' XFER-REF-BG *
' REJETEE' DELIMITED BY SIZE *
INTO XFER-ERRMSG1 *
MOVE PROCESS-INPUT-LIT TO CONTROL-INDICATOR *
MOVE '03' TO PFKEY-INDICATOR *
WHEN '03' *
EVALUATE XFER-SUB-TNX-TYPE-CODE *
WHEN '05' *
STRING 'DEMANDE DE MAINLEVEE DU CONTRAT ' *
XFER-IDTN-CAUT ' REJETEE' DELIMITED BY *
SIZE INTO XFER-ERRMSG1 *
MOVE PROCESS-INPUT-LIT TO CONTROL-INDICATOR *
MOVE '03' TO PFKEY-INDICATOR *
WHEN OTHER *
STRING 'DEMANDE DE MODIFICATION DU CONTRAT ' *
XFER-IDTN-CAUT ' REJETEE' DELIMITED BY *
SIZE INTO XFER-ERRMSG1 *
MOVE PROCESS-INPUT-LIT TO CONTROL-INDICATOR *
MOVE '03' TO PFKEY-INDICATOR *
END-EVALUATE *
END-EVALUATE *
END-IF *
END-IF *
MOVE 'Y1R0' TO NEXT-PROGRAM-NAME-ID *
END-IF. *
*----------------------------------------------! END MAJDEM ----
SKIP1
H-100-INPUT-TERM-RETURN.
EXIT.
EJECT
K-100-HOLD-RESTORE SECTION.
********************************************************
* K - 1 0 0 - H O L D - R E S T O R E *
********************************************************
* THIS ROUTINE RESTORES THE TRANSFER AREA UPON RETURN *
* FROM THE HELP OR HOLD FUNCTION. *
* *
* GENERATED - ENTIRE SECTION *
********************************************************
SKIP1
MOVE EIBTRMID TO HOLD-AREA-LTERM.
MOVE HOLD-AREA-APPLID-DFLT TO HOLD-AREA-APPLID.
MOVE 15016 TO HOLD-AREA-SIZE.
SKIP1
EXEC CICS READQ TS
INTO(HOLD-AREA)
LENGTH(HOLD-AREA-SIZE)
QUEUE(HOLD-AREA-KEY)
ITEM(1)
END-EXEC.
EXEC CICS DELETEQ TS
QUEUE(HOLD-AREA-KEY)
END-EXEC.
SKIP1
MOVE SCREEN-IMAGE TO TP-OUTPUT-BUFFER-FIELDS.
MOVE LOW-VALUES TO SCREEN-IMAGE-AREA.
SKIP1
IF HOLD-AREA-TYPE EQUAL 'D'
MOVE ERROR-MESSAGE-HOLD TO TPO-ERRMSG1
ELSE
MOVE ERROR-MESSAGE-HELP TO TPO-ERRMSG1.
SKIP1
K-100-HOLD-RESTORE-RETURN.
EXIT.
EJECT
K-200-HOLD-RESUME SECTION.
********************************************************
* K - 2 0 0 - H O L D - R E S U M E *
********************************************************
* THIS ROUTINE RETRIEVES THE HOLD AREA HEADER IF IT *
* EXISTS, SETS THE NEXT PROGRAM NAME BASED ON THE *
* HOLD-RESUME-PGM-ID AND INDICATES TO DO-TRANSFER. *
* IF NO RECORD IS ON HOLD, IT RETURNS AN ERROR. *
* *
* GENERATED - ENTIRE SECTION *
********************************************************
SKIP1
MOVE EIBTRMID TO HOLD-AREA-LTERM.
MOVE HOLD-AREA-APPLID-DFLT TO HOLD-AREA-APPLID.
MOVE 16 TO HOLD-AREA-SIZE.
SKIP1
EXEC CICS HANDLE CONDITION
QIDERR(K-200-HOLD-NOTFND)
LENGERR(K-200-RESUME-OK)
END-EXEC.
EXEC CICS READQ TS
INTO(HOLD-AREA)
LENGTH(HOLD-AREA-SIZE)
QUEUE(HOLD-AREA-KEY)
ITEM(1)
END-EXEC.
SKIP1
K-200-RESUME-OK.
MOVE HOLD-RESUME-PGM-ID TO NEXT-PROGRAM-NAME-ID.
MOVE HOLD-AREA-TYPE TO XFER-HOLD-INDICATOR.
MOVE DO-TRANSFER-LIT TO CONTROL-INDICATOR.
GO TO K-200-HOLD-RESUME-RETURN.
SKIP1
K-200-HOLD-NOTFND.
MOVE ERROR-MESSAGE-RESUME TO TPO-ERRMSG1.
PERFORM N-100-CURSOR-POSITION.
MOVE DO-WRITE-LIT TO CONTROL-INDICATOR.
SKIP2
K-200-HOLD-RESUME-RETURN.
EXEC CICS HANDLE CONDITION QIDERR LENGERR END-EXEC.
EJECT
L-100-HOLD-SAVE SECTION.
********************************************************
* L - 1 0 0 - H O L D - S A V E *
********************************************************
* THIS ROUTINE SAVES THE TRANSFER AREA IN THE HOLD *
* FILE. IT IS PERFORMED FOR THE HOLD OR HELP *
* FUNCTION. *
* *
* GENERATED - ENTIRE SECTION *
********************************************************
SKIP1
MOVE PROGRAM-NAME OF SYS-WORK-AREA TO HOLD-RESUME-PGM-ID.
MOVE EIBTRMID TO HOLD-AREA-LTERM.
MOVE HOLD-AREA-APPLID-DFLT TO HOLD-AREA-APPLID.
MOVE 16 TO HOLD-AREA-SIZE.
SKIP1
EXEC CICS HANDLE CONDITION
QIDERR(L-100-OK-TO-HOLD)
LENGERR(L-100-HOLD-ERROR)
END-EXEC.
EXEC CICS READQ TS
SET(UPDATE-PTR)
LENGTH(HOLD-AREA-SIZE)
QUEUE(HOLD-AREA-KEY)
ITEM(1)
END-EXEC.
L-100-HOLD-ERROR.
*
* FOR HELP FUNCTION, DELETE THE PRIOR HOLD RECORD
* FOR HOLD FUNCTION, MULTIPLE HOLDS ARE NOT ALLOWED
*
IF HOLD-AREA-TYPE = 'P'
EXEC CICS DELETEQ TS
QUEUE(HOLD-AREA-KEY)
END-EXEC
ELSE
MOVE ERROR-MESSAGE-HOLD-ISRT TO TPO-ERRMSG1
PERFORM N-100-CURSOR-POSITION
MOVE DO-WRITE-LIT TO CONTROL-INDICATOR
GO TO L-100-HOLD-SAVE-RETURN.
SKIP1
L-100-OK-TO-HOLD.
*
* INSERT THE HOLD AREA TO TEMPORARY STORAGE
*
MOVE 15016 TO HOLD-AREA-SIZE.
EXEC CICS WRITEQ TS MAIN
FROM (HOLD-AREA)
LENGTH(HOLD-AREA-SIZE)
QUEUE(HOLD-AREA-KEY)
END-EXEC.
MOVE DO-TRANSFER-LIT TO CONTROL-INDICATOR.
SKIP1
L-100-HOLD-SAVE-RETURN.
EXEC CICS HANDLE CONDITION QIDERR LENGERR END-EXEC.
EJECT
N-100-CURSOR-POSITION SECTION.
********************************************************
* N - 1 0 0 - C U R S O R - P O S I T I O N *
********************************************************
* THIS SECTION POSITIONS THE CURSOR TO THE PROPER *
* FIELD FOR OUTPUT. *
* *
* GENERATED - MOVE CURSOR-ATTR TO SCREEN/CURSOR FIELD *
* COPY CODE - SCREEN/CURSCUS *
********************************************************
SKIP1
SKIP1
* SCREEN/CURSCUS NOT CODED
SKIP1
SKIP1
N-100-CURSOR-POSITION-RETURN.
EXIT.
EJECT
P-100-PFKEYS SECTION.
********************************************************
* P - 1 0 0 - P F K E Y S *
********************************************************
* THIS SECTION PROCESSES PFKEYS. *
* *
* COPY CODE - SCREEN/PFKEYS *
********************************************************
SKIP1
MOVE SPACES TO TPO-ERRMSG1.
SKIP1
*
* PFKEY 3 ROUTINE
*
COPY Y1PFK3.
*
* PFKEY AUT ROUTINE
*
COPY Y1PFKAUT.
IF (CLEAR AND CONTINUE-PROCESS)
MOVE SPACES TO SPA-TRANSACTION-CODE
EXEC CICS SEND
FROM(SPA-TRANSACTION-CODE)
LENGTH(1)
END-EXEC
MOVE DO-TRANSFER-LIT TO CONTROL-INDICATOR.
SKIP1
P-100-PFKEYS-RETURN.
EXIT.
EJECT
Q-100-CICS-INIT SECTION.
********************************************************
* Q - 1 0 0 - C I C S - I N I T R O U T I N E *
********************************************************
* THIS ROUTINE OPTIONALLY CALLS THE TELON TEST *
* FACILITY FOR PROGRAM TRACE AND SCHEDULES THE DLI *
* PSB WHEN APPLICABLE. *
* *
* GENERATED - ENTIRE SECTION *
********************************************************
SKIP1
CALL 'ADLAATI' USING DFHEIBLK DFHCOMMAREA.
SKIP1
Q-100-CICS-INIT-RETURN.
EXIT.
EJECT
U-100-USER-IO SECTION.
********************************************************
* U - 1 0 0 - U S E R - I O *
********************************************************
* THIS SECTION GENERATES ALL THE SEGMENT IO REQUESTS *
* IN THE SCREEN DEFINITION. *
* *
* GENERATED - ENTIRE SECTION *
* COPY CODE - NONE *
********************************************************
SKIP1
U-100-COMMIT.
EXEC CICS SYNCPOINT END-EXEC.
MOVE SPACES TO DB2-CURSOR-CONTROL.
SKIP2
U-100-ROLLBACK.
EXEC CICS SYNCPOINT ROLLBACK END-EXEC.
MOVE SPACES TO DB2-CURSOR-CONTROL.
EJECT
SKIP1
U-100-READ-FY1008W.
MOVE 6000 TO WORKFLD-SEGLTH.
SKIP1
EXEC CICS READ FILE(SEGNAME-FY1008W)
INTO(E031-ERG-DEMANDE)
RIDFLD(E031-CLE-DEMANDE)
LENGTH(WORKFLD-SEGLTH)
NOHANDLE
END-EXEC.
MOVE EIBRCODE TO FY1008W-STATUS.
MOVE EIBRCODE TO DA-STATUS-FILE.
PERFORM U-100-SET-DA-STATUS-VSAM.
IF DA-STATUS-FILE NOT = DATASET-OK
AND DA-STATUS-FILE NOT = DATASET-NOTFND
SKIP1
MOVE 3500 TO ABT-ERROR-ABEND-CODE
MOVE 'READ ' TO ABT-DA-FUNCTION
MOVE 'VSAM' TO ABT-ERROR-ACTIVITY
MOVE 'FY1008W ' TO ABT-DA-ACCESS-NAME
CALL 'ADLAAT0'
PERFORM Z-980-ABNORMAL-TERM.
SKIP1
U-100-UPDATE-FY1008W.
MOVE 6000 TO WORKFLD-SEGLTH.
SKIP1
EXEC CICS READ FILE(SEGNAME-FY1008W)
SET(UPDATE-PTR)
RIDFLD(E031-CLE-DEMANDE)
LENGTH(WORKFLD-SEGLTH)
UPDATE
NOHANDLE
END-EXEC.
MOVE EIBRCODE TO FY1008W-STATUS.
MOVE EIBRCODE TO DA-STATUS-FILE.
PERFORM U-100-SET-DA-STATUS-VSAM.
IF FY1008W-STATUS = DATASET-OK
EXEC CICS REWRITE FILE(SEGNAME-FY1008W)
FROM(E031-ERG-DEMANDE)
LENGTH(WORKFLD-SEGLTH)
NOHANDLE
END-EXEC
MOVE EIBRCODE TO DA-STATUS-FILE
FY1008W-STATUS
PERFORM U-100-SET-DA-STATUS-VSAM.
IF DA-STATUS-FILE NOT = DATASET-OK
AND DA-STATUS-FILE NOT = DATASET-NOTFND
SKIP1
MOVE 3501 TO ABT-ERROR-ABEND-CODE
MOVE 'REWRITE' TO ABT-DA-FUNCTION
MOVE 'VSAM' TO ABT-ERROR-ACTIVITY
MOVE 'FY1008W ' TO ABT-DA-ACCESS-NAME
CALL 'ADLAAT0'
PERFORM Z-980-ABNORMAL-TERM.
SKIP1
U-100-UPDATE-VY102400.
*TELON--------------------------------------------------------------
*DS: H11 ! COPY STATUT *
*-------------------------------------------------------------------
* DEFAULT GENERATED DATA ACCESS *
* DEFAULT CALL: ** U-100-UPDATE-VY102400 * *
EXEC SQL *
UPDATE VY102400 *
SET *
C_STATUT='03', *
C_EN_CRS_MAJ='1', *
C_UTIL_MAJ=:XF-M6-LOGON-ETD, *
TIMESTAMP_MAJ=CURRENT TIMESTAMP *
WHERE (I_REF_BG=:XFER-REF-BG) *
END-EXEC. *
*----------------------------------------------! END STATUT ----
MOVE SQLCODE TO VY102400-STATUS.
MOVE 'Y' TO DB2-COMMIT-CHANGE-IND.
PERFORM U-100-SET-DA-STATUS-DB2.
IF VY102400-STATUS NOT = 0
AND VY102400-STATUS NOT = +100
MOVE 3502 TO ABT-ERROR-ABEND-CODE
MOVE 'UPDATE' TO ABT-DA-FUNCTION
MOVE 'DB2 ' TO ABT-ERROR-ACTIVITY
MOVE 'VY102400' TO ABT-DA-ACCESS-NAME
CALL 'ADLAAT0'
PERFORM Z-980-ABNORMAL-TERM.
EJECT
U-100-SET-DA-STATUS-DB2.
MOVE SQLCODE TO ABT-DB2-STATUS.
IF SQLCODE = 0
MOVE DA-OK-LIT TO DA-STATUS
ELSE
IF SQLCODE = +100
MOVE DA-NOTFOUND-LIT TO DA-STATUS
ELSE
IF SQLCODE = -803 OR -811
MOVE DA-DUPLICATE-LIT TO DA-STATUS
ELSE
IF SQLCODE = -501 OR -502
MOVE DA-LOGICERR-LIT TO DA-STATUS
ELSE
IF SQLCODE = -922
MOVE DA-SECURITY-LIT TO DA-STATUS
ELSE
IF SQLCODE = -911 OR -913 OR -904
MOVE DA-NOTAVAIL-LIT TO DA-STATUS
ELSE
MOVE DA-DBMERROR-LIT TO DA-STATUS.
SKIP1
EJECT
U-100-SET-DA-STATUS-VSAM.
MOVE DA-STATUS-FILE TO ABT-VSAM-CICS-STATUS.
IF DA-STATUS-FILE = DATASET-OK
MOVE DA-OK-LIT TO DA-STATUS
ELSE
IF DA-STATUS-FILE = DATASET-NOTFND
MOVE DA-NOTFOUND-LIT TO DA-STATUS
ELSE
IF DA-STATUS-FILE = DATASET-ENDFILE
MOVE DA-ENDFILE-LIT TO DA-STATUS
ELSE
IF DA-STATUS-FILE = DATASET-DUPREC
MOVE DA-DUPREC-LIT TO DA-STATUS
ELSE
IF DA-STATUS-FILE = DATASET-DUPKEY
MOVE DA-DUPKEY-LIT TO DA-STATUS
ELSE
IF DA-STATUS-FILE = DATASET-DISABLED
MOVE DA-DISABLED-LIT TO DA-STATUS
ELSE
IF DA-STATUS-FILE = DATASET-NOTAUTH
MOVE DA-NOTAUTH-LIT TO DA-STATUS
ELSE
IF DA-STATUS-FILE = DATASET-ILLOGIC
MOVE DA-LOGICERR-LIT TO DA-STATUS
ELSE
IF DA-STATUS-FILE = DATASET-INVREQ
MOVE DA-SECURITY-LIT TO DA-STATUS
ELSE
IF DA-STATUS-FILE = DATASET-NOTOPEN
MOVE DA-NOTAVAIL-LIT TO DA-STATUS
ELSE
MOVE DA-DBMERROR-LIT TO DA-STATUS.
SKIP1
SKIP2
U-100-USER-IO-RETURN.
EXIT.
EJECT
X-100-CONSIS-EDITS SECTION.
********************************************************
* X - 1 0 0 - C O N S I S - E D I T S *
********************************************************
* THIS SECTION CONTAINS THE COPY CODE FOR ALL *
* CONSISTENCY EDITS REQUIRED ON INPUT. *
* *
* COPY CODE - SCREEN/CONSIS *
********************************************************
SKIP1
*TELON--------------------------------------------------------------
*DS: H11 ! COPY CONSIS *
*-------------------------------------------------------------------
**************************************************************** *
* CONTROLES DES CHAMPS SAISIS * *
* * *
**************************************************************** *
IF XFER-CONFIRMATION = '1' OR '2' *
IF WK-BO-COMMENT01 = SPACES AND *
WK-BO-COMMENT02 = SPACES AND *
WK-BO-COMMENT03 = SPACES AND *
WK-BO-COMMENT04 = SPACES *
MOVE 'LE MOTIF DU REJET EST OBLIGATOIRE' *
TO TPO-ERRMSG1 *
MOVE DO-WRITE-LIT TO CONTROL-INDICATOR *
MOVE ERROR-ATTR TO TPO-BOCOM01-ATTR *
GO TO X-100-CONSIS-EDITS-RETURN *
END-IF *
END-IF. *
IF XFER-CONFIRMATION = '2' *
IF TPI-RCONFRJ = 'OUI' OR 'NON' *
IF TPI-RCONFRJ = 'OUI' *
MOVE '3' TO XFER-CONFIRMATION *
ELSE *
MOVE 'Y1R0' TO NEXT-PROGRAM-NAME-ID *
MOVE PROCESS-INPUT-LIT TO CONTROL-INDICATOR *
MOVE '03' TO PFKEY-INDICATOR *
GO TO X-100-CONSIS-EDITS-RETURN *
END-IF *
ELSE *
MOVE DO-WRITE-LIT TO CONTROL-INDICATOR *
MOVE ERROR-ATTR TO TPO-RCONFRJ-ATTR *
MOVE 'CONFIRMATION DU REJET INCORRECTE' *
TO TPO-ERRMSG1 *
GO TO X-100-CONSIS-EDITS-RETURN *
END-IF *
END-IF. *
*----------------------------------------------! END CONSIS ----
SKIP1
X-100-CONSIS-EDITS-RETURN.
EXIT.
EJECT
Z-900-SECTION-FALLOUT SECTION.
********************************************************
* Z - 9 0 0 - S E C T I O N - F A L L O U T *
********************************************************
* *
* THIS ROUTINE EXECUTES AN EXEC CICS ABEND WITH THE *
* ABEND CODE SPECIFIED BY FALLOUT-ABEND-CODE. *
* THE CODE IN THIS SECTION WILL ONLY BE EXECUTED IF *
* CONTROL FALLS OUT OF A PREVIOUS SECTION. *
* *
********************************************************
EXEC CICS ABEND ABCODE(FALLOUT-ABEND-CODE) END-EXEC.
EJECT
Z-980-ABNORMAL-TERM SECTION.
********************************************************
* Z - 9 8 0 - A B N O R M A L - T E R M I N A T I O N *
********************************************************
* *
* THIS SECTION CALLS THE ABNORMAL TERMINATION ROUTINE *
* IN ORDER TO HANDLE UNEXPECTED SITUATIONS IN THE *
* PROGRAM. IF THE ABT ROUTINE RETURNS, THEN ONE OF *
* THE FOLLOWING ACTIONS WILL OCCUR: *
* 1) AN ERROR MESSAGE IS PRESENTED IN TPO-ERRMSG1; *
* 2) A PROGRAM TRANSFER IS ATTEMPTED; *
* 3) PROCESSING CONTINUES (TEST MODE ONLY); *
* 4) Z-990 IS INVOKED TO CAUSE AN ABEND. *
********************************************************
* NOTE: THIS SECTION DOES NOT ADD ITSELF TO THE TRACE TABLE
* NOTE: IF INSTALLATION PGMCUST IS USED, IT MUST NOT CONTAIN ANY
* CODE THAT WOULD CAUSE CICS SERVICES TO BE ENVOKED
SKIP1
* PROGRAM CUSTOM CONTROL Z980I
COPY ERRVSAM.
SKIP1
IF ABT-IN-PROGRESS = 'N'
MOVE 'Y' TO ABT-IN-PROGRESS
ELSE
EXEC CICS ABEND ABCODE('TABT') END-EXEC.
MOVE TRACE-SECTION-NAME TO ABT-PROGRAM-FUNCTION.
MOVE SPACE TO ABT-U100-SUB.
IF ABT-ERROR-SECTION-NAME = 'U-100'
MOVE ABT-ERROR-SECTION-SUB TO ABT-U100-SUB.
MOVE DA-STATUS TO ABT-DA-GENERIC-STATUS.
MOVE SPACES TO ABT-ERROR-MESSAGE.
MOVE ' ' TO ABT-NEXT-PROGRAM-NAME-ID.
*************************************************************
* NOTE: ADDITIONAL PARAMETER ADDRESSES HAVE BEEN "PASSED" *
* TO ADLAATR BY USE OF IT'S ENTRY POINTS ADLAAT0 *
* ADLAAT1 AND ADLAAT2 *
*************************************************************
CALL 'ADLAATR' USING DFHEIBLK
DFHCOMMAREA
ABNORMAL-TERMINATION-AREA
IO-PCB
XFER-PCB
SQLCA
SPA-XFER-WORK-AREA
TP-BUFFER
TPO-ERRMSG1.
IF ABT-DO-WRITE
MOVE ABT-ERROR-MESSAGE TO TPO-ERRMSG1
PERFORM N-100-CURSOR-POSITION
MOVE DO-WRITE-LIT TO CONTROL-INDICATOR
GO TO MAIN-PROCESS-RETURN
ELSE
IF ABT-DO-TRANSFER
MOVE ABT-NEXT-PROGRAM-NAME TO NEXT-PROGRAM-NAME
MOVE DO-TRANSFER-LIT TO CONTROL-INDICATOR
GO TO MAIN-PROCESS-RETURN
ELSE
IF ABT-CONTINUE-PROCESS
MOVE 'N' TO ABT-IN-PROGRESS
ELSE
EXEC CICS ABEND ABCODE('TABT') END-EXEC.
Z-980-ABNORMAL-TERM-RETURN.
EXIT.
EJECT
Z-990-PROGRAM-ERROR SECTION.
********************************************************
* Z - 9 9 0 - P R O G R A M - E R R O R *
********************************************************
* *
* THIS SECTION CALLS THE COBOL ABEND ROUTINE WITH AN *
* ABEND CODE SPECIFIED BY CNTLERR-ABEND-CODE. IT IS *
* PERFORMED IF CONTROL-INDICATOR IS AN UNDEFINED *
* VALUE IN THE MAINLINE. *
********************************************************
EXEC CICS ABEND ABCODE(CNTLERR-ABEND-CODE) END-EXEC.
SKIP1