/* REXX PRODDATE computes various dates for the current week and 6 weeks prior. This is intended to run as a CA7 job a few seconds after midnight every Monday before any other production job. Production jobs initiated after this can INCLUDE the PRODDATE member and confidently use the symbolic dates calculated herein. Use '(routine name) ?' for HELP-text. Written by Frank Clarke 20051027 Impact Analysis . SYSEXEC PRDSTATS . SYSEXEC TRAPOUT Modification History 20051102 fxc made it startable from READY; 20051219 fxc use PRDSTATS to avoid S/913 in PROD; 20060103 fxc zero-fill day-portion of Julian date; 20060406 fxc add some Gregorian forms; 20070131 fxc full set for week-2; 20230220 fxc if batch, don't restart in ISPF; 20230726 fxc adjust HELP; 20230801 fxc upgrade logging; 20230803 fxc use hhmm for log file name; 20231212 fxc changed log lrecl from 4096 to 255; 20231218 fxc added NOLOG parm to suppress log production; 20240308 fxc chg dollar-sign to @ everywhere; 20240309 fxc add logpref; */ arg argline address TSO /* REXXSKEL ver.20040227 */ arg parms "((" opts signal on syntax signal on novalue call TOOLKIT_INIT /* conventional start-up -*/ if ^sw.batch then, if ^sw.inispf then do /* after TOOLKIT_INIT return */ arg line line = line "(( ISPSTART" /* tell the next invocation */ "ISPSTART CMD("exec_name line")" /* Invoke ISPF... */ exit /* ...then bail out */ end rc = Trace("O"); rc = Trace(tv) info = parms /* to enable parsing */ call A_INIT /* -*/ call B_GEN_DATES /* -*/ if sw.0Log then, call ZB_SAVELOG /* -*/ if \sw.nested then call DUMP_QUEUE /* -*/ if sw.0exit_ISPF then do /* just after DUMP_QUEUE */ rc = OutTrap('LL.') exit 4 end exit /*@ PRODDATE */ /* . ----------------------------------------------------------------- */ A_INIT: /*@ */ if branch then call BRANCH address TSO call AA_SETUP_LOG /* -*/ call AK_KEYWDS /* -*/ daylist = "Monday Tuesday Wednesday Thursday Friday Saturday Sunday" parse value Date("B") Date("W") with , basedate weekday . return /*@ A_INIT */ /* . ----------------------------------------------------------------- */ AA_SETUP_LOG: /*@ */ if branch then call BRANCH address TSO msglim = SYSVAR( "SYSWTERM" ) - 12 parse value "0 0 0 0 0" with, log# log. . parse value Date("S") Time("S") Time("N") with, yyyymmdd sssss hhmmss . hhmmss = Space( Translate( hhmmss,' ',':' ) ,0 ) parse var yyyymmdd 4 yrdigit 5 mm 7 dd /* 9 12 14 maybe */ if Pos(yrdigit,"13579") > 0 then mm = mm + 12 /* mm=24 */ logtag = Substr("ABCDEFGHIJKLMNOPQRSTUVWX",mm,1) /* logtag=X */ subid = logtag""dd""Left( hhmmss,4 ) /* X141743 ? */ subid = logtag""dd""Left( hhmmss,4 ) /* X141743 ? */ vb4k.0 = "NEW CATALOG UNIT(SYSDA) SPACE(1 5) TRACKS", "RECFM(V B) LRECL( 255 ) BLKSIZE(0)" vb4k.1 = "SHR" /* if it already exists... */ logdsn = "@LOG."exec_name"."subid".LIST" logpref = "("Branch("ID")")" call ZL_LOGMSG(exec_name "started by" Userid() yyyymmdd hhmmss) call ZL_LOGMSG( logpref "Arg:" argline) return /*@ AA_SETUP_LOG */ /* . ----------------------------------------------------------------- */ AK_KEYWDS: /*@ */ if branch then call BRANCH address TSO sw.0Log = SWITCH( "NOLOG" ) = 0 outdsn = KEYWD("WRITE") if outdsn = '' then do helpmsg = "WRITE was not specified. WRITE is required." call HELP /* ...and don't come back! -*/ end if Left(outdsn,1) = "'" then, outdsn = Strip(outdsn,,"'") else, outdsn = Userid()"."outdsn if Sysdsn("'"outdsn"'") <> "OK" then, helpmsg = "'"outdsn"'" Sysdsn("'"outdsn"'") else, /* */ if Sysdsn("'"outdsn"(PRODDATE)'") <> "OK" &, Sysdsn("'"outdsn"(PRODDATE)'") <> "MEMBER NOT FOUND" then, helpmsg = "'"outdsn"(PRODDATE)'" Sysdsn("'"outdsn"(PRODDATE)'") if helpmsg <> "" then call HELP /* ...and don't come back -*/ return /*@ AK_KEYWDS */ /* . ----------------------------------------------------------------- */ B_GEN_DATES: /*@ */ if branch then call BRANCH address TSO call BD_SET_DATES /* -*/ call BW_WRITE_DATES /* -*/ return /*@ B_GEN_DATES */ /* Parm is a basedate to be converted to 5-digit Julian . ----------------------------------------------------------------- */ BA_JULIAN: /*@ */ if branch then call BRANCH address TSO arg base . parse value Date("D",base,"B") Date("O",base,"B") with, ddd yymmdd . jul5 = Left(yymmdd,2)Right(ddd,3,0) return(jul5) /*@ BA_JULIAN */ /* Build all the SET statements for Julian and Gregorian dates. . ----------------------------------------------------------------- */ BD_SET_DATES: /*@ */ if branch then call BRANCH address TSO logpref = "("Branch("ID")")" monday_offset = WordPos(weekday,daylist) - 1 /* Monday = 0 */ basedate = basedate - monday_offset /* convert to Monday */ call ZL_LOGMSG( logpref "Monday basedate is" basedate) "NEWSTACK" monday_basedate = basedate tuesday_basedate = basedate + 1 wednesday_basedate = basedate + 2 thursday_basedate = basedate + 3 friday_basedate = basedate + 4 saturday_basedate = basedate + 5 sunday_basedate = basedate + 6 next_monday = basedate + 7 next_tuesday = basedate + 8 today_b = Date( "B",yyyymmdd,"S" ) today_j = BA_JULIAN( today_b ) txt = "//* "yyyymmdd" <-- Date last updated ("today_j")" call ZL_LOGMSG( logpref txt) ; queue txt txt = "// SET TUEJULA="BA_JULIAN(next_tuesday) call ZL_LOGMSG( logpref txt) ; queue txt txt = "// SET MONJULA="BA_JULIAN(next_monday) call ZL_LOGMSG( logpref txt) ; queue txt stage = 0 txt = "// SET SUNJUL"stage"="BA_JULIAN(sunday_basedate) ||, ",SUNGRG"stage"="Date("U",sunday_basedate,"B") call ZL_LOGMSG( logpref txt) ; queue txt txt = "// SET SATJUL"stage"="BA_JULIAN(saturday_basedate) ||, ",SATGRG"stage"="Date("U",saturday_basedate,"B") call ZL_LOGMSG( logpref txt) ; queue txt txt = "// SET FRIJUL"stage"="BA_JULIAN(friday_basedate) ||, ",FRIGRG"stage"="Date("U",friday_basedate,"B") call ZL_LOGMSG( logpref txt) ; queue txt txt = "// SET THUJUL"stage"="BA_JULIAN(thursday_basedate) ||, ",THUGRG"stage"="Date("U",thursday_basedate,"B") call ZL_LOGMSG( logpref txt) ; queue txt txt = "// SET WEDJUL"stage"="BA_JULIAN(wednesday_basedate) ||, ",WEDGRG"stage"="Date("U",wednesday_basedate,"B") call ZL_LOGMSG( logpref txt) ; queue txt txt = "// SET TUEJUL"stage"="BA_JULIAN(tuesday_basedate) ||, ",TUEGRG"stage"="Date("U",tuesday_basedate,"B") call ZL_LOGMSG( logpref txt) ; queue txt txt = "// SET MONJUL"stage"="BA_JULIAN(monday_basedate) ||, ",MONGRG"stage"="Date("U",monday_basedate,"B") call ZL_LOGMSG( logpref txt) ; queue txt basedate = basedate - 7 /* prior week */ monday_basedate = basedate tuesday_basedate = basedate + 1 wednesday_basedate = basedate + 2 thursday_basedate = basedate + 3 friday_basedate = basedate + 4 saturday_basedate = basedate + 5 sunday_basedate = basedate + 6 stage = 1 txt = "// SET SUNJUL"stage"="BA_JULIAN(sunday_basedate) ||, ",SUNGRG"stage"="Date("U",sunday_basedate,"B") call ZL_LOGMSG( logpref txt) ; queue txt txt = "// SET SATJUL"stage"="BA_JULIAN(saturday_basedate) ||, ",SATGRG"stage"="Date("U",saturday_basedate,"B") call ZL_LOGMSG( logpref txt) ; queue txt txt = "// SET FRIJUL"stage"="BA_JULIAN(friday_basedate) ||, ",FRIGRG"stage"="Date("U",friday_basedate,"B") call ZL_LOGMSG( logpref txt) ; queue txt txt = "// SET THUJUL"stage"="BA_JULIAN(thursday_basedate) ||, ",THUGRG"stage"="Date("U",thursday_basedate,"B") call ZL_LOGMSG( logpref txt) ; queue txt txt = "// SET WEDJUL"stage"="BA_JULIAN(wednesday_basedate) ||, ",WEDGRG"stage"="Date("U",wednesday_basedate,"B") call ZL_LOGMSG( logpref txt) ; queue txt txt = "// SET TUEJUL"stage"="BA_JULIAN(tuesday_basedate) ||, ",TUEGRG"stage"="Date("U",tuesday_basedate,"B") call ZL_LOGMSG( logpref txt) ; queue txt txt = "// SET MONJUL"stage"="BA_JULIAN(monday_basedate) ||, ",MONGRG"stage"="Date("U",monday_basedate,"B") call ZL_LOGMSG( logpref txt) ; queue txt do stage = 2 to 6 /* 7 weeks */ basedate = basedate - 7 /* prior week */ monday_basedate = basedate friday_basedate = basedate + 4 sunday_basedate = basedate + 6 txt = "// SET SUNJUL"stage"="BA_JULIAN(sunday_basedate) ||, ",SUNGRG"stage"="Date("U",sunday_basedate,"B") call ZL_LOGMSG( logpref txt) ; queue txt txt = "// SET FRIJUL"stage"="BA_JULIAN(friday_basedate) ||, ",FRIGRG"stage"="Date("U",friday_basedate,"B") call ZL_LOGMSG( logpref txt) ; queue txt txt = "// SET MONJUL"stage"="BA_JULIAN(monday_basedate) ||, ",MONGRG"stage"="Date("U",monday_basedate,"B") call ZL_LOGMSG( logpref txt) ; queue txt end /* stage */ return /*@ BD_SET_DATES */ /* . ----------------------------------------------------------------- */ BW_WRITE_DATES: /*@ */ if branch then call BRANCH address TSO "ALLOC FI(@DT) DA('"outdsn"(PRODDATE)') SHR REU" logpref = "("Branch("ID")")" call ZL_LOGMSG( logpref queued() , "lines written to '"outdsn"(PRODDATE)'") "EXECIO" queued() "DISKW @DT (FINIS" "FREE FI(@DT)" "DELSTACK" "%PRDSTATS {"outdsn "{PRODDATE {UID SPECIAL ((MONITOR " if sw.batch then return /* can't VIEW anything */ if sw.0exit_ISPF then return address ISPEXEC "VIEW DATASET('"outdsn"(PRODDATE)') PROFILE(DEFAULT)" return /*@ BW_WRITE_DATES */ /* . ----------------------------------------------------------------- */ LOCAL_PREINIT: /*@ customize opts */ address TSO sw.0exit_ISPF = SWITCH("ISPSTART") return /*@ LOCAL_PREINIT */ /* subroutines below LOCAL_PREINIT are not selected by SHOWFLOW */ /* . ----------------------------------------------------------------- */ ZB_SAVELOG: /*@ */ if branch then call BRANCH address TSO if Symbol("LOG#") = "LIT" then return /* not yet set */ "ALLOC FI(@LOG) DA("logdsn") REU" vb4k.0 "EXECIO" log# "DISKW @LOG (STEM LOG. FINIS" "FREE FI(@LOG)" return /*@ ZB_SAVELOG */ /* . ----------------------------------------------------------------- */ ZL_LOGMSG: Procedure expose, /*@ */ (tk_globalvars) log. log# msglim rc = Trace("O") address TSO parse arg msgtext /* for making the msgline always reasonably short: */ do while Length(msgtext) > msglim pt = LastPos(" ",msgtext,msglim) slug = Left(msgtext,pt) if monitor then say, slug parse value log#+1 slug with, zz log.zz 1 log# . msgtext = " "Substr(msgtext,pt) end /* while msglim */ parse value log#+1 msgtext with, zz log.zz 1 log# . if monitor then say, msgtext return /*@ ZL_LOGMSG */ /* . ----------------------------------------------------------------- */ HELP: /*@ */ address TSO;"CLEAR" ; say "" if helpmsg <> "" then say helpmsg ex_nam = Left(exec_name,8) /* predictable size */ say " " say " "ex_nam" computes Monday-to-Sunday dates for the current week in " say " both Julian- and Gregorian-form, Julian dates for the next" say " two days, and Julian and Gregorian Monday-Friday-Sunday " say " dates for the prior 6 weeks, all as JCL 'SET' statements. " say " " say " Syntax: "ex_nam" WRITE dsn (Required)" say " " say " dsn names (in TSO-format) a JCL-form dataset to receive " say " the SET statements. Member PRODDATE containing the " say " generated SETs will be written to this dataset. The" say " names of the variables used are MONJULx, MONGRGx, " say " (etc.) where (x) is the week-id: '0' for the " say " current week, '6' for six-weeks-prior. " say " " "NEWSTACK"; pull ; "CLEAR" ; "DELSTACK" say " Debugging tools provided include: " say " " say " MONITOR displays key information throughout processing. " say " " say " BRANCH show all paragraph entries. " say " " say " TRACE tv will use value following TRACE to place the " say " execution in REXX TRACE Mode. " say " " say " " say " Debugging tools can be accessed in the following manner: " say " " say " TSO "ex_nam" parameters (( debug-options " say " " say " For example " say " " say " TSO "ex_nam" (( MONITOR TRACE ?R " if sw.inispf then, address ISPEXEC "CONTROL DISPLAY REFRESH" exit /*@ HELP */ /* . ----------------------------------------------------------------- */ BRANCH: Procedure expose, /*@ */ sigl exec_name rc = trace("O") /* we do not want to see this */ arg brparm . origin = sigl /* where was I called from ? */ do currln = origin to 1 by -1 /* inch backward to label */ if Right(Word(Sourceline(currln),1),1) = ":" then do parse value sourceline(currln) with pgfname ":" . /* Label */ leave ; end /* name */ end /* currln */ select when brparm = "NAME" then return(pgfname) /* Return full name */ when brparm = "ID" then do /* wants the prefix */ parse var pgfname pgfpref "_" . /* get the prefix */ return(pgfpref) end /* brparm = "ID" */ otherwise say left(sigl,6) left(pgfname,40) exec_name "Time:" time("L") end /* select */ return /*@ BRANCH */ /* . ----------------------------------------------------------------- */ DUMP_QUEUE: /*@ Take whatever is in stack */ rc = trace("O") /* and write to the screen */ address TSO arg mode . "QSTACK" /* how many stacks? */ stk2dump = rc - tk_init_stacks /* remaining stacks */ if stk2dump = 0 & queued() = 0 then return if mode <> "QUIET" then, say "Total Stacks" rc , /* rc = #of stacks */ " Begin Stacks" tk_init_stacks , /* Stacks present at start */ " Excess Stacks to dump" stk2dump do dd = rc to tk_init_stacks by -1 /* empty each one. */ if mode <> "QUIET" then, say "Processing Stack #" dd " Total Lines:" queued() do queued();parse pull line;say line;end /* pump to the screen */ "DELSTACK" /* remove stack */ end /* dd = 1 to rc */ return /*@ DUMP_QUEUE */ /* Handle CLIST-form keywords added 20020513 . ----------------------------------------------------------------- */ CLKWD: Procedure expose info /*@ hide all except info */ arg kw kw = kw"(" /* form is 'KEY(DATA)' */ kw_pos = Pos(kw,info) /* find where it is, maybe */ if kw_pos = 0 then return "" /* send back a null, not found*/ rtpt = Pos(") ",info" ",kw_pos) /* locate end-paren */ slug = Substr(info,kw_pos,rtpt-kw_pos+1) /* isolate */ info = Delstr(info,kw_pos,rtpt-kw_pos+1) /* excise */ parse var slug (kw) slug /* drop kw */ slug = Reverse(Substr(Reverse(Strip(slug)),2)) return slug /*@CLKWD */ /* Handle multi-word keys 20020513 . ----------------------------------------------------------------- */ KEYWD: Procedure expose info /*@ hide all vars, except info*/ arg kw /* form is 'KEY DATA' */ kw_pos = wordpos(kw,info) /* find where it is, maybe */ if kw_pos = 0 then return "" /* send back a null, not found*/ kw_val = word(info,kw_pos+Words(kw))/* get the next word */ info = Delword(info,kw_pos,2) /* remove both */ return kw_val /*@ KEYWD */ /* . ----------------------------------------------------------------- */ KEYPHRS: Procedure expose, /*@ */ info helpmsg exec_name /* except these three */ arg kp /* form is 'KEY ;: DATA ;:' */ wp = wordpos(kp,info) /* where is it? */ if wp = 0 then return "" /* not found */ front = subword(info,1,wp-1) /* everything before kp */ back = subword(info,wp+1) /* everything after kp */ parse var back dlm back /* 1st token must be 2 bytes */ if length(dlm) <> 2 then /* Must be two bytes */ helpmsg = helpmsg, "Invalid length for delimiter("dlm") with KEYPHRS("kp")" if wordpos(dlm,back) = 0 then /* search for ending delimiter*/ helpmsg = helpmsg, "No matching second delimiter("dlm") with KEYPHRS("kp")" if helpmsg <> "" then call HELP /* Something is wrong */ parse var back kpval (dlm) back /* get everything b/w delim */ info = front back /* restore remainder */ return Strip(kpval) /*@ KEYPHRS */ /* . ----------------------------------------------------------------- */ NOVALUE: /*@ */ say exec_name "raised NOVALUE at line" sigl say " " say "The referenced variable is" condition("D") say " " zsigl = sigl signal SHOW_SOURCE /*@ NOVALUE */ /* . ----------------------------------------------------------------- */ SHOW_SOURCE: /*@ */ call DUMP_QUEUE /* Spill contents of stacks -*/ if sourceline() <> "0" then /* to screen */ say sourceline(zsigl) rc = trace("?R") nop exit /*@ SHOW_SOURCE */ /* . ----------------------------------------------------------------- */ SS: Procedure /*@ Show Source */ arg ssbeg ssct . /* 'call ss 122 6' maybe */ if ssct = "" then ssct = 10 if \datatype(ssbeg,"W") | \datatype(ssct,"W") then return ssend = ssbeg + ssct do ssii = ssbeg to ssend ; say Strip(sourceline(ssii),'T') ; end return /*@ SS */ /* . ----------------------------------------------------------------- */ SWITCH: Procedure expose info /*@ */ arg kw /* form is 'KEY' */ sw_val = Wordpos(kw,info) > 0 /* exists = 1; not found = 0 */ if sw_val then /* exists */ info = Delword(info,Wordpos(kw,info),1) /* remove it */ return sw_val /*@ SWITCH */ /* . ----------------------------------------------------------------- */ SYNTAX: /*@ */ errormsg = exec_name "encountered REXX error" rc "in line" sigl":", errortext(rc) say errormsg zsigl = sigl signal SHOW_SOURCE /*@ SYNTAX */ /* Can call TRAPOUT. . ----------------------------------------------------------------- */ TOOLKIT_INIT: /*@ */ address TSO info = Strip(opts,"T",")") /* clip trailing paren */ parse source sys_id how_invokt exec_name DD_nm DS_nm, as_invokt cmd_env addr_spc usr_tokn parse value "" with tv helpmsg . parse value 0 "ISR00000 YES" "Error-Press PF1" with, sw. zerrhm zerralrm zerrsm if SWITCH("TRAPOUT") then do "TRAPOUT" exec_name parms "(( TRACE R" info exit end /* trapout */ sw.nested = sysvar("SYSNEST") = "YES" sw.batch = sysvar("SYSENV") = "BACK" sw.inispf = sysvar("SYSISPF") = "ACTIVE" if Word(parms,1) = "?" then call HELP /* I won't be back */ "QSTACK" ; tk_init_stacks = rc /* How many stacks? */ parse value SWITCH("BRANCH") SWITCH("MONITOR") SWITCH("NOUPDT") with, branch monitor noupdt . parse value mvsvar("SYSNAME") sysvar("SYSNODE") with, #tk_cpu node . parse value KEYWD("TRACE") "N" with tv . tk_globalvars = "exec_name tv helpmsg sw. zerrhm zerralrm ", "zerrsm zerrlm tk_init_stacks branch monitor ", "noupdt" call LOCAL_PREINIT /* for more opts -*/ return /*@ TOOLKIT_INIT */