/*
     Here is the startup for XDLIPRE and XDLIPOST.

     This will establish the Global Work Area, setting the overlay
     characters to two bytes determined from the CICS APPLID. This
     conversion in our case is from a hard-coded table. It then
     starts the exits XDLIPRE and XDLIPOST.

     Duncan Mead
     GBFRIDME@IBMMAIL.COM
 */


*PROCESS ATTRIBUTES;
 /********************************************************************/
 /*      UTP94 - ENABLE PROGRAM DMPCH  AT EXIT XDLIPRE               */
 /*            - ENABLE PROGRAM DMPCI  AT EXIT XDLIPOST              */
 /********************************************************************/
1UTP94  :PROC OPTIONS(MAIN);
0  DCL PLIXOPT         CHAR(20) VAR STATIC EXTERNAL INIT ('NOSTAE');
   DCL MESSAGE1     CHAR(60) INIT
   ('FZDFH000 UTP94-01- DLIPRE EXIT STARTED (PROG=DMPCH)         ') ;
   DCL 1 M2 ,
         2 M2STD   CHAR(09) INIT('FZDFH000 ') ,
         2 M2ID    CHAR(09) INIT('UTP94-02-') ,
         2 M2MESS  CHAR(42) INIT('') ,
         2 M2RC    CHAR(07) INIT('RESP = ') ,
         2 M2RESP  PIC'999' INIT(0) ,
         2 M2R2C   CHAR(08) INIT('RCODE = '),
         2 M2RCODE CHAR(06) INIT('') ;
   DCL MESSAGE2    CHAR(84) BASED(P_M2) ;
   P_M2 = ADDR(M2) ;
   DCL MESSAGE3     CHAR(60) INIT
   ('FZDFH000 UTP94-03- DLIPOST EXIT STARTED (PROG=DMPCI)        ') ;
   DCL 1 M4 ,
         2 M4STD   CHAR(09) INIT('FZDFH000 ') ,
         2 M4ID    CHAR(09) INIT('UTP94-04-') ,
         2 M4MESS  CHAR(43) INIT
                      ('DLIPOST EXIT FAILED TO START (PROG=DMPCI)') ,
         2 M4RC    CHAR(07) INIT('RESP = ') ,
         2 M4RESP  PIC'999' INIT(0) ,
         2 M4R2C   CHAR(08) INIT('RCODE = '),
         2 M4RCODE CHAR(06) INIT('') ;
   DCL MESSAGE4    CHAR(85) BASED(P_M4) ;
   P_M4 = ADDR(M4) ;
   DCL 1 GWA        BASED(P_GWA) ,
         2 CONST    CHAR(8) ,
         2 OVERLAY  CHAR(2) ,
         2 REGNAME  CHAR(8) ;
   DCL NO_REG       FIXED BIN(15) INIT(19) ;
   DCL REGION(19) CHAR(10) INIT
             ('R0TESTR0  ','R1TESTR1  ','R2TESTR2  ','R3TESTR3  ',
              'R4TESTR4  ','RLTESTRL  ','RPTESTRP  ','RSTESTRS  ',
              'RTTESTRT  ','RUTESTRU  ','IDROSEPARM','UTTSCICS  ',
              'U2TESTRU2 ','U3TESTRU3 ','U4TESTRU4 ','W2TESTRW2 ',
              'C1T##CONS1','C2T##CONS2','UT        ');
   DCL 1 REG        BASED(P_REG) ,
         2 OVERLAY  CHAR(2) ,
         2 APPLID   CHAR(8) ;
   DCL LENG         FIXED BIN(15) ;
   DCL RESPCODE     FIXED BIN(15) ;
   DCL RESPCODE2    FIXED BIN(15) ;
   DCL CHAR6        CHAR(6) ;
   DCL PCHAR6       PIC'999999' BASED(P_CHAR6) ;
   P_CHAR6 = ADDR(CHAR6) ;
   DCL I1           FIXED BIN(15) ;
   DCL (P_M2,P_M4,P_REG,P_GWA,P_CHAR6)  POINTER ;
   DCL (CSTG,ADDR,SUBSTR) BUILTIN ;
1                        /*******************************************/
                         /*  ENABLE THE PROGRAM AND OBTAIN          */
                         /*  THE GLOBAL WORK AREA                   */
   LENG = 18 ;
   EXEC CICS ENABLE PROGRAM('DMPCH') EXIT('XDLIPRE')
                                      GALENGTH(LENG)
                                      RESP(RESPCODE) ;
   IF RESPCODE ª= DFHRESP(NORMAL) THEN DO ;
     M2.M2MESS  = '(1) DLIPRE - ERROR ENABLING EXIT' ;
     M2.M2RESP  = RESPCODE ;
     M2.M2RCODE = EIBRCODE ;
     EXEC CICS WRITE OPERATOR TEXT(MESSAGE2) ;
     GOTO FINISH ;
   END ; 
   EXEC CICS EXTRACT EXIT PROGRAM('DMPCH')
                          GASET(P_GWA)
                          GALENGTH(LENG)
                          RESP(RESPCODE) ;
   IF RESPCODE ª= DFHRESP(NORMAL) THEN DO ;
     M2.M2MESS  = '(2) DLIPRE - ERROR EXTRACTING GWA ADDRESS' ;
     M2.M2RESP  = RESPCODE ;
     M2.M2RCODE = EIBRCODE ;
     EXEC CICS WRITE OPERATOR TEXT(MESSAGE2) ;
     GOTO FINISH ;
   END ; 
   GWA.CONST = '*XDLIPRE' ;
   EXEC CICS ASSIGN APPLID(GWA.REGNAME) RESP(RESPCODE)
                                        RESP2(RESPCODE2) ;
   IF RESPCODE ª= DFHRESP(NORMAL) THEN DO ;
     M2.M2MESS  = '(3) DLIPRE - ERROR OBTAINING APPLID' ;
     M2.M2RESP  = RESPCODE ;
     M2.M2R2C   = 'RESP2 = ' ;
     PCHAR6     = RESPCODE2 ;
     M2.M2RCODE = CHAR6 ;
     EXEC CICS WRITE OPERATOR TEXT(MESSAGE2) ;
     GOTO FINISH ;
   END ; 
   DO I1 = 1 TO (NO_REG - 1)
      WHILE (GWA.REGNAME ª= SUBSTR(REGION(I1),3,8)) ;
   END ; 
   P_REG = ADDR(REGION(I1)) ;
   GWA.OVERLAY = REG.OVERLAY ;
   EXEC CICS ENABLE PROGRAM('DMPCH') START
                                     RESP(RESPCODE) ;
   IF RESPCODE ª= DFHRESP(NORMAL) THEN DO ;
     M2.M2MESS  = '(4) DLIPRE - ERROR STARTING XDLIPRE EXIT' ;
     M2.M2RESP  = RESPCODE ;
     M2.M2RCODE = EIBRCODE ;
     EXEC CICS WRITE OPERATOR TEXT(MESSAGE2) ;
     GOTO FINISH ;
   END ; 
   EXEC CICS WRITE OPERATOR TEXT(MESSAGE1) ;
                                      /*****************************/
                                      /* XDLIPOST EXIT             */
   EXEC CICS ENABLE PROGRAM('DMPCI') EXIT('XDLIPOST')
                                     START
                                     RESP(RESPCODE) ;
   IF RESPCODE = DFHRESP(NORMAL)
   THEN EXEC CICS WRITE OPERATOR TEXT(MESSAGE3) ;
   ELSE DO ;
     M4.M4RESP  = RESPCODE ;
     M4.M4RCODE = EIBRCODE ;
     EXEC CICS WRITE OPERATOR TEXT(MESSAGE4) ;
   END ; 
 FINISH :
   EXEC CICS RETURN ;
   END ;