SENDCC   TITLE 'Send condition codes for job to TSO user, email, etc'
* =================================================================== *
*
* Name: SENDCC
*
* Author: David Alcock :: dave@planetmvs.com
*
* Purpose: Send completion codes for each step to:
*          o The TSO user that submitted the job
*          o Written to //SYSPRINT
*          o Written to //SMTPNOTE (IBM's TCP/IP can email it!)
*
*          This is very useful for batch assemble/compiles and links!
*          You don't have to go into SDSF to find out whether
*          you got a good condition code from the assembler or
*          the compiler and you want to execute the program
*          online.  This is less important now that JES2 sends
*          the MAXCC back in the NOTIFY message (as seen in OS/390
*          JES2 2.5 and higher).
*
*          This program merely runs the SCTs (Step Control Tables)
*          for all previous steps and sends the condition code to
*          the destination of your choosing.
*
*          ASIS, it is NOT SYSPLEX-friendly for the TPUT function.
*          I *think* there may be support in some OS/390 release
*          for the TPUT call to send a message to the system that
*          the TSO user is executing on.  Authorization for this
*          is unknown to me at this time. @2000-09-26.
*
* Attributes: Non-reentrant, Non-Authorized
*
* Email notes:
* o Only IBM's TCP/IP SMTP is supported by this technique. The
*   writer-name should match your SMTP task's setup.
* o If you are having problems receiving an email from SENDCC,
*   write the SMTPNOTE file to SYSOUT and inspect.  Is valid
*   SMTP (RFC822) being generated?
* o See my http://www.planetmvs.com/mvsmail/ page for more info on
*   generating MVS mail
* o If IBM's SMTPNOTE rexx exec doesn't send mail to the expected
*   email address, SENDCC probably won't either.
* o Before attempting to use the email function of of SENDCC, ensure
*   that you can do IEBGENER and SMTPNOTE email functions first.
*
* Sample JCL:
*
* //--jobcard here--
* //STEP1    EXEC PGM=IEFBR14
* //STEP2    EXEC PGM=IEFBR14,COND=ONLY
* //STEP3    EXEC PGM=BOZO
* //*
* //** Echo step completion codes back to user who submitted job
* //*
* //COMPCODE EXEC PGM=SENDCC,COND=EVEN,
* //*PARM='NOTPUT'
* //*PARM='EMAIL=mvshost  bozo@clown.com'
* //*PARM='NOTPUT,EMAIL=mvshost  bozo@clown.com'
* // PARM='NOTPUT EMAIL=mvshost  bozo@clown.com'
* //STEPLIB  DD DISP=SHR,DSN=IBMUSER.DAVE.LOAD
* //SYSUDUMP DD SYSOUT=*
* //SYSPRINT DD SYSOUT=*
* //SMTPNOTE DD SYSOUT=(B,SMTP)   <- Email written here
* //
* //SMTPNOTE DD SYSOUT=*          <- Use for debugging
*
* Disclaimer: This program is FREEWARE.  Use at your own risk.  It
*             is provided for your enjoyment and neither David
*             Alcock or his employer provides any warranty for it's
*             use.  I'd like to hear how it works on your system.
*
*             This software is not in the public domain but is
*             available free of charge and with source code provided.
*             It is copyright 1996-2000 by David Alcock.  All rights
*             reserved.
* =================================================================== *
         SPACE 2
&DAVER   SETC  '1.1'
*======================================================================
*
*             M o d i f i c a t i o n   H i s t o r y
*
* Person     Date       VRM Description
* ---------- ---------- --- -------------------------------------------
* DGAlcock   2000-09-25 1.1 Support for SWA above the line; Removed
*                           dependance on my DA# macros; Added
*                           writting to //SYSPRINT; Added EMAIL code;
* DGAlcock   1996-06-05 1.0 Initial program started; It is based on
*                           code/concepts from program COMPCODE from
*                           the SHARE CD-ROM; Original author unknown;
*
*======================================================================
         EJECT ,
*
** IBM DSECTs
*
         PRINT NOGEN
         CVT   DSECT=YES,LIST=NO          MVS CVT
         IKJCPPL ,                        Command Processor Parm List
         IEFJESCT ,                       JES Communication Table
         IHAPSA ,                         Prefix save area
         IKJTCB ,                         Task Control Block
         IEZJSCB ,                        Job Step Control Block
         IEFAJCTB ,                       Job Control table
         IEFASCTB ,                       Step Control table
         IHAASCB ,                        Address Space Control Block
         IHAASSB ,                        Address Space Secondary Block
         IAZJSAB ,                        Job Schedular Addr Spc CB
         IEFZB505 LOCEPAX=YES             EPA mapping for SWAREQ
         IEFQMIDS ,                       Equates for SWA requests
         DCBD   DSORG=PO,DEVD=DA          Data Control Block
         YREGS ,                          Equate registers
         PRINT GEN
*
** Convert assembly date from format "YYYYMMDD" to "YYYY-MM-DD"
*
         LCLC  &ASMDATE
&ASMDATE SETC  '&SYSDATC'(1,4).'-'.'&SYSDATC'(5,2).'-'.'&SYSDATC'(7,2)
         EJECT
***********************************************************************
***
**       Module start
***
***********************************************************************
         SPACE 2
SENDCC   CSECT ,
SENDCC   AMODE 31
SENDCC   RMODE ANY
*
** Standard O/S eyecatcher
*
CC_EC    B    CC_ECL(0,R15)             Bump past EyeCatcher
         DC   AL1(CC_ECE-CC_ECV)        Length of eyecatcher
CC_ECV   DC   C'SENDCC    &ASMDATE &SYSTIME V&DAVER '
         DC   C'Send step condition codes to submitting userid, '
         DC   C'file, email, etc'
CC_ECE   EQU  *
         DS   0H
CC_ECL   EQU  *-CC_EC
*
** Standard ESA entry housekeeping code
*
         BAKR  R14,0                    Save registers
         LAE   R12,0(R15,0)             Get base register
         USING SENDCC,R12               Set module base
*
** Obtain Dynamic Save Area
*
         STORAGE OBTAIN,LENGTH=WORKDSL,LOC=BELOW Obtain storage
         LR    R13,R1                   Point to Save Area
*
         LR    R14,R13                  To: Address
         LA    R15,WORKDSL              To: Length
         SLR   R1,R1                    From: Set length and pad
         MVCL  R14,R0                   Zero out area
*
         MVC   4(4,R13),=C'F1SA'        Indicate stack SA
         USING WORKDS,R13               Get addressibility to area
*
** If the SYSPRINT file is allocated, open it
*
         DEVTYPE =CL8'SYSPRINT',DOUBLE
         LTR   R15,R15
         BNZ   I$SPRTX
         LA    R3,SYSPRINT                Locate DCB work area
         MVC   0(C_DCBOL,R3),C_DCBO
         MVC   DCBDDNAM-IHADCB(8,R3),=CL8'SYSPRINT'
         MVC   PARMLIST(C_LSTOL),C_LSTO
         OPEN  ((3),(OUTPUT)),MF=(E,PARMLIST)
         OI    FLAG1,$F1_SYSPRINT         Say we are writing to file
         MVC   X_PUTC(C_PUTCL),C_PUTC     Move code in
         MVI   RECOUT,C' '
         MVC   RECOUT+1(L'RECOUT-1),RECOUT
I$SPRTX  DS    0H
*
** Initialize message area
*
         MVI   MSG,C' '                   Get blank
         MVC   MSG+1(MSGL-1),MSG          Propagate it across
         MVC   MSG_JOB(3),=C'JOB'
         MVC   MSG_PGMS+1(4),=C'PGM='
         MVC   MSG_END+1(5),=C'Ended'
*
** Locate job-level information and put into message
*
         L     R4,PSAAOLD-PSA             -> ASCB
         L     R4,ASCBASSB-ASCB(,R4)      -> ASSB
         L     R4,ASSBJSAB-ASSB(,R4)      -> JSAB
         MVC   TPUT_USERID(8),JSABUSID-JSAB(R4) Save userid
         LA    R15,MSG_JOBAREA            Locate "jobname(jobid)" area
         MVC   0(L'JSABJBNM,R15),JSABJBNM-JSAB(R4) Get jobname
         LA    R0,L'JSABJBNM              Get max length of jobname
         BAS   R14,LOCATE_FIRST_SPACE     Locate first space
         MVI   0(R15),C'('                JOBID prefix
         MVC   1(L'JSABJBID,R15),JSABJBID-JSAB(R4) Get jobID
         MVI   1+L'JSABJBID(R15),C')'     JOBID suffix
         EJECT ,
***********************************************************************
***
**  Process the input parms
***
***********************************************************************
         SPACE 2
Process_Parameter ds 0h
         EREG  R1,R1                      Restore R1 on entry
         TM    CPPLCBUF-CPPL(R1),X'80'    Was this command called?
         BNO   PP$NC                      No, need to look at CBUF
*
** We were called, it has a Batch type (EXEC) parameter
*
         L     R2,0(R1)                   Get address of parm
         SLR   R3,R3                      Clear register
         ICM   R3,B'0011',0(R2)           Get length of parm
         BZ    PP$X                       None, leave
         LA    R2,2(R2)                   Bump past parm length HW
         B     PP$PARSE                   Parse the input
*
** We were not called, it is a "Command Processor"
*
PP$NC    DS    0H
         L     R2,CPPLCBUF-CPPL(R1)       Locate Command Buffer
         SLR   R3,R3                      Clear register
         ICM   R3,B'0011',0(R2)           Get total CBUF length
         SLR   R0,R0                      Clear register
         ICM   R0,B'0011',2(R2)           Get total Command name length
         LA    R15,4                      Length of header
         AR    R2,R15                     Bump past header
         SR    R3,R15                     Decrement for header length
         AR    R2,R0                      Bump past Command length
         SR    R3,R0                      Length of data
*
** Look thru command buffer/parameter for our commands
** Input: R2 - Address of command-buffer/Parameter
**        R3 - Length of command-buffer/Parameter
*
PP$PARSE DS    0H
         LTR   R3,R3                      Check out length
         BZ    PP$X                       Length = Zero: Leave
         BM    PP$X                       Length < Zero: Leave
*
** I'm doing really **** poor parsing here.  Here is the limited
** syntax that is supported:
**
** PARM='NOTPUT'
** PARM='EMAIL=mvshost  bozo@clown.com'
** PARM='NOTPUT,EMAIL=mvshost  bozo@clown.com'
** PARM='NOTPUT EMAIL=mvshost  bozo@clown.com'
**
** Where "mvshost" is really 8 characters
*
         CH    R3,=H'6'
         BL    PP$X
         CLC   0(6,R2),=C'NOTPUT'
         BNE   PP$TPUTX
         OI    FLAG1,$F1_NOTPUT
         LA    R2,6(R2)
         SH    R3,=H'6'
         LTR   R3,R3
         BZ    PP$X
         LA    R2,1(R2)                   Skip over blank or comma
         BCTR  R3,0
         LTR   R3,R3
         BZ    PP$X
PP$TPUTX DS    0H
*
         CH    R3,=H'7'                   "EMAIL=a" at least?
         BL    PP$EMAILX
         CLC   0(6,R2),=C'EMAIL='
         BNE   PP$EMAILX
         OI    FLAG1,$F1_EMAIL
         LA    R2,6(R2)
         SH    R3,=H'7'                   Length of EMAIL= plus 1 4ex
*-Here we could do some fancy parsing but let's just take 8 for mvshost
*-and the rest for the userid
         LA    R4,9(R2)
         LR    R5,R3
         SH    R5,=H'9'
         LTR   R5,R5
         BZ    PP$EMAILE
*        BCTR  R5,0                      Decrement for EX
*-At this point R4 has the email address and R5 has it's length
*-and needless to say, R2 points to a CL8'mvshost'
         B     PP$EMAILX
PP$EMAILE DS   0H
          WTO  'SENDCC - No email address was found, sorry'
          NI   FLAG1,255-$F1_EMAIL
PP$EMAILX DS   0H
*
PP$X     DS    0H
         EJECT
***********************************************************************
***
**       Initialization for smtp (email)
***
***********************************************************************
         SPACE 2
Initialize_Email ds 0h
         TM    FLAG1,$F1_EMAIL            Was parm coded?
         BNO   IE$X
*
** Here we open SMTPNOTE (if allocated)
*
         DEVTYPE =CL8'SMTPNOTE',DOUBLE    Get allocation info
         LTR   R15,R15                    Is //SMTPNOTE there?
         BNZ   IE$NFILE                   Nope, gripe about it
         LA    R3,SMTPNOTE                Locate DCB work area
         MVC   0(C_DCBOL,R3),C_DCBO
         MVC   DCBDDNAM-IHADCB(8,R3),=CL8'SMTPNOTE'
         MVC   PARMLIST(C_LSTOL),C_LSTO
         OPEN  ((3),(OUTPUT)),MF=(E,PARMLIST)
         TM    FLAG1,$F1_SYSPRINT         Already initialized?
         BO    IE$IFX                     Yes, continue
         MVC   X_PUTC(C_PUTCL),C_PUTC     Move code in
         MVI   RECOUT,C' '
         MVC   RECOUT+1(L'RECOUT-1),RECOUT
IE$IFX   DS    0H
*
** Write records
*
*-helo mvshost
         BAS   R14,IE$IMSG
         MVC   0(4,R15),=C'helo'
         LA    R15,5(R15)
         MVC   0(8,R15),0(R2)           Get MVS host
         BAS   R14,IE$PMSG
*-mail from:<bozo@clown.com>
         BAS   R14,IE$IMSG
         MVC   0(11,R15),=C'mail from:<'
         LA    R15,11(R15)
         EX    R5,IE$MADDR
         LA    R15,1(R5,R15)
         MVI   0(R15),C'>'
         BAS   R14,IE$PMSG
*-rcpt to:<bozo@clown.com>
         BAS   R14,IE$IMSG
         MVC   0(9,R15),=C'rcpt to:<'
         LA    R15,9(R15)
         EX    R5,IE$MADDR
         LA    R15,1(R5,R15)
         MVI   0(R15),C'>'
         BAS   R14,IE$PMSG
*-data
         BAS   R14,IE$IMSG
         MVC   0(4,R15),=C'data'
         BAS   R14,IE$PMSG
*-From:     bozo@clown.com
         BAS   R14,IE$IMSG
         MVC   0(5,R15),=C'From:'
         LA    R15,10(R15)
         EX    R5,IE$MADDR
         BAS   R14,IE$PMSG
*-To:       bozo@clown.com
         BAS   R14,IE$IMSG
         MVC   0(3,R15),=C'To:'
         LA    R15,10(R15)
         EX    R5,IE$MADDR
         BAS   R14,IE$PMSG
*-Subject:  Condition codes from job jobname(jobid)
         BAS   R14,IE$IMSG
         MVC   0(8,R15),=C'Subject:'
         LA    R15,10(R15)
         MVC   0(24,R15),=C'Condition codes from job'
         LA    R15,25(R15)
         MVC   0(L'MSG_JOBAREA,R15),MSG_JOBAREA
         BAS   R14,IE$PMSG
*-blank line here
         BAS   R14,IE$IMSG
         BAS   R14,IE$PMSG
         B     IE$X
IE$MADDR MVC   0(0,R15),0(R4)
*
** Initialize SMTP message
*
IE$IMSG  DS    0H
         LA    R15,SMTPMSG
         MVI   0(R15),C' '
         MVC   1(L'SMTPMSG-1,R15),0(R15)
         BSM   0,R14
*
** Print SMTP message to //SMTPNOTE file
*
IE$PMSG  DS    0H
         ST    R14,DOUBLE
*
         LA    R1,SMTPNOTE                Locate DCB
         LA    R0,SMTPMSG                 Locate record
         LA    R15,X_PUTC                 Locate routine
         BASSM R9,R15                     Call the routine
*
         L     R14,DOUBLE
         BSM   0,R14
*
** Error: EMAIL parm found but DD=SMTPNOTE not allocated
*
IE$NFILE DS    0H
         WTO   'SENDCC - Error: PARM EMAIL= coded but no //SMTPNOTE'
         NI    FLAG1,255-$F1_EMAIL     Turn off flag
*
** Common exit from Initialize_Email
*
IE$X     DS   0h
         EJECT
***********************************************************************
***                                                                 ***
**       Process SCTs (Step Control Table entries)                   **
***                                                                 ***
***********************************************************************
         SPACE 2
PROCESS_SCTS EQU *
*
** Locate First Step Control Table
*
         L     R4,PSATOLD-PSA             -> TCB
         L     R4,TCBJSCB-TCB(,R4)        -> Job Step Control Block
         L     R4,JSCBACT-IEZJSCB(,R4)    -> Active JSCB
         SLR   R15,R15
         ICM   R15,B'0111',JSCBJCTA-IEZJSCB(R4) -> JCT
         LA    R0,SWJCTID                 Obtain: Set ID
         BAS   R9,Obtain_SWA_CB           Obtain: justdoit
         LTR   R15,R15                    Obtain: Did it work?
         BZ    PS$Error                   Obtain: Nope...
         LR    R4,R15                     Save control block
         SLR   R15,R15
         ICM   R15,B'0111',JCTSDKAD-INJMJCT(R4) -> SCT
         LA    R0,SWSCTID                 Obtain: Set ID
         BAS   R9,Obtain_SWA_CB           Obtain: justdoit
         LTR   R15,R15                    Obtain: Did it work?
         BZ    PS$Error                   Obtain: Nope...
         LR    R4,R15                     Save control block
*
** Loop thru SCT entries
*
PS$L     EQU   *
         TM    SCTSTEND-INSMSCT(R4),SCTSTPND  Executed or flush?
*        BNO   PS$LX                      No, at end of table
         BNO   PS$LB                      No, skip it
*-Note: we could do a fancy lookup via the TCB chain to see if this
*-is really us but why bother?
         CLC   SCTPGMNM-INSMSCT(8,R4),=CL8'SENDCC' Is this US?
         BE    PS$LB                      Yes, skip it
         MVC   MSG_PGM(8),SCTPGMNM-INSMSCT(R4)
*
** Get procstep (if any) and stepname into message
*
         MVI   MSG_STEPAREA,C' '          Get blank
         MVC   MSG_STEPAREA+1(L'MSG_STEPAREA-1),MSG_STEPAREA
*
         LA    R15,MSG_STEPAREA           Locate stepname area
         MVC   0(L'SCTSNAME,R15),SCTSNAME-INSMSCT(R4) Get stepname
         LA    R0,L'SCTSNAME
         BAS   R14,LOCATE_FIRST_SPACE     Locate first space
PS$SNX   EQU   *
         CLI   SCTSCLPC-INSMSCT(R4),C' '  Procstep there?
         BE    PS$PSX                     Yep, need both
         MVI   0(R15),C'.'
         MVC   1(8,R15),SCTSCLPC-INSMSCT(R4)
PS$PSX   EQU   *
*
** Format completion code
*
         MVC   MSG_CC(5),=CL5'N/A'        Set default condition code
         TM    SCTSTEND-INSMSCT(R4),SCTSTSRT Did step start?
         BO    FCC$FX                     Yes, continue
         MVC   MSG_CC(5),=C'Flush'        Set field
         B     FCC$X                      Leave
FCC$FX   EQU   *
*
         SLR   R0,R0
         ICM   R0,B'0011',SCTSEXEC-INSMSCT(R4) Get Condition code
*
         TM    SCTABCND-INSMSCT(R4),SCTABEND Did Step abend?
         BO    FCC$ABND                   Yes, print ABEND code
         N     R0,=A(X'FFF')              Zero unused portion
         CVD   R0,DOUBLE                  Convert condcode to Packed
         MVC   MSG_CC-2(6),=X'40,21,20,20,20,20'
         ED    MSG_CC-2(6),DOUBLE+5
         MVI   MSG_END+5,C'd'             ensure it's okay
         B     FCC$X                      Leave
FCC$ABND EQU   *
*-Back in 1996, I put the next couple of statements in.  I don't know
*-why.  Research needed here.
 MVC MSG_CC(5),=C'ABEND'
 AGO .ABENDX  - Abend not in SCT but maxcc in JCT!!!
         TM    SCTSEXEC-INSMSCT(R4),X'80' User ABEND?
         BNO   FCC$SAB                    No, System ABEND
*        N     R0,=A(X'FFF')              Turn off unneeded bits
         CVD   R0,DOUBLE                  Convert to packed decimal
         MVC   MSG_CC-1(L'MSG_CC+1),=X'40,21,20,20,20,20'
         ED    MSG_CC-1(L'MSG_CC+1),DOUBLE+5
         MVI   MSG_CC,C'U'                Make it a user ABEND
         B     FCC$X                      Leave
*
FCC$SAB  EQU   *
         STH   R0,DOUBLE                  Save system ABEND code
         UNPK  MSG_CC+1(4),DOUBLE(3)
         MVZ   MSG_CC+1(3),=X'00,00,00'
         TR    MSG_CC+1(3),=C'0123456789ABCDEF'
         MVI   MSG_CC+4,C' '              Fix overflow
         MVI   MSG_CC,C'S'                Make it a system ABEND
.ABENDX  ANOP  , - - - - - - - - - - - - - - - - - - - - - - - -
FCC$X    EQU   *
*
** Issue message via TPUT to issuing user
*
         TM    FLAG1,$F1_NOTPUT           Need to TPUT message?
         BO    PS$TPUTX                   No, continue
         TPUT  MSG,MSGL,USERIDL=TPUT_USERID Send message to userid
PS$TPUTX DS    0H
*
** Print record on SYSPRINT if file is open
*
         TM    FLAG1,$F1_SYSPRINT         Writing to //SYSPRINT?
         BNO   PS$SPRTX                   No, continue
         LA    R1,SYSPRINT                Locate DCB
         LA    R0,RECOUT                  Locate record
         LA    R15,X_PUTC                 Locate routine
         BASSM R9,R15                     Call the routine
PS$SPRTX DS    0H
*
** Print record on SMTPNOTE if option is on
*
         TM    FLAG1,$F1_EMAIL            Doing Email?
         BNO   PS$EMAILX                  No, continue
         LA    R1,SMTPNOTE                Locate DCB
         LA    R0,RECOUT                  Locate record
         LA    R15,X_PUTC                 Locate routine
         BASSM R9,R15                     Call the routine
PS$EMAILX DS   0H
*
** Bump to next SCT (if any)
*
PS$LB    DS    0H
         SLR   R15,R15
         ICM   R15,B'0111',SCTANSCT-INSMSCT(R4) Locate next one
         BZ    Exit                       No more steps
         LA    R0,SWSCTID                 Obtain: Set ID
         BAS   R9,Obtain_SWA_CB           Obtain: justdoit
         LTR   R15,R15                    Obtain: Did it work?
         BZ    PS$Error                   Obtain: Nope...
         LR    R4,R15                     Save control block
         B     PS$L                       More more time...
PS$LX    EQU   *
         B     Exit
PS$Error DS    0h
         WTO   'SENDCC had error locating SWA control block'
         TM    FLAG1,$F1_SYSPRINT         Writing to //SYSPRINT?
         BNO   Exit                       No, continue
*-Low rent way of putting error message to //sysprint - not ideal
*-It would be better to put some diagnostic info on what happened...
         MVC   RECOUT(80),=CL80'SENDCC had error locating SWA CB'
         LA    R1,SYSPRINT                Locate DCB
         LA    R0,RECOUT                  Locate record
         LA    R15,X_PUTC                 Locate routine
         BASSM R9,R15                     Call the routine
         EJECT
***********************************************************************
***
**       Module termination
***
***********************************************************************
         SPACE 2
Exit     DS    0H
*-Close SYSPRINT file if open
         LA    R3,SYSPRINT
         TM    DCBOFLGS-IHADCB(R3),DCBOFOPN Is it OPEN?
         BNO   X$SPRTX                    No, ignore it
         MVC   PARMLIST(C_CLOSEL),C_CLOSE
         CLOSE ((3)),MF=(E,PARMLIST)      Close it
         FREEPOOL (3)
X$SPRTX  DS    0H
*-Close SMTPNOTE file if open
         LA    R3,SMTPNOTE
         TM    DCBOFLGS-IHADCB(R3),DCBOFOPN Is it OPEN?
         BNO   X$SMTPX                    No, ignore it
         MVC   PARMLIST(C_CLOSEL),C_CLOSE
         CLOSE ((3)),MF=(E,PARMLIST)      Close it
         FREEPOOL (3)
X$SMTPX  DS    0H
*-Free Storage for DSA
         LR    R2,R13                     Get storage address
         STORAGE RELEASE,LENGTH=WORKDSL,ADDR=(R2) Release storage
         SLR   R15,R15                    Set return code
*-Return to caller
         PR    ,                          Return to caller
         EJECT
***********************************************************************
***                                                                 ***
**       Misc internal subroutines                                   **
***                                                                 ***
***********************************************************************
         SPACE 2
*
** Point Register 15 to the first blank in a string
** Input:  R0  - Maximum length of the string
**         R15 - String
** Output: R15 - First space in the string
*
LOCATE_FIRST_SPACE EQU *
         CLI   0(R15),C' '                Blank?
         BE    LFS$X                      Yes, leave
         LA    R15,1(R15)                 No, bump to next byte
         BCT   R0,LOCATE_FIRST_SPACE      ..Repeat
LFS$X    EQU   *
         BSM   0,R14                      Return to caller
*
** Obtain SWA control block
**
** Input: R15 has SWA Token/address
**        R0 has control block ID
**
** Output: R15 has control block address or zero
*
Obtain_SWA_CB DS 0H
         LA    R1,X_SWAREQ                Locate start of EPA
         ST    R1,DOUBLE                  Save address
         XC    0(L'SWAEPAX,R1),0(R1)      Clear area to zeros
         STCM  R15,B'0111',SWVA-ZB505(R1) Save control block location
         STC   R0,SWBLKID-ZB505(R1)       Save control block ID
         MVC   X_SWAEPAX(C_SWAREQL),C_SWAREQ Initialize parmlist
        SWAREQ FCODE=RL,                  Locate Control block         @
               EPA=DOUBLE,                ..EPA pointer                @
               UNAUTH=YES,                ..Unauthorized acess         @
               MF=(E,X_SWAEPAX)           ..Execute from here
         LTR   R15,R15                    Successful?
         BNZ   OSC$SWAE                   No, branch to error
         LA    R1,X_SWAREQ                Locate start of EPA
         L     R15,SWBLKPTR-ZB505(R1)     Locate the control Block
         B     OSC$X                      Return to caller
*
C_SWAREQ SWAREQ FCODE=RL,EPA=*-*,MF=L
C_SWAREQL EQU *-C_SWAREQ
*
OSC$SWAE DS    0H
         SLR   R15,R15                    Indicate CB not obtained
OSC$X    DS    0H
         BSM   0,R9                       Return to caller
         EJECT
***********************************************************************
***
**       Constants and end of module
***
***********************************************************************
         SPACE 2
         LTORG ,
*
** PUT QSAM code
*
C_PUTC   DS    0H
         PUT   (1),(0)
         BSM   0,R9
C_PUTCL  EQU   *-C_PUTC
*
** I/O constants
*
C_CLOSE  CLOSE (*-*),MF=L
C_CLOSEL EQU   *-C_CLOSE
*
C_LSTO   OPEN  (*-*,(OUTPUT)),MF=L
C_LSTOL  EQU   *-C_LSTO
C_DCBO   DCB   DDNAME=C_DCBO,                                          @
               DSORG=PS,MACRF=PM,LRECL=80
C_DCBOL  EQU   *-C_DCBO
         DS    0D
SENDCC_Length EQU *-SENDCC
         EJECT
***********************************************************************
***                                                                 ***
**       GETMAINed work area                                         **
***                                                                 ***
***********************************************************************
             SPACE 2
WORKDS       DSECT ,
             DS    18F                    Register Save Area
DOUBLE       DS    D                      Double word
DOUBLE2      DS    2D                     Double word * 2
PARMLIST     DS    10F
X_PUTC       DS    XL(C_PUTCL)
X_SWAREQ     DS    XL(C_SWAREQL)
X_SWAEPAX    DS    XL(L'SWAEPAX)
             DS    0D
SYSPRINT     DS    XL(C_DCBOL)          SYSPRINT DCB
SMTPNOTE     DS    XL(C_DCBOL)          SMTPNOTE DCB
*
SMTPMSG      DS    CL80
RECOUT       DS    CL80
             ORG   RECOUT
MSG          EQU   *
             DS    C' '
MSG_JOB      DS    C'JOB '
MSG_JOBAREA  DS    C'jobname (JOB01234)'
             DS    C' '
MSG_STEPAREA DS    C'procstep.stepname'
MSG_END      DS    C' Ended '
MSG_CC       DS    CL5' '
MSG_PGMS     DS    C' PGM='
MSG_PGM      DS    CL8'program '
MSGL         EQU   *-MSG
             ORG   ,
*
TPUT_USERID  DS    CL8' '
FLAG1        DS    B'00000000'            Flag
$F1_NOTPUT   EQU   B'10000000'            ..Don't issue TPUT
$F1_SYSPRINT EQU   B'01000000'            ..Writing to //SYSPRINT
$F1_EMAIL    EQU   B'00100000'            ..Generating email?
*
             DS    0D                     Make GETMAIN/FREEMAIN Happy
WORKDSL      EQU   *-WORKDS
         END ,