./ ADD NAME=$$$INDEX
*---------------------------------------------------------------------*
*               Directory list of ABBYDALE.ALLFREE.REXX               *
*---------------------------------------------------------------------*
|  Member  | Description                                              |
*---------------------------------------------------------------------*
| $$$INDEX | This member.                                             |
*---------------------------------------------------------------------*
| ALIKE    | Create a dataset with the same attributes as the one     |
|          | in the ISPF 3.4 panel next to the command.               |
*---------------------------------------------------------------------*
| ASLDBACT | Loads a profile member (ASLACTDB) with list of defined   |
|          | DB2 subsystems on the LPAR along with their status.      |
*---------------------------------------------------------------------*
| ASLQMACT | Loads a profile member (ASLACTMQ) with list of defined   |
|          | MQ subsystems on the LPAR along with their status.       |
*---------------------------------------------------------------------*
| ASLTESTR | Checks for the existance of the passed sequential file   |
|          | and empties it. If the file doesn't exist it creates it  |
|          | and then empties it.                                     |
*---------------------------------------------------------------------*
| CHECKDSN | Checks a passed dataset name for correct format and to   |
|          | see if it exists or not.                                 |
*---------------------------------------------------------------------*
| CHGUID   | Changes all ISPF last updated by userids to the one      |
|          | passed to it. If no userid is passed the logon id of the |
|          | person running the exec is used.                         |
*---------------------------------------------------------------------*
| CLONE    | Creates a copy of the dataset.                           |
*---------------------------------------------------------------------*
| COUNTSTR | Counts the number of occurrences of one string in        |
|          | another string. (returns 0 if string not found)          |
*---------------------------------------------------------------------*
| CPUCHECK | Checks to see if an exec is allowed on the current LPAR. |
*---------------------------------------------------------------------*
| DB2STAT  | Show the status of all the DB2 subsystems on the LPAR.   |
*---------------------------------------------------------------------*
| DC       | Allows for delete from a 3.4 ISPF panel even for VSAM.   |
*---------------------------------------------------------------------*
| DELSTATS | Deletes all ISPF statistics for the dataset.             |
*---------------------------------------------------------------------*
| DIRLIST  | Lists the directory of a PDS.                            |
*---------------------------------------------------------------------*
| EDITREC  | Edit recovery code to allow for recovery if ISPF crashed.|
*---------------------------------------------------------------------*
| FINDIT   | Looks for a member in the current TSO allocations..      |
*---------------------------------------------------------------------*
| FINDMOD  | Checks to see if a load module exists.                   |
*---------------------------------------------------------------------*
| FINDREXX | Checks to see if a Rexx exec exists in either SYSEXEC or |
|          | the SYSPROC concatenations.                              |
*---------------------------------------------------------------------*
| GETDSN   | Returns the dataset associated with a passed DD name.    |
*---------------------------------------------------------------------*
| GETPROF  | Returns the current prefix being used by the TSO user.   |
*---------------------------------------------------------------------*
| ISDATE   | Tests a passed string to see if it is a valid date.      |
*---------------------------------------------------------------------*
| ISITREXX | Tests to see if a member of a dataset is a rexx exec.    |
*---------------------------------------------------------------------*
| JOBID    | Displays the JOBID of the task running the exec.         |
*---------------------------------------------------------------------*
| JOBNAME  | Displays the JOBNAME of the task running the exec.       |
*---------------------------------------------------------------------*
| JUL2GREG | Converts a passed Julian date to Gregorian.              |
*---------------------------------------------------------------------*
| LC       | Performs a LISTCAT of the adjacent dataset in 3.4        |
*---------------------------------------------------------------------*
| LEVELS   | Counts the number of levels in a passed dataset name.    |
*---------------------------------------------------------------------*
| LISTVOLS | Display all online DASD volume serial numbers and unit   |
|          | addresses.                                               |
*---------------------------------------------------------------------*
| MEMMATCH | Checks a PDS for the member or member pattern.           |
*---------------------------------------------------------------------*
| MQVER    | Displays the fix level of the Websphere MQ subsystems.   |
*---------------------------------------------------------------------*
| ONEEXT   | Makes a dataset into a one extent allocation.            |
*---------------------------------------------------------------------*
| PROPER   | Changes text to be in proper format i.e. Abbydale.       |
*---------------------------------------------------------------------*
| REXXINFO | Display running exec information.                        |
*---------------------------------------------------------------------*
| RUNNING  | Checks to see if a task is running or not.               |
*---------------------------------------------------------------------*
| SNAP     | Move the adjacent dataset to a different volume,         |
*---------------------------------------------------------------------*
| SORTDEMO | Demonstrates a simple way to sort an array.              |
*---------------------------------------------------------------------*
| STRCOUNT | Counts the number of occurrences of one string in        |
|          | another string and also returns the position of the 1st  |
|          | occurrence of the string (returns 0 if string not found) |
*---------------------------------------------------------------------*
| STRREPL  | Replaces a string within a specified string.             |
*---------------------------------------------------------------------*
| USERNAME | Returns the user name of the TSO user running the EXEC.  |
*---------------------------------------------------------------------*
| VALIDIP  | Validates the format of the passed dotted IP address.    |
*---------------------------------------------------------------------*
| VALIDMEM | Validates a member name for the correct format.          |
*---------------------------------------------------------------------*
| VALIDVOL | Validates a passed volume serial number.                 |
*---------------------------------------------------------------------*
| VU       | Updates the VTOC of the volume                           |
*---------------------------------------------------------------------*
| ZAPVTOC  | Zaps the VTOC of a volume. Useful for avoiding ENQs      |
*---------------------------------------------------------------------*
| ZELLER   | Tells you what day of the week a date fell on.           |
*---------------------------------------------------------------------*
|                 ©Copyright of Abbydale Systems LLC.                 |
*---------------------------------------------------------------------*
./ ADD NAME=ALIKE
/* rexx */
/*-------------------------------------------------------------------*/
/*                                                                   */
/*                         REXX Exec : ALIKE                         */
/*                                                                   */
/*  Description : Create a dataset with the same attributes as the   */
/*                one displayed on the 3.4 panel, or passed as a     */
/*                parameter.                                         */
/*                                                                   */
/*  Created on : 14 May 2018                                         */
/*  Created by : KEVIN FERGUSON                                      */
/*             : Userid(MIT001)                                      */
/*             : using ABBYDALE.XFER.REXX(ALIKE)                     */
/*                                                                   */
/*  Called by :                                                      */
/*                                                                   */
/*  Calls :                                                          */
/*                                                                   */
/*  Change Activity :                                                */
/*                                                                   */
/*  MM/DD/YYYY  ID   Comment                                         */
/*  ---------------------------------------------------------------  */
/*  10/20/2023  FIX  Fixed the issue when no answer is given for     */
/*                   new volume definition.                          */
/*                                                                   */
/*                ©Copyright of Abbydale Systems LLC.                */
/*                                                                   */
/*-------------------------------------------------------------------*/
signal on halt         /* attention key      */
parse upper arg dsn vol
dsn = strip(dsn,b,"'")
s = userid()
new = dsn
do while new = dsn
      say 'Enter new name'
      pull new
      iterate
end
DSN_STATUS = LISTDSI(''''dsn'''' smsinfo)
volume = sysvolume
block = sysblksize
do until done = 'Y'
say 'Allocate to a new volume? (Y or N)'
pull ans
SELECT
   when ans = 'Y' then do
      say 'Enter target volume'
      pull volume
      if LENGTH(volume) = '6' then do
         done = 'Y'
      end
   end
   when ans = 'N' then do
        done = 'Y'
   otherwise nop                                                 /*FIX*/
   end
end
say new 'will be allocated on' volume
TrapON=OutTrap('ON')
"ALLOC F(DATAOUT) DATASET('"new"')" ,
                  "SHR VOL("volume") UNIT("sysunit") REUS" ,
                  "BLKSIZE("block")"
trace 0
if kf = 0 then do
  say new "already exists on" vol ". Do you want to overwrite it?"
  pull ans
  if ans <> "Y" then exit
  end
  else do
If sysstorclass = '' then do
"ALLOC F(DATAOUT) DATASET('"new"') NEW CATALOG VOL("volume")" ,
"UNIT(3390) LIKE('"dsn"') REUS" ,
                  "BLKSIZE("block")"
 end
 else do
 say dsn ' is SMS Managed'
TrapON=OutTrap('OFF')
"ALLOC F(DATAOUT) DATASET('"new"') NEW CATALOG" ,
" LIKE('"dsn"') REUS",
" STORCLAS("sysstorclass")"
/* " MGMTCLAS("sysmgmtclass")" ,
" DATACLAS("sysdataclass")" */
 end
  end
 "free f(DATAOUT)"
exit
/*-------------------------------------------------------------------*/
/*                        Trap HALT Condition                        */
/*-------------------------------------------------------------------*/
halt:
say "HALT acknowledged in line" sigl
say "Cleanup processing in progress"
address "TSO"
"delstack"
exit(16)
/*-------------------------------------------------------------------*/
/*                           End of ALIKE                            */
/*-------------------------------------------------------------------*/
./ ADD NAME=ASLDBACT
/* rexx */
/*-------------------------------------------------------------------*/
/*                                                                   */
/*                         REXX Exec : ASLDBACT                      */
/*                                                                   */
/*  Description : Displays the DB subsystems defined on the LPAR and */
/*                the status of them (A) Active (I) Inactive         */
/*                                                                   */
/*  Created on : 4 Apr 2018                                          */
/*  Created by : Kevin Ferguson                                      */
/*             : Userid(MIT001)                                      */
/*             : using ABBYDALE.XFER.REXX(ASLDBACT)                  */
/*                                                                   */
/*  Called by :                                                      */
/*                                                                   */
/*  Calls : get_ptr, get_data (instream)                             */
/*                                                                   */
/*  Change Activity :                                                */
/*                                                                   */
/*                ©Copyright of Abbydale Systems LLC.                */
/*                                                                   */
/*-------------------------------------------------------------------*/
signal on halt                      /* attention key      */
numeric digits 10
cvt_ptr = get_ptr(10,)              /* CVT pointer            */
cvtjesct = get_ptr(cvt_ptr,'128')   /* address of CVTJESCT    */
ssct_ptr = get_ptr(cvtjesct,'18')   /* address of SSCT        */
Block_id = get_data(ssct_ptr,'0',4) /* Block_id must = 'SSCT' */
done = 'n'
cc = 0
temp = ""
do until done = 'y'
    if Block_id = 'SSCT' then do
       taskname = get_data(ssct_ptr,'8',4)
       SSCTSUSE_ptr = get_ptr(ssct_ptr,'14')
       ssct_anc = get_ptr(cvtjesct,'18')
       if ssctsuse_ptr = '0' then do
          ssct_ptr = get_ptr(ssct_ptr,'4')
       end
       else do
          if SSCTSUSE_ptr < '80000000' then do
             Early = get_data(SSCTSUSE_ptr,'4',4)
             if early = 'ERLY' then do
                Program = get_data(SSCTSUSE_ptr,'54',7)
                if Program = 'DSN3EPX' then do
                   run = get_ptr(ssct_ptr,'10',4)
                   run = get_ptr(run,'4',4)
                   st = "(A)"
                   if run = '0' then do
                      st = "(I)"
                   end
                   temp = temp||SUBSTR(taskname,1,4)||st||","
                end
             end
          end
          ssct_ptr = get_ptr(ssct_ptr,'4')
       end
       if ssct_ptr = '0' then do
       done = 'y'
       end
 end
 else do
    Say 'Logic error ' block_id 'found where SSCT should be'
    cc = 16
    done = 'y'
 end
end
ASLACTDB = substr(temp,1,LENGTH(temp)-1)
"ISPEXEC VPUT (ASLACTDB) PROFILE"
exit (cc)
/*-------------------------------------------------------------------*/
/*                         End of main line                          */
/*-------------------------------------------------------------------*/
/*                         get_ptr Subroutine                        */
/*-------------------------------------------------------------------*/
/* Returns a 4 byte pointer as hexadecimal string at address         */
/* ADDR+OFFSET (ADDR and OFFSET must be hex strings.)                */
/*-------------------------------------------------------------------*/
get_ptr: procedure
 arg addr,offset
temp=d2x(x2d(addr)+x2d(offset))
return c2x(storage(temp,4))
exit
/*-------------------------------------------------------------------*/
/*                    End of get_ptr Subroutine                      */
/*-------------------------------------------------------------------*/
/*                        get_date Subroutine                        */
/*-------------------------------------------------------------------*/
/* Returns LENGTH bytes at ADDR+OFFSET as an EBCDIC string.          */
/* (ADDR and OFFSET must be hex strings). LENGTH must be a decimal   */
/* string.                                                           */
/*-------------------------------------------------------------------*/
get_data: procedure
arg addr,offset,length
temp=d2x(x2d(addr)+x2d(offset))
return storage(temp,length)
exit
/*-------------------------------------------------------------------*/
/*                   End of get_data Subroutine                      */
/*-------------------------------------------------------------------*/
/*                        Trap HALT Condition                        */
/*-------------------------------------------------------------------*/
halt:
say "HALT acknowledged in line" sigl
say "Cleanup processing in progress"
address "TSO"
"delstack"
exit(16)
/*-------------------------------------------------------------------*/
/*                           End of ASLDBACT                         */
/*-------------------------------------------------------------------*/
./ ADD NAME=ASLQMACT
/* rexx */
/*-------------------------------------------------------------------*/
/*                                                                   */
/*                         REXX Exec : ASLQMACT                      */
/*                                                                   */
/*  Description : Displays the MQ subsystems defined on the LPAR and */
/*                the status of them (A) Active (I) Inactive         */
/*                                                                   */
/*  Created on : 4 Apr 2018                                          */
/*  Created by : KEVIN FERGUSON                                      */
/*             : Userid(MIT001)                                      */
/*             : using ABBYDALE.XFER.REXX(ASLQMACT)                  */
/*                                                                   */
/*  Called by : ASLMQBKP                                             */
/*                                                                   */
/*  Calls : get_ptr, get_data (instream)                             */
/*                                                                   */
/*  Change Activity :                                                */
/*                                                                   */
/*                ©Copyright of Abbydale Systems LLC.                */
/*                                                                   */
/*-------------------------------------------------------------------*/
signal on halt                      /* attention key      */
numeric digits 10
cvt_ptr = get_ptr(10,)              /* CVT pointer            */
cvtjesct = get_ptr(cvt_ptr,'128')   /* address of CVTJESCT    */
ssct_ptr = get_ptr(cvtjesct,'18')   /* address of SSCT        */
Block_id = get_data(ssct_ptr,'0',4) /* Block_id must = 'SSCT' */
done = 'n'
cc = 0
temp = ""
do until done = 'y'
    if Block_id = 'SSCT' then do
       taskname = get_data(ssct_ptr,'8',4)
       SSCTSUSE_ptr = get_ptr(ssct_ptr,'14')
       ssct_anc = get_ptr(cvtjesct,'18')
       if ssctsuse_ptr = '0' then do
          ssct_ptr = get_ptr(ssct_ptr,'4')
       end
       else do
          if SSCTSUSE_ptr < '80000000' then do
             Early = get_data(SSCTSUSE_ptr,'4',4)
             if early = 'ERLY' then do
                Program = get_data(SSCTSUSE_ptr,'54',7)
                if Program = 'CSQ3EPX' then do
                   run = get_ptr(ssct_ptr,'10',4)
                   run = get_ptr(run,'4',4)
                   st = "(A)"
                   if run = '0' then do
                      st = "(I)"
                   end
                   temp = temp||SUBSTR(taskname,1,4)||st||","
                end
             end
          end
          ssct_ptr = get_ptr(ssct_ptr,'4')
       end
       if ssct_ptr = '0' then do
       done = 'y'
       end
 end
 else do
    Say 'Logic error ' block_id 'found where SSCT should be'
    cc = 16
    done = 'y'
 end
end
ASLACTQM = substr(temp,1,LENGTH(temp)-1)
"ISPEXEC VPUT (ASLACTQM) PROFILE"
exit (cc)
/*-------------------------------------------------------------------*/
/*                         End of main line                          */
/*-------------------------------------------------------------------*/
/*                         get_ptr Subroutine                        */
/*-------------------------------------------------------------------*/
/* Returns a 4 byte pointer as hexadecimal string at address         */
/* ADDR+OFFSET (ADDR and OFFSET must be hex strings.)                */
/*-------------------------------------------------------------------*/
get_ptr: procedure
 arg addr,offset
temp=d2x(x2d(addr)+x2d(offset))
return c2x(storage(temp,4))
exit
/*-------------------------------------------------------------------*/
/*                    End of get_ptr Subroutine                      */
/*-------------------------------------------------------------------*/
/*                        get_date Subroutine                        */
/*-------------------------------------------------------------------*/
/* Returns LENGTH bytes at ADDR+OFFSET as an EBCDIC string.          */
/* (ADDR and OFFSET must be hex strings). LENGTH must be a decimal   */
/* string.                                                           */
/*-------------------------------------------------------------------*/
get_data: procedure
arg addr,offset,length
temp=d2x(x2d(addr)+x2d(offset))
return storage(temp,length)
exit
/*-------------------------------------------------------------------*/
/*                   End of get_data Subroutine                      */
/*-------------------------------------------------------------------*/
/*                        Trap HALT Condition                        */
/*-------------------------------------------------------------------*/
halt:
say "HALT acknowledged in line" sigl
say "Cleanup processing in progress"
address "TSO"
"delstack"
exit(16)
/*-------------------------------------------------------------------*/
/*                           End of ASLQMACT                         */
/*-------------------------------------------------------------------*/
./ ADD NAME=ASLTESTR
/* rexx */
/*-------------------------------------------------------------------*/
/*                                                                   */
/*                       REXX Exec : ASLTESTR                        */
/*                                                                   */
/*  Description : Tests for the existance of a dataset, if it        */
/*                exists it is emptied. If it doesn't it is created  */
/*                and then emptied.                                  */
/*                                                                   */
/*  Created on : 03 Aug 2001                                         */
/*  Created by : Kevin Ferguson                                      */
/*             : Userid MIT001                                       */
/*             : Using ABBYDALE.DEVL.REXX(ASLTESTR)                  */
/*                                                                   */
/*  Called by : Many things                                          */
/*                                                                   */
/*  Calls : LISTDSI                                                  */
/*                                                                   */
/*  Panels Used : None                                               */
/*                                                                   */
/*  Change Activity :                                                */
/*                                                                   */
/*                ©Copyright of Abbydale Systems LLC.                */
/*                                                                   */
/*-------------------------------------------------------------------*/
Parse upper arg Help rec
dialogid = sysvar(sysicmd)
parse source Exec_String
excname = word(Exec_String,3)
if Help = "" then do
   Say "No parmeter passed to" excname
   exit(8)
end
If Help = "?" Then do
   Call Disp_Help
   exit(4)
end
signal on halt         /* attention key      */
dsname = STRIP(Help)
rec = STRIP(rec)
TrapON=OutTrap('ON')
"FREE ATTR(ASLA)"
RECFM =
If rec = '' then do
   rec = 133
   recfm = A
end
"FREE ATTR(ASLA)"
"ATTR ASLA LRECL("rec") RECFM(F B "recfm") BLKSIZE(0) DSORG(PS)"
DsnStat=ListDsi("'"dsname"'" smsinfo)
if DsnStat = 16 then do
   "ALLOC  DA('"dsname"') NEW F(SYSUT2) REUS
        SPACE(600,100) USING(ASLA) UNIT(SYSALLDA)"
end
else do
   if sysdsorg <> "PS" then do
   say sysdsorg 'file types are not supported'
   exit(16)
   end
   "ALLOC DA('"dsname"') F(SYSUT2) SHR REUS"
end
line.1 = ""
"EXECIO * diskw SYSUT2 (FINIS stem line."
"FREE DD(SYSUT2)"
"FREE ATTR(ASLA)"
return
/*-------------------------------------------------------------------*/
/*                        Disp_Help Procedure                        */
/*-------------------------------------------------------------------*/
Disp_Help: Procedure
say "ASLTESTR - Tests for the existance of the passed dataset."
say "           If the dataset exists it is emptied, if it doesn't"
say "           exist it is created and then emptied"
say""
say "Usage: ASLTESTR dsname lrecl | ?"
say""
say"   dsname    - Is the name of the dataset to be emptied/created."
say""
say"   lrecl     - (optional). Defines the record length for the"
say"               dataset being created. The default is 133"
say""
say"    ?        - Generates this information."
say""
say"   Return Codes :"
say"                 4 - Help displayed"
say"                 8 - No parameter passed"
say"                16 - Dataset not a sequential file"
say""
Return
/*-------------------------------------------------------------------*/
/*                    End of Disp_Help Procedure                     */
/*-------------------------------------------------------------------*/
/*-------------------------------------------------------------------*/
/*                        Trap HALT Condition                        */
/*-------------------------------------------------------------------*/
halt:
say "HALT acknowledged in line" sigl
say "Cleanup processing in progress"
address "TSO"
"delstack"
exit(16)
/*-------------------------------------------------------------------*/
/*                          End of ASLTESTR                          */
/*-------------------------------------------------------------------*/
./ ADD NAME=CHECKDSN
/* rexx */
/*-------------------------------------------------------------------*/
/*                                                                   */
/*                       REXX Exec : CHECKDSN                        */
/*                                                                   */
/*  Description : Check the dataset name format and if it isn't a    */
/*                a new dataset, check to see if it exists.          */
/*                                                                   */
/*  Created on : 27 Jul 2017                                         */
/*  Created by : Kevin Ferguson                                      */
/*             : Userid(MIT001)                                      */
/*             : using ABBYDALE.PROD.REXX(CHECKDSN)                  */
/*                                                                   */
/*  Called by : Various Execs                                        */
/*                                                                   */
/*  Calls :  SYSDSN                                                  */
/*                                                                   */
/*  Change Activity :                                                */
/*                                                                   */
/*  MM/DD/YYYY  ID   Comment                                         */
/*  ---------------------------------------------------------------  */
/*  07/14/2023  ZER  Added check of empty member name                */
/*  05/15/2021  DSF  Changed code to support RC 12 for 'Not Found'   */
/*                   Corrected help information                      */
/*                                                                   */
/*                ©Copyright of Abbydale Systems LLC.                */
/*                                                                   */
/*-------------------------------------------------------------------*/
pee = ''
/*signal on novalue         un-initialized vars*/
rc = 8                 /* Set default of invalid */
new = 'n'              /* Set default            */
help = 'n'             /* Set default            */
member = ''            /* set default            */
forbid = '*%@!&^}{[_]:,;' /* characters forbidden in dataset name */
parse upper arg dsname new
if dsname = "?" then do
   call disp_help
   exit(4)
end
dsnmax = 44
if pos('(',dsname) > 0 then do
   if pos(')',dsname) < pos('(',dsname) then do
      say dsname ' - Invalid member specification'
      exit(8)
   end
   /* dsnmax = dsnmax + 10 */
   len = (pos(')',dsname) - pos('(',dsname) ) - 1
   if len > 8 then do
      say dsname ' - Invalid member specification'
      exit(8)
   end
   if len = 0 then do                                            /*ZER*/
      say dsname ' - Invalid member specification'               /*ZER*/
      exit(8)                                                    /*ZER*/
   end                                                           /*ZER*/
   member = substr(dsname,pos('(',dsname)+1,len)
   dsname = substr(dsname,1,pos('(',dsname)-1)
end
else do
   forbid = forbid||')('
end
dsname  = strip(dsname,B,"'")
if LENGTH(dsname) > dsnmax then do
   say dsname ' - Length error > 'dsnmax
   exit(8)
end
x = 1
do until x = LENGTH(forbid)
   if POS(SUBSTR(forbid,x,1),dsname) > 0 then do
   say dsname ' - Invalid character in name 'SUBSTR(forbid,x,1)
   exit(8)
   end
   x = x + 1
end                           /* Do end */
hit = 'n'             /* Set period hit indicator */
done = 'n'            /* Set get out variable     */
workname = dsname
len = LENGTH(dsname)
do until done = 'y'
   if pos('.',workname) = 0 then do
      done = 'y'
      if len > 8 then do
         say dsname ' - Qualifier length error'
         exit(8)
      end
      end
   else do
    if pos('.',workname) > 9 then do
        say dsname ' - Qualifier length error'
        exit(8)
    end
    /*   Check first character of the level */
    if substr(workname,1,1) > 'Z' then do
        say dsname ' - Invalid first character 'substr(workname,1,1)
        exit(8)
    end
    if substr(workname,1,1) < 'A' then do
        say dsname ' - Invalid first character 'substr(workname,1,1)
        exit(8)
    end
    len = len - pos('.',workname)
    workname = substr(workname,pos('.',workname)+1,len)
   end
end
/*   Check last level for first character */
if substr(workname,1,1) > 'Z' then do
    say dsname ' - Invalid first character 'substr(workname,1,1)
    exit(8)
end
if substr(workname,1,1) < 'A' then do
    say dsname ' - Invalid first character 'substr(workname,1,1)
    exit(8)
end
if new <> 'n' then do
   if member <> '' then do
      dsname = dsname||'('||member||')'
   end
   TrapON=OutTrap('ON')
   DSN_STATUS = SYSDSN("'"dsname"'")
   TrapON=OutTrap('OFF')
   if DSN_STATUS = 'OK' then do
      rc = 0
   end
   else do
  /*  say dsname ' - Dataset not found'         */
      rc = 12   /* Indicate dataset not found */                /*DSF*/
   end
end
exit rc
/*-------------------------------------------------------------------*/
/*                      disp_help procedure                          */
/*-------------------------------------------------------------------*/
disp_help: procedure
say "CHECKDSN - a REXX exec to check the dsname format."
say ""
say "Usage: CHECKDSN dsname new | ? "
say ""
say "     dsname - Specified the name of the module to locate."
say "     new    - (optional). If anything is passed as a second"
say "              parameter then the dataset is assumed to be going"
say "              to be created so just the format is checked"
say "     ?      - generates this information."
say ""
say "    Return Codes : 0 - Dataset name is valid"              /*DSF*/
say "                   4 - Help displayed"
say "                   8 - Invalid dataset name"               /*DSF*/
Say "                  12 - Dataset name valid but not found"   /*DSF*/
Say "                  16 - Critical error"
return
/*-------------------------------------------------------------------*/
/*                      Trap NOVALUE Condition                       */
/*-------------------------------------------------------------------*/
novalue:
say "NOVALUE entered from line" sigl
say condition("D")
say "The instruction is suppressed"
address "TSO"
"delstack"
exit(16)
/*-------------------------------------------------------------------*/
/*                          End of CHECKDSN                          */
/*-------------------------------------------------------------------*/
./ ADD NAME=CHGUID
/* rexx */
/*-------------------------------------------------------------------*/
/*                                                                   */
/*                         REXX Exec : CHGUID                        */
/*                                                                   */
/*  Description : Change userid statistics from a dataset.           */
/*                                                                   */
/*  Created on : 31 Mar 2018                                         */
/*  Created by : KEVIN FERGUSON                                      */
/*             : Userid(MIT001)                                      */
/*             : using ABBYDALE.XFER.REXX(CHGUID)                    */
/*                                                                   */
/*  Called by :                                                      */
/*                                                                   */
/*  Calls : LISTDSI                                                  */
/*                                                                   */
/*  Change Activity :                                                */
/*                                                                   */
/*                ©Copyright of Abbydale Systems LLC.                */
/*                                                                   */
/*-------------------------------------------------------------------*/
parse upper arg uid dsn
dialogid = sysvar(sysicmd)
parse source Exec_String
excnme = word(Exec_String,3)           /* Get EXEC's name          */
address ISPEXEC "CONTROL ERRORS RETURN"
if LASTPOS('.',uid) > 0 then do
   temp = uid
   uid = dsn
   dsn = temp
end
do while dsn = ""
   Say 'Enter Dataset Name. (use QUIT to terminate)'
   pull xsn
   if xsn = 'QUIT' then exit
   if xsn = 'END' then exit
   DSN_STATUS = LISTDSI(''''xsn'''' smsinfo)
   if sysrecfm <>"U" then do
      if sysdsorg == "PO" then do
         dsn = xsn
      end
   end
   if dsn <> xsn then do
      say 'invalid dataset type for' excnme
   end
end
if length(UID) > 7 then do
    Say 'Passed USERID length error. Correct and retry'
    rc = 8
  ZEDSMSG = 'CHGUID Failed'
  ZEDLMSG = 'Passed userid length error'
  ZDLMSG = "UID Length error"
  ZDLREF = 'Y'
  Address ISPEXEC "VPUT (ZDLMSG ZDLMSG) SHARED"
  address ISPEXEC "SETMSG MSG(ISRZ001)"
  exit rc
end
if UID = "" then do
   UID = userid()
end
dsn = strip(dsn,b,"'")
kf  =outtrap('on')
DSN_STATUS = LISTDSI(''''dsn'''' smsinfo)
rc = 8
if sysrecfm <>"U" then do
   if sysdsorg = "PO" then do
      address ISPEXEC "LMINIT DATAID(RES) DATASET('"dsn"') ENQ(SHR)"
      if rc <> 0 then say 'LMINIT error' zerrlm
      address ISPEXEC "LMMSTATS DATAID("RES") MEMBER(*) USER("UID")"
      if rc <> 0 then say 'LMSTAT error' zerrlm
      address ISPEXEC "LMFREE DATAID("RES")"
      if rc <> 0 then say 'LMFREE error' zerrlm
   end
end
kf  =outtrap('off')
if rc = 8 then do
  Say excnme 'only works on PDS datasets'
  ZEDSMSG = excnme 'failed'
  ZEDLMSG = dsn 'is the wrong dataset type'
  ZDLMSG = "Invalid type"
  ZDLREF = 'Y'
  Address ISPEXEC "VPUT (ZDLMSG ZDLMSG) SHARED"
  address ISPEXEC "SETMSG MSG(ISRZ001)"
  exit rc
end
exit rc
/*-------------------------------------------------------------------*/
/*                        End of CHGUID                              */
/*-------------------------------------------------------------------*/
./ ADD NAME=CLONE
/* rexx */
/*-------------------------------------------------------------------*/
/*                                                                   */
/*                         REXX Exec : CLONE                         */
/*                                                                   */
/*  Description : Create a copy of a dataset. Invoke by typing       */
/*                CLONE next to the dataset name on the ISPF 3.4 menu*/
/*                                                                   */
/*  Created on : 31 Mar 2018                                         */
/*  Created by : KEVIN FERGUSON                                      */
/*             : Userid(MIT001)                                      */
/*             : using ABBYDALE.XFER.REXX(CLONE)                     */
/*                                                                   */
/*  Called by :                                                      */
/*                                                                   */
/*  Calls : REPRO, IEBCOPY, LISTDSI                                  */
/*                                                                   */
/*  Change Activity :                                                */
/*                                                                   */
/*  MM/DD/YYYY  ID   Comment                                         */
/*  ---------------------------------------------------------------  */
/*  08/15/2022  NEW  Changed to allow quotes around the new name     */
/*  10/20/2023  FIX  Fixed the issue when no answer is given for     */
/*                   new volume definition.                          */
/*                                                                   */
/*                ©Copyright of Abbydale Systems LLC.                */
/*                                                                   */
/*-------------------------------------------------------------------*/
parse upper arg dsn vol
dsn = strip(dsn,b,"'")
s = userid()
new = dsn
do while new = dsn
      say 'Enter new name'
      pull new
      iterate
end
new = strip(new,b,"'")                                          /*NEW*/
trace o
DSN_STATUS = LISTDSI(''''dsn'''' smsinfo)
volume = sysvolume
done = 'N'
do until done = 'Y'
say 'Allocate to a new volume? (Y or N)'
pull ans
SELECT
   when ans = 'Y' then do
      say 'Enter target volume'
      pull volume
      if LENGTH(volume) = '6' then do
         done = 'Y'
      end
   end
   when ans = 'N' then do
        done = 'Y'
   otherwise nop                                                /*FIX*/
   end
end
say new 'will be allocated on' volume
TrapON=OutTrap('ON')
"ALLOC F(DATAOUT) DATASET('"new"')" ,
                  "SHR VOL("volume") UNIT("sysunit") REUS"
trace 0
if kf = 0 then do
  say new "already exists on" vol ". Do you want to overwrite it?"
  pull ans
  if ans <> "Y" then exit
  end
  else do
If sysstorclass = '' then do
"ALLOC F(DATAOUT) DATASET('"new"') NEW CATALOG VOL("volume")" ,
"UNIT(3390) LIKE('"dsn"') REUS"
 end
 else do
 say dsn ' is SMS Managed'
TrapON=OutTrap('OFF')
"ALLOC F(DATAOUT) DATASET('"new"') NEW CATALOG" ,
" LIKE('"dsn"') REUS",
" STORCLAS("sysstorclass")"
/* " MGMTCLAS("sysmgmtclass")" ,
" DATACLAS("sysdataclass")" */
 end
  end
/* if empty <> '' then exit */
DSN_STATUS = LISTDSI(''''dsn'''' DIRECTORY)
SELECT
       WHEN sysdsorg = 'PS' then do
"Alloc F(DATAIN) da('"dsn"') SHR REUS"
"repro infile(DATAIN) outfile(DATAOUT)"
 kef = rc
 'FREE F (DATAIN DATAOUT)'
 say "Copy ended Return code" kef
end
       WHEN sysdsorg = 'PO' then do
TrapON=OutTrap('Off')
"Alloc F(DATAIN) da('"dsn"') vol("sysvolume") SHR REUS"
"Alloc F(DATAOUT) da('"new"') vol("volume") SHR REUS"
"FREE FI(SYSIN,SYSPRINT,SYSUT3,SYSUT4)"
"ALLOC FILE(SYSIN) SPACE(1,1) TRACK LRECL(80) RECFM(F) BLKSIZE(80) REU"
"ALLOC FILE(SYSPRINT) da(*) BLKSIZE(121)"
"ALLOC FILE(SYSUT3) UNIT(SYSDA) SPACE(1,1) CYLINDERS REU"
"ALLOC FILE(SYSUT4) UNIT(SYSDA) SPACE(1,1) CYLINDERS REU"
SYSIN.1 = "   COPY OUTDD=DATAOUT,INDD=((DATAIN,R))"
'EXECIO * DISKW SYSIN (STEM SYSIN. FINIS'
"CALL 'SYS1.LINKLIB(IEBCOPY)' 'SIZE=512K'"
 kef = rc
 say "Copy ended Return code" kef
end
       otherwise do
say sysdsorg " Files are not supported"
exit
end
end
/* "free f(DATAIN DATAOUT)" */
exit
/*-------------------------------------------------------------------*/
/*                           End of CLONE                            */
/*-------------------------------------------------------------------*/
./ ADD NAME=COUNTSTR
/* rexx */
/*-------------------------------------------------------------------*/
/*                                                                   */
/*                       REXX Exec : COUNTSTR                        */
/*                                                                   */
/*  Description : Counts the number of occurrences of the string in  */
/*                another string.                                    */
/*                                                                   */
/*  Usage : x = CountStr('Needle','Haystack')                        */
/*                                                                   */
/*  Created on : 25 Apr 2001                                         */
/*  Created by : Kevin Ferguson                                      */
/*             : Userid MIT001                                       */
/*             : Using ABBYDALE.ALLFREE.REXX(COUNTSTR)               */
/*                                                                   */
/*  Called by : XMT                                                  */
/*                                                                   */
/*  Calls : Nothing                                                  */
/*                                                                   */
/*  Panels Used : None                                               */
/*                                                                   */
/*  Change Activity :                                                */
/*                                                                   */
/*                ©Copyright of Abbydale Systems LLC.                */
/*                                                                   */
/*-------------------------------------------------------------------*/
signal on novalue      /* un-initialized vars*/
signal on halt         /* attention key      */
CountStr:
find = ARG(1)
where = ARG(2)
if find = "" then signal novalue
if where = "" then signal novalue
RETURN length(space(where,0)),
               -length(space(translate(where,' ',find),0))
/*-------------------------------------------------------------------*/
/*                      End of CountStr Procedure                    */
/*-------------------------------------------------------------------*/
/*-------------------------------------------------------------------*/
/*                      Trap NOVALUE Condition                       */
/*-------------------------------------------------------------------*/
novalue:
say "NOVALUE entered from line" sigl
say condition("D")
say "The instruction is suppressed"
address "TSO"
"delstack"
exit(16)
/*-------------------------------------------------------------------*/
/*                        Trap HALT Condition                        */
/*-------------------------------------------------------------------*/
halt:
say "HALT acknowledged in line" sigl
say "Cleanup processing in progress"
address "TSO"
"delstack"
exit(16)
/*-------------------------------------------------------------------*/
/*                          End of COUNTSTR                          */
/*-------------------------------------------------------------------*/
./ ADD NAME=CPUCHECK
/* rexx */
/*-------------------------------------------------------------------*/
/*                                                                   */
/*                       REXX Exec : CPUCHECK                        */
/*                                                                   */
/*  Description : Checks to see if the exec is running on an allowed */
/*                systems or not.                                    */
/*                                                                   */
/*  Created on : 1 Apr 2018                                          */
/*  Created by : KEVIN FERGUSON                                      */
/*             : Userid(MIT001)                                      */
/*             : using ABBYDALE.XFER.REXX(CPUCHECK)                  */
/*                                                                   */
/*  Called by :                                                      */
/*                                                                   */
/*  Calls :                                                          */
/*                                                                   */
/*  Change Activity :                                                */
/*                                                                   */
/*                ©Copyright of Abbydale Systems LLC.                */
/*                                                                   */
/*-------------------------------------------------------------------*/
system = MVSVAR(sysname)
allow = 'CPU2CPU3'
x = POS(system,allow)
if x = 0 then
    rc = 8
  else
    rc = 0
exit rc
/*-------------------------------------------------------------------*/
/*                          End of CPUCHECK                          */
/*-------------------------------------------------------------------*/
./ ADD NAME=DB2STAT
/* rexx */
/*-------------------------------------------------------------------*/
/*                                                                   */
/*                         REXX Exec : DB2STAT                       */
/*                                                                   */
/*  Description : Displays the DB2 subsystems on the current LPAR    */
/*                                                                   */
/*  Created on : 4 Apr 2018                                          */
/*  Created by : Kevin Ferguson                                      */
/*             : Userid(MIT001)                                      */
/*             : using ABBYDALE.XFER.REXX(DB2STAT)                   */
/*                                                                   */
/*  Called by :                                                      */
/*                                                                   */
/*  Calls :                                                          */
/*                                                                   */
/*  Change Activity :                                                */
/*                                                                   */
/*                ©Copyright of Abbydale Systems LLC.                */
/*                                                                   */
/*-------------------------------------------------------------------*/
signal on halt         /* attention key      */
numeric digits 10
cvt_ptr = get_ptr(10,)              /* CVT pointer            */
cvtjesct = get_ptr(cvt_ptr,'128')   /* address of CVTJESCT    */
ssct_ptr = get_ptr(cvtjesct,'18')   /* address of SSCT        */
Block_id = get_data(ssct_ptr,'0',4) /* Block_id must = 'SSCT' */
done = 'n'
cc = 0
do until done = 'y'
    if Block_id = 'SSCT' then do
       taskname = get_data(ssct_ptr,'8',4)
       SSCTSUSE_ptr = get_ptr(ssct_ptr,'14')
       ssct_anc = get_ptr(cvtjesct,'18')
       ssrc = get_data(SSCTSUSE_ptr,'70',1)
       if ssctsuse_ptr = '0' then do
          ssct_ptr = get_ptr(ssct_ptr,'4')
       end
       else do
          if SSCTSUSE_ptr < '80000000' then do
             ASIDname = get_data(SSCTSUSE_ptr,'c',8)
             ASIDSSRC = get_data(SSCTSUSE_ptr,'66',2)
             Program = get_data(SSCTSUSE_ptr,'54',7)
             Early = get_data(SSCTSUSE_ptr,'4',4)
             If early = "ERLY" then do
                If program = 'DSN3EPX' then do
                   run = get_ptr(ssct_ptr,'10',4)
                   run = get_ptr(run,'4',4)
                   st = "*ACTIVE*"
                   If run = '0' then do
                       st = "INACTIVE"
                   end
                   temp = st 'DB2 subsystem' taskname
                   temp = temp'('ASIDName') SSRC('ssrc')'
                   say temp
                end
             end
          end
          ssct_ptr = get_ptr(ssct_ptr,'4')
       end
       if ssct_ptr = '0' then do
       done = 'y'
       end
 end
 else do
    Say 'Logic error ' block_id 'found where SSCT should be'
    cc = 16
    done = 'y'
 end
end
exit (cc)
/*                         end of main line                           */
get_ptr: procedure
/*
returns a 4 byte pointer as hexadecimal string at address ADDR+OFFSET
ADDR and OFFSET must be hex strings.                   */
 arg addr,offset
temp=d2x(x2d(addr)+x2d(offset))
return c2x(storage(temp,4))
exit
get_data: procedure
/*
returns LENGTH bytes att ADDR+OFFSET as an EBCDIC string.
ADDR and OFFSET must be hex strings.  LENGTH must be a
decimal string.
*/
arg addr,offset,length
temp=d2x(x2d(addr)+x2d(offset))
return storage(temp,length)
exit
get_data2: procedure
/*
returns LENGTH bytes att ADDR+OFFSET as an EBCDIC string.
ADDR and OFFSET must be hex strings.  LENGTH must be a
decimal string.
*/
arg addr,offset,length
temp=d2x(x2d(addr)+x2d(offset))
return storage(temp,length)
exit
/*-------------------------------------------------------------------*/
/*                        Trap HALT Condition                        */
/*-------------------------------------------------------------------*/
halt:
say "HALT acknowledged in line" sigl
say "Cleanup processing in progress"
address "TSO"
"delstack"
exit(16)
/*-------------------------------------------------------------------*/
/*                           End of DB2STAT                          */
/*-------------------------------------------------------------------*/
./ ADD NAME=DC
/* rexx */
/*-------------------------------------------------------------------*/
/*                                                                   */
/*                          REXX Exec : DC                           */
/*                                                                   */
/*  Description :  Allows DC to be typed on 3.4 panels for Delete    */
/*                                                                   */
/*  Created on : 9 May 2016                                          */
/*  Created by : Kevin Ferguson                                      */
/*             : Userid(MIT001)                                      */
/*             : using ABBYDALE.PROD.REXX(DC)                        */
/*                                                                   */
/*  Called by :                                                      */
/*                                                                   */
/*  Calls :  IDCAMS DELETE CLUSTER                                   */
/*                                                                   */
/*  Change Activity :                                                */
/*                                                                   */
/*                ©Copyright of Abbydale Systems LLC.                */
/*                                                                   */
/*-------------------------------------------------------------------*/
parse upper arg dsn
dsn = strip(dsn,b,"'")
kf  = outtrap('on')
DSN_STATUS = LISTDSI(''''dsname'''' smsinfo)
kf  = outtrap('off')
if sysdsorg = "VS" then do
   "DELETE '"dsn"' CLUSTER"
   if rc  = 0 then do
      ZEDSMSG = 'DC Successful'
      ZEDLMSG = dsn 'deleted'
      ZDLMSG = 'DC Successful'
      ZDLREF = 'Y'
      Address ISPEXEC "VPUT (ZDLMSG ZDLMSG) SHARED"
      address ISPEXEC "SETMSG MSG(ISRZ001)"
   end
end
else do
   "DELETE '"dsn"'"
   if rc = 0 then do
      ZEDSMSG = 'DC Successful'
      ZEDLMSG = dsn 'deleted'
      ZDLMSG = 'DC Successful'
      ZDLREF = 'Y'
      Address ISPEXEC "VPUT (ZDLMSG ZDLMSG) SHARED"
      address ISPEXEC "SETMSG MSG(ISRZ001)"
   end
end
exit
/*-------------------------------------------------------------------*/
/*                             End of DC                             */
/*-------------------------------------------------------------------*/
./ ADD NAME=DELSTATS
/* rexx */
/*-------------------------------------------------------------------*/
/*                                                                   */
/*                         REXX Exec : DELSTATS                      */
/*                                                                   */
/*  Description : Delete the ISPF Statistics from a dataset.         */
/*                                                                   */
/*  Created on : 31 Mar 2018                                         */
/*  Created by : KEVIN FERGUSON                                      */
/*             : Userid(MIT001)                                      */
/*             : using ABBYDALE.XFER.REXX(DELSTATS)                  */
/*                                                                   */
/*  Called by :                                                      */
/*                                                                   */
/*  Calls : LISTDSI                                                  */
/*                                                                   */
/*  Change Activity :                                                */
/*                                                                   */
/*                ©Copyright of Abbydale Systems LLC.                */
/*                                                                   */
/*-------------------------------------------------------------------*/
parse upper arg dsn
dialogid = sysvar(sysicmd)
parse source Exec_String
excnme = word(Exec_String,3)           /* Get EXEC's name          */
address ISPEXEC "CONTROL ERRORS RETURN"
do while dsn = ""
   Say 'Enter Dataset Name. (use QUIT to terminate)'
   pull xsn
   if xsn = 'QUIT' then exit
   if xsn = 'END' then exit
   DSN_STATUS = LISTDSI(''''xsn'''' smsinfo)
   if sysrecfm <>"U" then do
      if sysdsorg == "PO" then do
         dsn = xsn
      end
   end
   if dsn <> xsn then do
      say 'invalid dataset type for' excnme
   end
end
dsn = strip(dsn,b,"'")
kf  =outtrap('on')
DSN_STATUS = LISTDSI(''''dsn'''' smsinfo)
rc = 8
if sysrecfm <>"U" then do
   if sysdsorg = "PO" then do
      address ISPEXEC "LMINIT DATAID(RES) DATASET('"dsn"') ENQ(SHR)"
      if rc <> 0 then say 'LMINIT error' zerrlm
      address ISPEXEC "LMMSTATS DATAID("RES") MEMBER(*) DELETE"
      if rc <> 0 then say 'LMSTAT error' zerrlm
      address ISPEXEC "LMFREE DATAID("RES")"
      if rc <> 0 then say 'LMFREE error' zerrlm
      ZEDSMSG = 'Stats deleted'
      ZEDLMSG = 'ISPF stats deleted from 'dsn
      ZDLMSG = 'Stats deleted'
      ZDLREF = 'Y'
      Address ISPEXEC "VPUT (ZDLMSG ZDLMSG) SHARED"
      address ISPEXEC "SETMSG MSG(ISRZ001)"
   end
end
kf  =outtrap('off')
if rc = 8 then do
  Say excnme 'only works on PDS datasets'
  ZEDSMSG = excnme 'failed'
  ZEDLMSG = dsn 'is the wrong dataset type'
  ZDLMSG = "Invalid type"
  ZDLREF = 'Y'
  Address ISPEXEC "VPUT (ZDLMSG ZDLMSG) SHARED"
  address ISPEXEC "SETMSG MSG(ISRZ001)"
  exit rc
end
exit rc
/*-------------------------------------------------------------------*/
/*                        End of DELSTATS                            */
/*-------------------------------------------------------------------*/
./ ADD NAME=DIRLIST
/* rexx */
/*-------------------------------------------------------------------*/
/*                                                                   */
/*                        REXX Exec : DIRLIST                        */
/*                                                                   */
/*  Description : Display the directory list of a PDS                */
/*                                                                   */
/*  Created on : 7 Jul 2017                                          */
/*  Created by : Kevin Ferguson                                      */
/*             : Userid MIT001                                       */
/*             : Using ABBYDALE.DEVL.REXX(DIRLIST)                   */
/*                                                                   */
/*  Called by :                                                      */
/*                                                                   */
/*  Calls : CHECKDSN, LISTDSI                                        */
/*                                                                   */
/*  Panels Used : None                                               */
/*                                                                   */
/*  Change Activity :                                                */
/*                                                                   */
/*                ©Copyright of Abbydale Systems LLC.                */
/*                                                                   */
/*-------------------------------------------------------------------*/
Parse upper arg dsn    /* Check for Help */
signal on halt         /* attention key  */
If SYSVAR("SYSISPF")<>"ACTIVE" then Do
   Say "ISPF must be active to use "DIRLIST
   exit(16)
End
If dsn = "?" Then Do
   Call Disp_Help
   exit(4)
End
If dsn = "" then do
   Do while dsn = ""
      say 'Enter the PDS name to be listed. (use <QUIT> to terminate)'
      parse upper pull dsn
      If dsn = '<QUIT>' then Exit(0)
      If dsn = 'HELP' Then Do
         dsn = ""
         Call Disp_Help
      End
      Else do
         dsn = strip(dsn,B,"'")
         call trydsn
         if dsn = "" then do
             say 'Invalid dataset name'
             dsn = ""
         end
      end
   End
end
else do
   dsn = strip(dsn,B,"'")
   call trydsn dsn
   if dsn = "" then exit(8)
end
TrapON=OutTrap('ON')
DSN_STATUS = LISTDSI(''''dsn'''' smsinfo)
TrapON=OutTrap('OFF')
ISPEXEC "LMINIT DATAID(RES) DATASET('"dsn"') ENQ(SHR)"
if rc <> 0 then say 'LMINIT error' zerrlm
ISPEXEC "LMOPEN DATAID("RES") OPTION(INPUT)"
if rc <> 0 then say 'LMOPEN error' zerrlm
lmrc = 0
Pattern = ""
say 'Directory List of 'dsn
Do While lmrc = 0
  ISPEXEC "LMMLIST  DATAID("RES") MEMBER(lst),
     OPTION(LIST) STATS(YES) PATTERN("pattern")"
   lmrc = rc
   if lmrc =0 then do
     if substr(sysrecfm,1,1) = "U" then do
       say lst
     end
     else do
       say lst         ZLC4Date ZLM4DATE ZLCNORC ZLUSER ZLVERS
     end
   end
end
ISPEXEC "LMCLOSE DATAID("RES")"
ISPEXEC "LMFREE DATAID("RES")"
exit
/*-------------------------------------------------------------------*/
/*                        Trydsn Procedure                           */
/*-------------------------------------------------------------------*/
Trydsn:
parse arg dsn
rc = 0
dsn = strip(dsn,B,"'")
Checkdsn dsn
if rc <> 0 then do
   say 'Invalid dataset name'
   dsn = ""
end
else do
   TrapON=OutTrap('ON')
   DSN_STATUS = LISTDSI(''''dsn'''' smsinfo)
   TrapON=OutTrap('OFF')
   if substr(sysdsorg,1,2) <> "PO" then do
      say 'Dataset 'dsn' not partitioned'
      dsn = ""
      end
end
return
/*-------------------------------------------------------------------*/
/*                      End of Trydsn Procedure                      */
/*-------------------------------------------------------------------*/
/*-------------------------------------------------------------------*/
/*                        Disp_Help Procedure                        */
/*-------------------------------------------------------------------*/
Disp_Help: Procedure
say "DIRLIST -"
say""
say"  Displays a directory list of a PDS dataset."
say""
say "Usage: DIRLIST dsn | ?"
say""
say"    ?        - Generates this information."
say""
say"   Return Codes :"
say"                 0 - PDS listed or <QUIT> entered"
say"                 4 - Help displayed"
say"                16 - Not under ISPF"
say""
Return
/*-------------------------------------------------------------------*/
/*                    End of Disp_Help Procedure                     */
/*-------------------------------------------------------------------*/
/*-------------------------------------------------------------------*/
/*                      Trap NOVALUE Condition                       */
/*-------------------------------------------------------------------*/
novalue:
say "NOVALUE entered from line" sigl
say condition("D")
say "The instruction is suppressed"
address "TSO"
"delstack"
exit(16)
/*-------------------------------------------------------------------*/
/*                        Trap HALT Condition                        */
/*-------------------------------------------------------------------*/
halt:
say "HALT acknowledged in line" sigl
say "Cleanup processing in progress"
address "TSO"
"delstack"
exit(16)
/*-------------------------------------------------------------------*/
/*                          End of DIRLIST                           */
/*-------------------------------------------------------------------*/
./ ADD NAME=EDITREC
/* rexx */
/*-------------------------------------------------------------------*/
/*                                                                   */
/*                        REXX Exec : EDITREC                        */
/*                                                                   */
/*  Description : Call IBM edit recovery services in case the user   */
/*                crashed while editing in a previous life.          */
/*                                                                   */
/*  Created on : 23 Jan 2019                                         */
/*  Created by : Kevin Ferguson                                      */
/*             : Userid(MIT001)                                      */
/*             : using ABBYDALE.DEVL.REXX(EDITREC)                   */
/*                                                                   */
/*  Called by : Several Rexx Execs                                   */
/*                                                                   */
/*  Calls : EDREC                                                    */
/*                                                                   */
/*  Change Activity :                                                */
/*                                                                   */
/*                ©Copyright of Abbydale Systems LLC.                */
/*                                                                   */
/*-------------------------------------------------------------------*/
EditRec:
Address TSO
Done = "n"
Do Until Done = "y"
   rc = 0
   address ISPEXEC "EDREC QUERY"
   if rc = 4 then do
      address ISPEXEC "DISPLAY PANEL(ISREDM02)"
      Select
         When (ZEDCMD = C) then do
            address ISPEXEC "EDREC CANCEL"
            ZEDSMSG = 'Recovery Cancelled'
            ZEDLMSG = 'Dataset 'Z1' Recovery Cancelled'
            address ISPEXEC 'SETMSG MSG(ISRZ001)'
            end
         When (ZEDCMD = D) then do
            address ISPEXEC "EDREC DEFER"
            ZEDSMSG = 'Recovery Defered'
            ZEDLMSG = 'Dataset 'Z1' Recovery defered'
            address ISPEXEC 'SETMSG MSG(ISRZ001)'
            end
         Otherwise +
            Do
            address ISPEXEC "EDREC PROCESS"
            If rc > 0 Then do
               ZEDSMSG = 'Severe Error'
               ZEDLMSG = Z1' Recovery had a Severe Error'
               address ISPEXEC 'SETMSG MSG(ISRZ001)'
            End
            End
      End  /* End of Selects */
  End
  Else Done = "y"
End
/*-------------------------------------------------------------------*/
/*                          End of EDITREC                           */
/*-------------------------------------------------------------------*/
./ ADD NAME=FINDIT
/* rexx */
/*-------------------------------------------------------------------*/
/*                                                                   */
/*                       REXX Exec : FINDIT                          */
/*                                                                   */
/*  Description : Checks for the existance of a REXX EXEC in the     */
/*                SYSEXEC or SYSPROC concatenation                   */
/*                                                                   */
/*  Created on : 31 Jul 2003                                         */
/*  Created by : Kevin Ferguson                                      */
/*             : Userid MIT001                                       */
/*             : Using ABBYDALE.PROD.REXX(FINDIT)                    */
/*                                                                   */
/*  Called by : ALIKE, MQDISP                                        */
/*                                                                   */
/*  Calls : SYSDSN                                                   */
/*                                                                   */
/*  Panels Used :  None                                              */
/*                                                                   */
/*  Change Activity :                                                */
/*                                                                   */
/*  Version 2 eliminates the LISTALC and navigates the TIOT instead  */
/*                                                                   */
/*                ©Copyright of Abbydale Systems LLC.                */
/*                                                                   */
/*-------------------------------------------------------------------*/
Parse Arg Help         /* Check for Help */
ISPF = "Y"
If SYSVAR("SYSISPF")<>"ACTIVE" then do
   ISPF = "N"
end
if ISPF = "Y" then do
   Address ISREDIT "MACRO (Help) PROCESS"
End
If Help = "?" then do
   Call Disp_Help
   exit(4)
end
Mac = "N"
if ISPF = "Y" then do
   Address ISREDIT "(mac)  = MACRO_LEVEL"
   if mac <> "MAC" then do
      Mac = "Y"
   end
end
signal on novalue      /* un-initialized vars*/
signal on halt         /* attention key      */
Mbr = Help
doit = "n"
tcb      = ptr(540)                    /* Address of TCB (PSATOLD)  */
jscb     = ptr(tcb+180)                /* Jscb tcbjscb              */
tiot     = ptr(tcb+12)                 /* Address of TIOT (TCBTIO)  */
tioentry = tiot+24                     /* Address of 1st TIOT entry */
tioelngh = C2D(stg(tioentry, 1))       /* TIOT entry length         */
parse upper var Mbr Mbr
mrc = 8
found = 0
do until tioelngh == 0
   thisddname = strip(stg(tioentry+4,8))
   if left(thisddname, 1) == '00'x then do /* Valid DD entry?       */
      tioentry = tioentry+tioelngh         /* Next TIOT entry       */
      tioelngh = c2d(stg(tioentry, 1))     /* TIOT entry length     */
      iterate
   end
   if left(thisddname,1) = ' ' then do
      j = j + 1
   end
   else do
      doit = "y"
      j = 1
      if left(thisddname,3) = 'ISP' then do
         if substr(thisddname,4,1) > "Z" then doit = "n"
      end
      if left(thisddname,3) = 'SYS' then do
         if substr(thisddname,4,1) > "Z" then doit = "n"
      end
/* if left(thisddname, 1) \= ' ' then do      a new DD found */
      myddn = thisddname
   end
   if doit = "y" then do                /* Is it ours?           */
      svatoken = stg(tioentry+12,3)    /* TIOEJFCB SVA address token*/
      jfcb = swareq(svatoken)          /* Convert into JFCB address */
      dsname   = stg(jfcb, 44)         /* dataset name */
      dsname   = strip(dsname,'T')
      TrapON=OutTrap('ON')
      DSN_STATUS = SYSDSN("'"dsname||'('||Mbr||')'"'")
      TrapON=OutTrap('OFF')
      if DSN_STATUS = 'OK' then do
         found = found + 1
         say mbr 'is in the 'myddn 'concatenation('j')'
         say mbr 'is in 'dsname
         if Mac = "Y" then do
            ZEDSMSG = Mbr "Found"
            ZEDLMSG = Mbr "found in" dsname
            ZDLREF = 'Y'
            Address ISPEXEC "VPUT (ZDLMSG ZDLMSG) SHARED"
            Address ISPEXEC "SETMSG MSG(ISRZ001)"
            mrc = 0
         end
      end
   end
   tioentry = tioentry+tioelngh       /*Next TIOT entry*/
   tioelngh  = c2d(stg(tioentry, 1))  /*TIOT entry length */
end
If mrc <> 0 then do
   ZEDSMSG = Mbr "Not found"
   ZEDLMSG = Mbr "Not found in SYSEXEC nor SYSPROC concatentaions"
   ZDLREF = 'Y'
   Address ISPEXEC "VPUT (ZDLMSG ZDLMSG) SHARED"
   Address ISPEXEC "SETMSG MSG(ISRZ001)"
end
EXIT mrc
ptr: Return C2D(storage(D2X(ARG(1)),4))
stg: Return storage(d2x(arg(1)),arg(2))
swareq:
parse arg svatoken
if right(c2x(svatoken),1) \= 'F' then  /* Swa=Below ?   */
   thisjfcb = c2d(svatoken)+16
else do                                 /* SWA is above 16MB line. */
   sva      = c2d(svatoken)             /* Convert to decimal      */
   nextqmat = qmat
   do while sva>65536
      nextqmat = ptr(nextqmat+12)       /* Next qmat qmat+12      */
      sva=sva-65536                     /* 010006F -> 000006F     */
   end
   thisjfcb = ptr(qmat+sva+1)+16        /* JFCB in 31 bit address */
end
return thisjfcb
/*-------------------------------------------------------------------*/
/*                        Disp_Help Procedure                        */
/*-------------------------------------------------------------------*/
Disp_Help: Procedure
say "FINDIT   - Checks for the existance of a REXX exec"
say""
say "Usage: FINDIT   xxxxx | ?"
say""
say"    ?        - Generates this information."
say""
say"   Return Codes :"
say"                 0 - Rexx found"
say"                 4 - Help displayed"
say"                 8 - Rexx not found"
say""
Return
/*-------------------------------------------------------------------*/
/*                    End of Disp_Help Procedure                     */
/*-------------------------------------------------------------------*/
/*-------------------------------------------------------------------*/
/*                      Trap NOVALUE Condition                       */
/*-------------------------------------------------------------------*/
novalue:
say "NOVALUE entered from line" sigl
say condition("D")
say "The instruction is suppressed"
address "TSO"
"delstack"
exit(16)
/*-------------------------------------------------------------------*/
/*                        Trap HALT Condition                        */
/*-------------------------------------------------------------------*/
halt:
say "HALT acknowledged in line" sigl
say "Cleanup processing in progress"
address "TSO"
"delstack"
exit(16)
/*-------------------------------------------------------------------*/
/*                          End of FINDIT                            */
/*-------------------------------------------------------------------*/
./ ADD NAME=FINDMOD
/* rexx */
/*-------------------------------------------------------------------*/
/*                                                                   */
/*                        REXX Exec : FINDMOD                        */
/*                                                                   */
/*  Description : Searches STEPLIB, LPALIST and LINKLIST (in that    */
/*                order), for a module name passed as a parameter.   */
/*                                                                   */
/*  Created on : 9 Jan 2006                                          */
/*  Created by : Kevin Ferguson                                      */
/*             : Userid(MIT001)                                      */
/*             : using ABBYDALE.PROD.REXX(FINDMOD)                   */
/*                                                                   */
/*  Called by : XMITTER, XMITBAT                                     */
/*                                                                   */
/*  Calls :  LISTALC                                                 */
/*                                                                   */
/*  Return Codes : 0 - Module located                                */
/*                 4 - Help displyed                                 */
/*                 8 - Module not found                              */
/*                16 - Critical error                                */
/*                                                                   */
/*  Change Activity :                                                */
/*                                                                   */
/*                ©Copyright of Abbydale Systems LLC.                */
/*                                                                   */
/*-------------------------------------------------------------------*/
pee = ''
signal on novalue                /* un-initialized vars */
signal on halt                   /* attention key       */
dsn = ""
found = "n"
parse upper arg module show
help = "n"
if module = "" then do
   do while module = ""
   Say 'Enter module to find (use <QUIT> to terminate)'
   parse upper pull module
   if module = '<QUIT>' then exit
   if LENGTH(module) > 8 then do
      module = ""
      say 'Module name Length error. Re-enter'
   end
   end
   show = "b"
end
if module = "?" then do
   call disp_help
   exit(4)
end
Hit1 = "N"
X=Outtrap('Hline.')
Address TSO "LISTALC SY ST"
X=Outtrap('OFF')
Do I=2 to Hline.0
  If Left(Hline.I,2)='  ' then do
    X=Substr(Hline.I,3,8)
    If Left(X,1)<>' ' then do
      ddn = Strip(x)
      if ddn = "STEPLIB" then hit1 = "Y"
      if ddn <> "STEPLIB" then hit1 = "N"
    end
    If Left(Dsn,1)='*' Then Iterate
    If Left(Dsn,9)='TERMFILE ' Then Iterate
    If LEFT(Dsn,9)='NULLFILE ' Then Iterate
  end
  else do
    if hit1 = "Y" then do
       i = i - 2
       dsn=Hline.I
       i = i + 2
  address ISPEXEC "LMINIT DATAID(RES) DATASET('"dsn"') ENQ(SHR)"
  if rc <> 0 then say 'LMINIT error' zerrlm
  address ISPEXEC "LMOPEN DATAID("RES") OPTION(INPUT)"
  if rc <> 0 then say 'LMOPEN error' zerrlm
  address ISPEXEC "LMMFIND DATAID("RES") MEMBER("module")"
  if rc = 0 then do
     if show <> "" then do
     say 'found' module 'in 'ddn dsn
     end
     found = "y"
  end
  address ISPEXEC "LMCLOSE DATAID("RES")"
  address ISPEXEC "LMFREE DATAID("RES")"
  if found = "y" then exit
    end
  end
End
ddn = "LPALIST"
address "TSO"
numeric digits 10
cvt_ptr=get_ptr(10,)
cvtn     = c2d(storage(10,4))      /* address of cvt */
ecvt_ptr=get_ptr(cvt_ptr,'8c')     /* address of ecvt */
mcvt_ptr=get_ptr(cvt_ptr,'4ac')    /* address of cvtsmext */
plps_ptr=get_ptr(mcvt_ptr,'38')    /* address of cvteplps */
lpa_header = get_data(plps_ptr,'0',4)
lpa_count = get_data(plps_ptr,'4',4)
next_entry = d2x(x2d(plps_ptr) + 8)
lpa_entries = c2d(get_data(plps_ptr,4,4))
do i = 1 to lpa_entries
  entry_size   = 44
  entry_dsn    = get_data(next_entry,1,entry_size)
  entry_dsn    = strip(entry_dsn)
  address ISPEXEC "LMINIT DATAID(RES) DATASET('"entry_dsn"') ENQ(SHR)"
  if rc <> 0 then say 'LMINIT error' zerrlm
  address ISPEXEC "LMOPEN DATAID("RES") OPTION(INPUT)"
  if rc <> 0 then say 'LMOPEN error' zerrlm
  address ISPEXEC "LMMFIND DATAID("RES") MEMBER("module")"
  if rc = 0 then do
     if show <> "" then do
     say 'found' module 'in 'ddn entry_dsn
     end
     found = "y"
  end
  address ISPEXEC "LMCLOSE DATAID("RES")"
  address ISPEXEC "LMFREE DATAID("RES")"
  if found = "y" then exit
  next_entry = d2x(x2d(next_entry) + entry_size + 1)
end
ddn = "LINKLIST"
lnk_ptr=get_ptr(cvt_ptr,'4dc')     /* point to linklist */
next_entry = d2x(x2d(lnk_ptr) + 8)
x = 'n'
do until x = 'y'
  entry_size   = get_ptr(next_entry,0)
  entry_dsn    = get_data(next_entry,1,44)
  if entry_size = '80808080' then
          x = 'y'
  else
          do
  next_entry = d2x(x2d(next_entry) + 45)
  entry_dsn = strip(entry_dsn)
  address ISPEXEC "LMINIT DATAID(RES) DATASET('"entry_dsn"') ENQ(SHR)"
  if rc <> 0 then say 'LMINIT error' zerrlm
  address ISPEXEC "LMOPEN DATAID("RES") OPTION(INPUT)"
  if rc <> 0 then say 'LMOPEN error' zerrlm
  address ISPEXEC "LMMFIND DATAID("RES") MEMBER("module")"
  if rc = 0 then do
     if show <> "" then do
     say 'found' module 'in 'ddn entry_dsn
     end
     found = "y"
  end
  address ISPEXEC "LMCLOSE DATAID("RES")"
  address ISPEXEC "LMFREE DATAID("RES")"
  if found = "y" then exit
  end
end
if found = "Y" then do
   rc = 0
   end
   else do
   rc = 8
   if show <> "" then do
      say 'Module 'module 'not found'
   end
end
exit rc
/*-------------------------------------------------------------------*/
/*                       get_ptr procedure                           */
/*-------------------------------------------------------------------*/
get_ptr: procedure
arg addr,offset
temp=d2x(x2d(addr)+x2d(offset))
return c2x(storage(temp,4))
exit
/*-------------------------------------------------------------------*/
/*                       get_data procedure                          */
/*-------------------------------------------------------------------*/
get_data: procedure
arg addr,offset,length
temp=d2x(x2d(addr)+x2d(offset))
return storage(temp,length)
exit
/*-------------------------------------------------------------------*/
/*                      disp_help procedure                          */
/*-------------------------------------------------------------------*/
disp_help: procedure
pgm_name=sysvar("sysicmd")
if pgm_name="" then pgm_name="name"
say left(pgm_name,8) "- a REXX exec that will locate a load module."
say ""
say "Usage: FINDMOD module list | ? "
say ""
say "     module - Specifies the name of the module to locate."
say "     list   - (optional). If anything is passed as a second"
say "              parameter then a message is displayed showing"
say "              which library the module was found in."
say "     ?      - generates this information."
say ""
say "    The search order is:"
say "       STEPLIB"
say "       LPALIST"
say "       LINKLIST"
say ""
say "    The exec will stop searching once it finds the "
say "    specified module."
say ""
say "    Return Codes : 0 - Module located"
say "                   4 - Help displayed"
say "                   8 - Module not found"
Say "                  16 - Critical error"
return
/*-------------------------------------------------------------------*/
/*                      trap NOVALUE condition                       */
/*-------------------------------------------------------------------*/
novalue:
say 'NOVALUE entered from line' sigl
say condition("D")
say 'The instruction is suppressed'
address "TSO"
"delstack"
exit(16)
/*-------------------------------------------------------------------*/
/*                        trap HALT condition                        */
/*-------------------------------------------------------------------*/
halt:
say 'HALT acknowledged in line' sigl
say 'Cleanup processing in progress'
address "TSO"
"delstack"
exit(16)
/*-------------------------------------------------------------------*/
/*                          End of FINDMOD                           */
/*-------------------------------------------------------------------*/
./ ADD NAME=FINDREXX
/* rexx */
/*-------------------------------------------------------------------*/
/*                                                                   */
/*                       REXX Exec : FINDREXX                        */
/*                                                                   */
/*  Description : Checks for the existance of a REXX EXEC in the     */
/*                SYSEXEC or SYSPROC concatenation                   */
/*                                                                   */
/*  Created on : 31 Jul 2003                                         */
/*  Created by : Kevin Ferguson                                      */
/*             : Userid MIT001                                       */
/*             : Using ABBYDALE.PROD.REXX(FINDREXX)                  */
/*                                                                   */
/*  Called by : ALIKE, MQDISP                                        */
/*                                                                   */
/*  Calls : SYSDSN                                                   */
/*                                                                   */
/*  Panels Used :  None                                              */
/*                                                                   */
/*  Change Activity :                                                */
/*                                                                   */
/*                ©Copyright of Abbydale Systems LLC.                */
/*                                                                   */
/*-------------------------------------------------------------------*/
Parse Arg Help         /* Check for Help */
ISPF = "Y"
If SYSVAR("SYSISPF")<>"ACTIVE" then do
   ISPF = "N"
end
if ISPF = "Y" then do
   Address ISREDIT "MACRO (Help) PROCESS"
End
If Help = "?" then do
   Call Disp_Help
   exit(4)
end
Mac = "N"
if ISPF = "Y" then do
   Address ISREDIT "(mac)  = MACRO_LEVEL"
   if mac <> "MAC" then do
      Mac = "Y"
   end
end
signal on novalue      /* un-initialized vars*/
signal on halt         /* attention key      */
Mbr = Help
doit = "n"
tcb      = ptr(540)                    /* Address of TCB (PSATOLD)  */
jscb     = ptr(tcb+180)                /* Jscb tcbjscb              */
tiot     = ptr(tcb+12)                 /* Address of TIOT (TCBTIO)  */
tioentry = tiot+24                     /* Address of 1st TIOT entry */
tioelngh = C2D(stg(tioentry, 1))       /* TIOT entry length         */
parse upper var Mbr Mbr
mrc = 8
found = 0
do until tioelngh == 0
   thisddname = strip(stg(tioentry+4,8))
   if left(thisddname, 1) == '00'x then do /* Valid DD entry?       */
      tioentry = tioentry+tioelngh         /* Next TIOT entry       */
      tioelngh = c2d(stg(tioentry, 1))     /* TIOT entry length     */
      iterate
   end
   if left(thisddname, 1) \= ' ' then do   /* a new DD found */
      select
         When thisddname = "SYSEXEC" then do
            myddn = thisddname
            doit = "y"
            end
         When thisddname = "SYSPRIC" then do
            myddn = thisddname
            doit = "y"
            end
         otherwise doit="n"
      end
   end
   if doit = "y" then do                /* Is it ours?           */
      svatoken = stg(tioentry+12,3)    /* TIOEJFCB SVA address token*/
      jfcb = swareq(svatoken)          /* Convert into JFCB address */
      dsname   = stg(jfcb, 44)         /* dataset name */
      dsname   = strip(dsname,'T')
      TrapON=OutTrap('ON')
      DSN_STATUS = SYSDSN("'"dsname||'('||Mbr||')'"'")
      TrapON=OutTrap('OFF')
      if DSN_STATUS = 'OK' then do
         found = found + 1
         if Mac = "Y" then do
            ZEDSMSG = Mbr "Found"
            ZEDLMSG = Mbr "found in" dsname
            ZDLREF = 'Y'
            Address ISPEXEC "VPUT (ZDLMSG ZDLMSG) SHARED"
            Address ISPEXEC "SETMSG MSG(ISRZ001)"
            mrc = 0
            exit mrc
         end
      end
   end
   tioentry = tioentry+tioelngh       /*Next TIOT entry*/
   tioelngh  = c2d(stg(tioentry, 1))  /*TIOT entry length */
end
If Mac = "Y" then do
   ZEDSMSG = Mbr "Not found"
   ZEDLMSG = Mbr "Not found in SYSEXEC nor SYSPROC concatentaions"
   ZDLREF = 'Y'
   Address ISPEXEC "VPUT (ZDLMSG ZDLMSG) SHARED"
   Address ISPEXEC "SETMSG MSG(ISRZ001)"
end
EXIT mrc
ptr: Return C2D(storage(D2X(ARG(1)),4))
stg: Return storage(d2x(arg(1)),arg(2))
swareq:
parse arg svatoken
if right(c2x(svatoken),1) \= 'F' then  /* Swa=Below ?   */
   thisjfcb = c2d(svatoken)+16
else do                                 /* SWA is above 16MB line. */
   sva      = c2d(svatoken)             /* Convert to decimal      */
   nextqmat = qmat
   do while sva>65536
      nextqmat = ptr(nextqmat+12)       /* Next qmat qmat+12      */
      sva=sva-65536                     /* 010006F -> 000006F     */
   end
   thisjfcb = ptr(qmat+sva+1)+16        /* JFCB in 31 bit address */
end
return thisjfcb
/*-------------------------------------------------------------------*/
/*                        Disp_Help Procedure                        */
/*-------------------------------------------------------------------*/
Disp_Help: Procedure
say "FINDREXX - Checks for the existance of a REXX exec"
say""
say "Usage: FINDREXX xxxxx | ?"
say""
say"    ?        - Generates this information."
say""
say"   Return Codes :"
say"                 0 - Rexx found"
say"                 4 - Help displayed"
say"                 8 - Rexx not found"
say""
Return
/*-------------------------------------------------------------------*/
/*                    End of Disp_Help Procedure                     */
/*-------------------------------------------------------------------*/
/*-------------------------------------------------------------------*/
/*                      Trap NOVALUE Condition                       */
/*-------------------------------------------------------------------*/
novalue:
say "NOVALUE entered from line" sigl
say condition("D")
say "The instruction is suppressed"
address "TSO"
"delstack"
exit(16)
/*-------------------------------------------------------------------*/
/*                        Trap HALT Condition                        */
/*-------------------------------------------------------------------*/
halt:
say "HALT acknowledged in line" sigl
say "Cleanup processing in progress"
address "TSO"
"delstack"
exit(16)
/*-------------------------------------------------------------------*/
/*                          End of FINDREXX                          */
/*-------------------------------------------------------------------*/
./ ADD NAME=GETDSN
/* rexx */
/*-------------------------------------------------------------------*/
/*                                                                   */
/*                        REXX Exec : GETDSN                         */
/*                                                                   */
/*  Description : Get the dataset associated with a DD card          */
/*                                                                   */
/*  Created on : 16 Apr 2022                                         */
/*  Created by : Wendy Miller                                        */
/*             : Userid MIT002                                       */
/*             : Using ABBYDALE.DEVL.REXX(GETDSN)                    */
/*                                                                   */
/*  Called by : PRODVERS                                             */
/*                                                                   */
/*  Calls :                                                          */
/*                                                                   */
/*  Panels Used :                                                    */
/*                                                                   */
/*  Change Activity :                                                */
/*                                                                   */
/*                ©Copyright of Abbydale Systems LLC.                */
/*                                                                   */
/*-------------------------------------------------------------------*/
Parse upper Arg Help pool    /* Check for Help */
If Help = "?" Then do
   Call Disp_Help
   exit(4)
end
signal on halt         /* attention key      */
tcb      = ptr(540)                    /* Address of TCB (PSATOLD)  */
jscb     = ptr(tcb+180)                /* Jscb tcbjscb              */
tiot     = ptr(tcb+12)                 /* Address of TIOT (TCBTIO)  */
tioentry = tiot+24                     /* Address of 1st TIOT entry */
tioelngh = C2D(stg(tioentry, 1))       /* TIOT entry length         */
if Help = "" then do
   do forever
      Say "DDName to check. Enter <END> or <QUIT> to exit"
      parse upper pull Ans
      if Ans = "<QUIT>" then exit(8)
      if Ans = "<END>" then exit(8)
      if length(ans) > 8 then do
         say "Invalid DDname entered."
      end
      else do
         if substr(Ans,1,1) > 0 then do
            say "Invalid character found in DDNAME"
         end
         else do
            leave
         end
      end
   end
end
else do
   ans = help
end
found = 0
do until tioelngh == 0
   thisddname = strip(stg(tioentry+4,8))
   if left(thisddname, 1) == '00'x then do /* Valid DD entry?       */
      tioentry = tioentry+tioelngh         /* Next TIOT entry       */
      tioelngh = c2d(stg(tioentry, 1))     /* TIOT entry length     */
      iterate
   end
   if thisddname = Ans then do             /* Is it ours?           */
      svatoken = stg(tioentry+12,3)    /* TIOEJFCB SVA address token*/
      jfcb = swareq(svatoken)          /* Convert into JFCB address */
      dsname   = stg(jfcb, 44)         /* dataset name */
      dsname   = strip(dsname,'T')
      found = 1
      leave
   end
   tioentry = tioentry+tioelngh       /*Next TIOT entry*/
   tioelngh  = c2d(stg(tioentry, 1))  /*TIOT entry length */
end
if found = 0 then do
   xdsn = "DDNAME not found"
end
else do
   xdsn = dsname
end
xdsn = strip(xdsn)
if Help = "" then do
   say xdsn
end
else do
   push xdsn
end
return
ptr: Return C2D(storage(D2X(ARG(1)),4))
stg: Return storage(d2x(arg(1)),arg(2))
swareq:
parse arg svatoken
if right(c2x(svatoken),1) \= 'F' then  /* Swa=Below ?   */
   thisjfcb = c2d(svatoken)+16
else do                                 /* SWA is above 16MB line. */
   sva      = c2d(svatoken)             /* Convert to decimal      */
   nextqmat = qmat
   do while sva>65536
      nextqmat = ptr(nextqmat+12)       /* Next qmat qmat+12      */
      sva=sva-65536                     /* 010006F -> 000006F     */
   end
   thisjfcb = ptr(qmat+sva+1)+16        /* JFCB in 31 bit address */
end
return thisjfcb
/*-------------------------------------------------------------------*/
/*                        Disp_Help Procedure                        */
/*-------------------------------------------------------------------*/
Disp_Help: Procedure
say "GETDSN -"
say""
say "Usage: GETDSN xxxxx | ?"
say""
say"    ?        - Generates this information."
say""
say"   Return Codes :"
say"                 4 - Help displayed"
say"                16 - Not under ISPF"
say""
Return
/*-------------------------------------------------------------------*/
/*                    End of Disp_Help Procedure                     */
/*-------------------------------------------------------------------*/
/*-------------------------------------------------------------------*/
/*                        Trap HALT Condition                        */
/*-------------------------------------------------------------------*/
halt:
say "HALT acknowledged in line" sigl
say "Cleanup processing in progress"
address "TSO"
"delstack"
exit(16)
/*-------------------------------------------------------------------*/
/*                           End of GETDSN                           */
/*-------------------------------------------------------------------*/
./ ADD NAME=GETPROF
/* rexx */
/*-------------------------------------------------------------------*/
/*                                                                   */
/*                        REXX Exec : GETPROF                        */
/*                                                                   */
/*  Description : Returns the prefix being used by a user. Returns   */
/*                "N" if NOPREFIX is defined.                        */
/*                                                                   */
/*  Created on : 10 May 2017                                         */
/*  Created by : KEVIN FERGUSON                                      */
/*             : Userid(MIT001)                                      */
/*             : using ABBYDALE.DEVL.REXX(GETPROF)                   */
/*                                                                   */
/*  Called by : VU, ZAPVTOC                                          */
/*                                                                   */
/*  Calls :                                                          */
/*                                                                   */
/*  Change Activity :                                                */
/*                                                                   */
/*                ©Copyright of Abbydale Systems LLC.                */
/*                                                                   */
/*-------------------------------------------------------------------*/
Parse Arg Help         /* Check for Help */
If SYSVAR("SYSISPF")<>"ACTIVE" then do
   Say "ISPF must be active to use "GETPROF
   exit(16)
end
If Help = "?" Then do
   Call Disp_Help
   exit(4)
end
signal on novalue      /* un-initialized vars*/
signal on halt         /* attention key      */
Get_Prof:
parse arg Prof
x = Outtrap("Profile",1)
"profile"
if POS("NOPREFIX",profile1) = 0 then do
    x = POS("FIX(",profile1)+4
    pr = SUBSTR(profile1,x,8)
    y = POS(")",pr)
    Prof = SUBSTR(pr,1,y-1)
end
else do
    Prof='N'
end
return Prof
/*-------------------------------------------------------------------*/
/*                        Disp_Help Procedure                        */
/*-------------------------------------------------------------------*/
Disp_Help: Procedure
say "GETPROF -"
say""
say " GETPROF will return the prefix that is being used by the USERID."
say " This can be used to reset the profile in a Rexx exec to what it"
say " was when the Rexx exec started. If PROFILE NOPREFIX is used it "
say " will return 'N' as the value."
say""
say "Usage: var = GETPROF(var) or Getprof ?"
say""
say"    ?        - Generates this information."
say""
say"   Return Codes :"
say"                 4 - Help displayed"
say"                16 - Not under ISPF"
say""
Return
/*-------------------------------------------------------------------*/
/*                    End of Disp_Help Procedure                     */
/*-------------------------------------------------------------------*/
/*-------------------------------------------------------------------*/
/*                      Trap NOVALUE Condition                       */
/*-------------------------------------------------------------------*/
novalue:
say "NOVALUE entered from line" sigl
say condition("D")
say "The instruction is suppressed"
address "TSO"
"delstack"
exit(16)
/*-------------------------------------------------------------------*/
/*                        Trap HALT Condition                        */
/*-------------------------------------------------------------------*/
halt:
say "HALT acknowledged in line" sigl
say "Cleanup processing in progress"
address "TSO"
"delstack"
exit(16)
/*-------------------------------------------------------------------*/
/*                          End of GETPROF                           */
/*-------------------------------------------------------------------*/
./ ADD NAME=ISDATE
/* rexx */
/*-------------------------------------------------------------------*/
/*                                                                   */
/*                        REXX Exec : ISDATE                         */
/*                                                                   */
/*  Description : Checks a passed string to see if it is a valid     */
/*                date or not.                                       */
/*                                                                   */
/*  Created on : 15 Oct 2018                                         */
/*  Created by : Kevin Ferguson                                      */
/*             : Userid MIT001                                       */
/*             : Using ABBYDALE.DEVL.REXX(ISDATE)                    */
/*                                                                   */
/*  Called by :                                                      */
/*                                                                   */
/*  Calls : CountStr                                                 */
/*                                                                   */
/*  Panels Used : None                                               */
/*                                                                   */
/*  Return Codes : 0 - Date is valid                                 */
/*                 4 - Help displayed                                */
/*                 8 - Date is invalid                               */
/*                12 - Incorrect date format                         */
/*                                                                   */
/*  Change Activity :                                                */
/*                                                                   */
/*  MM/DD/YYYY  ID   Comment                                         */
/*  ---------------------------------------------------------------  */
/*  05/15/2019  DSF  Changed to allow for dates in the local date    */
/*                   format (dd mmm yyyy) i.e 5 May 2019             */
/*                                                                   */
/*                ©Copyright of Abbydale Systems LLC.                */
/*                                                                   */
/*-------------------------------------------------------------------*/
Parse upper Arg Help DateForm                    /* Check for Help */
testdate = ARG(1)
Dateform = ARG(2)
signal on halt         /* attention key      */
upper testdate
upper dateform
mon.1 = 31          /* Days in January       */
mon.2 = 28          /* Days in February      */
mon.3 = 31          /* Days in March         */
mon.4 = 30          /* Days in April         */
mon.5 = 31          /* Days in May           */
mon.6 = 30          /* Days in June          */
mon.7 = 31          /* Days in July          */
mon.8 = 31          /* Days in August        */
mon.9 = 30          /* Days in September     */
mon.10 = 31         /* Days in October       */
mon.11 = 30         /* Days in November      */
mon.12 = 31         /* Days in December      */
daysfirst = "N"
mnn.1 = 'January'   /* January                                   DSF */
mnn.2 = 'February'  /* February                                  DSF */
mnn.3 = 'March'     /* March                                     DSF */
mnn.4 = 'April'     /* April                                     DSF */
mnn.5 = 'May'       /* May                                       DSF */
mnn.6 = 'June'      /* June                                      DSF */
mnn.7 = 'July'      /* July                                      DSF */
mnn.8 = 'August'    /* August                                    DSF */
mnn.9 = 'September' /* September                                 DSF */
mnn.10 = 'October'  /* October                                   DSF */
mnn.11 = 'November' /* November                                  DSF */
mnn.12 = 'December' /* December                                  DSF */
daysfirst = "N"
If Help = "?" Then do
   Call Disp_Help
   exit(4)
end
term = 8
type = 2
if length(Dateform) <> 0 then do
   term = 12
   if DATATYPE(DateForm,U) = 0 then exit(term)
   if length(DateForm) <> 8 then exit(term)
   select
      WHEN DateForm = "DDMMYYYY" then do
         type = 1
      end
      WHEN DateForm = "MMDDYYYY" then do
         type = 2
      end
      WHEN DateForm = "YYYYMMDD" then do
         type = 3
      end
      WHEN DateForm = "YYYYDDMM" then do
         type = 4
      end
      otherwise
         exit(term)
   end
end
term = 8                       /* Set bad date return code */
testdate = strip(testdate,b,'"')
testdate = strip(testdate,b,"'")
if POS('/',testdate) = 0 then do                                /*DSF*/
   if words(testdate) <> 3 then exit(term)                      /*DSF*/
   if length(word(testdate,2)) <> 3 then exit(term)             /*DSF*/
   if length(word(testdate,3)) <> 4 then exit(term)             /*DSF*/
   if datatype(word(testdate,3),n) <> 1 then exit(term)         /*DSF*/
   if datatype(word(testdate,1),n) <> 1 then exit(term)         /*DSF*/
   if datatype(word(testdate,2),m) <> 1 then exit(term)         /*DSF*/
   month = "DSF"                                                /*DSF*/
   testmon = translate(word(testdate,2))                        /*DSF*/
   Do I = 1 to 12                                               /*DSF*/
      testi = translate(mnn.i)                                  /*DSF*/
      If testmon = LEFT(testi,3) then do                        /*DSF*/
         month = i                                              /*DSF*/
         I = 12                                                 /*DSF*/
      end                                                       /*DSF*/
   end                                                          /*DSF*/
   if month = "DSF" then exit(term)                             /*DSF*/
   testdate = word(testdate,1)"/"month"/"word(testdate,3)       /*DSF*/
   type = 1                                                     /*DSF*/
end                                                             /*DSF*/
if length(testdate) > 10 then exit(term)
if length(testdate) < 8  then exit(term)
/*
     We now know the date length is good(ish) 8 < testdate < 10
                                                           */
dimindx = 1                    /* Point at start of string */
stringtest = testdate          /* Point at end of string   */
chunks = 0                     /* Count of seperators      */
if countstr('/',stringtest) <> 2 then exit(term)
gauge = 2                      /* Moving start             */
do i = 1 to 3
   if pos('/',stringtest) > 0 then do
      gauge = pos('/',stringtest)
      dim.dimindx = SUBSTR(stringtest,1,gauge-1)
      if DATATYPE(Dim.dimindx,N) = 0 then exit(term)
      kf = length(stringtest)-(Pos('/',stringtest))
      stringtest = substr(stringtest,gauge+1, kf)
      dimindx = dimindx + 1
   end
   else do
      dim.dimindx = stringtest
   end
end     /* Do loop end */
select
   WHEN type = 1 then do
        day = dim.1
        month = dim.2
        year  = dim.3
   end
   WHEN type = 2 then do
        day = dim.2
        month = dim.1
        year  = dim.3
   end
   WHEN type = 3 then do
        day = dim.3
        month = dim.2
        year  = dim.1
   end
   WHEN type = 4 then do
        day = dim.2
        month = dim.3
        year  = dim.1
   end
      otherwise
         exit(term)
end
/*
         At this point we have all we need to check the validity
*/
If year < 1753 then exit(term)           /* No dates less that 1753 */
If month > 12 then exit(term)            /* no month higher than 12 */
month = month + 0                        /* This drop the leading 0 */
leap = year//4
if leap = 0 then do
   mon.2 = "29"
   if year//100 = 0 then do
      mon.2 = "28"
      if year//400 = 0 then mon.2 = "29"
      end
   else do
      if year//400 = 0 then do
         mon.2 = "29"
      end
   end
end
If day > mon.month then exit(term)    /* check days in month     */
term = 0
exit(term)
/*-------------------------------------------------------------------*/
/*                        Disp_Help Procedure                        */
/*-------------------------------------------------------------------*/
Disp_Help: Procedure
say "ISDATE - Will validate a date passed to it."
say""
say "Usage: ISDATE (testdate, dateform) | ?"
say""
say"    testdate - Is the date to be checked. It should have /s"
say"               to deliniate the day, month and year. The format"
say"               can be controlled by the optional dateformat"
say"               parameter."
say""
say"    dateform - (optional) defines the input format for the date"
say"               minus the /s ie. DDMMYYYY. The default is mMDDYYYY"
say""
say"    ?        - Generates this information."
say""
say"   Return Codes :"
say"                 0 - Passed date is a valid"
say"                 4 - Help displayed"
say"                 8 - Passed date is invalid"
say"                12 - Invalid format for date format"
say""
Return
/*-------------------------------------------------------------------*/
/*                    End of Disp_Help Procedure                     */
/*-------------------------------------------------------------------*/
/*-------------------------------------------------------------------*/
/*                        Trap HALT Condition                        */
/*-------------------------------------------------------------------*/
halt:
say "HALT acknowledged in line" sigl
say "Cleanup processing in progress"
address "TSO"
"delstack"
exit(16)
/*-------------------------------------------------------------------*/
/*                           End of ISDATE                           */
/*-------------------------------------------------------------------*/
./ ADD NAME=ISITREXX
/* rexx */
/*-------------------------------------------------------------------*/
/*                                                                   */
/*                       REXX Exec : ISITREXX                        */
/*                                                                   */
/*  Description : Test to see if the member is a rexx exec or not    */
/*                                                                   */
/*  Created on : 3 Jul 2021                                          */
/*  Created by : Kevin Ferguson                                      */
/*             : Userid MIT001                                       */
/*             : Using ABBYDALE.DEVL.REXX(ISITREXX)                  */
/*                                                                   */
/*  Called by :                                                      */
/*                                                                   */
/*  Calls : CHECKDSN                                                 */
/*                                                                   */
/*  Panels Used :                                                    */
/*                                                                   */
/*  Change Activity :                                                */
/*                                                                   */
/*                ©Copyright of Abbydale Systems LLC.                */
/*                                                                   */
/*-------------------------------------------------------------------*/
pee = ''
parse upper arg  member dsname
If SYSVAR("SYSISPF")<>"ACTIVE" then do
   Say "ISPF must be active to use "ISITREXX
   exit(16)
end
If member = "?" Then do
   Call Disp_Help
   exit(4)
end
do while member = ""
   say 'Enter member name. (use QUIT to terminate)'
   pull memx
   parse upper var memx
   if memx = "QUIT" then exit
   if memx = "EXIT" then exit
   if length(memx) > 8 then do
      say 'Invalid member name length. Please re-enter'
   end
   else do
      member = memx
   end
end
If length(member) > 8 then do
   exit 12
end
do while dsname = ""
   say 'Enter dataset name. (use QUIT to terminate)'
   pull dsnx
   parse upper var dsnx
   if dsnx = "QUIT" then exit
   if dsnx = "EXIT" then exit
   if length(dsnx) > 44 then do
      say 'Invalid dataset name length. Please re-enter'
   end
   else do
      checkdsn dsnx
      if rc = 0 then do
         dsname = dsnx
      end
      else do
         say 'Invalid dataset. Please re-enter'
      end
   end
end
checkdsn dsname
if rc > 0 then do
   exit 10
end
asl  = outtrap('on')
DSN_STATUS = LISTDSI(''''dsname'''' smsinfo)
asl  = outtrap('off')
if substr(sysdsorg,1,2) <> "PO" then do
   say 'Invalid DSORG'
   exit 18
end
rdsn = dsname'('member')'  /* construct correct dataset name */
IsRexx = "N"               /* set default as not rexx */
/*-------------------------------------------------------------------*/
/*  Now we are going to open the member and do some checking. This   */
/*  check will be based on a some fairly standard rexx type command  */
/*  formats viz the presence of the word rexx or rexx comments and   */
/*-------------------------------------------------------------------*/
"ALLOC F(TESTMEM) DA('"rdsn"') SHR REUS"
"EXECIO * DISKR TESTMEM (STEM testit. FINIS"
linecnt = testit.0
slashpos = 0
do k = 1 to linecnt
   if POS('/*',testit.k) > 0 then do
      if POS('*/',testit.k) > 0 then do
         if POS('rexx',testit.k) > 0 then do
            IsRexx = "Y"
            leave
         end
      end
      else do
         slashpos = k
      end
   end
   if POS('*/',testit.k) > 0 then do
      if slashpos > 0 then do
         IsRexx = "Y"
         leave
      end
   end
   if POS('signal on',testit.k) > 0 then do
      IsRexx = "Y"
      leave
   end
end
"FREE F(TESTMEM)"
if IsRexx = "Y" then do
   myRC = 0
end
else do
   myRC = 8
end
exit myRC
signal on novalue      /* un-initialized vars*/
signal on halt         /* attention key      */
/*-------------------------------------------------------------------*/
/*                        Disp_Help Procedure                        */
/*-------------------------------------------------------------------*/
Disp_Help: Procedure
say "ISITREXX - Tests to see if the passed member in the passed dataset"
say "           is a rexx exec or not"
say""
say "Usage: ISITREXX member dataset | ?"
say""
say"    member   - The member name to be checked."
say"    dataset  - The name of the dataset containing the member."
say""
say"    The Rexx exec requires a member name and dataset name is passed"
say"    to it, otherwise it will request them from user."
say""
say"    The dataset orgranisation must be a partitioned dataset"
say" "
say"    ?        - Generates this information."
say""
say"   Return Codes :"
say""
say"                 0 - Member is a rexx exec"
say"                 4 - Help displayed"
say"                 8 - Member is not a rexx exec"
say"                10 - Passed dsname is invalid"
say"                12 - Invalid member name"
say"                16 - Logic error"
say"                18 - Invalid dataset organisation"
say""
Return
/*-------------------------------------------------------------------*/
/*                    End of Disp_Help Procedure                     */
/*-------------------------------------------------------------------*/
/*                      Trap NOVALUE Condition                       */
/*-------------------------------------------------------------------*/
novalue:
say "NOVALUE entered from line" sigl
say condition("D")
say "The instruction is suppressed"
address "TSO"
"delstack"
exit(16)
/*-------------------------------------------------------------------*/
/*                        Trap HALT Condition                        */
/*-------------------------------------------------------------------*/
halt:
say "HALT acknowledged in line" sigl
say "Cleanup processing in progress"
address "TSO"
"delstack"
exit(16)
/*-------------------------------------------------------------------*/
/*                          End of ISITREXX                          */
/*-------------------------------------------------------------------*/
./ ADD NAME=JOBID
/* rexx */
/*-------------------------------------------------------------------*/
/*                                                                   */
/*                         REXX Exec : JOBID                         */
/*                                                                   */
/*  Description : Returns the jobid of the task running this exec.   */
/*                                                                   */
/*  Created on : 1 Apr 2018                                          */
/*  Created by : KEVIN FERGUSON                                      */
/*             : Userid(MIT001)                                      */
/*             : using ABBYDALE.XFER.REXX(JOBID)                     */
/*                                                                   */
/*  Called by :                                                      */
/*                                                                   */
/*  Calls :                                                          */
/*                                                                   */
/*  Change Activity :                                                */
/*                                                                   */
/*                ©Copyright of Abbydale Systems LLC.                */
/*                                                                   */
/*-------------------------------------------------------------------*/
CVT = storage(10,4)      /* FLCCVT-PSA DATA AREA */
TCBP = storage(D2X(C2D(CVT)),4)         /* CVTTCBP */
TCB = storage(D2X(C2D(TCBP)+4),4)
JSCB = STORAGE(D2X(C2D(TCB)+180), 4)
SSIB = STORAGE(D2X(C2D(JSCB)+316), 4)
jobno = STORAGE(D2X(C2D(SSIB)+12), 8)
say jobno
exit
/*-------------------------------------------------------------------*/
/*                           End of JOBID                            */
/*-------------------------------------------------------------------*/
./ ADD NAME=JOBNAME
/* rexx */
/*-------------------------------------------------------------------*/
/*                                                                   */
/*                        REXX Exec : JOBNAME                        */
/*                                                                   */
/*  Description : Returns the jobname of the task running this exec  */
/*                                                                   */
/*  Created on : 1 Apr 2018                                          */
/*  Created by : KEVIN FERGUSON                                      */
/*             : Userid(MIT001)                                      */
/*             : using ABBYDALE.XFER.REXX(JOBNAME)                   */
/*                                                                   */
/*  Called by :                                                      */
/*                                                                   */
/*  Calls :                                                          */
/*                                                                   */
/*  Change Activity :                                                */
/*                                                                   */
/*                ©Copyright of Abbydale Systems LLC.                */
/*                                                                   */
/*-------------------------------------------------------------------*/
CVT = storage(10,4)      /* FLCCVT-PSA DATA AREA */
TCBP = storage(D2X(C2D(CVT)),4)       /* CVTTCBP */
TCB = storage(D2X(C2D(TCBP)+4),4)
TIOT = storage(D2X(C2D(TCB)+12),4)     /* TCBTIO */
job = strip(storage(D2X(C2D(TIOT)),8)) /* TIOCNJOB */
say job
exit
/*-------------------------------------------------------------------*/
/*                          End of JOBNAME                           */
/*-------------------------------------------------------------------*/
./ ADD NAME=JUL2GREG
/* rexx */
/*-------------------------------------------------------------------*/
/*                                                                   */
/*                       REXX Exec : JUL2GREG                        */
/*                                                                   */
/*  Description : This exec can be called as a command or as a stand-*/
/*                alone procedure.                                   */
/*                                                                   */
/*  Created on : 16 Jun 1991                                         */
/*  Created by : Kevin Ferguson                                      */
/*             : Userid MIT001                                       */
/*             : Using ABBYDALE.DEVL.REXX(JUL2GREG)                  */
/*                                                                   */
/*  Called by : Many EXECs                                           */
/*                                                                   */
/*  Calls : COUNTSTR                                                 */
/*                                                                   */
/*  Panels Used : None                                               */
/*                                                                   */
/*  Change Activity :                                                */
/*                                                                   */
/*                ©Copyright of Abbydale Systems LLC.                */
/*                                                                   */
/*-------------------------------------------------------------------*/
Parse Arg Help chat    /* Check for Help */
Jul2Greg:
If Help = "?" Then do
   Call Disp_Help
   exit(4)
end
signal on halt         /* attention key      */
codate = ARG(1)
chat = ARG(2)
done = "n"
mm. = 0               /* Build month array              */
push 31 x 31 30 31 30 31 31 30 31 30 31
pull mm.1 mm.2 mm.3 mm.4 mm.5 mm.6 mm.7 mm.8 mm.9 mm.10 mm.11 mm.12
if codate = "" then do
   do until done = "y"
   say 'Enter date to be converted in the format yyyy.jjj or <QUIT>'
   parse upper pull xdate
   if xdate = "<QUIT>" then exit
   if pos('.',xdate) <> 5 then do
      say 'Invalid date. The date must be in the format yyyy.jjj'
   end
   else do
      if countstr('.',xdate) > 1 then do
         say 'Too many periods found in date. Re-enter'
      end
      else do
         if length(xdate) <> 8 then do
            say 'Length error. Date must be 8 characters in the format',
                'yyyy.jjj. Please re-enter'
         end
         else do
            year = substr(xdate,1,4)
            Julian = Substr(xdate,6,3)
            mm.2 = 28 + (year//4=0) + (year//100=0) - (year//400=0)
            if datatype(year,'N') = 1 then do
               if datatype(Julian,'N') = 1 then do
                  done = "y"
                  If mm.2 = 29 then do
                     if Julian > 366  then do
                     say 'Invalid number of days for Julian specified'
                     done = "n"
                     end
                     else do
                         if Julian > 365 then do
                     say 'Invalid number of days for Julian specified'
                     done = "n"
                        end
                     end
                  end
                  if julian = 0 then do
                     say 'Julian day can not be zero. Re-enter'
                     done = "n"
                  end
                  if year = 0 then do
                     say 'Year can not be zero. Re-enter'
                     done = "n"
                  end
               end
               else do
                  say 'Date must be numeric. Please re-enter'
               end
            end
            else do
               say 'Year value not numeric. Please re-enter'
            end
         end
      end
   end
codate = xdate
end
end
year = substr(codate,1,4)              /* 4-digit year               */
Julian = Substr(codate,6,3)
mm.2 = 28 + (year//4=0) + (year//100=0) - (year//400=0)
mm = 1
if mm.2 = "29" then do
   if Julian > 366 then do
      exit(8)
   end
end
else do
   if Julian > 365 then do
      exit(8)
   end
end
if chat <> " " then do
   if pos('.',codate) <> 5 then do
      exit(1)
   end
   else do
      if countstr('.',codate) > 1 then do
         exit(2)
      end
      else do
         if length(codate) <> 8 then do
            exit(3)
         end
         else do
            if datatype(year,'N') = 1 then do
               if datatype(Julian,'N') = 1 then do
                  If mm.2 = 29 then do
                     if Julian > 366 then do
                        exit(5)
                     end
                     else do
                        if Julian > 365 then do
                           exit(5)
                     end
                  end
                  if julian = 0 then do
                     exit(7)
                     done = "n"
                  end
                  if year = 0 then do
                     exit(9)
                  end
               end
               end
               else do
                  exit(6)
               end
            end
            else do
               exit(6)
            end
         end
      end
   end
end
if julian <= 31 then do
   codate = year'/'right(mm,2,'0')'/'right(julian,2,'0')
   signal leave
end
julian = julian - mm.1
Do k = 2 to 12
   z = julian - mm.k
   if z <= 0 then do
      codate = year'/'right(k,2,'0')'/'right(Julian,2,'0')
      signal leave
   end
   julian = z
end
leave:
if chat <> "" then do
   return codate
end
else do
   say 'YYYY MM DD'
   say '----------'
   say codate
   return
end
/*-------------------------------------------------------------------*/
/*                        Disp_Help Procedure                        */
/*-------------------------------------------------------------------*/
Disp_Help: Procedure
say "JUL2GREG - Converts a Julian format date to a Gregorian."
say""
say "           The input date should be in the format yyyy.jjj"
say "           The output date is in the format yyy/mm/dd"
say""
say "Usage: JUL2GREG yyyy.jjj chat | ?"
say""
say"    yyyy.jjj - Specifies the Julian date to be converted."
say"    chat     - Any non-blank character will cause the message"
say"               displaying the converted date to be suppressed."
say"    ?        - Generates this information."
say""
say"       If no date is passed to the exec then the user will be"
say"       prompted for a date. A reply of <QUIT> will end the exec"
say""
say"   Return Codes :"
say"                 1 - Incorrect date format. No period in position 5"
say"                 2 - Too many periods in date"
say"                 3 - Date too long"
say"                 4 - Help displayed"
say"                 5 - Invalid number of days in year"
say"                 6 - Date not numeric"
say"                 7 - Julian day value was 0"
say"                 8 - Too many days in year"
say"                 9 - Year value was zero"
say""
Return
/*-------------------------------------------------------------------*/
/*                    End of Disp_Help Procedure                     */
/*-------------------------------------------------------------------*/
/*                        Trap HALT Condition                        */
/*-------------------------------------------------------------------*/
halt:
say "HALT acknowledged in line" sigl
say "Cleanup processing in progress"
address "TSO"
"delstack"
exit(16)
/*-------------------------------------------------------------------*/
/*                          End of JUL2GREG                          */
/*-------------------------------------------------------------------*/
./ ADD NAME=LC
/* rexx */
/*                                                                  */
/*                   Welcome to LC                                  */
/*                                                                  */
/*  Description :  Allows LC to be typed on 3.4 panels for listcat  */
/*                                                                  */
/*  Created : 04/17/02 by Kevin Ferguson                            */
/*          : using ABBYDALE.PROD.REXX(LC)                          */
/*                                                                  */
/*  Called by :                                                     */
/*                                                                  */
/*  Calls : IDCAMS LISTCAT                                          */
/*                                                                  */
/*  Change Activity :                                               */
/*                                                                  */
/*                                                                  */
parse upper arg dsn act
dsn = strip(dsn,b,"'")
"LISTCAT ENT('"dsn"') " act
ZEDSMSG = 'LC successful'
ZEDLMSG = dsn 'catalog entry listed'
ZDLMSG = "LC Complete"
ZDLREF = 'Y'
Address ISPEXEC "VPUT (ZDLMSG ZDLMSG) SHARED"
address ISPEXEC "SETMSG MSG(ISRZ001)"
exit
/*-------------------------------------------------------------------*/
/*                        End of LC                                  */
/*-------------------------------------------------------------------*/
./ ADD NAME=LEVELS
/* rexx */
/*-------------------------------------------------------------------*/
/*                                                                   */
/*                        REXX Exec : LEVELS                         */
/*                                                                   */
/*  Description : Returns a count of the number of levels in a       */
/*                dataset name. Using a second parameter will break  */
/*                down and display the levels in the dataset name    */
/*                                                                   */
/*  Created on : 21 May 2022                                         */
/*  Created by : Kevin Ferguson                                      */
/*             : Userid MIT001                                       */
/*             : Using ABBYDALE.PROD.REXX(LEVELS)                    */
/*                                                                   */
/*  Called by : Anything                                             */
/*                                                                   */
/*  Calls : Nothing                                                  */
/*                                                                   */
/*  Panels Used : None                                               */
/*                                                                   */
/*  Change Activity :                                                */
/*                                                                   */
/*                ©Copyright of Abbydale Systems LLC.                */
/*                                                                   */
/*-------------------------------------------------------------------*/
Parse arg dsn list
If dsn = "?" Then do
   Call Disp_Help
   exit(99)
end
signal on novalue      /* un-initialized vars*/
signal on halt         /* attention key      */
qualifiers = TRANSLATE(dsn,' ','.')
if list <> "" then do
   x = 1
   do until x = words(qualifiers) + 1
      say word(qualifiers,x)
      x = x + 1
   end
end
return words(qualifiers)
/*-------------------------------------------------------------------*/
/*                        Disp_Help Procedure                        */
/*-------------------------------------------------------------------*/
Disp_Help: Procedure
say""
say "LEVELS - Counts the levels of a passed dataset name"
say""
say "Usage: LEVELS dsn (list) | ?"
say""
say"    ?        - Generates this information."
say"    dsn      - (Required) is the dataset name whose levels are"
say"               to be counted"
say"    list     - (Optional) if specified will display the levels"
say"               within the dataset"
say""
say"   Return Codes :"
say"                99 - Help displayed"
say"         Otherwise - A count of the number of levels"
say""
Return
/*-------------------------------------------------------------------*/
/*                    End of Disp_Help Procedure                     */
/*-------------------------------------------------------------------*/
/*-------------------------------------------------------------------*/
/*                      Trap NOVALUE Condition                       */
/*-------------------------------------------------------------------*/
novalue:
say "NOVALUE entered from line" sigl
say condition("D")
say "The instruction is suppressed"
address "TSO"
"delstack"
exit(16)
/*-------------------------------------------------------------------*/
/*                        Trap HALT Condition                        */
/*-------------------------------------------------------------------*/
halt:
say "HALT acknowledged in line" sigl
say "Cleanup processing in progress"
address "TSO"
"delstack"
exit(16)
/*-------------------------------------------------------------------*/
/*                           End of LEVELS                           */
/*-------------------------------------------------------------------*/
./ ADD NAME=LISTVOLS
/* rexx */
/*-------------------------------------------------------------------*/
/*                                                                   */
/*                       REXX Exec : LISTVOLS                        */
/*                                                                   */
/*  Description : List all online DASD Volumes and unit addresses    */
/*                                                                   */
/*  Note : This EXEC should work on z/OS systems from Z/OS 1.7       */
/*                   ------                                          */
/*         onwards. Additonal information could be obtained from     */
/*         the UCBs iy you need to display it (ie Unit type etc).    */
/*                                                                   */
/*  Created on : 5 Sep 2022                                          */
/*  Created by : Kevin Ferguson                                      */
/*             : Userid MIT001                                       */
/*             : Using ABBYDALE.PROD.REXX(LISTVOLS)                  */
/*                                                                   */
/*  Called by : VTOCCHK                                              */
/*                                                                   */
/*  Calls : Nothing                                                  */
/*                                                                   */
/*  Panels Used : None                                               */
/*                                                                   */
/*  Change Activity :                                                */
/*                                                                   */
/*                ©Copyright of Abbydale Systems LLC.                */
/*                                                                   */
/*-------------------------------------------------------------------*/
Parse Arg Help         /* Check for Help */
If SYSVAR("SYSISPF")<>"ACTIVE" then do
   Say "ISPF must be active to use "LISTVOLS
   exit(16)
end
If Help = "?" Then do
   Call Disp_Help
   exit(4)
end
signal on halt                      /* attention key                 */
Numeric Digits 10                   /* Set sensitivity               */
VolCount = 0                        /* Volume count                  */
cvt_ptr = get_ptr(10,)              /* CVT Pointer                   */
IOCOM= get_ptr(cvt_ptr,'7C')        /* IOCOM Pointer                 */
IOVT = get_ptr(IOCOM,'D0')          /* IOVT Pointer                  */
ULUT = get_ptr(IOVT,'8')            /* ULUT Pointer                  */
SysType = Calc_Address(ULUT '+' 4)  /* Get system level              */
SysType =  get_it(HDATA SysType ,1) /* Make it usable                */
Select
  when Systype = 1 then do          /* Type 1 ULUT                   */
     loop  = Calc_Address(ULUT '+' 10)   /*    Loop Counter          */
     UCTAB = get_ptr(ULUT, '10')    /* UCB Table                     */
  end
  when Systype = 2 then do          /* Type 2 ULUT                   */
     loop  = Calc_Address(ULUT '+' 18)   /*    Loop Counter          */
     UCTAB = get_ptr(ULUT, '14')    /* UCB Table                     */
  end
  otherwise                         /* Type 3 ULUT                   */
     loop  = Calc_Address(ULUT '+' 1C)   /*    Loop Counter          */
     UCTAB = get_ptr(ULUT, '1C')    /* UCB Table                     */
end
Loop =  x2d(get_it(HDATA loop 4))   /* Get loop counter              */
do until loop = 0
   UCB  = get_ptr(UCTAB, 8)         /* Point to the UCB              */
   device = calc_address(UCB '+' 12) /* Find Device type             */
   device = get_it(HDATA Device 1)  /*  Get device type              */
   if device = 20 then do           /* Only Porcess DASD Devices     */
      online = calc_address(UCB '+' 3) /* See if it is online        */
      online = x2d(get_it(HDATA online 1))
      if online > 130 then do       /* Only Process Online DASD      */
         volser = calc_address(UCB '+' 1c) /* Point to VOLSER        */
         say get_it(HDATA UCTAB 2) get_it(CDATA volser 6)
   /*    say get_it(HDATA UCTAB 2)     Display unit                  */
         VolCount = VolCount + 1    /* Increase Volume Count         */
      end
   end
   UCTAB = calc_Address(UCTAB '+' 'c') /* Bubble to next UCB         */
   loop = loop - 1                  /* Decrease Loop Count           */
end
say "There are" VolCount "online DASD volumes"
return
/*-------------------------------------------------------------------*/
/*                        Disp_Help Procedure                        */
/*-------------------------------------------------------------------*/
Disp_Help: Procedure
say "LISTVOLS - Lists the online DASD volumes"
say""
say "Usage: LISTVOLS | ?"
say""
say"    ?        - Generates this information."
say""
say"   Return Codes :"
say"                 4 - Help displayed"
say"                16 - Not under ISPF"
say""
Return
/*-------------------------------------------------------------------*/
/*                    End of Disp_Help Procedure                     */
/*-------------------------------------------------------------------*/
/*                         get_ptr Subroutine                        */
/*-------------------------------------------------------------------*/
/* Returns a 4 byte pointer as hexadecimal string at address         */
/* ADDR+OFFSET (ADDR and OFFSET must be hex strings.)                */
/*-------------------------------------------------------------------*/
get_ptr: procedure
 arg addr,offset
temp=d2x(x2d(addr)+x2d(offset))
return c2x(storage(temp,4))
exit
/*-------------------------------------------------------------------*/
/*                    End of get_ptr Subroutine                      */
/*-------------------------------------------------------------------*/
/*                       Calc-Address Procedure                      */
/*-------------------------------------------------------------------*/
Calc_Address: Procedure
arg string
parse var string Address Oper Offset        /* breakout variables     */
Interpret value "= "'D2X( X2D('Address') 'Oper' X2D('Offset') )'""
return value                                /* and return the value   */
/*-------------------------------------------------------------------*/
/*                         Get_it Procedure                          */
/*-------------------------------------------------------------------*/
Get_it: Procedure
arg string
parse var string type address lgth          /* breakout variables     */
if type = 'ADDR' && type = 'HDATA' then,    /* data type ADDR or HEX? */
  value = C2X(Storage(address,lgth))        /* Yes - Change it        */
  else if type = 'DDATA' then,              /* Is it decimal data?    */
         value = C2D(Storage(address,lgth)) /* Yes - Change to decimal*/
  else if type = 'BDATA' then,              /* is it binary data?     */
    value = X2B(C2X(Storage(address,lgth))) /* Yes - Change to binary */
  else value = Storage(address,lgth)        /* No - Just get value    */
Return value                                /* .. and return it       */
/*-------------------------------------------------------------------*/
/*                        get_date Subroutine                        */
/*-------------------------------------------------------------------*/
/* Returns LENGTH bytes at ADDR+OFFSET as an EBCDIC string.          */
/* (ADDR and OFFSET must be hex strings). LENGTH must be a decimal   */
/* string.                                                           */
/*-------------------------------------------------------------------*/
get_data: procedure
arg addr,offset,length
temp=d2x(x2d(addr)+x2d(offset))
return storage(temp,length)
exit
/*-------------------------------------------------------------------*/
/*                   End of get_data Subroutine                      */
/*-------------------------------------------------------------------*/
/*                        Trap HALT Condition                        */
/*-------------------------------------------------------------------*/
halt:
say "HALT acknowledged in line" sigl
say "Cleanup processing in progress"
address "TSO"
"delstack"
exit(16)
/*-------------------------------------------------------------------*/
/*                          End of LISTVOLS                          */
/*-------------------------------------------------------------------*/
./ ADD NAME=MEMMATCH
/* rexx */
/*-------------------------------------------------------------------*/
/*                                                                   */
/*                       REXX Exec : MEMMATCH                        */
/*                                                                   */
/*  Description : Checks a passed PDS and member name for existance  */
/*                Member name can be for a generic name i.e. ASL*    */
/*                                                                   */
/*             *** Must run under ISPF for LM calls ***              */
/*                                                                   */
/*  Created on : 1 Aug 2020                                          */
/*  Created by : Kevin Ferguson                                      */
/*             : Userid MIT001                                       */
/*             : Using ABBYDALE.PROD.REXX(MEMMATCH)                  */
/*                                                                   */
/*  Call Format : MEMMATCH dsn member  (both dsn and member are      */
/*                                      required)                    */
/*                                                                   */
/*  Return Codes :   0 - Member or generic members found in dsn      */
/*                   8 - Member or generic members not found in dsn  */
/*                  12 - Dataset not found or not partitioned        */
/*                  16 - Invalid call                                */
/*                                                                   */
/*  Called by :                                                      */
/*                                                                   */
/*  Calls : LISDSI, CheckDSN                                         */
/*                                                                   */
/*  Panels Used : None                                               */
/*                                                                   */
/*  Change Activity :                                                */
/*                                                                   */
/*                ©Copyright of Abbydale Systems LLC.                */
/*                                                                   */
/*-------------------------------------------------------------------*/
Parse Arg dsname
dialogid = sysvar(sysicmd)
parse source Exec_String
excnme = word(Exec_String,3)
If SYSVAR("SYSISPF")<>"ACTIVE" then do
   Say "ISPF must be active to use "excnme
   exit(16)
end
If ARG() > 1 then exit(16)
If ARG() = 0 then exit(16)
member = ARG(1)
dsn = ""
If POS(" ",ARG(1)) > 0 then do
   member = Substr(ARG(1),POS(" ",ARG(1))+1)
   dsn = Substr(ARG(1),1,POS(" ",ARG(1))-1)
end
If POS(",",ARG(1)) > 0 then do
   member = Substr(ARG(1),POS(",",ARG(1))+1)
   dsn = Substr(ARG(1),1,POS(",",ARG(1))-1)
end
member = Strip(member,b," ")
forbid = '%!&^}{[_]:,;()'   /* characters forbidden in member name */
forbid2 = '1234567890'      /* Invalid first characters */
if POS(SUBSTR(member,1,1),forbid2) > 0 then do
   say 'Invalid member name'
   exit(16)
end
x = 1
do until x = LENGTH(forbid)
   if POS(SUBSTR(forbid,x,1),member) > 0 then do
      Say 'Invalid member name'
      exit(16)
   end
   x = X + 1
end
if length(member) > 8 then exit(12)
if Length(dsn) = 0 then exit(12)
dsn = strip(dsn,b," ")
parse upper var dsn
parse upper var member
TrapON=OutTrap('ON')
DSN_STATUS = LISTDSI(''''dsn'''' smsinfo)
TrapON=OutTrap('OFF')
if substr(sysdsorg,1,2) <> "PO" then do
   say 'Dataset 'dsn 'not partitioned'
   exit(12)
end
checkdsn dsn
if rc > 0 then do
   if rc = 12 then do
      say 'dataset 'dsn 'not found'
   end
   else do
      say 'dataset name is in error'
   end
   exit(12)
end
ISPEXEC "LMINIT DATAID(MCH) DATASET('"dsn"') ENQ(SHR)"
ISPEXEC "LMOPEN DATAID("MCH") OPTION(INPUT)"
ISPEXEC "LMMLIST DATAID("MCH") MEMBER(lst) OPTION(LIST),
         STATS(YES) PATTERN("member")"
if rc > 0 then exit(8)
ISPEXEC "LMCLOSE DATAID("MCH")"
ISPEXEC "LMFREE DATAID("MCH")"
exit(0)
/*-------------------------------------------------------------------*/
/*                          End of MEMMATCH                          */
/*-------------------------------------------------------------------*/
./ ADD NAME=MQVER
/* rexx */
/*-------------------------------------------------------------------*/
/*                                                                   */
/*                         REXX Exec : MQVER                         */
/*                                                                   */
/*  Description : Displays the version number of Websphere MQ running*/
/*                on this LPAR                                       */
/*                                                                   */
/*  Created on : 4 Apr 2018                                          */
/*  Created by : KEVIN FERGUSON                                      */
/*             : Userid(MIT001)                                      */
/*             : using ABBYDALE.XFER.REXX(MQVER)                     */
/*                                                                   */
/*  Called by :                                                      */
/*                                                                   */
/*  Calls :                                                          */
/*                                                                   */
/*  Change Activity :                                                */
/*                                                                   */
/*                ©Copyright of Abbydale Systems LLC.                */
/*                                                                   */
/*-------------------------------------------------------------------*/
signal on halt         /* attention key      */
numeric digits 10
cvt_ptr = get_ptr(10,)              /* CVT pointer            */
cvtjesct = get_ptr(cvt_ptr,'128')   /* address of CVTJESCT    */
ssct_ptr = get_ptr(cvtjesct,'18')   /* address of SSCT        */
Block_id = get_data(ssct_ptr,'0',4) /* Block_id must = 'SSCT' */
done = 'n'
cc = 0
do until done = 'y'
    if Block_id = 'SSCT' then do
       taskname = get_data(ssct_ptr,'8',4)
       SSCTSUSE_ptr = get_ptr(ssct_ptr,'14')
       ssct_anc = get_ptr(cvtjesct,'18')
       if ssctsuse_ptr = '0' then do
          ssct_ptr = get_ptr(ssct_ptr,'4')
       end
       else do
          if SSCTSUSE_ptr < '80000000' then do
             Early = get_data(SSCTSUSE_ptr,'4',4)
             if early = 'ERLY' then do
                ASIDname = get_data(SSCTSUSE_ptr,'c',8)
                Program = get_data(SSCTSUSE_ptr,'54',7)
                if Program = 'CSQ3EPX' then do
                   run = get_ptr(ssct_ptr,'10',4)
                   run = get_ptr(run,'4',4)
                   RIB_ptr = get_ptr(SSCTSUSE_ptr,'80')
                   version = get_data(RIB_ptr,'19',5)
                   version = STRIP(version,b,' ')
                   PTFLevel = get_data(RIB_ptr,'3C',7)
                   dig2 = get_data(RIB_Ptr,'21',1)
                   first = C2D(dig2,1)
                   dig2 = get_data2(RIB_Ptr,'22',1)
                   second = C2D(dig2,1)
                   st = "*ACTIVE*"
                   if run = '0' then do
                       st = "INACTIVE"
                   end
                   temp = st 'MQ subsystem' taskname
                   temp = temp'('ASIDName') Ver('version')'
                temp = temp 'Level('first'.'second') last PTF' PTFLevel
                   say temp
                end
             end
          end
          ssct_ptr = get_ptr(ssct_ptr,'4')
       end
       if ssct_ptr = '0' then do
       done = 'y'
       end
 end
 else do
    Say 'Logic error ' block_id 'found where SSCT should be'
    cc = 16
    done = 'y'
 end
end
exit (cc)
/*                         end of main line                           */
get_ptr: procedure
/*
returns a 4 byte pointer as hexadecimal string at address ADDR+OFFSET
ADDR and OFFSET must be hex strings.                   */
 arg addr,offset
temp=d2x(x2d(addr)+x2d(offset))
return c2x(storage(temp,4))
exit
get_data: procedure
/*
returns LENGTH bytes att ADDR+OFFSET as an EBCDIC string.
ADDR and OFFSET must be hex strings.  LENGTH must be a
decimal string.
*/
arg addr,offset,length
temp=d2x(x2d(addr)+x2d(offset))
return storage(temp,length)
exit
get_data2: procedure
/*
returns LENGTH bytes att ADDR+OFFSET as an EBCDIC string.
ADDR and OFFSET must be hex strings.  LENGTH must be a
decimal string.
*/
arg addr,offset,length
temp=d2x(x2d(addr)+x2d(offset))
return storage(temp,length)
exit
/*-------------------------------------------------------------------*/
/*                        Trap HALT Condition                        */
/*-------------------------------------------------------------------*/
halt:
say "HALT acknowledged in line" sigl
say "Cleanup processing in progress"
address "TSO"
"delstack"
exit(16)
/*-------------------------------------------------------------------*/
/*                           End of MQVER                            */
/*-------------------------------------------------------------------*/
./ ADD NAME=ONEEXT
/* rexx */
/*-------------------------------------------------------------------*/
/*                                                                   */
/*                        REXX Exec : ONEEXT                         */
/*                                                                   */
/*  Description : Make a dataset into just one extent.               */
/*                                                                   */
/*  Created on : 27 Feb 2021                                         */
/*  Created by : Kevin Ferguson                                      */
/*             : Userid MIT001                                       */
/*             : using ABBYDALE.PROD.REXX(ONEEXT)                    */
/*                                                                   */
/*  Called by :                                                      */
/*                                                                   */
/*  Calls : LISTDSI                                                  */
/*                                                                   */
/*  Change Activity :                                                */
/*                                                                   */
/*                ©Copyright of Abbydale Systems LLC.                */
/*                                                                   */
/*-------------------------------------------------------------------*/
parse upper arg dsname keep
if dsname = "?" then do
   call disp_help
   exit(4)
end
dsname = strip(dsname,b,"'")
kf  = outtrap('on')
DSN_STATUS = LISTDSI(''''dsname'''' smsinfo)
kf  = outtrap('off')
if sysextents = 0 then exit
if sysextents = 1 then do
   ZEDSMSG = 'ONEEXT Not run'
   ZEDLMSG = dsname 'already in 1 extent'
   ZDLMSG = 'ONEEXT not run'
   ZDLREF = 'Y'
   Address ISPEXEC "VPUT (ZDLMSG ZDLMSG) SHARED"
   address ISPEXEC "SETMSG MSG(ISRZ001)"
   exit
end
if LENGTH(dsname) < 42 then do
   newdsname = dsname||".O"
   end
else do
   ZEDSMSG = 'ONEEXT Failed'
   ZEDLMSG = dsn 'too long to process'
   ZDLMSG = "ONEEXT Failed"
   ZDLREF = 'Y'
   Address ISPEXEC "VPUT (ZDLMSG ZDLMSG) SHARED"
   address ISPEXEC "SETMSG MSG(ISRZ001)"
   exit
end
secs = 0
if keep <> "" then do
   secs = sysseconds
end
if sysunits = "BLOCK" then do
   quantity = sysalloc /* sysblkstrk */
   Allocin = sysunits"("sysblksize") SPACE("quantity","secs")"
end
else do
   Allocin = sysunits "SPACE("sysused","secs")"
end
if sysstorclass = '' then do
  "ALLOC F(DATAOUT) DATASET('"newdsname"') NEW CATALOG ,
   VOL("sysvolume") UNIT(SYSALLDA) LIKE('"dsname"') REUS",
   allocin
end
else do
  "ALLOC F(DATAOUT) DATASET('"newdsname"') NEW CATALOG  ,
   LIKE('"dsname"') REUS ,
   STORCLAS("sysstorclass") "allocin
end
if rc > 0 then do
   ZEDSMSG = 'ONEEXT Failed'
   ZEDLMSG = 'Allocation failed for 'newdsname
   ZDLMSG = "ONEEXT Failed"
   ZDLREF = 'Y'
   Address ISPEXEC "VPUT (ZDLMSG ZDLMSG) SHARED"
   address ISPEXEC "SETMSG MSG(ISRZ001)"
   exit 16
end
SELECT
       WHEN sysdsorg = 'PS' then do
"Alloc F(DATAIN) da('"dsname"') SHR REUS"
"repro infile(DATAIN) outfile(DATAOUT)"
 kef = rc
 'FREE F (DATAIN DATAOUT)'
 say "Copy ended Return code" kef
end
       WHEN sysdsorg = 'PO' then do
TrapON=OutTrap('Off')
"Alloc F(DATAIN) da('"dsname"') SHR REUS"
"FREE FI(SYSIN,SYSPRINT,SYSUT3,SYSUT4)"
"ALLOC FILE(SYSIN) SPACE(1,1) TRACK LRECL(80) RECFM(F) BLKSIZE(80) REU"
"ALLOC FILE(SYSPRINT) da(*) BLKSIZE(121)"
"ALLOC FILE(SYSUT3) UNIT(SYSDA) SPACE(1,1) CYLINDERS REU"
"ALLOC FILE(SYSUT4) UNIT(SYSDA) SPACE(1,1) CYLINDERS REU"
SYSIN.1 = "   COPY OUTDD=DATAOUT,INDD=((DATAIN,R))"
'EXECIO * DISKW SYSIN (STEM SYSIN. FINIS'
"CALL 'SYS1.LINKLIB(IEBCOPY)' 'SIZE=512K'"
 kef = rc
 say "Copy ended Return code" kef
end
       otherwise do
   ZEDSMSG = 'ONEEXT Failed'
   ZEDLMSG = sysdsorg 'files are not supported'
   ZDLMSG = "ONEEXT Failed"
   ZDLREF = 'Y'
   Address ISPEXEC "VPUT (ZDLMSG ZDLMSG) SHARED"
   address ISPEXEC "SETMSG MSG(ISRZ001)"
   outit = outtrap('on')
   "delete '"newname"'"
   outit = outtrap('off')
   exit 16
exit
end
end
if rc > 0 then do
   ZEDSMSG = 'ONEEXT Aborted'
   ZEDLMSG = 'Copy step failed. Run Aborted'
   ZDLMSG = 'ONEEXT Aborted'
   ZDLREF = 'Y'
   Address ISPEXEC "VPUT (ZDLMSG ZDLMSG) SHARED"
   address ISPEXEC "SETMSG MSG(ISRZ001)"
   outit = outtrap('on')
   "delete '"newname"'"
   outit = outtrap('off')
   exit 16
end
"del '"dsname"'"
"alter '"newdsname"' NEWNAME('"dsname"')"
ZEDSMSG = 'ONEEXT Ended'
ZEDLMSG = dnsame 'no in a single extent'
ZDLMSG = 'ONEEXT Ended'
ZDLREF = 'Y'
Address ISPEXEC "VPUT (ZDLMSG ZDLMSG) SHARED"
address ISPEXEC "SETMSG MSG(ISRZ001)"
exit
/*-------------------------------------------------------------------*/
/*                      disp_help procedure                          */
/*-------------------------------------------------------------------*/
disp_help: procedure
say "ONEEXT - a REXX exec to rebuild a dataset into one extent."
say ""
say "Usage: ONEEXT dsname keep | ? "
say ""
say "     dsname - Specified the name of the module to locate."
say "     keep   - (optional). If anything is passed as a second"
say "              parameter then the current secondary allocation"
say "              value is used for the recreated dataset. If this"
say "              value is omitted then a 0 secondary allocation will"
say "              be used."
say "     ?      - generates this information."
say ""
say "    Return Codes : 0 - Dataset recreated"
say "                   4 - Help displayed"
say "                   8 - Module not found"
Say "                  16 - Critical error"
return
/*-------------------------------------------------------------------*/
/*                           End of ONEEXT                           */
/*-------------------------------------------------------------------*/
./ ADD NAME=PROPER
/* rexx */
/*-------------------------------------------------------------------*/
/*                                                                   */
/*                        REXX Exec : PROPER                         */
/*                                                                   */
/*  Description : This subroutine will return a string in Proper     */
/*                name format i.e. Abbydale                          */
/*                                                                   */
/*  Created on : 27 Jun 2018                                         */
/*  Created by : KEVIN FERGUSON                                      */
/*             : Userid(MIT001)                                      */
/*             : using ABBYDALE.PROD.REXX(PROPER)                    */
/*                                                                   */
/*  Called by : Anything                                             */
/*                                                                   */
/*  Calls :                                                          */
/*                                                                   */
/*  Change Activity :                                                */
/*                                                                   */
/*                ©Copyright of Abbydale Systems LLC.                */
/*                                                                   */
/*-------------------------------------------------------------------*/
signal on novalue      /* un-initialized vars*/
signal on halt         /* attention key      */
Proper:
Orig = ARG(1)
if length(orig) > 1 then do /* Ensure there is more than one char */
  UPPER = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
  LOWER = "abcdefghijklmnopqrstuvwxyz"
  tempName = TRANSLATE(Orig,LOWER,UPPER)
  build = substr(tempName,2,Length(tempName)-1)
  initial = substr(tempName,1,1)
  initial = TRANSLATE(initial,UPPER,LOWER)
  newname = initial||build
end
else do
  newname = Orig
end
return newname
/*-------------------------------------------------------------------*/
/*                      Trap NOVALUE Condition                       */
/*-------------------------------------------------------------------*/
novalue:
say "NOVALUE entered from line" sigl
say condition("D")
say "The instruction is suppressed"
address "TSO"
"delstack"
exit(16)
/*-------------------------------------------------------------------*/
/*                        Trap HALT Condition                        */
/*-------------------------------------------------------------------*/
halt:
say "HALT acknowledged in line" sigl
say "Cleanup processing in progress"
address "TSO"
"delstack"
exit(16)
/*-------------------------------------------------------------------*/
/*                           End of PROPER                           */
/*-------------------------------------------------------------------*/
./ ADD NAME=REXXINFO
/* rexx */
/*-------------------------------------------------------------------*/
/*                                                                   */
/*                        REXX Exec : REXXINFO                       */
/*                                                                   */
/*  Description : Display running exec information                   */
/*                                                                   */
/*                This just serves as an example of how to extract   */
/*                information about the Rexx exec that is running.   */
/*                                                                   */
/*  Created on : 03 Jan 1993                                         */
/*  Created by : Kevin Ferguson                                      */
/*             : Userid MIT001                                       */
/*             : Using ABBYDALE.DEVL.REXX(REXXINFO)                  */
/*                                                                   */
/*  Called by : Nothing                                              */
/*                                                                   */
/*  Calls : Nothing                                                  */
/*                                                                   */
/*  Panels Used : None                                               */
/*                                                                   */
/*  Change Activity :                                                */
/*                                                                   */
/*                ©Copyright of Abbydale Systems LLC.                */
/*                                                                   */
/*-------------------------------------------------------------------*/
s=userid()
dialogid = sysvar(sysicmd)
parse source Exec_String
excnme = word(Exec_String,3)            /* Get EXEC's name          */
dataset = word(Exec_String,5)           /* Get dataset name         */
say s 'is running' excnme 'from' dataset
exit
/*-------------------------------------------------------------------*/
/*                       End of REXXINFO                             */
/*-------------------------------------------------------------------*/
./ ADD NAME=RUNNING
/* rexx */
/*-------------------------------------------------------------------*/
/*                                                                   */
/*                        REXX Exec : RUNNING                        */
/*                                                                   */
/*  Description : Checks to see if a task is running                 */
/*                                                                   */
/*  Created on : 1 Aug 2020                                          */
/*  Created by : Kevin Ferguson                                      */
/*             : Userid(MIT001)                                      */
/*             : using ABBYDALE.PROD.REXX(RUNNING)                   */
/*                                                                   */
/*  Called by :                                                      */
/*                                                                   */
/*  Calls :                                                          */
/*                                                                   */
/*  Change Activity :                                                */
/*                                                                   */
/*  MM/DD/YYYY  ID   Comment                                         */
/*  ---------------------------------------------------------------  */
/*  10/17/2021  MSG  Added ability to supress messages               */
/*                                                                   */
/*                ©Copyright of Abbydale Systems LLC.                */
/*                                                                   */
/*-------------------------------------------------------------------*/
pee = ''
signal on novalue                /* un-initialized vars */
signal on halt                   /* attention key       */
parse upper arg taskname msg                                    /*MSG*/
if taskname = "" then do
   msg = "x"                                                    /*MSG*/
   do while taskname = ""
   say 'Enter task name to check. (use <QUIT> to terminate)'
   parse upper pull taskname
   if taskname = '<QUIT>' then exit(12)
   if length(taskname) > 8 then do
      task = ""
      Say 'Invalid task name. Length > 8. Re-Enter'
   end
   end
end
if taskname = "?" then do
   Call disp_help
   exit(4)
end
if length(taskname) > 8 then do
   say 'Invalid task name length (>8).'
   exit(12)
end
  asidn = 1
  cvt  = storage(10,4)                   /* cvt address in memory */
  asvt   = storage(d2x(556+c2d(cvt)),4)  /* adress of ASVT        */
  ascb1  = storage(d2x(528+c2d(asvt)),4)   /* ASCB of *MASTER*  */
  acro   = storage(d2x(512+c2d(asvt)),4)  /* acronym of "ASVT"     */
  maxu   = storage(d2x(516+c2d(asvt)),4)  /* asvtmaxu */
  rc = 8
  max =  c2d(maxu)
  if  acro \= 'ASVT' then do
      say '** Addressing error, ASVT not working'
      exit (8)
      end
  do forever
    job = getjbn(asidn)
    if job = taskname then do
       if msg <> "" then do                                     /*MSG*/
       say job 'is running'
       end                                                      /*MSG*/
       rc = 0
       leave
    end
    if job=0 then leave
    end
    if rc = 8 then do                                           /*MSG*/
       if msg <> "" then do                                     /*MSG*/
          say taskname 'is not running'                         /*MSG*/
       end                                                      /*MSG*/
    end                                                         /*MSG*/
  exit(rc)
getjbn: procedure expose asidn  ,
                         cvt asvt max  opt ascb1 task
  if asidn > max  then return 0   /* end of jobs? */
  offset = 4*asidn-4
  asvten =  d2x(offset+528+c2d(asvt))
  ascb   = storage(d2x(offset+528+c2d(asvt)),4)
  asidn = asidn + 1

  /* non-reusable ASCB                */
  if substr(c2x(ascb),1,1) = '8' then do    /* non-free ascb       */
         if substr(c2x(ascb),2,7) =  substr(c2x(ascb1),2,7) then do
            end
         return ''
         end

  if substr(c2x(ascb),2,7) = '0000000' then do
     say ' ** Error the ASCB ''asvt, is zero' asvten ,
           ' asid' asidn-1 '(dec)'
     end

  ascbjbni   = storage(d2x(172+c2d(ascb)),4)
  ascbjbns   = storage(d2x(176+c2d(ascb)),4)
  jobname = 'STARTING'

  if c2x(ascbjbns) \= 0 then do
               jobname = storage(c2x(ascbjbns),8)
               tsb = storage(d2x(60+c2d(ascb)),4)
               if c2x(tsb) \= 0 then do
                                typ = 'tsu'
                                end
               end
  if c2x(ascbjbni) \= 0 then do
               jobname = storage(c2x(ascbjbni),8)
               end
  return jobname
/*-------------------------------------------------------------------*/
/*                      disp_help procedure                          */
/*-------------------------------------------------------------------*/
disp_help: procedure
pgm_name=sysvar("sysicmd")
if pgm_name="" then pgm_name="RUNNING"
say left(pgm_name,8) "- a REXX exec that will check to see if a named"
say "task is executing."
say ""
say "Usage: running taskname showmsg | ? "                      /*MSG*/
say ""
say "     taskname - Name of the task to be checked for."
say "     showmsg  - Show the messages."                        /*MSG*/
say "     ?        - generates this information."
say ""
say "    Return Codes : 0 - Task is runnung"
say "                   4 - Help displyed"
say "                   8 - Task is not running"
say "                  12 - Invalid taskname entered"
Say "                  16 - Critical error"
return
/*-------------------------------------------------------------------*/
/*                      trap NOVALUE condition                       */
/*-------------------------------------------------------------------*/
novalue:
say 'NOVALUE entered from line' sigl
say condition("D")
say 'The instruction is suppressed'
address "TSO"
"delstack"
exit(16)
/*-------------------------------------------------------------------*/
/*                        trap HALT condition                        */
/*-------------------------------------------------------------------*/
halt:
say 'HALT acknowledged in line' sigl
say 'Cleanup processing in progress'
address "TSO"
"delstack"
exit(16)
/*-------------------------------------------------------------------*/
/*                          End of RUNNING                           */
/*-------------------------------------------------------------------*/
./ ADD NAME=SNAP
/* rexx */
/*-------------------------------------------------------------------*/
/*                                                                   */
/*                         REXX Exec : SNAP                          */
/*                                                                   */
/*  Description : Moves a dataset from one volume to another.        */
/*                Works for sequential and for PDS datasets. To      */
/*                invoke type SNAP next to the dataset to be moved.  */
/*                You will be prompted for the new name and volume.  */
/*                                                                   */
/*  Created on : 31 Mar 2018                                         */
/*  Created by : KEVIN FERGUSON                                      */
/*             : Userid(MIT001)                                      */
/*             : using ABBYDALE.XFER.REXX(SNAP)                      */
/*                                                                   */
/*  Called by :                                                      */
/*                                                                   */
/*  Calls : LISTDSI, IEBCOPY, REPRO                                  */
/*                                                                   */
/*  Change Activity :                                                */
/*                                                                   */
/*                ©Copyright of Abbydale Systems LLC.                */
/*                                                                   */
/*-------------------------------------------------------------------*/
parse upper arg dsn vol
dsn = strip(dsn,b,"'")
s = userid()
if vol = '' then do
say 'Move ' dsn ' to where?'
pull vol
end
DSN_STATUS = LISTDSI(''''dsn'''' DIRECTORY)
SELECT
       WHEN sysdsorg = 'PS' then do
       if sysunits = BLOCK then do
"ALLOC DATASET('"dsn".SNP') NEW CATALOG VOL("vol") UNIT(SYSALLDA)" ,
sysunits"("sysblksize") LIKE('"dsn"')" ,
"SPACE("sysprimary sysseconds")"
end
else do
"ALLOC DATASET('"dsn".SNP') NEW CATALOG VOL("vol") UNIT(SYSALLDA)" ,
"SPACE("sysprimary sysseconds") "sysunits "LIKE('"dsn"')"
end
"Alloc F(DATAIN) da('"dsn"') SHR REUS"
"Alloc F(DATAOUT) da('"dsn".SNP') SHR REUS"
"repro infile(DATAIN) outfile(DATAOUT)"
 kef = rc
 'FREE F (DATAIN DATAOUT)'
 say "Copy ended Return code" kef
end
       WHEN sysdsorg = 'PO' then do
"ALLOC DATASET('"dsn".SNP') NEW CATALOG VOL("vol") UNIT(SYSALLDA)" ,
"LIKE('"dsn"')"
"Alloc F(DATAIN) da('"dsn"') SHR REUS"
"Alloc F(DATAOUT) da('"dsn".SNP') SHR REUS"
"FREE FI(SYSIN,SYSPRINT,SYSUT3,SYSUT4)"
"ALLOC FILE(SYSIN) SPACE(1,1) TRACK LRECL(80) RECFM(F) BLKSIZE(80) REU"
"ALLOC FILE(SYSPRINT) da(*) BLKSIZE(121)"
"ALLOC FILE(SYSUT3) UNIT(SYSDA) SPACE(1,1) CYLINDERS REU"
"ALLOC FILE(SYSUT4) UNIT(SYSDA) SPACE(1,1) CYLINDERS REU"
SYSIN.1 = "   COPY OUTDD=DATAOUT,INDD=((DATAIN,R))"
'EXECIO * DISKW SYSIN (STEM SYSIN. FINIS'
"CALL 'SYS1.LINKLIB(IEBCOPY)' 'SIZE=512K'"
 kef = rc
 say "Copy ended Return code" kef
end
       otherwise do
say sysdsorg " Files are not supported"
exit
end
end
trace o
"free da('"dsn".SNP')"
if kef = 0 then do
"del '"dsn"'"
"alter '"dsn".SNP' NEWNAME('"dsn"')"
end
else do
Say "rename aborted due to return code of " kef
end
exit
/*-------------------------------------------------------------------*/
/*                            End of SNAP                            */
/*-------------------------------------------------------------------*/
./ ADD NAME=SORTDEMO
/* rexx */
/*-------------------------------------------------------------------*/
/*                                                                   */
/*                       REXX Exec : SORTDEMO                        */
/*                                                                   */
/*  Description : Demonstration of sorting an array                  */
/*                                                                   */
/*  Created on : 14 Jul 2023                                         */
/*  Created by : Wendy Miller                                        */
/*             : Userid MIT002                                       */
/*             : Using ABBYDALE.DEVL.REXX(SORTDEMO)                  */
/*                                                                   */
/*  Called by : Nothing                                              */
/*                                                                   */
/*  Calls : Nothing                                                  */
/*                                                                   */
/*  Panels Used : None                                               */
/*                                                                   */
/*  Change Activity :                                                */
/*                                                                   */
/*                ©Copyright of Abbydale Systems LLC.                */
/*                                                                   */
/*-------------------------------------------------------------------*/
/*                       First build your array
*/
call BuildArray

lx = 8                /* Number of elements in array   */

/*                       Now show the original array
*/

say '-- Unsorted Table --'
Do x = 1 to lx
       say Linkmod.x 'is used via a 'LinkHow.x
End
/*                       Sort the table
*/
   do k = 1 to lx -1
      do r = k+1 to lx
        k_Linkmod = linkmod.k
        k_Linkhow = linkhow.k
        r_Linkmod = linkmod.r
        r_Linkhow = linkhow.r
        if r_Linkmod < k_Linkmod  then do
           Linkmod.k = r_Linkmod
           Linkhow.k = r_Linkhow
           Linkmod.r = k_Linkmod
           Linkhow.r = k_Linkhow
        end
      end
   end
   say ' '
   say ' '
/*                   Now show the sorted array
*/
say '--- Sorted Table ---'
Do x = 1 to lx
       say Linkmod.x 'is used via a 'LinkHow.x
End
call BuildArray          /*  Rebuild the array  */

/*                       Sort the table on both fields
*/
   do k = 1 to lx -1
      do r = k+1 to lx
        k_Linkmod = linkmod.k
        k_Linkhow = linkhow.k
        r_Linkmod = linkmod.r
        r_Linkhow = linkhow.r
        if r_Linkmod < k_Linkmod then do
           Linkmod.k = r_Linkmod
           Linkhow.k = r_Linkhow
           Linkmod.r = k_Linkmod
           Linkhow.r = k_Linkhow
        end
        if r_Linkmod = k_Linkmod then do
           if r_Linkhow < k_Linkhow then do
              Linkmod.k = r_Linkmod
              Linkhow.k = r_Linkhow
              Linkmod.r = k_Linkmod
              Linkhow.r = k_Linkhow
           end
        end
      end
   end
   say ' '
   say ' '
/*                   Now show the sorted array
*/
say '-- Table Sorted on both Fields --'
Do x = 1 to lx
       say Linkmod.x 'is used via a 'LinkHow.x
End
Exit
BuildArray:
/*                       Here is where we build our demonstration
                         array. Each array item will have two fields.
                         You can add additional fields if needed
                                 i.e fred.1                       */
Linkmod.1 = 'IEBCOPY'
LinkHow.1 = 'Call'
Linkmod.2 = 'ASLCOPY'
LinkHow.2 = 'Link'
Linkmod.3 = 'WHATNAME'
LinkHow.3 = 'Link'
Linkmod.4 = 'WHATNAME'
LinkHow.4 = 'Call'
Linkmod.5 = 'IEBUPDTE'
LinkHow.5 = 'Call'
Linkmod.6 = 'ASLDEL'
LinkHow.6 = 'Call'
Linkmod.7 = 'ASLQWTO'
LinkHow.7 = 'Attach'
Linkmod.8 = 'MQERROR'
LinkHow.8 = 'LOad'
return
/*-------------------------------------------------------------------*/
/*                          End of SORTDEMO                          */
/*-------------------------------------------------------------------*/
./ ADD NAME=STRCOUNT
/* Rexx */
/*-------------------------------------------------------------------*/
/*                                                                   */
/*                        REXX Exec : StrCount                       */
/*                                                                   */
/*  Description : Finds the number of occurrences of a character or  */
/*                string in another string. It will also return the  */
/*                position of the first occurrence of the string.    */
/*                                                                   */
/*  Usage : strCount Needle HayStack Count FirstPos                  */
/*                                                                   */
/*  Count & FirstPos are optional but if omitted those names will be */
/*  used as the returned PUSHed variables.                           */
/*                                                                   */
/*                                                                   */
/*  Created on : 19 Jul 2018                                         */
/*  Created by : Kevin Ferguson                                      */
/*             : Userid(MIT001)                                      */
/*             : using ABBYDALE.PROD.REXX(StrCount)                  */
/*                                                                   */
/*  Called by : XMT                                                  */
/*                                                                   */
/*  Calls :                                                          */
/*                                                                   */
/*  Change Activity :                                                */
/*                                                                   */
/*                ©Copyright of Abbydale Systems LLC.                */
/*                                                                   */
/*-------------------------------------------------------------------*/
parse upper arg Needle Haystack Count FirstPos
signal on novalue      /* un-initialized vars*/
signal on halt         /* attention key      */
strCount:
if Needle = "" then do
   say "strCount error: No search string passsed"
   signal leave
end
if HayStack = "" then do
   say "strCount error: No source string passsed"
   signal leave
end
Count = 0
FirstPos = 0
do until pos(Needle,HayStack) = 0
   if pos(Needle,HayStack) > 0 then do
      if FirstPos = 0 then FirstPos = pos(Needle,HayStack)
      Count = Count + 1
      w = pos(Needle,HayStack)
      HayStack = substr(HayStack,w+1,LENGTH(HayStack)-w)
   end
end
push Count
push FirstPos
leave:
return
/*-------------------------------------------------------------------*/
/*                      Trap NOVALUE Condition                       */
/*-------------------------------------------------------------------*/
novalue:
say "NOVALUE entered from line" sigl
say condition("D")
say "The instruction is suppressed"
address "TSO"
"delstack"
exit(16)
/*-------------------------------------------------------------------*/
/*                        Trap HALT Condition                        */
/*-------------------------------------------------------------------*/
halt:
say "HALT acknowledged in line" sigl
say "Cleanup processing in progress"
address "TSO"
"delstack"
exit(16)
/*-------------------------------------------------------------------*/
/*                          End of StrCount                          */
/*-------------------------------------------------------------------*/
/*-------------------------------------------------------------------*/
/*                      Trap NOVALUE Condition                       */
/*-------------------------------------------------------------------*/
novalue:
say "NOVALUE entered from line" sigl
say condition("D")
say "The instruction is suppressed"
address "TSO"
"delstack"
exit(16)
/*-------------------------------------------------------------------*/
/*                        Trap HALT Condition                        */
/*-------------------------------------------------------------------*/
halt:
say "HALT acknowledged in line" sigl
say "Cleanup processing in progress"
address "TSO"
"delstack"
exit(16)
/*-------------------------------------------------------------------*/
/*                          End of StrCount                          */
/*-------------------------------------------------------------------*/
./ ADD NAME=STRREPL
/* Rexx */
/*-------------------------------------------------------------------*/
/*                                                                   */
/*                        REXX Exec : STRREPL                        */
/*                                                                   */
/*  Description : Replace one string with another in given string.   */
/*                                                                   */
/*  Usage : new = strRepl(Input,Find,Replace,Limit)                  */
/*                                                                   */
/*  Limit, if omitted, will default to 999999 and this should catch  */
/*  all the occurences of the find string and replace them.          */
/*                                                                   */
/*                                                                   */
/*  Created on : 19 Jul 2018                                         */
/*  Created by : KEVIN FERGUSON                                      */
/*             : Userid(MIT001)                                      */
/*             : using ABBYDALE.DEVL.REXX(STRREPL)                   */
/*                                                                   */
/*  Called by :                                                      */
/*                                                                   */
/*  Calls :                                                          */
/*                                                                   */
/*  Change Activity :                                                */
/*                                                                   */
/*                ©Copyright of Abbydale Systems LLC.                */
/*                                                                   */
/*-------------------------------------------------------------------*/
signal on novalue      /* un-initialized vars*/
signal on halt         /* attention key      */
strRepl:
Orig = ARG(1)
Oldtxt = ARG(2)
Newtxt = ARG(3)
Limit  = ARG(4)
Newstr = ''
StrCount = 0
If DATATYPE(limit) <> 'NUM' then do
   Limit = 999999
end
work = Orig
Do while POS(Oldtxt,work)<> 0
   Newstr = Newstr||substr(Work,1,POS(Oldtxt,work)-1)||Newtxt
   work = substr(work,POS(Oldtxt,work)+LENGTH(oldtxt))
   StrCount = StrCount + 1
   if StrCount >= limit then leave
end
Newstr = Newstr||substr(work,1)
return newstr
/*-------------------------------------------------------------------*/
/*                      Trap NOVALUE Condition                       */
/*-------------------------------------------------------------------*/
novalue:
say "NOVALUE entered from line" sigl
say condition("D")
say "The instruction is suppressed"
address "TSO"
"delstack"
exit(16)
/*-------------------------------------------------------------------*/
/*                        Trap HALT Condition                        */
/*-------------------------------------------------------------------*/
halt:
say "HALT acknowledged in line" sigl
say "Cleanup processing in progress"
address "TSO"
"delstack"
exit(16)
/*-------------------------------------------------------------------*/
/*                          End of STRREPL                           */
/*-------------------------------------------------------------------*/
/*-------------------------------------------------------------------*/
/*                      Trap NOVALUE Condition                       */
/*-------------------------------------------------------------------*/
novalue:
say "NOVALUE entered from line" sigl
say condition("D")
say "The instruction is suppressed"
address "TSO"
"delstack"
exit(16)
/*-------------------------------------------------------------------*/
/*                        Trap HALT Condition                        */
/*-------------------------------------------------------------------*/
halt:
say "HALT acknowledged in line" sigl
say "Cleanup processing in progress"
address "TSO"
"delstack"
exit(16)
/*-------------------------------------------------------------------*/
/*                          End of STRREPL                           */
/*-------------------------------------------------------------------*/
./ ADD NAME=USERNAME
/* rexx */
/*-------------------------------------------------------------------*/
/*                                                                   */
/*                       REXX Exec : USERNAME                        */
/*                                                                   */
/*  Description : Returns the logged on user name to the caller      */
/*                                                                   */
/*  Created on : 20 May 2021                                         */
/*  Created by : Kevin Ferguson                                      */
/*             : Userid(MIT001)                                      */
/*             : using ABBYDALE.DEVL.REXX(USERNAME)                  */
/*                                                                   */
/*  Called by : REXXIT                                               */
/*                                                                   */
/*  Calls : Nothing but it does PUSH a variable onto a stack         */
/*                                                                   */
/*  Panels Used : None                                               */
/*                                                                   */
/*  Change Activity :                                                */
/*                                                                   */
/*  MM/DD/YYYY  ID   Comment                                         */
/*  ---------------------------------------------------------------  */
/*  06/13/2021  CMD  Allow exec to be called as a normal exec        */
/*                                                                   */
/*                ©Copyright of Abbydale Systems LLC.                */
/*                                                                   */
/*-------------------------------------------------------------------*/
Parse Arg Help         /* Check for Help */
If Help = "?" Then do
   Call Disp_Help
   exit(4)
end
If arg  = "?" Then do                                           /*CMD*/
   Call Disp_Help                                               /*CMD*/
   exit(4)                                                      /*CMD*/
end                                                             /*CMD*/
/*gnal on novalue         un-initialized vars                     CMD*/
signal on halt         /* attention key      */
Orig = ARG(1)          /* Get where to put it */
ascb = storage(224,4)                             /* psaaold  */
asxb = storage(d2x(c2d(ascb)+108),4)              /* ascbasxb */
acee = storage(d2x(c2d(asxb)+200),4)              /* acee     */
unam = storage(d2x(c2d(acee)+100),4)              /* aceeunam */
name=strip(storage(d2x(c2d(unam)+1),24))          /* Get name */
parse upper var name   /* fold to uppercase to make the check easier */
y = 1                  /* Start character */
do until y >= 24
   x = substr(name,y,1)
   if x <> ' ' then do
      if x < "A" then do
         k = y-1
         y = 24
      end
      if x > "Z" then do
         k = y-1
         y = 24
      end
   end
   y = y + 1
end
name = substr(name,1,k)
y = words(name)
x = 1
xname = ""
if y >= 1 then do
   do until x > y
      xname = xname||Proper(word(name,x))||" "
      x = x + 1
   end
end
else do
   xname = "Not Specified"
end
xname = '"'||strip(xname)||'"'
if orig = "" then do                                            /*CMD*/
   say xname                                                    /*CMD*/
end                                                             /*CMD*/
else do                                                         /*CMD*/
   push xname
end                                                             /*CMD*/
return
/*-------------------------------------------------------------------*/
/*                        Disp_Help Procedure                        */
/*-------------------------------------------------------------------*/
Disp_Help: Procedure
say "USERNAME - Returns the name of the current signed on user that is"
say "           runnng the EXEC. If no name is associated with the"
say "           TSO userid 'Not Specified' is returned"
say""
say "Usage: USERNAME | ?"
say""
say"    No parameter is actually required as the EXEC can only extract"
say"    the name from the control blocks of the user running the EXEC."
say" "
say"    ?        - Generates this information."
say""
say"   Return Codes :"
say""
say"                 4 - Help displayed"
say""
Return
/*-------------------------------------------------------------------*/
/*                    End of Disp_Help Procedure                     */
/*-------------------------------------------------------------------*/
/*                      Trap NOVALUE Condition                       */
/*-------------------------------------------------------------------*/
novalue:
say "NOVALUE entered from line" sigl
say condition("D")
say "The instruction is suppressed"
address "TSO"
"delstack"
exit(16)
/*-------------------------------------------------------------------*/
/*                        Trap HALT Condition                        */
/*-------------------------------------------------------------------*/
halt:
say "HALT acknowledged in line" sigl
say "Cleanup processing in progress"
address "TSO"
"delstack"
exit(16)
/*-------------------------------------------------------------------*/
/*                          End of USERNAME                          */
/*-------------------------------------------------------------------*/
./ ADD NAME=VALIDIP
/* rexx */
/*-------------------------------------------------------------------*/
/*                                                                   */
/*                        REXX Exec : VALIDIP                        */
/*                                                                   */
/*  Description : Validates that the passed IP address is in the     */
/*                correct format as a dotted IP address.             */
/*                                                                   */
/*  Created on : 18 Jun 2015                                         */
/*  Created by : Kevin Ferguson                                      */
/*             : Userid MIT001                                       */
/*             : Using ABBYDALE.PROD.REXX(VALIDIP)                   */
/*                                                                   */
/*  Called by :                                                      */
/*                                                                   */
/*  Calls : Nothing                                                  */
/*                                                                   */
/*  Panels Used : None                                               */
/*                                                                   */
/*  Change Activity :                                                */
/*                                                                   */
/*                ©Copyright of Abbydale Systems LLC.                */
/*                                                                   */
/*-------------------------------------------------------------------*/
Parse Arg Help         /* Check for Help */
If SYSVAR("SYSISPF")<>"ACTIVE" then do
   Say "ISPF must be active to use "VALIDIP
   exit(16)
end
If Help = "?" Then do
   Call Disp_Help
   exit(4)
end
signal on novalue      /* un-initialized vars*/
signal on halt         /* attention key      */
say help
Validip = 8            /* set default of not valid */
Looper = 1             /* Number of dots to find   */
Count = 0
do while looper < 4
   if pos('.',help) > 0 then do
      count = count + 1
      con = SUBSTR(help,1,POS('.',help)-1)
      if con > 255 then signal LeaveIt
      if looper = 1 then do
         If con = 0 then signal LeaveIt
      end
      If verify(con,'1234567890')  > 0 then signal LeaveIt
      help = SUBSTR(help,Pos('.',help)+1,LENGTH(HELP)-POS('.',help))
   end
   looper = looper + 1
end
if Count = 3 then do
   ValidIp = 0
end
LeaveIt:
exit(Validip)
/*-------------------------------------------------------------------*/
/*                        Disp_Help Procedure                        */
/*-------------------------------------------------------------------*/
Disp_Help: Procedure
say "VALIDIP - Checks to see if the passed IP address format is valid"
say""
say "Usage: VALIDIP IPAddr | ?"
say""
say"    IPAddr   - Specifies the dotted IP address to be checked"
say"    ?        - Generates this information."
say""
say"   Return Codes :"
say"                 0 - Passed IP address is ina valid format"
say"                 4 - Help displayed"
say"                 8 - Passed IP address is not a valid format"
say"                16 - Not under ISPF"
say""
Return
/*-------------------------------------------------------------------*/
/*                    End of Disp_Help Procedure                     */
/*-------------------------------------------------------------------*/
/*-------------------------------------------------------------------*/
/*                      Trap NOVALUE Condition                       */
/*-------------------------------------------------------------------*/
novalue:
say "NOVALUE entered from line" sigl
say condition("D")
say "The instruction is suppressed"
address "TSO"
"delstack"
exit(16)
/*-------------------------------------------------------------------*/
/*                        Trap HALT Condition                        */
/*-------------------------------------------------------------------*/
halt:
say "HALT acknowledged in line" sigl
say "Cleanup processing in progress"
address "TSO"
"delstack"
exit(16)
/*-------------------------------------------------------------------*/
/*                          End of VALIDIP                           */
/*-------------------------------------------------------------------*/
./ ADD NAME=VALIDMEM
/* rexx */
/*-------------------------------------------------------------------*/
/*                                                                   */
/*                       REXX Exec : VALIDMEM                        */
/*                                                                   */
/*  Description : Validate a passed member name                      */
/*                                                                   */
/*  Created on : 14 Apr 2020                                         */
/*  Created by : KEVIN FERGUSON                                      */
/*             : Userid(MIT001)                                      */
/*             : using ABBYDALE.DEVL.REXX(VALIDMEM)                  */
/*                                                                   */
/*  Called by :                                                      */
/*                                                                   */
/*  Calls :                                                          */
/*                                                                   */
/*  Change Activity :                                                */
/*                                                                   */
/*                ©Copyright of Abbydale Systems LLC.                */
/*                                                                   */
/*-------------------------------------------------------------------*/
pee = ''
signal on halt                   /* attention key       */
valid = 8                        /* Set default return code */
badchar = ""
forbid = '*%!&^}{[_]:,;()'  /* characters forbidden in member name */
forbid2 = '1234567890'      /* Invalid first characters */
parse upper arg testit msg
testit = strip(testit,b,"'")
if testit = "?" then do
   call disp_help
   exit(4)
end
if testit = "" then do
   do while testit = ""
   Say 'Enter member to validate. (use <QUIT> to terminate)'
   parse upper pull testit
   if testit = '<QUIT>' then exit
   if LENGTH(testit) > 8 then do
      testit = ""
      say 'Invalid member name length. Re-enter'
   end
   end
end
if LENGTH(testit) > 8 then do
   mess = 'Invalid member name length'
   signal leaveit
end
x = 1
if POS(SUBSTR(testit,1,1),forbid2) > 0 then do
        badchar = SUBSTR(testit,1,1)
badness:
        mess = ' - Invalid character in name '
        signal leaveit
end
do until x = LENGTH(forbid)
   if POS(SUBSTR(forbid,x,1),testit) > 0 then do
      badchar = SUBSTR(forbid,x,1)
      signal badness
   end
   x = x + 1
end
mess = ' - Valid'
valid = 0
leaveit:
if msg <> "" then do
   say testit||mess|| badchar
end
exit(valid)
/*-------------------------------------------------------------------*/
/*                      disp_help procedure                          */
/*-------------------------------------------------------------------*/
disp_help: procedure
pgm_name=sysvar("sysicmd")
if pgm_name="" then pgm_name="VALIDMEM"
say left(pgm_name,8) "- a REXX exec that will validate a member name."
say ""
say "Usage: VALIDMEM member msgs | ? "
say ""
say "     member - Member name to be validated."
say "     msgs   - (optional) if coded all messages will be displayed."
say "     ?      - generates this information."
say ""
say "    Return Codes : 0 - valid member name."
say "                   4 - Help displyed"
say "                  12 - Invalid member name."
Say "                  16 - Critical error"
return
/*-------------------------------------------------------------------*/
/*                      trap NOVALUE condition                       */
/*-------------------------------------------------------------------*/
novalue:
say 'NOVALUE entered from line' sigl
say condition("D")
say 'The instruction is suppressed'
address "TSO"
"delstack"
exit(16)
/*-------------------------------------------------------------------*/
/*                        trap HALT condition                        */
/*-------------------------------------------------------------------*/
halt:
say 'HALT acknowledged in line' sigl
say 'Cleanup processing in progress'
address "TSO"
"delstack"
exit(16)
/*-------------------------------------------------------------------*/
/*                          End of VALIDMEM                          */
/*-------------------------------------------------------------------*/
./ ADD NAME=VALIDVOL
/* rexx */
/*-------------------------------------------------------------------*/
/*                                                                   */
/*                       REXX Exec : VALIDVOL                        */
/*                                                                   */
/*  Description : Validate a passed volume serial number             */
/*                                                                   */
/*  Created on : 14 Feb 2021                                         */
/*  Created by : KEVIN FERGUSON                                      */
/*             : Userid(MIT001)                                      */
/*             : using ABBYDALE.DEVL.REXX(VALIDVOL)                  */
/*                                                                   */
/*  Called by : XMT                                                  */
/*                                                                   */
/*  Calls : LISTDSI                                                  */
/*                                                                   */
/*  Change Activity :                                                */
/*                                                                   */
/*                ©Copyright of Abbydale Systems LLC.                */
/*                                                                   */
/*-------------------------------------------------------------------*/
pee = ''
signal on novalue                /* un-initialized vars */
signal on halt                   /* attention key       */
valid = 8                        /* Set default return code */
parse upper arg volser
if volser = "" then do
   do while volser = ""
   Say 'Enter volser to validate. (use <QUIT> to terminate)'
   parse upper pull volser
   if volser = '<QUIT>' then exit
   if LENGTH(volser) <> 6 then do
      volser = ""
      say 'Invalid volume serial number length. Re-enter'
   end
   end
end
if volser = "?" then do
   call disp_help
   exit(4)
end
if LENGTH(volser) <> 6 then do
   say 'Invalid volume serial number length'
   exit(valid)
end
MyDsn=finddsn()
If pos('(',MyDsn)>0 then Do
   MyDsn = SubStr(MyDsn,2,pos('(',MyDsn)-2)
end
TrapON=OutTrap('ON')
"ALLOC F(ASLTEMP) DATASET('"userid()".ASLTEMP')" ,
       "NEW VOL("volser") UNIT(SYSALLDA)",
       "LIKE('"mydsn"') SPACE(1)"
valid = rc
if valid = 0 then do
   "FREE F(ASLTEMP)"
   "DEL '"userid()".ASLTEMP'"
end
TrapON=OutTrap('OFF')
exit(valid)
finddsn:
Procedure
answer='* UNKNOWN *'                   /* assume disaster            */
Parse Source . . name dd ds .          /* get known info             */
Call listdsi(dd 'FILE')                /* get 1st ddname from file   */
Numeric digits 10                      /* allow up to 7FFFFFFF       */
If name = '?' Then                     /* if sequential exec         */
  answer=''''ds''''                    /* use info from parse source */
Else                                   /* now test for members       */
  If sysdsn(''''sysdsname'('name')''')='OK' Then /* if in 1st ds     */
    answer=''''sysdsname'('name')'''   /* go no further              */
  Else                                 /* hooboy! Lets have some fun!*/
    Do                                 /* scan tiot for the ddname   */
      tiotptr=24+ptr(12+ptr(ptr(ptr(16)))) /* get ddname array       */
      tioelngh=c2d(stg(tiotptr,1))     /* length of 1st entry        */
      Do Until tioelngh=0 | tioeddnm = dd /* scan until dd found     */
        tioeddnm=strip(stg(tiotptr+4,8)) /* get ddname from tiot     */
        If tioeddnm <> dd Then         /* if not a match             */
          tiotptr=tiotptr+tioelngh     /* advance to next entry      */
        tioelngh=c2d(stg(tiotptr,1))   /* length of next entry       */
      End
      If dd=tioeddnm Then              /* if we found it, loop through
                                          the data sets doing an swareq
                                          for each one to get the
                                          dsname                     */
        Do Until tioelngh=0 | stg(4+tiotptr,1)<> " "
          tioejfcb=stg(tiotptr+12,3)
          jfcb=swareq(tioejfcb)        /* convert SVA to 31-bit addr */
          dsn=strip(stg(jfcb,44))      /* dsname JFCBDSNM            */
          vol=storage(d2x(jfcb+118),6) /* volser JFCBVOLS (not used) */
          If sysdsn(''''dsn'('name')''')='OK' Then /* found it?      */
            Leave                      /* we is some happy campers!  */
          tiotptr=tiotptr+tioelngh     /* get next entry             */
          tioelngh=c2d(stg(tiotptr,1)) /* get entry length           */
        End
      answer=''''dsn'('name')'''       /* assume we found it         */
    End
Return answer

ptr:  Return c2d(storage(d2x(Arg(1)),4))
stg:  Return storage(d2x(Arg(1)),Arg(2))

swareq:
Procedure
If right(c2x(Arg(1)),1) \= 'F' Then    /* SWA=BELOW ?                */
  Return c2d(Arg(1))+16                /* yes, return sva+16         */
svaexit2d(Arg(1))                      /* convert to decimal         */
tcb = c2d(storage(21c,4))              /* TCB PSATOLD                */
tcb = ptr(540)                         /* TCB PSATOLD                */
jscb = ptr(tcb+180)                    /* JSCB TCBJSCB               */
qmpl = ptr(jscb+244)                   /* QMPL JSCBQMPI              */
qmat = ptr(qmpl+24)                    /* QMAT QMADD                 */
Do While sva>65536
  qmat = ptr(qmat+12)                  /* next QMAT QMAT+12          */
  sva=sva-65536                        /* 010006F -> 000006F         */
End
Return ptr(qmat+sva+1)+16
/*-------------------------------------------------------------------*/
/*                      disp_help procedure                          */
/*-------------------------------------------------------------------*/
disp_help: procedure
pgm_name=sysvar("sysicmd")
if pgm_name="" then pgm_name="VALIDVOL"
say left(pgm_name,8) "- a REXX exec that will validate a volume serial."
say ""
say "Usage: VALIDVOL volser | ? "
say ""
say "     volser - Name of the volume serial number to be tested."
say "     ?      - generates this information."
say ""
say "    Return Codes : 0 - valid volume serial number"
say "                   4 - Help displyed"
say "                  12 - Invalid volume serial number"
Say "                  16 - Critical error"
return
/*-------------------------------------------------------------------*/
/*                      trap NOVALUE condition                       */
/*-------------------------------------------------------------------*/
novalue:
say 'NOVALUE entered from line' sigl
say condition("D")
say 'The instruction is suppressed'
address "TSO"
"delstack"
exit(16)
/*-------------------------------------------------------------------*/
/*                        trap HALT condition                        */
/*-------------------------------------------------------------------*/
halt:
say 'HALT acknowledged in line' sigl
say 'Cleanup processing in progress'
address "TSO"
"delstack"
exit(16)
/*-------------------------------------------------------------------*/
/*                          End of VALIDVOL                          */
/*-------------------------------------------------------------------*/
./ ADD NAME=VU
/* rexx */
/*                                                                  */
/*                   Welcome to VU                                  */
/*                                                                  */
/*  Description : Invokes VTOCUPDT to change the name of a dataset  */
/*                with the Format4 record (VTOC) of the volume      */
/*                                                                  */
/*  Created : 02/16/18 by Kevin Ferguson                            */
/*          : using ABBYDALE.DEVL.REXX(VU)                          */
/*                                                                  */
/*  Called by :  Invoked from ISPF 3.4 panel                        */
/*                                                                  */
/*  Calls : Panels : ASLVU01P or ASLVU02P depending on if the fix   */
/*                   is applied to ISRUDLP or not.                  */
/*          Program: VTOCUPDT                                       */
/*          EXECs  : GETPROF                                        */
/*                                                                  */
/*  Change Activity :                                               */
/*                                                                  */
/*                                                                  */
parse upper arg dsn
dsn = strip(dsn,b,"'")
trace o
address ispexec "VGET (ZDLPVL) SHARED"
volume = ZDLPVL
newdsn = dsn
panel = volume
address ispexec "addpop"
testdsn = dsn
a ='Y'
do while testdsn = dsn
   if panel = '' then do
      address ispexec  "display panel(ASLVU02P)"
   end
   else do
      address ispexec  "display panel(ASLVU01P)"
   end
   If rc > 0 Then SIGNAL exit
   DSN_STATUS = LISTDSI(''''dsn'''' smsinfo)
   catvol = sysvolume
   if volume = catvol then do
     zedsmsg = "Catalog error"
     zedlmsg = "Dataset "dsn" cataloged on "catvol
     Address ISPEXEC "SETMSG MSG(ISRZ000)"
     iterate
   end
   testdsn = newdsn
   if testdsn = dsn then do
   zedsmsg = "Dataset name error"
   zedlmsg = "Change the new dataset name"
   Address ISPEXEC "SETMSG MSG(ISRZ000)"
   iterate
   end
end
Prof = getProf(prof)
Address TSO "Profile noprefix"
if a = 'Y' then do
 ver = 'VERIFY'
 end
 else do
 ver = 'NOVERIFY'
 end
Address TSO "VTOCUPDT "dsn ,
                       newdsn volume ver
if rc = 0 then do
   say dsn 'renamed to' newdsn 'on' volume
end
if Prof/='N' then do
   Address TSO "Profile PREFIX("Prof")"
end
exit:
address ispexec "rempop all"
exit
./ ADD NAME=ZAPVTOC
/* Rexx */
/*-------------------------------------------------------------------*/
/*                                                                   */
/*                        REXX Exec : ZAPVTOC                        */
/*                                                                   */
/*  Description : Creates a list of datasets to be renamed by zapping*/
/*                the FORMAT4 (VTOC) record of the specified volser  */
/*                                                                   */
/*  Created on : 22 Jul 2018                                         */
/*  Created by : KEVIN FERGUSON                                      */
/*             : Userid(CD9P07)                                      */
/*             : using ABBYDALE.PROD.REXX(ZAPVTOC)                   */
/*                                                                   */
/*  Called by : TSO Line command                                     */
/*                                                                   */
/*  Calls : Panels  : ASLZV01P and ASLZV03P                          */
/*          Programs: ASLVTOC and VTOCUPDT                           */
/*          EXECs   : StrRepl and GETPROF                            */
/*                                                                   */
/*  Change Activity :                                                */
/*          FIX001  : Fix error where list was duplicated after PFK3 */
/*                                                                   */
/*                ©Copyright of Abbydale Systems LLC.                */
/*                                                                   */
/*-------------------------------------------------------------------*/
parse upper arg vol
s = userid()
Prof = getProf(prof)
Address TSO "Profile noprefix"
TrapON=OutTrap('ON')
DSN_STATUS = SYSDSN(''''s'.ZAPOUT''')
TrapON=OutTrap('OFF')
if subword(DSN_STATUS,2,2)  = 'NOT FOUND' then do
   Address TSO "ALLOC DA('"s".ZAPOUT') DSORG(PS)
               NEW BLOCK(6160) LRECL(80) RECFM(F B)
               UNIT(SYSDA) SPACE(100,200)"
               "FREE DA('"s".ZAPOUT') KEEP"
end
"alloc fi(ZAPOUT) dsn('"s".ZAPOUT') shr reuse"
reshow1:
address ispexec "addpop"
if vol = "" then do
   v = "N"          /* set default VERFIY flag to N */
   Ver = 'NOVERIFY'
   a = "N"          /* set default ALL flag to N */
   count = 0
   address ispexec  "display panel(ASLZV01P)"
   If rc > 0 Then SIGNAL exit
end
address ispexec "rempop all"
newstack    /*  List.                            FIX001*/
newstack    /*  Queue                            FIX001*/
uncat = ""
if A = 'Y' THEN uncat = 'ALL'
if V = 'Y' THEN Ver = 'VERIFY'
z = Outtrap(list.)
Address TSO aslvtoc vol uncat
do x = 1 to list.0
   dsn = WORD(list.x,1)
   cat = Word(list.x,2)
   mdsn = dsn
   if POS(Fstring,dsn) = 0 then iterate
   mdsn = strrepl(dsn,Fstring,Rstring)
   if words(mdsn) > 1 then iterate
   if length(mdsn) > 44 then do
      vol = ''
      ZEDSMSG = 'New DSN error'
   ZEDLMSG = 'Replacing the string will result in a dsn length > 44'
      address ISPEXEC 'SETMSG MSG(ISRZ001)'
      delstack
      newstack
      count = 0
      signal reshow1
   end
   TrapON=OutTrap('ON')
   DSN_STATUS = SYSDSN("'"mdsn"'")
   TrapON=OutTrap('OFF')
   say 'Congratulations ' mdsn DSN_STATUS
   if cat = "CAT( " then do
      cat = "Not Cataloged"
   end
   else do
      cat = "Cataloged on "SUBSTR(cat,5,6)
   end
   count = count + 1
   queue.count = 'VTOCUPDT' dsn '-'
   count = count + 1
   queue.count = ' 'mdsn vol Ver
end
if count = 0 then do
   Say = 'No valid, matching dataset names'
   signal reshow1
end
address TSO "EXECIO * DISKW ZAPOUT (STEM queue. FINIS"
reshow:
address ISPEXEC "EDIT DATASET('"s".ZAPOUT')"
if rc = 0 then do
   address TSO "EXECIO * DISKR ZAPOUT (STEM queue. FINIS"
     count = queue.0
               "EXECIO * DISKW ZAPOUT (STEM queue. FINIS"
      ZEDSMSG = 'Changes saved'
   ZEDLMSG = 'The changes were saved. Now press PFK3 to continue'
      address ISPEXEC 'SETMSG MSG(ISRZ001)'
   signal reshow
end
R = 'N'
address ispexec  "display panel(ASLZV03P)"
If rc > 0 Then do                /* FIX001 */
   delstack                      /* FIX001 */
   newstack                      /* FIX001 */
   count=0                       /* FIX001 */
   signal reshow1                /* FIX001 */
end                              /* FIX001 */
Upper R
select
    when R = 'Y'then do
         x = 1
         do while count > 0
            y = x + 1
            say queue.x||queue.y
            c =  queue.x||queue.y
            address TSO c
            count = count - 2
            x = x + 2
         end
    end
    when R = 'N' then do
          signal exit
    end
    when R = 'N' then do
          signal reshow1
    end
end
exit:
Address TSO "FREE F(ZAPOUT)"
if Prof/='N' then do
   Address TSO "Profile PREFIX("Prof")"
end
exit
./ ADD NAME=ZELLER
/* rexx */
/*-------------------------------------------------------------------*/
/*                                                                   */
/*                        REXX Exec : ZELLER                         */
/*                                                                   */
/*  Description : Calculate the day of the week from a date          */
/*                                                                   */
/*  Created on : 12 Dec 2010                                         */
/*  Created by : KEVIN FERGUSON                                      */
/*             : Userid(MIT001)                                      */
/*             : using ABBYDALE.DEVL.REXX(ZELLER)                    */
/*                                                                   */
/*  Called by :                                                      */
/*                                                                   */
/*  Calls : CLEAR, Proper                                         JUL*/
/*                                                                   */
/*  Change Activity :                                                */
/*                                                                   */
/*  MM/DD/YYYY  ID   Comment                                         */
/*  ---------------------------------------------------------------  */
/*  05/29/2021  ALG  Changed algorithm to correctly account for      */
/*                   January and February dates.                     */
/*  05/29/2021  TRC  Show calculation if required.                   */
/*  01/11/2022  JUL  Allow for the correct date format for dates     */
/*                   prior to 24th March 1752                        */
/*                                                                   */
/*                ©Copyright of Abbydale Systems LLC.                */
/*                                                                   */
/*-------------------------------------------------------------------*/
day.0 = Saturday
day.1 = Sunday
day.2 = Monday
day.3 = Tuesday
day.4 = Wednesday
day.5 = Thursday
day.6 = Friday
mon.1 = January
mon.2 = February
mon.3 = March
mon.4 = April
mon.5 = May
mon.6 = June
mon.7 = July
mon.8 = August
mon.9 = September
mon.10 = October
mon.11 = November
mon.12 = December
dd = 99                    /* set dummy day     */
mm = 99                    /* set dummy month   */
cal = "Gregorian"                                                /*JUL*/

clear /* <-- If you don't have a clearscreen program remove this   JUL*/

Say 'Do you want to see the calculation? (Reply y for trace)'    /*TRC*/
Pull trc                                                         /*TRC*/
do until dd < 31
   Say Day?                /* Ask for day       */
   Pull dd
end
do until mm < 13
   Say Month "(1 - 12)"    /* Ask for month     */
   Pull mm
end
Say Year (yyyy)            /* Ask for year      */
Pull yyyy
monmon = mm
entyyyy = yyyy                                                   /*ALG*/
If yyyy < 1752 then do                                           /*JUL*/
   cal = "Julian"                                                /*JUL*/
end                                                              /*JUL*/
If yyyy = 1752 then do                                           /*JUL*/
   if mm <= 3 then do                                            /*JUL*/
      if dd <= 24 then do                                        /*JUL*/
          cal = "Julian"                                         /*JUL*/
      end                                                        /*JUL*/
   end                                                           /*JUL*/
end                                                              /*JUL*/
if mm < 3 then  do
   if trc = "Y" then do
      say  'Month is 'mon.monmon ,                               /*TRC*/
      ' so subtract 1 from 'yyyy 'giving' yyyy-1                 /*TRC*/
      say ''                                                     /*TRC*/
      say 'Also add 12 to the month ('mm') giving' mm+12         /*TRC*/
   end
   mm = mm + 12
   yyyy = yyyy - 1
end
temp1 = ((mm+1)*13)%5                                            /*ALG*/
temp2 = yyyy%4                                                   /*ALG*/
temp3 = yyyy%100                                                 /*ALG*/
temp4 = yyyy%400                                                 /*ALG*/
if trc = "Y" then do                                             /*TRC*/
   say '*** Calculate the complicated bits! ***'                 /*TRC*/
   say ''                                                        /*TRC*/
   say 'This date will use the' cal 'calendar calculation'       /*JUL*/
   say ''                                                        /*JUL*/

   say 'The INTeger value of (('mm'+1)x13)/5) =' temp1,          /*TRC*/
       'Name it V1'                                              /*TRC*/
   say '                       mm + 1 =' mm + 1                  /*TRC*/
   say '                   (mm + 1)13 =' (mm + 1)*13             /*TRC*/
   say '   Int value of (mm + 1)*13/5 =' temp1 '   so V1='temp1  /*TRC*/
   say ''                                                        /*TRC*/
   say 'The INTeger value of year/4 =' temp2 'Name it V2'        /*TRC*/
   say '          Int value of 'yyyy'/4 =' temp2 '   so V2='temp2/*TRC*/
   say ''                                                        /*TRC*/
   if cal = "Gregorian" then do                                  /*JUL*/
   say 'The INTeger value of year/100 =' temp3 'Name it V3'      /*TRC*/
   say '        INT value of year/100 =' temp3 'so V3='temp3     /*TRC*/
   say ''                                                        /*TRC*/
   say 'The INTeger value of year/400 =' temp4 'Name it V4'      /*TRC*/
   say '        INT value of year/400 =' temp4 'so V4='temp4     /*TRC*/
   end                                                           /*JUL*/
   v1 = temp1                                                    /*TRC*/
   v2 = temp2                                                    /*TRC*/
   v3 = temp3                                                    /*TRC*/
   v4 = temp4                                                    /*TRC*/
   say ''                                                        /*TRC*/
   say '*** End of complicated bits! ***'                        /*TRC*/
   say ''                                                        /*TRC*/
   If cal = "Gregorian" then do                                  /*JUL*/
   say 'Add day + V1 + Year + V2 - V3 + V4 =' temp1,             /*TRC*/
   'Name it TOT1'                                                /*TRC*/
   say '   'dd' +' v1 '+' yyyy '+' V2 '-' V3 '+' V4 '=' temp1    /*TRC*/
   say ''                                                        /*TRC*/
   end                                                           /*JUL*/
   else do                                                       /*JUL*/
   say 'Add day + V1 + Year + V2 + 5 =' temp1,                   /*JUL*/
   'Name it TOT1'                                                /*JUL*/
   say '   'dd' +' v1 '+' yyyy '+' V2 - 5 '=' temp1              /*JUL*/
   say ''                                                        /*JUL*/
   end                                                           /*JUL*/
   TOT1 = temp1                                                  /*TRC*/
end                                                              /*TRC*/
If cal = "Gregorian" then do                                     /*JUL*/
   temp1 = dd+temp1+yyyy+temp2-temp3+temp4                       /*ALG*/
end                                                              /*JUL*/
else do                                                          /*JUL*/
   temp1 = dd+temp1+yyyy+temp2 + 5                               /*JUL*/
end                                                              /*JUL*/
/*
if yyyy <=  1752 then do
  if trc = "Y" then do                                           /*TRC*/
  Say 'If the date is before 24th March 1752 then add 11 to TOT1'/*TRC*/
   say ''                                                        /*TRC*/
end                                                              /*TRC*/
  temp1 = temp1 + 11
end
if yyyy =  1752 then do
  if mm <= 3 then do
     if mm = 3 then do
        if dd <= 24 then do
           temp1 = temp1 - 11
        end
     end
     temp1 = temp1 + 11
  end
end                                          */
temp4 = temp1%7
temp2 = temp4*7
temp3 = temp1-temp2
if trc = "Y" then do                                             /*TRC*/
   say 'Calculate the remainder (MOD) of' TOT1,                  /*TRC*/
   'divided by 7 =' temp3                                        /*TRC*/
   say ''                                                        /*TRC*/
   say 'The remaining number corresponds to the day of the week' /*TRC*/
   say ''                                                        /*TRC*/
   say 'In this case the remaining number is' temp3              /*TRC*/
   say ''                                                        /*TRC*/
   say 'Which corresponds to a 'Proper(day.temp3)                /*TRC*/
   say ''                                                        /*TRC*/
end                                                              /*TRC*/
say Proper(day.temp3) dd Proper(mon.monmon) entyyyy              /*ALG*/
exit
/*-------------------------------------------------------------------*/
/*                           End of ZELLER                           */
/*-------------------------------------------------------------------*/
./ ENDUP       "REVIEW" PDS MEMBER OFFLOAD AT 15:38 ON 23-12-01