/* REXX -- Invoke SCRIPT with PostScript options                   */
 /*  Author: David McRitchie, "The REXX Macros Toolbox", 1991/09/05 */
 /*  Note PostScript codepages are not compatible with 3800-1 chars*/
 /*                                                                */
 /*  Unless a destination is coded, DEST() or GO, output will      */
 /*  remain only in the dataset.  userid.PUBLIC.membername         */
 /*                                                                */
 /* options :                                                      */
 /*  B,          BookMaster                                        */
 /*  DEST(---------)   required if file is to be sent              */
 /*  DEV(----------)                                               */
 /*    LEGAL,    Paper is legal size 8.5 x 11  DEVICE(PSL)         */
 /*  CLASS(-),  specify sysout class, default is G                 */
 /*  CHARS(matrix),  Specify Adobe Font Matrix                     */
 /*  CONT,           Continue after error(s) encountered           */
 /*  FORCE,          Attempt to print even though errors found     */
 /*  REPRINT,        Will not format, print old output at own risk */
 /*  CHARS(----------)   Initial FONTS .......   available TYPESIZE*/
 /*     HELVETICA            generates PSFHV...      3, 7, 8, 10 I  */
 /*     TIMES ROMAN          generates PSFTR...      7, 10   I      */
 /*     COURIER              generates PSFCR...      7, 10   I      */
 /*     PALATINO             generates PSFPL...      7, 10   I      */
 /*  the following are abbreviated to 1st significant word,         */
 /* ITC Avant Garde Gothic   generates PSFAG...      4, 6    I      */
 /* ITC Bookman              generates PSFBK...      3, 6    I      */
 /* ITC Garamond             generates PSFGR...      3, 7    I      */
 /* ITC Korinna              generates PSFKO...      7, 10   I      */
 /*  the following is abbreviated as  NCS                           */
 /* New Century Schoolbook   generates PSFNCS...     7, 10   I      */
 /*  pointsizes,     appended to   CHARS(PSF--xxx)                 */
 /*    3,7,8,10  Pointsize  generates L,B,BK,(null)                */
 /*================================================================*/
 /* store  Encapsulated PostScript (.EPS) in  SYS6.EPS.LOGOS(member)*/
 /*================================================================*/
Address "ISREDIT"
"MACRO (token)"
  tokenOrig = token
 " (VAR014A) = DATA_CHANGED"
 If VAR014A  = "YES" THEN do
   address "ISREDIT"
   "SAVE"
   "LINE_BEFORE .ZFIRST = NOTELINE """TIME('N'),
      "SCRIPTPS  *Data had to be saved before invoking SCRIPT"""
 END
"(MEMBERX) = MEMBER "
"(DSNX)    = DATASET"
 Address "TSO" "IEFBR14 -- SCRIPTPS" token "--" dsnx"("memberx")"
dev="";chars="";dest="";left="";right="";copies="1";groupid="";PSFILE=""
reprint="";library="SCRIPT.R40.MACLIB"
token = TRANSLATE(' '||token||' ')  /* TRANSLATE TO UPPERCASE */
"(CARD1ST) = LINE .ZFIRST"  /* FP(1) DUPLEX(NO) can be defaulted */
card1st = translate(card1st)

REL = ""
i = index(token,' R40 ');
if i /=0 then do; REL = "R40"
   parse var token left " R40 " right
   token = left || ' ' || right
end
BOOK = ""
i = index(token,' REPRINT ');
if i /=0 then do; Useprev = "USEPREV"
   parse var token left " REPRINT " right
   token = " "left || ' ' || right" "
end
i = index(token,' B ');
if i /=0 then do; Book = "B"
   parse var token left " B " right
   token = left || ' ' || right
   library = "SCRIPT.EDF.EDFMAC"   /* SCRIPT.EDF.EDFMAC VERSION LATER*/
end
i = index(token,' R40 ');
if i /=0 then do; REL = "R40"
   parse var token left " R40 " right
   token = left || ' ' || right
end

/******************/
ibmprof   = process('ibmprof')
if ibmprof="IBMPROF" then do
    profiledsn= "DCF.R40.MACLIB"
    library= "tech.vmsubset.MACLIB"  /* and dcf.r40.maclib */
end
/******************/
useprev  = process('USEPREV');
noprint = process('NOPRINT');
continue=''
CONTINUE = process('NOCO');
if CONTINUE = '' then CONTINUE = process('CONTINUE')
if CONTINUE = '' then CONTINUE =process('CONT')
if CONTINUE = '' then CONTINUE =process('CO')
if continue \= '' then continue = " CO "
if CONTINUE = 'NOCO' then CONTINUE = ''
force = process('FORCE')
browse = process('BROWSE')
if browse ="" then Browse=process('B')
if browse \= "" then Browse = "BROWSE"

i = index(token,' CLASS(')
if i/=0 then do;
   parse var token left " CLASS(" class ")" right
   token = left || ' ' || right
end
else class = "G"
parse var token left " FP(" fp ") " right
   token = left || ' ' || right
   if fp /='' then fp = ' FP('fp')';
   if fp ='' then do
      "find 'FP(1)' .zfirst .zfirst"
      if rc = 0 then do ; fp = ' FP(1) ';say "Found FP(1) ",
         "on first card will format one pass only"
      end
      else fp=' FP(2)'
   end
x8=time('N');x6=substr(x8,1,2)substr(x8,4,2)substr(x8,7,2)
i = index(token,' GROUPID(')
if i/=0 then do;
   parse var token left " GROUPID(" groupid ")" right
   token = left || ' ' || right
end
else groupid = "T"x6
i = index(token,' COPIES(')
if i/=0 then do;
   parse var token left " COPIES(" copies ")" right
   token = left || ' ' || right
end
else copies = "1"
sysvar = ""
/* The following SYSVAR are in the Starter Set GML */
/*    C,D,H,P,R,S,T,and W,  also find I,L,M, and X */
/*    and the SCRIPTPS macro adds        Y, and Z  */
if substr(sysvar(sysproc),5,4) = "TEST" then do
    if rel = "" then do
       rel = "R40"
       say ' '
       say 'use of a TEST logon proc has forced',
         '-- using Release 4.0.0 macros ------'
       say ' '
       say 'use of a TEST logon proc has forced',
         '-- using Release 4.0.0 macros ------'
    end
end
if rel = "" then rel = "R40"
if rel = "R32" then DSMPROF="DSMPROF4"
if rel = "R40" then DSMPROF="DSMPROF4"
if rel = "" then do;DSMPROF="DSMPROF4";rel="R40";end


Parse var token left " DEV(" DEV ")" right
If dev /= '' then token = left right
/* some special devices not checking for redundancy */
I = index(token," L "); If I /=0 then
   do;DEV = "PSA90";token = substr(token,1,I)substr(token,I+3);end
I = index(token," ACROSS "); If I /=0 then
   do;DEV = "PSA90";token = substr(token,1,I)substr(token,I+8);end
I = index(token," LEGAL "); If I/=0 then   /* change paper size*/
   do; dev="PSL"; token = substr(token,1,I)substr(token,I+7); end
If DEV = '' then DEV = "PSA"

Parse var token left " DEST(" dest ")" right;token = left right
If dest = "" then do
   I = index(token," GO ")
   If I /= 0 then do;dest = "P15NF";  /* used to be P15NF, PROG1A3A */
      token =substr(token,1,I)substr(token,I+3); end;
   /* -- three tokens available for SYSTECH room LaserJet IV -MX-   */
   if dest='' then dest=process("PU2ZD","PU2ZD")
   if dest='' then dest=process("PU","PU2ZD")
   if dest='' then dest=process("TECHPS","P1CBX")    /*TCP/IP*/
   /* no-- if dest='' then dest=process("TECHPS","TCPPRTST")  */
      /*  SYS6.VPS.CNTL for prod,   SYS6.VPS.R61.CNTL for test       */
      /*        | member    =G         =A   |  =G         =A         */
      /*        | dual      dest=    dest=  | single G    single A   */
      /* TCP    |  no dual avail for TCP    | TCPPRTST    TCPPRTS1   */
      /*        |                           | ======== or ========   */
      /* VTAM   | PU2ZDALL PU2ZD    PU2ZD   |                        */
      /*        | ======== <--active        |                        */
end
parse var token left " FORMS(" forms ") " right
   token = left || ' ' || right
parse var token left " DUPLEX(" duplex ") " right
   token = left || ' ' || right
   duplex = substr(duplex,1,1)
   i = pos('DUPLEX(NO)',card1st);
   if i \=0 then do;
     say "Found DUPLEX(NO) ",
        "on first card will include SYSVAR(D N)"
     if duplex = '' then duplex = "N"
   end   /* save duplex for sysvar later on */
STOP = process("STOP")
i=index(token," TECHPSF ");
if i \= 0 then do
   ZEDSMSG = "TECHPSF invalid"
   ZEDLMSG = "TECHPSF is valid in @SCRIPT, but not in SCRIPTPS"
   ADDRESS 'ISPEXEC' 'SETMSG MSG(ISRZ000)'
   EXIT 4
end

Parse var token  left ' PAGE(' page ')' right;token= left right
If page /= '' then page = " PAGE("page")"

If token = " " THEN CHARS = "PSFHV"  /* USE DEFAULT */
Parse var token  left ' CHARS(' CHARS ')' RIGHT;token = left right
Parse var token  left ' FILE(' PSFILE ')' Right;token = left right
If CHARS = '' THEN DO
   If 0 /= INDEX(token,' HELVETICA ') THEN CHARS = "PSFHV"
   ELSE If 0 /= INDEX(token,' TIMES ROMAN ') THEN do
      CHARS = "PSFTR"; token = substr(token,1,I)||substr(token,I+12)
      signal chdone
   end
   ELSE If 0 /= INDEX(token,' COURIER ')  THEN CHARS = "PSFCR"
   ELSE If 0 /= INDEX(token,' AVANT ')    THEN CHARS = "PSFAG"
   ELSE If 0 /= INDEX(token,' PALATINO ') THEN CHARS = "PSFPL"
   ELSE If 0 /= INDEX(token,' BOOKMAN')   THEN CHARS = "PSFBK"
   ELSE If 0 /= INDEX(token,' GARAMOND')  THEN CHARS = "PSFGR"
   ELSE If 0 /= INDEX(token,' KORINNA')   THEN CHARS = "PSFKO"
   ELSE If 0 /= INDEX(token,' NCS')       THEN CHARS = "PSFNCS"
   ELSE If 0 /= INDEX(token,' KORINNA')   THEN CHARS = "PSFKO"
   ELSE CHARS = 'PSFHV'
   If I /= 0 then do; k = index(substr(token,I,),' ');
      token = substr(token,1,I)||substr(token,I+k)
   end; chdone:
END
If 0 /= INDEX(token,' 3 ') THEN CHARS = CHARS||'L';
If 0 /= INDEX(token,' 7 ') THEN CHARS = CHARS||'B';
If 0 /= INDEX(token,' 8 ') THEN CHARS = CHARS||'BK';
If 0 /= INDEX(token,' ITALIC ') | ,
   0 /= INDEX(token,' I ') THEN DO
     xx = substr(chars,4,2)
     If 0 /= index('HV CR AG',substr(chars,4,2))
     then chars = chars||'O'; else chars = Chars||'I';
end

If token /= "" then do
   say "Possibility of unprocessed parameters"
   say " --" token
   /*return*/
end

If 0 /= INDEX(token,' E ') THEN PSOUT = 'E'; ELSE PSOUT = 'A'
MEMBERD = MEMBERX
If MEMBERD = "CNTL" | MEMBERD = "TEXT" THEN MEMBERD = "LIST"
IF substr(memberx,1,1) = "S" then
   if dsnx = "TECH.LIBR2.TEXT" then memberx = 'A'||substr(memberx,2)
if memberd = '' then memberd='GOGO'
FILE = "PUBLIC."||MEMBERD
If SUBSTR(FILE,1,13) = "PUBLIC.ESHAJK" THEN
   FILE = "PUBLIC."||SUBSTR(FILE,12)
FILE = "'"||SYSVAR(SYSUID)||"."||FILE||"'"
if PSFILE \= '' then do
   if substr(psfile,1,1) \= "'" then psfile="'"psfile"'"
   say "Override FILE" file '..with..' psfile
   file = psfile
end
Address "TSO"
X = SYSDSN(FILE)
If x = "OK" THEN DEL FILE

X = SYSDSN('''SCRIPT.'rel'.FONTPS('||CHARS||')''')
If x /= "OK" then do
  Address "ISREDIT"
  "LINE_BEFORE .ZFIRST = NOTELINE """TIME('N'),
   "SCRIPTPS   ADOBE FONT Matrix (AFM) not found -- "||chars||"  RC=4"""
  "LINE_BEFORE .ZFIRST = NOTELINE ""          ",
         "using  SCRIPTPS"||token||""""
  "UP MAX"
  "LOC 0"
   ZEDSMSG = "CHARS(??)"
   ZEDLMSG = "Adobe Font Matrix (AFM) not found in SCRIPT."rel".FONTPS",
      "FOR CHAR("||chars||")"
   ADDRESS 'ISPEXEC' 'SETMSG MSG(ISRZ000)'
   EXIT 4
end
"$TIME -- SCRIPTPS"
/* place our default SYSVAR in font of any supplied, except BookMaster*/
if duplex = "Y" | duplex = "YES" | duplex = "" then duplex = "Y"
sysvar = strip(sysvar) "D" duplex
psdest = dest
if psdest = "" then psdest = 'None'
if book = "B" then do;
   profiledsn = "SYS1.EDF.EDFMAC1"
   profiledsn = "SCRIPT.EDF.EDFMAC"
   dsmprof="EDFPRF40"
   sysvar = sysvar "G INLINE Z" psdest
end;
else do;
   profiledsn = "SCRIPT."rel".MACLIB"
   sysvar = "X NO H NO Y" sysvar("SYSUID") "Z" psdest" D "duplex
   /******************/
   if ibmprof="IBMPROF" then profiledsn= "DCF.R40.MACLIB"
   /******************/
end;
if memberx /= '' then DCFcommand =,
    "SCRIPT '"||DSNX||"("||MEMBERX||")'"
else DCFcommand =  "SCRIPT '"||DSNX"'"
if library \= '' then  library = " LIB('"library"')"
DCFcommand = DCFcommand "INDEX B(1I)"fp||continue,
   " SYS("sysvar")" library,
   page" DEV("||DEV||") CHARS("||CHARS||")" ,
   "PSOUT("||PSOUT||") FI("||FILE||")" ,
   "FO('SCRIPT."rel".FONTPS') PRO('"profiledsn"("DSMPROF")')"
say '-------------'
say DCFcommand
say '-------------'
if stop = "STOP" then do
     Address "ISREDIT" "LINE_BEFORE .ZFIRST = NOTELINE """TIME('N'),
        "You choose to  STOP  before formatting"""
     ZEDSMSG = "STOP in effect"
     ZEDLMSG = "You choose to  STOP  before formatting"
     ADDRESS 'ISPEXEC' 'SETMSG MSG(ISRZ000)'
     return 1
end
if USEPREV = "USEPREV" then lastcc = 0
else DCFcommand
lastcc = rc

status = msg('off')
ADDRESS "TSO" "FREE DA('SYS6.EPS.LOGOS')"
status = msg('on')

"$TIME -- SCRIPTPS"
ScriptRC = lastcc
if ScriptRC = 4 then
   say 'Script/VS RC='ScriptRC' -- will try to use'
if ScriptRC > 4  then do
   if FORCE = "FORCE" then if continue \= "" then leave
   /* if you use force you may be asking for a heap of trouble */
   if dest \= "" then  say 'Script/VS RC='ScriptRC', print terminated'
   else say 'Script/VS RC='ScriptRC', errors occurred do not print'
   ZEDSMSG = "Script/VS RC="ScriptRC
   ZEDLMSG = "SCRIPT invoked by" SYSVAR(SYSICMD) ,
        "had errors,  Script/VS RC="ScriptRC
   Address "ISPEXEC" "SETMSG MSG(ISRZ000)"
   return 1
end
if Browse = "BROWSE" then do;"$BROWSE" FILE;say DCFcommand;end
if noprint = "NOPRINT" then do
     Address "ISREDIT"
     "LINE_BEFORE .ZFIRST = NOTELINE """TIME('N'),
        "You chose not to print, even though",
            "you set dest="dest", Script/VS RC="||ScriptRC""""
     "LINE_BEFORE .ZFIRST = NOTELINE """TIME('N'),
        "You may reprint without reformatting by reinvoking",
            "SCRIPTPS and including  REPRINT"""
     ZEDSMSG = "SCRIPTPS RC="||lastcc
     ZEDLMSG = "SCRIPTPS invoked SCRIPT and got",
             "a return code of "||lastcc
     ADDRESS 'ISPEXEC' 'SETMSG MSG(ISRZ000)'
   return 1
end
If dest /= "" then do
   Address "TSO"
   status = msg('off')
   "FREE OUTDES(NAME1) FI(SYSUT1 SYSUT2 SYSPRINT)"
   status = msg('on')
   groupid = " GROUPID("groupid")"
   outdes = "DEST("dest") COPIES("copies")" groupid
   if forms \= '' then outdes = outdes "FORMS("strip(forms)")"
   "OUTDES NAME1" OUTDES
   rcc = rc
   if rcc /= 0 then do
     Address "ISREDIT"
     "LINE_BEFORE .ZFIRST = NOTELINE """TIME('N'),
        "OUTDES NAME1" OUTDES " --- failed  RC="||rcc""""
     Address "TSO"
   end
   If rcc /= 0 then leave
   "ALLOC FI(SYSPRINT) DUMMY                 "
   "ALLOC FI(SYSUT1) DA("FILE") SHR"
   "ALLOC FI(SYSUT2) SYSOUT("class") OUTDES(NAME1) "
   "ALLOC FI(SYSIN) DUMMY REUSE              "
   "CALL 'SYS1.LINKLIB(IEBGENER)'            "
   rcc=rc
   If rcc = 0 then do
     SAY "PostScript Document has been Printed to CLASS("class")",
         "  DEST("dest") COPIES("copies"),  Script/VS RC="ScriptRC
     Address "ISREDIT"
     "LINE_BEFORE .ZFIRST = INFOLINE """TIME('N'),
        "SCRIPTPS   Printed CLASS("class") DEST("dest")  RC="||,
        rcc", ScriptRC="ScriptRC" COPIES("copies") --" tokenOrig """"
     Address "TSO"
   end
   else SAY "#$#$#$# Failed PostScript Document to CLASS("class") rc="rcc
   "FREE FI(SYSUT1 SYSUT2) OUTDES(NAME1)     "
   "ALLOC FI(SYSIN) DA(*) REUSE              "
   "ALLOC FI(SYSPRINT) DA(*) REUSE           "
end
Address "ISREDIT"
"LINE_BEFORE .ZFIRST = NOTELINE """TIME('N'),
   "SCRIPTPS   Created " FILE "Chars("||chars||")  RC="||lastcc""""
ZEDSMSG = "SCRIPTPS RC="||lastcc
ZEDLMSG = "SCRIPTPS invoked SCRIPT and got a return code of "||lastcc
ADDRESS 'ISPEXEC' 'SETMSG MSG(ISRZ000)'
"up 3"
"LOC 0"
if dest = "" then do
  say "You chose not to print, there was no destination. DEST(dest)"
  say "You chose not to print, there was no destination. DEST(dest)"
  say  "You may reprint without reformatting by reinvoking",
            "SCRIPTPS and including"
  say  "    REPRINT DEST(xxxx)"
  address "ISREDIT" "LINE_BEFORE .ZFIRST = NOTELINE ""     You chose",
     "not to print since you did not supply a destination"""
end
If lastcc /= 0 then exit 4;else exit 1
return
Process: procedure expose token
 arg subtoken, giveback  /* comma is important, must match*/
 if giveback = '' then giveback = subtoken
 i = index(token,' '||subtoken||' ')
 if i=0 then return ''
 tokenx = substr(token,1,I) || substr(token,I+2+length(subtoken))
 token = tokenx
 return giveback