BSLJX07B TITLE 'JES2 Control block I/O Exit (EXIT # 7)'                         
***********************************************************************         
*                        HASP EXIT 7                                  *         
*                                                                     *         
*  This exit is used as a "Job termination" exit. All jobs processed  *         
*  by BSLJX28B (EXIT28) have a flag set (bit 1 of JCTUSER0+1). If     *         
*  the flag is on when this exit is entered, it is turned off and job *         
*  termination processing is done. This routine also searches for any *         
*  jobs with /*AFTER cards for the job that is terminating and turns  *         
*  off the after condition if the job eneded successfully.            *         
*                                                                     *         
* Register usage (ENTRY/EXIT) :                                       *         
*                                                                     *         
*    REG       Value on entry             Value on exit               *         
*    R0        Parameter list                                         *         
*    R1        Control block address      n/a                         *         
*    R2-R10    n/a                        Unchanged                   *         
*    R11       Address of HCT             Unchanged                   *         
*    R12       n/a                        Unchanged                   *         
*    R13       Address of PCE             Unchanged                   *         
*    R14       Return address             Unchanged                   *         
*    R15       Entry address              Return code (see below)     *         
*                                                                     *         
* Parameter list :                                                    *         
*                                                                     *         
*        Please refer to the $XPL documentation for this value        *         
*                                                                     *         
* Return codes (R15 on exit)                                          *         
*         0  = Continue normal processing. Call any additional        *         
*              routines for exit 7.                                   *         
*         4  = Continue normal processing. Do NOT call and additional *         
*              routines for exit 7.                                   *         
*                                                                     *         
***********************************************************************         
         COPY  $HASPGBL            Include the JES2 Global values               
BSLJX07B $MODULE SYSP=(GEN,GEN,DATA,GEN,GEN),                          *        
               TITLE='JES2 CONTROL BLOCK I/O EXIT (EXIT # 7)',         *        
               ENVIRON=JES2,                                           *        
               WPL,                Required by WTO                     *        
               $HASPEQU,           USED BY PGM                         *        
               $CAT,               REQUIRED BY $QJQE                   *        
               $CATBERT,           REQUIRED BY $DOGBERT                *        
               $BERT,                                                  *        
               $BERTTAB,                                               *        
               $TRE,               HASP TRE DSECT                      *        
               $PRE,               HASP PRE DSECT                      *        
               $ERA,               HASP ERA DSECT                      *        
               $HCCT,              Common storage communication table  *        
               $HCT,               HASP control table                  *        
               $JCT,               REQUIRED                            *        
               $JQE,               REQUIRED                            *        
               $KIT,               REQUIRED BY $CKPT                   *        
               $MIT,               Module information table            *        
               $USERCBS,           User defined control blocks         *        
               $PCE,               Processor control element DSECT     *        
               RMode=ANY,          Load program above the line         *        
               $XPL,               USED BY PGM                         *        
               SSOB                USED BY PGM                                  
         TITLE 'JES2 CONTROL BLOCK I/O EXIT (EXIT # 7)'                         
EXIT07C  $ENTRY BASE=R12                                                        
        $SAVE                                                                   
         LR    R12,R15             Establish base register as R12               
         LR    R10,R1              Get JCT pointer                              
         LR    R2,R0               Get XPL pointer                              
        $ESTAE RECADDR==A(X7RECOVR),RETRY=X07RETRY,BASE=(12)                    
         L     R14,PCEPRE          Get address of the PRE and ...               
         USING PRE,R14             ...Address it                                
         MVC   PRETRACK(L'X7MSG),X7MSG  Move message to PRE ...                 
         MVI   PRELOGLN,L'X7MSG    ... and set the length of message            
         DROP  R14                 Kill PRE addressability                      
         USING JCT,R10             Establish JCT addressability                 
         USING XPL,R2              Establish XPL addressability                 
         IF    (CLC,X007CBID,=CL4'JCT',EQUAL),AND, If this is a JCT    *        
               (TM,JCTUSER0+1,BIT1,ON) and EXIT028 has processed it             
         NI    JCTUSER0+1,FF-BIT1  Set off so we don't process it again         
*                                  If job didn't abend or fail in XEQ           
         If    (TM,JCTJTFlg,SSJTAbnd+SSJTJFal,ZERO),AND,               *        
               (CLC,JCTCnvRC,=A(JCTCOK),EQUAL),AND, and no JCL error   *        
               (TM,JCTUseID,Bit0,NO),AND, and ERROR program not invoked*        
               (CLC,JCTXEQOn(8),$Zeros,NEQUAL),AND, and started XEQ    *        
               (CLC,JCTXEQOf(8),$Zeros,NEQUAL)  and finished XEQ                
         L     R1,$JOBQPTR         JCT pointer into R1                          
         A     R1,JCTJQE           Add to get JQE ...                           
         USING JQE,R1              ... and establish addressability             
         IF    (TM,JQEFLAG1,JQE1OCAN,NO),DO,CKAFTRTN                            
         DROP  R1                  Kill JQE addressability                      
         ENDIF                                                                  
         ENDIF                                                                  
        $RETURN                    Return to caller                             
* ------------------------------------------------------------------- *         
* -                         CKAFTRTN                                - *         
* - This routine searches for jobs with /*AFTER cards specifying    - *         
* - this job and releases the AFTER condition.                        *         
* ------------------------------------------------------------------- *         
         BGNSEG CKAFTRTN                                                        
        $GETWORK WORDS=WRKWORDS,USE=J007 Get some work storage                  
         LR    R5,R1               ... and put address into R5 ...              
         USING WORKAREA,R5         ... and address it a WORKAREA                
         MVC   CLASSENT,$BLANKS    Initialise CLASSENT to blank                 
        $QSUSE ,                   Get access to update JES checkpoint          
SRCHJQE  DS    0H                                                               
         XC    WORKNUM,WORKNUM     Clear work area for job number               
         NI    SWITCH,FF-BIT0      Clear Switch                                 
         LA    R6,CLASSTBL         Point to start of class table                
SRCHCLS  DS    0H                                                               
         MVC   CLASSENT(1),0(R6)   Move in class to CLASSENT                    
        $QJQE  TYPE=EXEC,                                              *        
               REG=(R4),           Put returned JQE address in R4      *        
               CLASS=CLASSENT,     Read the JQE for this class         *        
               LOOP=NEXTJQE,                                           *        
               NOMORE=NEXTCLAS                                                  
         USING JQE,R4              Address the returned JQE                     
*        MVC   xUR_WTO(EJT_WTOL),EJT_WTO                                        
*        MVC   xUR_WTO+14(4),=c'R4=>'                                           
*        MVC   xUR_WTO+18(8),JQEJNAME                                           
*       $$WTO  xUR_WTO             Issue diagnostic message                     
        $DOGBERT ACTION=GETOFFSET, Get extension created in SSM mods   *        
               CBTYPE=JQE,                                             *        
               NAME=STQNAME,                                           *        
               ERRET=NEXTJQE                                                    
         LA    R3,JQE(R1)          Point to the STQNAME area                    
         USING STQNAME,R3          ... and address it                           
*        MVC   xUR_WTO(EJT_WTOL),EJT_WTO                                        
*        MVC   xUR_WTO+14(4),=c'r3=>'                                           
*        MVC   xUR_WTO+18(24),0(R3)                                             
*       $$WTO  xUR_WTO             Issue diagnostic message                     
         TM    UBRMFLAG,UBRAFT     Is the AFTER condition true?                 
         BZ    NEXTJQE             No - go get next JQE                         
         CLC   JCTJNAME,UBRAFTR    Does AFTER condition pertain to JOB          
         BNE   NEXTJQE             No - go get next JQE                         
SAVEJQE  DS    0H                                                               
         LH    R1,WORKNUM          Get our work number                          
         CH    R1,=Y(SAVENUM)      Are we at the mximum allowed?                
         BNL   TBLOVFLW            Yes - go deal with table overflow            
         LA    R1,1(,R1)           Increment counter ...                        
         STH   R1,WORKNUM          ... and save it                              
        $JQEJNUM JQE=JQE,REG=R0    Go get JOB Number                            
         LH    R1,WORKNUM          Get our work number                          
         BCTR  R1,0                Subtract one for zero based count            
         SLL   R1,2                Multiply by 8                                
         ST    R0,WORKJBNO(R1)     and save returned Job # into table           
         B     NEXTJQE             ... get the next one                         
NEXTCLAS DS    0H                                                               
         LA    R6,1(,R6)           Up to next class                             
         C     R6,=A(CLASSTBL+L'CLASSTBL) ..end of classes yet?                 
         BL    SRCHCLS             No - Go get JQE for this class               
         CLC   WORKNUM,=H'0'       Did we find any?                             
         BE    CKAFTXIT            No - go drop out                             
UPDTEJQE DS    0H                                                               
         XR    R6,R6               Clear R6 as we are done with it              
GETJQE   DS    0H                                                               
         LR    R1,R6                                                            
         SLL   R1,2                                                             
         L     R1,WORKJBNO(R1)     Load job number                              
        $QLOC  (R1),NOTFOUND=NXTJOBNO                                           
        $DOGJQE JQE=(R1),ACTION=(FETCH,UPDATE)                                  
         LR    R4,R0               R4 Points to JQE                             
        $DOGBERT ACTION=GETOFFSET,                                     *        
               CBTYPE=JQE,                                             *        
               NAME=STQNAME,                                           *        
               ERRET=RETJQE                                                     
         LA    R3,JQE(R1)          Point to the STQNAME area                    
         TM    UBRMFLAG,UBRAFT     Is the AFTER condition true?                 
         BZ    RETJQE              No - go and return the JQE                   
         XC    WORKCTR2,WORKCTR2   Clear counter                                
         CLC   JCTJNAME,UBRAFTR    Does the after jobname match ours?           
         BNE   RETJQE              No - go and return the JQE                   
NEXTAFT3 DS    0H                                                               
         MVC   UBRAFTR,=C'        ' Clear the AFTER jobname                     
         XC    UBRAFTR,UBRAFTR      Clear the AFTER jobname                     
         NI    UBRMFLAG,FF-UBRAFT   Turn the AFTER flag off                     
*        NI    JQEAFLG1,FF-UBRAFT                                               
RETJQE   DS    0H                                                               
        $DOGJQE CBADDR=JQE,ACTION=RETURN  Return the JQE                        
NXTJOBNO DS    0H                                                               
         LA    R6,1(,R6)           Go get next job number to process            
         CH    R6,WORKNUM          Are we done yet?                             
         BL    GETJQE              No - Go get the next one then                
         TM    SWITCH,BIT0         Table overflow?                              
         BO    SRCHJQE             Yes - continue JQE search                    
         B     CKAFTXIT            No - Go to return to caller                  
TBLOVFLW DS    0H                                                               
         OI    SWITCH,BIT0         Set tableover flow switch                    
         B     UPDTEJQE            ... and go deal with the table               
CKAFTXIT DS    0H                                                               
        $RETWORK (R5)              Free up the work area                        
         ENDSEG                                                                 
X07RETRY LA    R6,4                Set bad return code 4                        
RETURN   DS     0H                                                              
        $ESTAE CANCEL              Cancel ESTAE environment                     
        $RETURN (R6)               Return to caller                             
BADBERT  DS    0H                  Error from DOGBERT come here                 
        $RETWORK (R5)                                                           
         LA    R6,16(0,0)          Set a bad return code - RC=16                
         B     RETURN              Go to return to caller                       
* ------------------------------------------------------------------- *         
* -      Show_R3 subroutine.                                        - *         
* ------------------------------------------------------------------- *         
* -     This subroutine is only used for diagnostics (if required)  - *         
* -     It will make the contents of R3 printable and then issue the- *         
* -     $$WTO to display the message in xUR_WTO                     - *         
* -     Exit is via R6 and R3 is destroyed by this routine.         - *         
* ------------------------------------------------------------------- *         
Show_r3  DS    0H                                                               
         ST    R2,BSL_SAVERE       Save R2 for safe keeping                     
         LA    R0,8                Set loop count                               
         LA    R1,XUR_WTO+20       Point to target area                         
LOOP_it  LA    R2,X'0F'            Prime R2 with 0F                             
         SLDL  R2,4                Shift first nibble from R3                   
         CH    R2,=X'00FA'         Is it F0 to F9?                              
         BL    SKIP                ...No, skip subtract                         
         SH    R2,=X'0039'         Subtract 39 to get Hex letter                
SKIP     STC   R2,0(R1)            Store character                              
         LA    R1,1(R1)            Increment R1                                 
         BCT   R0,LOOP_it          Loop until done                              
        $$WTO  XUR_WTO             Issue message                                
         L     R2,BSL_SAVERE       Restore R2 ...                               
         BR    R6                  ... and return to caller                     
* ------------------------------------------------------------------- *         
X7MSG    DC    C'ESTAE SET UP FOR EXIT 7'                                       
EJT_WTO  WTO   '$HASPX07B-I:                                      ',   C        
               MF=L,                                                   C        
               ROUTCDE=(2),DESC=(4)                                             
EJT_WTOL EQU   *-EJT_WTO           Length of skeleton WTO                       
* ------------------------------------------------------------------- *         
*                   Executed instructions                             *         
* ------------------------------------------------------------------- *         
ClearAFT MVC   0(0,R7),8(R7)                                                    
SHFTDNAM MVC   0(0,R7),8(R7)                                                    
* ------------------------------------------------------------------- *         
CLASSTBL DC    C'ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789'                          
SAVENUM  EQU   256                                                              
         USING X7RECOVR,R12        Set local addressability                     
         USING ERA,R5              Set ERA addressability                       
X7RECOVR $SAVE                     Save callers registers                       
         LR    R12,R15             Set local base register                      
         LR    R5,R1               Set ERA address                              
         L     R1,ERAPRE           Get PRE address                              
         MVC   ERAREG12,PREBASE-PRE(R1) Set resumes local base                  
         L     R2,PRERESUM-PRE(,R1) Get resume address                          
        $SETRP RECOVER,RESUME=(R2) Set recovery address                         
**************************************************************                  
*        Return to caller                                    *                  
**************************************************************                  
        $RETURN                    Return to caller                             
         DROP  R5                  Drop ERA addressability                      
         DROP  R12                 Drop rtn addressability                      
         IEZBITS                                                                
         EJECT                                                                  
         LTORG                                                                  
         EJECT                                                                  
        $MODEND                                                                 
         EJECT                                                                  
WORKAREA DSECT                                                                  
BSL_SAVER0 DS F                                                                 
BSL_SAVER1 DS F                                                                 
BSL_SAVER3 DS F                                                                 
BSL_SAVER6 DS F                                                                 
BSL_SAVERE DS F                                                                 
BSL_SAVERF DS F                                                                 
Xur_WTO  WTO   '*** EXPANSION OF THE OS/VS2 WRITE TO OPERATOR       ***C        
               *** (WTO) MACRO - EXPANDS TO LEAVE ROOM FOR 120      ***C        
               *** CHARS',                                             C        
               ROUTCDE=(2),DESC=4,MF=L                                          
Xur_WTOL EQU   *-Xur_WTO         LENGTH OF HASP900                              
CLASSENT DS    CL8                                                              
WORKCTR1 DS    H                                                                
WORKCTR2 DS    H                                                                
SWITCH   DS    XL1                                                              
WORKNUM  DS    H                   NUMBER OF TABLE ENTRIES IN USE               
WORKJBNO DS    (SAVENUM)F                                                       
WORKEND  DS    0F                  ALIGN ON FULLWORD BOUNDARY                   
WRKWORDS EQU   (WORKEND-WORKAREA)/4 NUMBER OR WORDS IN WORKAREA                 
         END   BSLJX07B                                                         

