/* REXX ------------------------------------------------------$$PROLOG*/
/*     Program Name: RxHtmlQ                                          */
/*      Description: QA text for the RxHtml() function.               */
/*       Change log: Add new entries to the top                       */
/*-----------------Changed 20-MAY-2003 by: Bob Stark -----------------*/
/* 1. Initial coding                                                  */
/*--------------------------------------------------------------------*/

CALL   ON ERROR   NAME RXERROR
SIGNAL ON SYNTAX  NAME RXERROR
SIGNAL ON NOVALUE NAME RXERROR
TRACE N

debug = ''
rc = KWPARSE(ARG(1))
IF rc <> 0
THEN CALL ERRMSGX 'KWPARSE Failed, rc='rc

IF debug <> '' THEN TRACE I

IF WORDPOS(GETENV(),'CMDWNT') THEN
  DO
  PARSE UPPER SOURCE _src +3 . _type .
  IF _src = 'NT '                         /* Where are we running?    */
  THEN environment = 'DOSENVIRONMENT'     /* Automation Point REXX    */
  ELSE environment = 'ENVIRONMENT'        /* IBM Object REXX          */
  tmp = VALUE('TMP',,environment)         /* Get environment variable */
  tempfile = tmp'\REX'RANDOM(9999)'.HTM'  /* e.g. C:\TEMP\REX8259.HTM */

  IF 1 THEN
    DO  /* Example for the documentation...                             */
    dwarf.1='Grumpy'; dwarf.2='Sleepy'; dwarf.3='Dopey'; dwarf.4='Doc';
    dwarf.5='Happy'; dwarf.6='Bashful'; dwarf.7='Sneezy'; dwarf.0=7
    rc=RxHtml('Head',"Title('Some Famous Dwarves') Output('web.')")
    rc=RxHtml('Body','BackColor(Blue) TextColor(Yellow) output(web.)')
    rc=RxHtml('List','Numbered(1) STEM(dwarf.) output(web.)')
    rc=RxHtml('Table','Output(web.) BACKCOLOR(Yellow) Colcolor(Blue)',
                      'COLALIGN(CENTER) Head1(Name) Col1Stem(dwarf.)')
    rc=RxHtml('Foot','output(web.)')
    END

  IF 0 THEN
    DO  /* Nested tables... (this doesn't work)                       */
    dwarf.1='Grumpy'; dwarf.2='Sleepy'; dwarf.3='Dopey'; dwarf.4='Doc';
    dwarf.5='Happy'; dwarf.6='Bashful'; dwarf.7='Sneezy'; dwarf.0=7
    rc=RxHtml('Table','BACKCOLOR(Yellow) Colcolor(Blue)',
                      'COLALIGN(CENTER) Head1(Name) Col1Stem(dwarf.)',
                      'Output(dwarfTbl.)')
    nav.1='<a href="http://www.ycs-online.com">www.ycs-online.com</a>'
    nav.2='<a href="http://www.protechpts.com">www.protechpts.com</a>'
    nav.0=2
    rc=RxHtml('Head',"Title('Nested Tables') Output('dwarfTbl.')")
    rc=RxHtml('Body','output(web.) BACKCOLOR(White)')
    rc=RxHtml('Table','Output(web.)',
                      'Col2Stem(nav.)',
                      'Col1Stem(dwarftbl.)')
    rc=RxHtml('Foot','output(web.)')
    END

  IF 0 THEN
    DO
    rc = RxHtml('Head',"Title('This tests the TITLE') Output('web.')")
    rc = RxHtml('Body','BackColor(Blue) TextColor(Yellow) output(web.)')
    web.0 = web.0 + 1
    n = web.0
    web.n = '<p>This is a paragraph</>'
    dwarf.1 = 'Grumpy'; dwarf.2 = 'Sleepy'; dwarf.3 = 'Dopey'
    dwarf.4 = 'Bashful'; dwarf.5 = 'Happy'; dwarf.6 = 'Doc'
    dwarf.7 = 'Sneezy'; dwarf.0 = 7
    a.1= 'My'; a.2 = 'Favorite'; a.3= 'Disney'; a.4 = 'Movie'
    a.5= 'is'; a.6 = 'Lady and the Tramp'; a.7=''; a.0 = 0
    rc = RxHtml('FOO','TBLWIDTH(80%) BACKCOLOR(MAROON)')
    IF rc = 0 THEN SAY ' This should not have worked'
              ELSE SAY 'Test passed, rc='rc
    rc = RxHtml('Table','',
                        'COLCOLOR(LIME) COLALIGN(RIGHT)',
                        'COL1STEM(dwarf.) COL1COLOR(WHITE) HEAD1(Name)',
                        'COL1ALIGN(LEFT)',
                        'COL2STEM(a.)     HEAD2(Stuff)',
                        'COL3STEM(dwarf.) COL3COLOR(BLACK) HEAD3(Quest)',
                        'COL3ALIGN(CENTER)',
                        'COL4STEM(dwarf.) COL4COLOR(UGLY) HEAD4(Foo)',
                        'COL5STEM(dwarf.) COL5COLOR(YELLOW) HEAD5(Foo)',
                        'COL6STEM(dwarf.) COL6COLOR(YELLOW) HEAD6(Foo)',
                        'COL7STEM(dwarf.) COL7COLOR(YELLOW) HEAD7(Foo)',
                        'COL8STEM(dwarf.) COL8COLOR(YELLOW) HEAD8(Foo)',
                        'COL9STEM(dwarf.) COL9COLOR(YELLOW) HEAD9(Foo)',
                        'RULES(NONE)      FRAME(TOP)',
                        'output(web.)')
    SAY 'rc='rc

    rc = RxHtml('List','Bullet(disk) STEM(dwarf.) output(web.)')
    rc = RxHtml('List','Bullet(disk) STEM(dwarf.) output(web.)')
    rc = RxHtml('List','Bullet(circle) STEM(dwarf.) output(web.)')
    rc = RxHtml('List','Bullet(square) STEM(dwarf.) output(web.)')
    rc = RxHtml('List','Numbered(A) STEM(dwarf.) output(web.)')
    rc = RxHtml('List','Numbered(1) STEM(dwarf.) output(web.)')
    rc = RxHtml('List','Numbered(i) STEM(dwarf.) output(web.)')
    rc = RxHtml('List','Numbered(a) STEM(dwarf.) output(web.)')
    rc = RxHtml('List','Numbered(I) STEM(dwarf.) output(web.)')
    rc = RxHtml('Foot','output(web.)')
    END

  rc=IOWRITE('FILENAME('tempfile') STEM(web.)')
  ADDRESS CMD tempfile
  END

EXIT:
IF SYMBOL('max_rc') = 'LIT'
THEN max_rc = 0
EXIT max_rc

/*RXCOPY RXHTML NODUP 930 LINES COPIED ON 09-19-03 AT 11:08************/
/*Start of RxHtml() Function----------------------------Version-01.00-*/
/*:RxHtml Function: Generates HTML to display tables and lists, whose */
/* contents are passed into RxHtml are passed in via stem variables.  */
/* Syntax:                                                            */
/*  HEAD - define the HEAD section of a web page. The output will be  */
/*         issued as SAY commands (the default), but can be directed  */
/*         to the stack of saved in a stem variable):                 */
/*  rc=RxHtml('Head',"Title('Text of page title') Output('stem.')")   */
/*                                                        STACK       */
/*                                                        SAY         */
/*  BODY - define the BODY section of a web page. Note that the       */
/*         following colors are supported: AQUA BLUE BLACK FUSHSIA    */
/*         GRAY GREEN LIME MAROON NAVY OLIVE PURPLE RED SILVER TEAL   */
/*         WHITE YELLOW:                                              */
/*  rc=RxHtml('Body','BackColor(color) TextColor(color)',             */
/*                   'LinkColor(color) VisitedLinkColor(color)',      */
/*                   'ActiveLinkColor(color) Output(dest)')           */
/*                                                                    */
/*  LIST - define a LIST at the current portion of the web page. Note */
/*  that STEM is required, and Bullet and Numbered are mutually       */
/*  exclusive:                                                        */
/*  rc=RxHtml('List','STEM(input.stemVarName.) Output(dest)',         */
/*                   'BULLET(Disk | Circle | Square)',                */
/*                   'NUMBERED(A | 1 | a | i | I)')                   */
/*                   Lettered--^   ^           ^                      */
/*                   Numbered------+           +------Roman Numerals  */
/*                                                                    */
/*  TABLE - define a table at the current portion of the web page;    */
/*          data for the columns is provided by stem variables.       */
/*  rc=RxHtml('Table','Output(dest)',              Output destination */
/*                    'COLCOLOR(color)',           Default text color */
/*                    'BACKCOLOR(color)',            Background color */
/*                    'COLALIGN(LEFT|CENTER|RIGHT)', Default column   */
/*  Frame controls exterior grid lines...             alignment       */
/*           'FRAME(TOP|BOTTOM|LEFT|RIGHT|ALL|TOP,BOTTOM|LEFT,RIGHT)',*/
/*                    'RULES(NONE|ROWS|COLS|ALL)', Interior grid lines*/
/*                    'TBLWIDTH(nn%|nnn)',    Table width % or pixels */
/*  The following TABLE parms are for individual columns, col1-col12  */
/*                    'COL1STEM(stem.)', Input stem variable for col1 */
/*                    'COL1COLOR(color)',         Text color for col1 */
/*                    'HEAD1(Heading text)', optional Heading for col1*/
/*                    'FOOT1(Footer text)',  optional footer for col1 */
/*                    'COL1ALIGN(LEFT|CENTER|RIGHT)',  text alignment */
/*                                                                    */
/*  FOOT - Close off the bottom of the web page.                      */
/*                                                                    */
/*Example:                                                            */
/* dwarf.1='Grumpy'; dwarf.2='Sleepy'; dwarf.3='Dopey'; dwarf.4='Doc';*/
/* dwarf.5='Happy'; dwarf.6='Bashful'; dwarf.7='Sneezy'; dwarf.0=7    */
/* rc=RxHtml('Head',"Title('Some Famous Dwarves') Output('web.')")    */
/* rc=RxHtml('Body','BackColor(Blue) TextColor(Yellow) output(web.)') */
/* rc=RxHtml('List','Numbered(1) STEM(dwarf.) output(web.)')          */
/* rc=RxHtml('Table','Output(web.) BACKCOLOR(Yellow) Colcolor(Blue)', */
/*                   'COLALIGN(CENTER) Head1(Name) Col1Stem(dwarf.)'  */
/* rc=RxHtml('Foot','output(web.)')                                   */
/*--------------------------------------------------------------------*/
RxHtml:   /* No expose here because caller passes stem vars by name.  */
_htmerr = _HTMParse(ARG(1),ARG(2)) /* Parse incoming parameters       */
IF _htmerr <> '' THEN RETURN _htmerr  /* Return w/ error if parse fail*/
RETURN RxHtml1(ARG(1))

RxHtml1: PROCEDURE EXPOSE gbl. _htmp. _htm. (_htm.0expose)
  SELECT
  WHEN TRANSLATE(ARG(1)) = 'BODY' THEN
    DO
    _htmo = '<body'
    IF SYMBOL('_htmp.0BACKCOLOR') = 'VAR'
    THEN _htmo=_htmo 'bgcolor="'_htmp.0BACKCOLOR'"'
    IF SYMBOL('_htmp.0TEXTCOLOR') = 'VAR'
    THEN _htmo=_htmo 'text="'_htmp.0TEXTCOLOR'"'
    IF SYMBOL('_htmp.0LINKCOLOR') = 'VAR'
    THEN _htmo=_htmo 'link="'_htmp.0LINKCOLOR'"'
    IF SYMBOL('_htmp.0VISITEDLINKCOLOR') = 'VAR'
    THEN _htmo=_htmo 'vlink="'_htmp.0VISITEDLINKCOLOR'"'
    IF SYMBOL('_htmp.0ACTIVELINKCOLOR') = 'VAR'
    THEN _htmo=_htmo 'alink="'_htmp.0ACTIVELINKCOLOR'"'
    _htmo=_htmo'>'
    rc=_htmo(_htmo)
    END
  WHEN TRANSLATE(ARG(1)) = 'FOOT' THEN
    DO
    rc=_htmo('</body>')
    rc=_htmo('</html>')
    END
  WHEN TRANSLATE(ARG(1)) = 'HEAD' THEN
    DO
    rc=_htmo('<!DOCTYPE HTML PUBLIC',
             '"-//W3C//DTD HTML 4.01 Transitional//EN">')
    rc=_htmo(' ')
    rc=_htmo('<html>')
    rc=_htmo('<head">')
    IF SYMBOL('_htmp.0TITLE') = 'VAR'
    THEN rc=_htmo('<title>'_htmp.0title'</title>')
    rc=_htmo('</head>')
    END
  WHEN TRANSLATE(ARG(1)) = 'LIST' THEN
    DO
    IF SYMBOL('_htmp.0BULLET') = 'VAR'
    THEN rc=_htmo('<ul type="'_htmp.0bullet'">')
    IF SYMBOL('_htmp.0NUMBERED') = 'VAR'
    THEN rc=_htmo('<ol type="'_htmp.0numbered'">')

      DO i = 1 to VALUE(_htmp.0stem'0')
      rc=_htmo('<li>'VALUE(_htmp.0stem''i)'</li>')
      END i

    IF SYMBOL('_htmp.0BULLET') = 'VAR'
    THEN rc=_htmo('</ul>')
    IF SYMBOL('_htmp.0NUMBERED') = 'VAR'
    THEN rc=_htmo('</ol>')
    END
  WHEN TRANSLATE(ARG(1)) = 'TABLE' THEN
    DO
    rc=_htmo('<table cellspacing="1" cellpadding="1"')
    IF SYMBOL('_htmp.0BACKCOLOR') = 'VAR'
    THEN rc=_htmo('bgcolor="'_htmp.0backColor'" ')
    /* If either FRAME() or RULES() is requested, set the border      */
    IF SYMBOL('_htmp.0FRAME') = 'VAR' & SYMBOL('_htmp.0RULES') = 'VAR'
    THEN
      IF _htmp.0rules <> 'NONE'
      THEN rc=_htmo(' border="1"')

    IF SYMBOL('_htmp.0FRAME') = 'VAR' THEN
      DO
        SELECT
        WHEN POS('TOP',_htmp.0FRAME)>0 & POS('BOTTOM',_htmp.0FRAME)>0,
           & POS('LEFT',_htmp.0FRAME)>0 & POS('RIGHT',_htmp.0FRAME)>0
          THEN frame = 'border'
        WHEN POS('TOP',_htmp.0FRAME)>0 & POS('BOTTOM',_htmp.0FRAME)>0
          THEN frame = 'hsides'
        WHEN POS('LEFT',_htmp.0FRAME)>0 & POS('RIGHT',_htmp.0FRAME)>0
          THEN frame = 'vsides'
        OTHERWISE
          frame = WORDTRAN(_htmp.0FRAME,
                          ,'TOP   BOTTOM LEFT RIGHT ALL',
                          ,'above below  lhs  rhs   border',
                          ,'')
        END
      rc=_htmo(' frame="'frame'"')
      END

    IF SYMBOL('_htmp.0RULES') = 'VAR' THEN
      IF _htmp.0rules <> 'NONE' THEN
        rc=_htmo(' rules="'_htmp.0RULES'"')

    IF SYMBOL('_htmp.0TBLWIDTH') = 'VAR' THEN
      rc=_htmo(' width="'_htmp.0TBLWIDTH'"')
    rc=_htmo('>')     /* End of the attributes on the table tag */

    IF SYMBOL('_htmp.0HEAD1') = 'VAR' THEN
      DO
      rc=_htmo('<tr>')             /* Start header row                */
        DO col = 1 BY 1
        IF SYMBOL('_htmp.0COL'col'STEM') <> 'VAR' /* Any more columns?*/
        THEN LEAVE col                            /* No, done this row*/
          SELECT
          /* Specific color for this column?                          */
          WHEN SYMBOL('_htmp.0COL'col'COLOR') = 'VAR' THEN
            color = VALUE('_htmp.0COL'col'COLOR')
          /* Generic color for entire table?                          */
          WHEN SYMBOL('_htmp.0COLCOLOR') = 'VAR' THEN
            color = _htmp.0COLCOLOR
          OTHERWISE  /* No color, carry forward current color.        */
            color = ''
          END

        align = ''
          SELECT
          /* Specific alignment for this column?                      */
          WHEN SYMBOL('_htmp.0COL'col'ALIGN') = 'VAR' THEN
            IF VALUE('_htmp.0COL'col'ALIGN') <> 'LEFT',
             | SYMBOL('_htmp.0COLALIGN') = 'VAR'
            THEN align=' align="'VALUE('_htmp.0COL'col'ALIGN')'"'
          /* Generic alignment for entire table?                      */
          WHEN SYMBOL('_htmp.0COLALIGN') = 'VAR' THEN
            IF VALUE('_htmp.0COL'col'ALIGN') <> 'LEFT'
            THEN align = ' align="'VALUE('_htmp.0COLALIGN')'"'
          OTHERWISE  /* No alignment, browser assigns defaults.       */
          END
        IF SYMBOL('_htmp.0HEAD'col) = 'VAR'
        THEN value = VALUE('_htmp.0HEAD'col)
        ELSE value = ''
        IF color <> ''
        THEN rc=_htmo('<th'align'><font',
               'color="'color'">'value'</font></th>')
        ELSE rc=_htmo('<th'align'>'value'</th>')
        END col
      rc=_htmo('</tr>')            /* End header row                  */
      END

      DO row = 1 TO VALUE(_htmp.0COL1STEM''0)
      rc=_htmo('<tr>')             /* Start first (or next) row       */
        DO col = 1 BY 1
        IF SYMBOL('_htmp.0COL'col'STEM') <> 'VAR' /* Any more columns?*/
        THEN LEAVE col                            /* No, done this row*/
          SELECT
          /* Specific color for this column?                          */
          WHEN SYMBOL('_htmp.0COL'col'COLOR') = 'VAR' THEN
            color = VALUE('_htmp.0COL'col'COLOR')
          /* Generic color for entire table?                          */
          WHEN SYMBOL('_htmp.0COLCOLOR') = 'VAR' THEN
            color = _htmp.0COLCOLOR
          OTHERWISE  /* No color, carry forward current color.        */
            color = ''
          END

        rc=_htmo('<td')            /* Start first (or next) column    */
          SELECT
          /* Specific alignment for this column?                      */
          WHEN SYMBOL('_htmp.0COL'col'ALIGN') = 'VAR' THEN
            IF VALUE('_htmp.0COL'col'ALIGN') <> 'LEFT'
            THEN rc=_htmo(' align="'VALUE('_htmp.0COL'col'ALIGN')'"')
          /* Generic alignment for entire table?                      */
          WHEN SYMBOL('_htmp.0COLALIGN') = 'VAR' THEN
            IF VALUE('_htmp.0COL'col'ALIGN') <> 'LEFT'
            THEN rc=_htmo(' align="'VALUE('_htmp.0COLALIGN')'"')
          OTHERWISE  /* No alignment, browser assigns defaults.       */
          END
        rc=_htmo('>')              /* End bracket for <td tag.        */
        IF color <> ''
        THEN rc=_htmo('<font color="'color'">',
                      VALUE(VALUE('_htmp.0COL'col'STEM')row),
                      '</font></td>')
        ELSE rc=_htmo(VALUE(VALUE('_htmp.0COL'col'STEM')row)'</td>')
        END col
      rc=_htmo('</tr>')            /* End this row                    */
      END row

    IF SYMBOL('_htmp.FOOT1') = 'VAR' THEN
      DO
      rc=_htmo('<tr>')             /* Start footer row                */
        DO col = 1 BY 1
        IF SYMBOL('_htmp.0COL'col'STEM') <> 'VAR' /* Any more columns?*/
        THEN LEAVE col                            /* No, done this row*/
          SELECT
          /* Specific color for this column?                          */
          WHEN SYMBOL('_htmp.0COL'col'COLOR') = 'VAR' THEN
            color = VALUE('_htmp.0COL'col'COLOR')
          /* Generic color for entire table?                          */
          WHEN SYMBOL('_htmp.0COLCOLOR') = 'VAR' THEN
            color = _htmp.0COLCOLOR
          OTHERWISE  /* No color, carry forward current color.        */
            color = ''
          END
        IF SYMBOL('_htmp.0FOOT'col) = 'VAR'
        THEN value = VALUE('_htmp.0FOOT'col)
        ELSE value = ''
        IF color <> ''
        THEN rc=_htmo('<th><font color="'color'">'value'</font></th>')
        ELSE rc=_htmo('<th>'value'</th>')
        END col
      rc=_htmo('</tr>')            /* End footer row                  */
      END
    rc=_htmo('</table>')           /* End this table                  */
    END /* WHEN TRANSLATE(ARG(1)) = 'TABLE' */
  OTHERWISE
  END
RETURN 0

/*--------------------------------------------------------------------*/
/*:_HTMName2Color(colorName) function: returns color code for a given */
/* color name, or blank if invalid color name passed                  */
/*--------------------------------------------------------------------*/
_HTMName2Color: PROCEDURE EXPOSE gbl.
p = WORDPOS(TRANSLATE(ARG(1)),
  ,'AQUA   BLUE   BLACK FUSHSIA GRAY   GREEN  LIME   MAROON NAVY',
   'OLIVE  PURPLE RED    SILVER TEAL   WHITE  YELLOW')
IF p = 0
THEN RETURN ''
RETURN '#'WORD('',
  '00FFFF 0000FF 000000 FF00FF 808080 008000 00FF00 800000 000080',
  '808000 800080 FF0000 C0C0C0 008080 FFFFFF FFFF00',p)

/*--------------------------------------------------------------------*/
/*:_HTMO() function: outputs tags to a given destination              */
/*--------------------------------------------------------------------*/
_HTMO:
  SELECT
  WHEN _HTMP.0OUTPUT = 'SAY' THEN
    SAY ARG(1)
  WHEN _HTMP.0OUTPUT = 'STACK' THEN
    QUEUE ARG(1)
  OTHERWISE
    IF SYMBOL(_HTMP.0OUTPUT'0') = 'LIT'
    THEN CALL VALUE _htmp.0OUTPUT'0', 0
    n = VALUE(_htmp.0OUTPUT'0') + 1
    CALL VALUE _htmp.0OUTPUT'0', n
    CALL VALUE _htmp.0OUTPUT''n, ARG(1)
  END
RETURN 0

/*--------------------------------------------------------------------*/
/*:_HTMParse(arg1,arg2) function: Parses the parameters for a given   */
/* request type, issues error messages if values are invalid or       */
/* missing, and stores the parm values in the _HTMP.0parmname stem    */
/*--------------------------------------------------------------------*/
_HTMParse: PROCEDURE EXPOSE gbl. _htmp. _htm.
_htm.0expose = ''        /* Variables to be exposed by our caller     */

reqtype = TRANSLATE(ARG(1))
rc = KWVALID('REQTYPE','LIST(BODY,FOOT,HEAD,LIST,TABLE)','_HTMPARSEINV')
IF rc <> 0 THEN RETURN rc

  SELECT
  WHEN reqtype = 'BODY' THEN
    DO
    valkeys = 'BACKCOLOR TEXTCOLOR LINKCOLOR VISITEDLINKCOLOR',
              'ACTIVELINKCOLOR OUTPUT'
    reqkeys = ''
    END /* WHEN reqtype = 'BODY' THEN */
  WHEN reqtype = 'FOOT' THEN
    DO
    valkeys = 'OUTPUT'
    reqkeys = ''
    END /* WHEN reqtype = 'FOOT' THEN */
  WHEN reqtype = 'HEAD' THEN
    DO
    valkeys = 'TITLE OUTPUT'
    reqkeys = ''
    END /* WHEN reqtype = 'HEAD' THEN */
  WHEN reqtype = 'LIST' THEN
    DO
    valkeys = 'BULLET NUMBERED STEM OUTPUT'
    reqkeys = 'STEM'
    END /* WHEN reqtype = 'LIST' THEN */
  WHEN reqtype = 'TABLE' THEN
    DO
    valkeys = 'BACKCOLOR COLCOLOR COLALIGN FRAME RULES TBLWIDTH OUTPUT'
    maxColumns = 12                /* max no of supported columns     */
      DO i = 1 TO maxColumns /* Generate keywords to max columns      */
      valkeys=SPACE(valkeys 'HEAD'i 'FOOT'i,
                    'COL'i'ALIGN' 'COL'i'COLOR' 'COL'i'STEM')
      END i
    reqkeys = 'COL1STEM'
    END /* WHEN reqtype = 'TABLE' THEN */
  OTHERWISE
    SAY 'Bug1! Reqtype='reqtype 'has not been handled'
  END /* SELECT */

/*--------------------------------------------------------------------*/
/* Determine which parms are valid and required, based on request type*/
/*--------------------------------------------------------------------*/
krc = KWPARSE(ARG(2),valkeys)
IF krc <> 0 THEN
  DO; SAY krc; RETURN krc; END

/* Ensure that all required keywords have been entered. */
  DO i = 1 TO WORDS(reqkeys)
  IF SYMBOL(WORD(reqkeys,i)) <> 'VAR' THEN
    DO; rc = 'Missing required parm 'WORD(reqkeys,i)'()'
    SAY rc; RETURN rc
    END
  END i

IF SYMBOL('output') = 'LIT'
THEN output = 'SAY'
output = TRANSLATE(output)
CALL VALUE '_HTMP.0OUTPUT', output /* Save value of output parm       */
IF WORDPOS(output,'SAY STACK') = 0 THEN
  DO /* Have caller expose the stem contents, so it can access it     */
  _htm.0expose = SPACE(_htm.0expose output,1)
  END

  SELECT
  WHEN reqtype = 'BODY' THEN
    DO
    keys = 'ACTIVELINKCOLOR BACKCOLOR LINKCOLOR TEXTCOLOR',
           'VISITEDLINKCOLOR'
      DO i = 1 TO WORDS(keys)
      key = WORD(keys,i)
      IF SYMBOL(key) = 'VAR' THEN
        DO
        val = _HTMName2Color(VALUE(key))
        IF val = ''
        THEN SAY 'Invalid value for' key'('VALUE(key)'), ignored'
        ELSE CALL VALUE '_HTMP.0'key, val
        END
      END i
    END /* WHEN reqtype = 'BODY' THEN */

  WHEN reqtype = 'HEAD' THEN
    DO
    _HTMP.0TITLE = title           /* Save value of TITLE(xx) parm    */
    END /* WHEN reqtype = 'HEAD' THEN */

  WHEN reqtype = 'FOOT' THEN
    NOP

  WHEN reqtype = 'LIST' THEN
    DO
    _HTMP.0STEM = stem             /* Save value of STEM(xxx) parm    */
    _htm.0expose = SPACE(_htm.0expose stem,1)
    IF SYMBOL('BULLET')SYMBOL('NUMBERED') = 'VARVAR' THEN
      DO; rc = 'LIST keywords BULLET() and NUMBERED() are mutually',
               'exclusive, specify one or the other, not both'
      SAY rc; RETURN rc
      END
    IF SYMBOL('BULLET')SYMBOL('NUMBERED') = 'LITLIT'
    THEN bullet = 'DISK'           /* Set default if none specified   */
    IF SYMBOL('BULLET') = 'VAR' THEN
      DO
      bullet = LOWER(bullet)       /* HTML wants these in lower case. */
      CALL KWVALID 'BULLET','LIST(disk,circle,square)','_HTMPARSEINV'
      _HTMP.0BULLET = bullet
      END
    IF SYMBOL('NUMBERED') = 'VAR' THEN
      DO
      CALL KWVALID 'NUMBERED','LIST(A,1,a,i,I)','_HTMPARSEINV'
      _HTMP.0NUMBERED = numbered
      END
    END /* WHEN reqtype = 'LIST' THEN */

  WHEN reqtype = 'TABLE' THEN
    DO
    keys = 'BACKCOLOR COLCOLOR'
      DO i = 1 TO WORDS(keys)
      key = WORD(keys,i)
      IF SYMBOL(key) = 'VAR' THEN
        DO
        val = _HTMName2Color(VALUE(key))
        IF val = ''
        THEN SAY 'Invalid value for' key'('VALUE(key)'), ignored'
        ELSE CALL VALUE '_HTMP.0'key, val
        END
      END i

    IF SYMBOL('COLALIGN') = 'VAR' THEN
      DO
      colalign = TRANSLATE(colalign)
      CALL KWVALID 'COLALIGN','LISTABBR(LEFT,CENTER,RIGHT)',
                  ,'_HTMPARSEINV'
      _HTMP.0COLALIGN = colalign
      END

    IF SYMBOL('FRAME') = 'VAR' THEN
      DO  /* This needs a KWVALID enhancement to handle (TOP,BOTTOM)  */
      frame = TRANSLATE(frame)
      CALL KWVALID 'FRAME','LISTABBR(TOP,BOTTOM,LEFT,RIGHT,ALL)',
                  ,'_HTMPARSEINV'
      _HTMP.0FRAME = frame
      END

    IF SYMBOL('RULES') = 'VAR' THEN
      DO
      rules = TRANSLATE(rules)
      CALL KWVALID 'RULES','LISTABBR(ROWS,COLS,ALL,NONE)',
                  ,'_HTMPARSEINV'
      _HTMP.0RULES = rules
      END

    IF SYMBOL('TBLWIDTH') = 'VAR' THEN
      DO
      _HTMP.0TBLWIDTH = tblwidth
      END

      DO i = 1 TO maxColumns /* Generate keywords to max columns      */
      IF WORDPOS('VAR',
                ,SYMBOL('HEAD'i) SYMBOL('FOOT'i) SYMBOL('COL'i'ALIGN'),
                 SYMBOL('COL'i'COLOR')) > 0 THEN
      IF SYMBOL('COL'i'STEM') <> 'VAR' THEN
        DO; rc = 'TABLE keywords HEAD'i'() FOOT'i'() COL'i'ALIGN() or',
                 'COL'i'COLOR() require COL'i'STEM keyword. Ignored.'
        SAY rc; RETURN rc
        END
      IF SYMBOL('COL'i'STEM') <> 'VAR'       /* Any more stems?       */
      THEN LEAVE i                           /* No, exit this loop    */
      CALL VALUE '_HTMP.0COL'i'STEM', VALUE('COL'i'STEM')
      _htm.0expose = SPACE(_htm.0expose VALUE('COL'i'STEM'),1)
      IF SYMBOL('HEAD'i) = 'VAR'
      THEN CALL VALUE '_HTMP.0HEAD'i, VALUE('head'i)
      IF SYMBOL('FOOT'i) = 'VAR'
      THEN CALL VALUE '_HTMP.0FOOT'i, VALUE('foot'i)
      IF SYMBOL('COL'i'ALIGN') = 'VAR' THEN
        DO
        CALL VALUE 'COL'i'ALIGN', TRANSLATE(VALUE('COL'i'ALIGN'))
        CALL KWVALID 'COL'i'ALIGN','LISTABBR(LEFT,CENTER,RIGHT)',
                    ,'_HTMPARSEINV'
        CALL VALUE '_HTMP.0COL'i'ALIGN', VALUE('COL'i'ALIGN')
        END
      IF SYMBOL('COL'i'COLOR') = 'VAR' THEN
        DO
        val = _HTMName2Color(VALUE('COL'i'COLOR'))
        IF val = ''
        THEN SAY 'Invalid value for',
                 'COL'i'COLOR('VALUE('COL'i'COLOR')'), ignored'
        ELSE CALL VALUE '_HTMP.0COL'i'COLOR', VALUE('COL'i'COLOR')
        END
      END i
    END /* WHEN reqtype = 'TABLE' THEN */
  OTHERWISE
    SAY 'Bug2! Reqtype='reqtype 'has not been handled'
  END /* SELECT */

RETURN ''                          /* Return w/ no errors             */

_HTMParseInv:
SAY _kwerrmsg
RETURN _kwerrmsg
/*-End of RxHtml function---------------------------------------------*/

/*RXCOPY KWPARSE NODUP 128 LINES COPIED ON 09-19-03 AT 11:08***********/
/*Start of KWPARSE Function-----------------------------Version-01.03-*/
/*:KWPARSE Subroutine: Extracts keyword parameters from the data      */
/* passed to it, and sets the value of the keyword into REXX          */
/* variables that match the keyword name.  KWPARSE supports two       */
/* methods of defining allowable keywords:                            */
/* 1. Define keywords as rexx variables before calling KWPARSE, and   */
/*    leave off the 2nd positional parm.                              */
/* 2. List the keywords by name in the 2nd positional parm.  This     */
/*    method is preferable if you have other active rexx variables    */
/*    might get mistaken for parms and reset, or if you want to       */
/*    support abbreviated keywords.                                   */
/* Returns: 0:    Data parsed successfully.                           */
/*          text: Error occured, text gives the details.              */
/* For example:                                                       */
/*   PARSE ARG parms           <* Copy callers arguments to rexx var  */
/*   parms    = "MSG('Hello world') DEBUG SELFTEST"                   */
/*   msg      = 'Test message' <* Define 'MSG' keyword default        */
/*   selftest = ''             <* Define 'SELFTEST' keycode           */
/*   debug    = ''             <* Define 'DEBUG' keycode              */
/*   CALL kwparse(parms)       <* Call KWPARSE w/ imlicit kw defn.    */
/*     <or>                                                           */
/*   CALL kwparse(parms,'MSG SELFTEST DEBUG'  <*w/ exlicit kw defn.   */
/*                                                                    */
/* Usage Notes:                                                       */
/* o Keycode variables that have been parsed will be set to their     */
/*   own names. To test for their presence, check for non-null, ie:   */
/*     IF DEBUG <> '' THEN TRACE R                                    */
/* o Invalid keywords are warned with a msg, ignored, and retcode = 4 */
/* o Some invalid input isn't detectible, e.g. a keyword w/o parens   */
/*   is treated as a keycode, and visa versa.                         */
/* o If you specify a keyword list (2nd positional parm), then        */
/*   keywords may be abbreviated, if the abbreviation is unique.      */
/* Copyright (C) 1995,2003 ProTech. All rights reserved.              */
/*--------------------------------------------------------------------*/
KWPARSE:
TRACE Normal                       /* Turn off rexx tracing           */
PARSE arg _parm                    /* Copy calling arguments          */
PARSE version _rxlang _rxversion .
IF _rxlang='REXX370' & _rxversion<3.52  /* Is diadic VALUE() avail?   */
THEN _dvalue = 0                        /* No, have to interpret      */
ELSE _dvalue = 1                        /* Yes, remember to use it.   */
_kwparse_maxrc = ''                /* Initialize return code          */
  DO _i = 1 TO 2                   /* 2 passes, most specific to      */
                                   /*  least, starting w/ quoted data */
  /*------------------------------------------------------------------*/
  /* Keyword extraction logic: Extract all keyword parameters,        */
  /* eliminating them and their data from _PARM as each one is        */
  /* found.  REVERSE is used to make the last word of _PARML (the     */
  /* keyword) into the first word, because parse can be used to       */
  /* extract the first word from a string, but there is no REXX       */
  /* function to extract the last word from a string.                 */
  /*------------------------------------------------------------------*/
    DO WHILE _parm <> ''           /* Done if we run out of input     */
      SELECT
      WHEN _i = 1 THEN PARSE VAR _parm,
        _parml "('" +0 _delim +2 _value "')" _parmr
      WHEN _i = 2 THEN PARSE VAR _parm,
        _parml "(" +0 _delim +1 _value ")" _parmr
      END /* SELECT */
    IF _delim = '' THEN LEAVE      /* No keywords left, we're done    */
    PARSE VALUE REVERSE(_parml) WITH _kw _parml       /* get keyword  */
    _kw = TRANSLATE(REVERSE(_kw))  /* Un-reverse & upcase the keyword */
    _parm = REVERSE(_parml)_parmr  /* Glue remaining parms together   */
    IF KWPARSE_KWVALID(ARG(2)) <> '' THEN /* Keyword valid?           */
      IF _dvalue                        /* Diadic VALUE() available?  */
      THEN _value = VALUE(_kw,_value)   /* Yes, use it.               */
      ELSE INTERPRET _kw" = VALUE('_value')" /* No, use interpret.    */
    END /* DO WHILE _parm <> '' */
  END /* DO _i = 1 to 2 */

/* Final pass extracts one-word  "Keycodes", like DEBUG               */
DROP _value
  DO WHILE _parm <> ''
  PARSE UPPER VAR _parm _kw _parm  /* Extract one "keycode"           */
  IF KWPARSE_KWVALID(ARG(2)) <> '' THEN /* Keyword valid?             */
    IF _dvalue                     /* Diadic VALUE() available?       */
    THEN CALL VALUE _kw,_kw        /* Yes, use enhanced value         */
    ELSE INTERPRET _kw" = VALUE('_kw')" /* No, use interpret.         */
  END /* DO WHILE _parm <> '' */
DROP _parm _parml _parmr _delim _i _j _kw _value _rxlang,
  _rxversion _dvalue _kwfull
IF _kwparse_maxrc = '' THEN _kwparse_maxrc = 0
return _kwparse_maxrc

KWPARSE_KWVALID:
IF ARG(1) <> '' THEN               /* Keyword list passed by caller?  */
  DO                               /* Yes, use it to determine kw name*/
  IF WORDPOS(_kw,TRANSLATE(ARG(1)))=0 THEN /* KW not in list?         */
    DO                             /* No. Look for abbrev.            */
    _kwfull=''      /* See if keywd is a unique abbreviation in list  */
      DO _j = 1 to WORDS(ARG(1))   /* Look at each keyword in list    */
      IF ABBREV(TRANSLATE(WORD(ARG(1),_j)),_kw)             /* Abbrev?*/
      THEN _kwfull=_kwfull TRANSLATE(WORD(ARG(1),_j))       /* Yes.   */
      END _j
    IF WORDS(_kwfull) = 1          /* Unique keyword found, Replace   */
    THEN _kw = STRIP(_kwfull)      /* abbrev w/ full, and fall thru.  */
    ELSE
      DO
      IF WORDS(_kwfull) > 1 THEN   /* Found, but not unique. Sorry.   */
        IF SYMBOL('_value') = 'VAR'
        THEN _kwparse_maxrc = _kwparse_maxrc,
             'Ignoring ambiguous keyword:'_kw'('_value'),',
             'could be any one of '_kwfull';'
        ELSE _kwparse_maxrc = _kwparse_maxrc,
             'Ignoring ambiguous keycode:'_kw',',
             'could be any one of '_kwfull';'
      ELSE
        IF SYMBOL('_value') = 'VAR'
        THEN _kwparse_maxrc = _kwparse_maxrc,
             'Ignoring unrecognized keyword:'_kw'('_value');'
        ELSE _kwparse_maxrc = _kwparse_maxrc,
             'Ignoring unrecognized keycode:'_kw';'
      RETURN ''                    /* Get next parm                   */
      END
    END
  END
ELSE                               /* No explicit keyword list,       */
  IF symbol(_kw) <> 'VAR' THEN     /*  see if keyword is a rexx var.  */
    DO
    IF SYMBOL('_value') = 'VAR'
    THEN _kwparse_maxrc = _kwparse_maxrc,
         'Ignoring unrecognized keyword:'_kw'('_value');'
    ELSE _kwparse_maxrc = _kwparse_maxrc,
         'Ignoring unrecognized keycode:'_kw';'
    RETURN ''                      /* Get next parm                   */
    END
RETURN _kw
/*End of KWPARSE function---------------------------------------------*/

/*RXCOPY KWVALID NODUP 272 LINES COPIED ON 09-19-03 AT 11:08***********/
/*-Start of KWVALID function----------------------------Version-01.05-*/
/*:KWVALID Function: Validates that a keyword is set validly. Useful  */
/*                   in subroutines that support a lot of keywords.   */
/*   Parms: name, validtypes, exitlabel                               */
/*   where: name       is the name of a REXX variable.                */
/*         validtypes List of one or more parm types, as follows:     */
/*                    DATE(mm/dd/yyyy) DSNAME MEMBER LIST(a,b)        */
/*                    NONBLANK RANGE(min,max) REXXVAR                 */
/*                    TIME(hh:mm:ss) TIME(hh:mm) TIME(hhmm)           */
/*                    NONBLANK RANGE(min,max)                         */
/*         exitlabel  is optional - if provided, KWVALID will         */
/*                    SIGNAL to that label if parm is invalid.        */
/*                    If not provided, KWVALID returns 0 or error text*/
/* Returns:      0 if valid, error message if not.                    */
/* Example:      rc = KWVALID('OPTION','LIST(CREATE,UPDATE)','EXIT'); */
/* Copyright (C) 2002 ProTechPTS.com. All rights reserved.            */
/*--------------------------------------------------------------------*/
KWVALID:
TRACE Normal
_kwname = ARG(1)
IF ARG() < 2 THEN
  DO
  _kwerrmsg = 'Must pass 2 or more arguments to KWVALID'
  SIGNAL KWNVALID
  END
IF SYMBOL(ARG(1)) <> 'VAR' THEN
  DO
  _kwerrmsg = ARG(1)' parm not initialized'
  SIGNAL KWNVALID
  END
ELSE _kwvalue = VALUE(_kwname)

_kwtypes = ARG(2)

  DO WHILE _kwtypes <> ''
  PARSE VAR _kwtypes _kwtype _kwtypes
  PARSE VAR _kwtype _kwdatatype '(' _kwdataval ')' .

    SELECT

    WHEN TRANSLATE(_kwdatatype) = 'TIME' THEN
      SELECT
      WHEN TRANSLATE(_kwdataval) = 'HH:MM:SS' THEN
        DO
        PARSE VAR _kwvalue _kwhh ':' _kwmm ':' _kwss
        IF _kwhh < 0 | _kwhh > 23 | _kwmm < 0 | _kwmm > 59 | ,
           _kwss < 0 | _kwss > 59 | DATATYPE(_kwhh,'W') <> 1 |,
           DATATYPE(_kwmm,'W') <> 1 | DATATYPE(_kwss,'W') <> 1 THEN
          DO
          _kwerrmsg = _kwname'('_kwvalue') parm invalid -',
                      'invalid TIME(hh:mm:ss)'
          SIGNAL KWNVALID
          END
        END
      WHEN POS(TRANSLATE(_kwdataval), 'HH:MM HHMM') > 0 THEN
        DO
        IF POS(':',_kwdataval) > 0
        THEN PARSE VAR _kwvalue _kwhh ':' _kwmm
        ELSE PARSE VAR _kwvalue 1 _kwhh 3 _kwmm
        IF _kwhh < 0 | _kwhh > 23 | _kwmm < 0 | _kwmm > 59 |,
           DATATYPE(_kwhh,'W') <> 1 | DATATYPE(_kwmm,'W') <> 1 THEN
          DO
          _kwerrmsg = _kwname'('_kwvalue') parm invalid -',
                      'invalid TIME(hh:mm)'
          SIGNAL KWNVALID
          END
        END
      OTHERWISE
        _kwerrmsg = _kwname'('_kwvalue') validation error -',
                    'TIME('_kwdataval') invalid'
          SIGNAL KWNVALID
      END

    WHEN _kwdatatype = 'DATE' THEN
      DO
      IF TRANSLATE(_kwdataval) = 'MM/DD/YYYY' THEN
        DO
        PARSE VAR _kwvalue _kwmm '/' _kwdd '/' _kwyy
        IF _kwmm < 1 | _kwmm > 12 | _kwdd < 1 | _kwmm > 31 | ,
           _kwyy < 0 | _kwyy > 9999 THEN
          DO
          _kwerrmsg = _kwname'('_kwvalue') parm invalid -',
                      'invalid DATE(mm/dd/yyyy)'
          SIGNAL KWNVALID
          END
        END
      END

    WHEN _kwdatatype = 'DSNAME' THEN
      DO
      _kwvalue = TRANSLATE(STRIP(_kwvalue))
      IF _kwvalue = '' THEN
        DO
        _kwerrmsg = _kwname'() parm invalid -',
                    'value must be a non-blank dataset name'
        SIGNAL KWNVALID
        END
      IF LENGTH(_kwvalue) > 44 THEN
        DO
        _kwerrmsg = 'Error, '_kwname'() parm invalid -',
                    'value is too long to be a valid dataset name'
        SIGNAL KWNVALID
        END
      _kwvrng1 = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ@#$' /*Valid for 1st char */
      _kwvrng2 = VALUE('_KWVRNG1')'0123456789.'  /*Valid for rest of  */
      _kwvtemp = TRANSLATE(_kwvalue)
        DO WHILE _kwvtemp <> ''
        PARSE VAR _kwvtemp _kwvnode '.' _kwvtemp
        IF LENGTH(_kwvnode) > 8 | LENGTH(_kwvnode) < 1 THEN
          DO
          _kwerrmsg = _kwname'() parm invalid -',
                      'invalid characters in dataset name'
          SIGNAL KWNVALID
          END
        IF POS(LEFT(_kwvnode,1),_kwvrng1) = 0 THEN
          DO
          _kwerrmsg = _kwname'() parm invalid -',
                      'invalid character to start dataset name'
          SIGNAL KWNVALID
          END
        /* Translate all valid characters into dots, and if result is */
        /* all dots, then it is valid.                                */
        IF TRANSLATE(SUBSTR(_kwvnode, 2, LENGTH(_kwvnode)-1), '',,
                     _kwvrng2,'.')<>COPIES('.',LENGTH(_kwvnode)-1) THEN
          DO
          _kwerrmsg = _kwname'('_kwvalue') parm invalid',
                      ' - invalid character in dataset name'
          SIGNAL KWNVALID
          END
        END /* DO WHILE _kwvtemp <> '' */
      END  /* WHEN _kwdatatype = 'DSNAME' THEN */

    WHEN _kwdatatype = 'LIST' THEN
      DO
      _kwdataval = TRANSLATE(_kwdataval,'',',',' ')
      IF WORDPOS(_kwvalue,_kwdataval) = 0 THEN
        DO
        _kwerrmsg = _kwname'('_kwvalue') parm invalid -',
                    'must be one of: '_kwdataval
        SIGNAL KWNVALID
        END
      END

    WHEN _kwdatatype = 'LISTABBR' THEN
      DO
      _kwdataval = TRANSLATE(TRANSLATE(_kwdataval,'',',',' '))
      _kwvtemp = ''
        DO _kwvrng1 = 1 TO WORDS(_kwdataval)
        IF ABBREV(WORD(_kwdataval,_kwvrng1),_kwvalue) = 1
        THEN _kwvtemp = SPACE(_kwvtemp' 'WORD(_kwdataval,_kwvrng1))
        END _kwvrng1
      IF WORDS(_kwvtemp) = 0 THEN
        DO
        _kwerrmsg = _kwname'('_kwvalue') parm invalid -',
                    'must be one of: '_kwdataval
        SIGNAL KWNVALID
        END
      IF WORDS(_kwvtemp) > 1 THEN
        DO
        _kwerrmsg = _kwname'('_kwvalue') parm value is ambiguous -',
                    'is one of: '_kwvtemp
        SIGNAL KWNVALID
        END
      CALL VALUE _kwname,_kwvtemp  /* Replace abbrev value w/ full    */
      END

    WHEN _kwdatatype = 'MEMBER' THEN
      DO
      _kwvalue = TRANSLATE(_kwvalue)
      IF WORDS(_kwvalue) <> 1 | LENGTH(_kwvalue) > 8 THEN
        DO
        _kwerrmsg = _kwname'('_kwvalue') parm invalid -',
                    'must be a valid PDS member name'
        SIGNAL KWNVALID
        END
      _kwvrng1 = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ@#$' /*Valid for 1st char */
      _kwvrng2 = VALUE('_KWVRNG1')'0123456789.'  /*Valid for rest of  */
      IF POS(TRANSLATE(LEFT(_kwvalue,1)),_kwvrng1) = 0 THEN
        DO
        _kwerrmsg = _kwname'('_kwvalue') parm invalid -',
                    'invalid characters in member name'
        SIGNAL KWNVALID
        END
      /* Tricky... Translate all the valid characters into dots, and  */
      /* if result is all dots, then it is valid.                     */
      IF TRANSLATE(SUBSTR(_kwvalue,2,LENGTH(_kwvalue)-1),,
                   '',_kwvrng2,'.'),
         <> COPIES('.',LENGTH(_kwvalue)-1) THEN
        DO
        _kwerrmsg = _kwname'('_kwvalue') parm invalid -',
                    'invalid characters in member name'
        SIGNAL KWNVALID
        END
      END

    WHEN _kwdatatype = 'NONBLANK' THEN
      DO

      IF WORDS(_kwvalue) = 0 THEN
        DO
        _kwerrmsg = _kwname'() parm invalid -',
                    'value must be non-blank'
        SIGNAL KWNVALID
        END
      END

    WHEN _kwdatatype = 'RANGE' THEN
      DO
      PARSE VAR _kwdataval _kwlower ',' _kwupper .
      IF _kwvalue < _kwlower | _kwvalue > _kwupper THEN
        DO
        _kwerrmsg = _kwname'('_kwvalue') parm invalid -',
                    'range must be: '_kwlower' <= '_kwname' <= '_kwupper
        SIGNAL KWNVALID
        END
      END

    WHEN _kwdatatype = 'REXXVAR' THEN
      DO
      _kwvalue = TRANSLATE(_kwvalue)
      IF WORDS(_kwvalue) <> 1 THEN
        DO
        _kwerrmsg = _kwname'('_kwvalue') parm invalid -',
                    'must be a valid REXX variable name without blanks'
        SIGNAL KWNVALID
        END
      _kwvrng1 = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ?!_' /*Valid for 1st char */
      _kwvrng2 = VALUE('_KWVRNG1')'0123456789.'  /*Valid for rest of  */
      IF POS(TRANSLATE(LEFT(_kwvalue,1)),_kwvrng1) = 0 THEN
        DO
        _kwerrmsg = _kwname'('_kwvalue') parm invalid -',
                    'invalid characters in variable name'
        SIGNAL KWNVALID
        END
      /* Tricky... Translate all the valid characters into dots, and  */
      /* if result is all dots, then it is valid.                     */
      IF TRANSLATE(SUBSTR(_kwvalue,2,LENGTH(_kwvalue)-1),,
                   '',_kwvrng2,'.'),
         <> COPIES('.',LENGTH(_kwvalue)-1) THEN
        DO
        _kwerrmsg = _kwname'('_kwvalue') parm invalid -',
                    'invalid characters in variable name'
        SIGNAL KWNVALID
        END
      END /* WHEN _kwdatatype = 'REXXVAR' THEN */

    OTHERWISE
      _kwerrmsg = _kwdatatype' is an invalid KWVALID()',
                  'datatype'
      SIGNAL KWNVALID
    END /* SELECT */

  END /* DO WHILE */

/* Cleanup our variables before we exit...                            */
DROP _kwdatatype _kwdataval _kwlower _kwname _kwtype _kwtypes,
     _kwupper _kwvalue _kwvnode _kwvrng1 _kwvrng2 _kwvtemp
RETURN 0                           /* All tests passed, keyword valid */

KWNVALID:
PARSE SOURCE . . _kwnfilename .
PARSE VALUE REVERSE(_kwnfilename) WITH _kwnfilename '\'
_kwnfilename = REVERSE(_kwnfilename)
IF ARG() >= 3 THEN
  DO
  SAY 'Error calling '_kwnfilename': '_kwerrmsg
  rc = _kwerrmsg
  SIGNAL VALUE ARG(3)
  INTERPRET "SIGNAL "ARG(3)        /* For platforms w/o SIGNAL VALUE  */
  END
RETURN _kwerrmsg
/*-End of KWVALID  function-------------------------------------------*/

/*RXCOPY LOWER NODUP 6 LINES COPIED ON 09-19-03 AT 11:08***************/
/*-Start of LOWER function------------------------------Version-01.00-*/
/*:LOWER() translates a string to lower case.                         */
/*--------------------------------------------------------------------*/
LOWER: RETURN TRANSLATE(ARG(1),'abcdefghijklmnopqrstuvwxyz',
                              ,'ABCDEFGHIJKLMNOPQRSTUVWXYZ')
/*-End of LOWER function----------------------------------------------*/

/*RXCOPY WORDTRAN NODUP 17 LINES COPIED ON 09-19-03 AT 11:08***********/
/*-Start of WORDTRAN function---------------------------Version-01.00-*/
/*: WORDTRANS translates an input word to an output word:             */
/* Example:                                                           */
/* WORDTRAN(user,userids,emails,'')                                   */
/*--------------------------------------------------------------------*/
WORDTRAN: PROCEDURE
TRACE N
IF ARG() < 4 THEN
  DO; SAY 'Error, WORDTRAN() requires 4 input arguments'
  RETURN
  END
PARSE ARG word, wordlist, newlist, default
w = WORDPOS(word,wordlist)
IF w > 0
THEN RETURN WORD(newlist,w)
ELSE RETURN default
/*-End of WORDTRAN function-------------------------------------------*/

/*--------------------------------------------------------------------*/
/* RXCOPY routines follow (in alphabetical order)                     */
/*--------------------------------------------------------------------*/

/*RXCOPY ERRMSGX NODUP 27 LINES COPIED ON 09-19-03 AT 11:08************/
/*-Start of ERRMSGX function----------------------------Version-01.04-*/
/*:ERRMSGX SUBROUTINE: Issues a formatted error message and exits.    */
/* Parameters: Message text                                           */
/* DOES NOT RETURN!                                                   */
/* For example:                                                       */
/* IF missing <> ''                                                   */
/* then call ERRMSGX('Missing required parameter(s):'missing)         */
/* Copyright (C) 1996,2003 ProTech. All rights reserved.              */
/*--------------------------------------------------------------------*/
ERRMSGX:
TRACE N
PARSE ARG _errmsgx_text
PARSE SOURCE . . _errmsgx_filename .
_errmsgx_errtext = 'REXX Error: '_errmsgx_filename' '_errmsgx_text
SAY _errmsgx_errtext
IF ADDRESS() = 'AXC' THEN
  DO
  ADDRESS AXC "WTXC '"_errmsgx_errtext"'"
  ADDRESS AXC "WTOH '"_errmsgx_errtext"'"
  END

IF SYMBOL('max_rc') = 'LIT'       /* Does max_rc variable exist?      */
THEN max_rc = 8                   /* No, initialize it to 8.          */
ELSE IF DATATYPE(max_rc) = 'NUM'  /* Yes, is it numeric?              */
     THEN max_rc = MAX(8,max_rc)  /* Yes, bump it up to 8             */
SIGNAL EXIT
/*-End of ERRMSGX  function-------------------------------------------*/

/*RXCOPY GETENV NODUP 169 LINES COPIED ON 09-19-03 AT 11:08************/
/*-Start of GETENV subroutine---------------------------Version-01.13-*/
/*:GETENV Function: Determines current REXX / AO product environment. */
/* Returns: ATMCMS  CMDCMS  ATMREXX ATMTSO  MVSTSO  OPSREXX OPSTSO    */
/*  CMDRULE DOMRULE EOMRULE GLVRULE MSGRULE OMGRULE REQRULE SCRRULE   */
/*  SECRULE TODRULE NETVMVS IMF     AFOPER  MVSUSS                    */
/*  AXCOS2  CMDOS2  AXCONT  CMDONT  AXCWNT  CMDWNT  AXCW95  CMDW95    */
/*  SPFWNT  CMDDOS  AXCUNIX CMDUNIX RAWUNIX CMDR98  CMDRNT UNKNOWN    */
/*    Note: All variables used in this routine should be _hidden.     */
/* Copyright (C) 1995,2003 ProTech. All rights reserved.              */
/*--------------------------------------------------------------------*/
GETENV:
TRACE N                            /* Turn off rexx tracing           */
IF SYMBOL('the_environment')='VAR' /* If we were already called,      */
THEN RETURN the_environment        /* then just return the same answer*/
the_environment = 'UNKNOWN'        /* Initialize - assume unknown     */

PARSE UPPER SOURCE _src +3 1 . . . . . . . . _token .
PARSE UPPER VERSION _version .
IF _src = 'OPS' THEN
  DO                               /* Running in OPS. Assume xxxRULE  */
  the_environment = OPSINFO('EVENTTYPE')'RULE'
  IF the_environment = 'NONERULE'  /* Not running in a rule?          */
  THEN the_environment = 'OPSREXX' /* No, return OPSREXX instead      */
  SIGNAL GETENV_EXIT
  END
IF _src = 'UNI' THEN
  DO
  IF ADDRESS() = 'AXC'
  THEN DO; the_environment = 'AXCUNIX'; SIGNAL GETENV_EXIT; END
  IF POS(TRANSLATE(ADDRESS()),'UNIX KSH CSH') > 0
  THEN DO; the_environment = 'CMDUNIX'; SIGNAL GETENV_EXIT; END
  IF POS(TRANSLATE(ADDRESS()),'COMMAND') > 0
  THEN DO; the_environment = 'RAWUNIX'; SIGNAL GETENV_EXIT; END
  END
IF _src = 'OS/' THEN
  DO
  IF ADDRESS() = 'AXC'
  THEN DO; the_environment = 'AXCOS2'; SIGNAL GETENV_EXIT; END
  IF POS(TRANSLATE(ADDRESS()),'CMD PMREXX') > 0
  THEN DO; the_environment = 'CMDOS2'; SIGNAL GETENV_EXIT; END
  END
IF _src = 'WIN' THEN
  DO
  IF ABBREV(_version,'REXX-REGINA') = 1 THEN
    DO                             /* Regina REXX, tack on OS         */
    INTERPRET "the_environment='CMDR'RIGHT(UNAME('S'),2)"/*WIN98,WINNT*/
    SIGNAL GETENV_EXIT
    END
  PARSE UPPER SOURCE _src .
  _src = 'W'RIGHT(_src,2)          /* WNT or W95                      */
  IF ADDRESS() = 'AXC'
  THEN DO; the_environment = 'AXC'_src; SIGNAL GETENV_EXIT; END
  IF TRANSLATE(ADDRESS()) = 'CMD'
  THEN DO; the_environment = 'CMD'_src; SIGNAL GETENV_EXIT; END
  END
IF _src = 'NT ' THEN
  DO
  _src = 'ONT'                     /* OpenREXX Running on NT          */
  IF ADDRESS() = 'AXC'
  THEN DO; the_environment = 'AXC'_src; SIGNAL GETENV_EXIT; END
  IF TRANSLATE(ADDRESS()) = 'CMD'
  THEN DO; the_environment = 'CMD'_src; SIGNAL GETENV_EXIT; END
  END
IF _src = 'DOS' THEN
  DO
  IF TRANSLATE(ADDRESS()) = 'COMMAND'
  THEN DO; the_environment = 'CMDDOS'; SIGNAL GETENV_EXIT; END
  IF TRANSLATE(ADDRESS()) = 'ISREDIT' /* SPF/Professional on WindowsNT*/
  THEN DO; the_environment = 'SPFWNT'; SIGNAL GETENV_EXIT; END
  END
IF _src = 'TSO' THEN
  DO                               /* Setup OUTTRAP if possible.      */
  IF SYMBOL('IMFENAME') SYMBOL('IMFORGN') = 'VAR VAR'
  THEN DO; the_environment = 'IMF'; SIGNAL GETENV_EXIT; END
  IF _token = 'OPENMVS'            /* Running inside UNIX Sys Serv?   */
  THEN DO; the_environment = 'MVSUSS'; SIGNAL GETENV_EXIT; END
  IF ADDRESS() = 'AFHOST'          /* Running inside AFOPER?          */
  THEN DO; the_environment = 'AFOPER'; SIGNAL GETENV_EXIT; END
  IF ADDRESS() = 'NETVIEW'         /* Running inside NetView?         */
  THEN DO; the_environment = 'NETVMVS'; SIGNAL GETENV_EXIT; END
  INTERPRET "CALL OFF ERROR"       /* Turn off error handler (n/a SPF)*/
  INTERPRET "CALL OFF FAILURE"     /* Turn off error handler (n/a SPF)*/
  ADDRESS MVS "SUBCOM AFHOST"      /* Running inside AFOPER?          */
  IF rc=0 THEN DO; the_environment = 'AFOPER'; SIGNAL GETENV_EXIT; END
  ADDRESS MVS "SUBCOM NETVIEW"     /* Running inside NETVIEW?         */
  IF rc=0 THEN DO; the_environment = 'NETVMVS'; SIGNAL GETENV_EXIT; END
  IF ADDRESS() = 'MVS'             /* Running MVS native rexx?        */
  THEN DO; the_environment = 'ATMREXX'; SIGNAL GETENV_EXIT; END
  ADDRESS MVS "SUBCOM TSO"         /* Make sure TSO available         */
  IF rc=0 THEN                     /* Is it?                          */
    DO                             /* Yes, now safe to call OUTTRAP() */
    _fndops = 0                    /* Haven't found OPS/MVS (yet)     */
    _fndatm = 0                    /* Haven't found AutoMate (yet)    */
    NUMERIC DIGITS 9               /* Reset to default precision      */
    INTERPRET "_cvt   = STORAGE(10,4)"                /* -> CVT       */
    INTERPRET "_jesct = STORAGE(D2X(C2D(_cvt)+C2D('128'x)),4)"
    INTERPRET "_ssct  = STORAGE(D2X(C2D(_jesct)+C2D('18'X)),4)"
      DO _i = 1 BY 1 WHILE _ssct <> '00000000'x   /* Scan SSCT chain  */
      INTERPRET "PARSE VALUE STORAGE(C2X(_ssct),20) WITH",
        "1 _ssctid +4 5 _ssct +4 9 _ssctsnam +4 17 _ssctssvt +4"
      IF _ssctid <> 'SSCT' THEN SAY 'GETENV error, bad ssct @ 'C2X(ssct)
      IF _ssctssvt <> '00000000'x THEN    /* Is subsys active?        */
        DO                               /* Yes, check subsys name   */
        IF ABBREV(_ssctsnam,'OPS') THEN _fndops = 1
        IF ABBREV(_ssctsnam,'ATM') THEN _fndatm = 1
        END
      END _i
    IF _fndops = 0 & _fndatm = 0 THEN
      DO; the_environment = 'MVSTSO'; SIGNAL GETENV_EXIT; END
    IF _fndops = 1 & _fndatm = 0 THEN
      DO; the_environment = 'OPSTSO'; SIGNAL GETENV_EXIT; END
    IF _fndops = 0 & _fndatm = 1 THEN
      DO; the_environment = 'ATMTSO'; SIGNAL GETENV_EXIT; END
    /*----------------------------------------------------------------*/
    /* OUTTRAP() is used to quietly issue TSO cmds.  If OUTTRAP() is  */
    /* already active, and we're nested too deeply to see vars needed */
    /* to restore caller's outtrap, then don't run (avoid side-effect)*/
    /*----------------------------------------------------------------*/
    INTERPRET "_savtrap = OUTTRAP()" /* Is outtrap active?            */
    IF _savtrap = 'OFF'
    THEN _savtrap = "x=OUTTRAP('OFF')" /* No,Build outtrap shutoffcmd */
    ELSE
      DO
      INTERPRET "_symbol = SYMBOL('"_savtrap"MAX')"
      IF _symbol = 'VAR'             /* Active, but restore data avail*/
      THEN _savtrap= "x=OUTTRAP("_savtrap","_savtrap"MAX,"_savtrap"CON)"
      ELSE
        DO                         /* Outtrap restore data not exposed*/
        SAY 'GETENV error: OUTTRAP() Active and cannot be used'
        DROP _savtrap              /* Keep exit from restoring outtrap*/
        SIGNAL GETENV_EXIT
        END
      END
    /* Turn off TSO error messages (come out if command not found)    */
    INTERPRET "_msg_status=MSG('OFF')"/*Interpret (hide from OPS/REXX)*/
    INTERPRET "x = OUTTRAP('_outtrap.',1,'NOCONCAT')" /* OUTTRAP is on*/
    ADDRESS TSO 'OPSMODE SHOW' /*OPS7950I COMMAND MODE IS ATM|OPS|NONE*/
    IF rc<0 THEN DO; the_environment = 'ATMTSO'; SIGNAL GETENV_EXIT; END
    IF _outtrap.0 = 1
    THEN the_environment = WORD(_outtrap.1,WORDS(_outtrap.1))'TSO'
    IF WORDPOS(the_environment,'OPSTSO ATMTSO') > 0
    THEN SIGNAL GETENV_EXIT
    ADDRESS TSO 'GETVAR ATMJOBNAME _atmjobname'
    INTERPRET "_sysuid =  SYSVAR('SYSUID')"
    IF _sysuid = _atmjobname
    THEN DO; the_environment = 'ATMTSO'; SIGNAL GETENV_EXIT; END
    ELSE DO; the_environment = 'OPSTSO'; SIGNAL GETENV_EXIT; END
    END /* SUBCOM TSO */
  END /* IF _src = 'TSO' THEN */
IF _src = 'CMS' THEN
  DO
  ADDRESS CMS 'PIPE COMMAND GETVAR ATMID ATMID | STEM _outtrap.'
  IF RC <> -3
  THEN DO; the_environment = 'ATMCMS'; SIGNAL GETENV_EXIT; END
  ELSE DO; the_environment = 'CMDCMS'; SIGNAL GETENV_EXIT; END
  END /* IF _src = 'CMS' THEN */

GETENV_EXIT:
IF _src = 'TSO' THEN
  DO                               /* Restore callers environment     */
  IF SYMBOL('_savtrap') = 'VAR' THEN
    DO
    INTERPRET _savtrap             /* Restore caller's OUTTRAP status */
    INTERPRET "CALL MSG _msg_status" /* Restore caller's MSG() status */
    END
  END
DROP _src _savtrap _msg_status _outtrap. _version _token
RETURN the_environment
/*-End of GETENV   subroutine-----------------------------------------*/

/*RXCOPY IOSUBS NODUP 1085 LINES COPIED ON 09-19-03 AT 11:08***********/
/*Start of IOSUBS Routines------------------------------Version-01.11-*/
/* IOSUBS is a collection of multi-platform REXX I/O routines,        */
/* supporting TSO/E REXX, OPS/REXX, MVS ISPF, NetView, OS/2, WinNT/95,*/
/* and DOS.                                                           */
/*  IOREAD     Reads data into a REXX stemmed variable.               */
/*  IOWRITE    Writes data from a REXX stemmed variable to a dataset. */
/* Note 1: This routine calls GETENV() and ISPFLMF(), so you must     */
/*         RXCOPY them into your routine.                             */
/* Copyright (C) 1996,2003 ProTech. All rights reserved.              */
/*--------------------------------------------------------------------*/
OPTIONS 'OPSWXTRN=OPSSVC99'
/*:IOREAD Function - reads a sequential file or PDS member into a     */
/* stem variable.                                                     */
/* Parms:                                                             */
/*   DDNAME('ddname')      MVS only.  Mutually exclusive w/ FILENAME()*/
/*                         If under ISPF, must be true sequential.    */
/*   FILENAME('fully qualified name of a partitioned dataset')        */
/*            '<OR> relative or full path name of a file.'            */
/*   LEAVEOPEN(YES | NO)   If yes, file is kept open so that          */
/*                         additional records can be read.            */
/*                         Default: LEAVEOPEN(NO).                    */
/*   LEAVEALLOC(YES | NO)  If yes, file is kept allocated to speed up */
/*                         future access to same file.                */
/*                         Default: LEAVEALLOC(NO).                   */
/*   RECORDS(ALL | n)      Number of records to read. Use RECORDS(0)  */
/*                         to close file w/o read.                    */
/*                         Default: RECORDS(ALL).                     */
/*   STEM(line.)           Stem variable name to contain data.        */
/*                         Default: STEM(LINE.).                      */
/*   TOKENVAR('rexx variable name')  A token is required when you will*/
/*                         make several related IOREAD() calls for    */
/*                         the same file, using LEAVEOPEN(YES) or     */
/*                         LEAVEALLOC(YES).  Default: no token.       */
/*   USE(SHR | EXCL)       Controls serialization of the file.        */
/*                         USE(EXCL) LEAVEOPEN(YES) can be used when  */
/*                         you want to update a file with IOWRITE().  */
/*                         Ignored if running outside of MVS.         */
/*                         Default: USE(SHR).                         */
/* Example: rc=IOREAD('FILENAME(SYS1.PARMLIB(CONSOL00)) STEM(LINE.)   */
/* Returns: 0:    Data read okay.                                     */
/*          text: Error occured, text gives the details.              */
/*  Note 1: All variables used in this routine should be _hidden.     */
/*--------------------------------------------------------------------*/
IOREAD:
TRACE N
PARSE UPPER ARG 1 ' DEBUG' +0 _debug . ,
  1 'DDNAME(' _ddname ')'         1 'FILENAME(' _filename ')',
  1 'LEAVEALLOC(' _leavealloc ')' 1 'LEAVEOPEN(' _leaveopen ')',
  1 'RECORDS(' _records ')'       1 'STEM(' _stem ')',
  1 'TOKENVAR(' _tokenvar ')'     1 'USE(' _use ')'
IF _debug <> '' THEN TRACE I
IF _filename = '' & _ddname = ''
THEN RETURN 'Missing FILENAME() or DDNAME() parm'
/* See if filename is an MVS PDS name.  If so, isolate member name    */
PARSE VAR _filename _dsname '(' _member ')'
/* If dataset is a PDS, add trailing paren to terminate member name   */
IF _member <> '' THEN _filename = _filename')'
IF _leaveopen = '' THEN _leaveopen = 'NO'   /* Default LEAVEOPEN(NO)  */
IF WORDPOS(_leaveopen,'YES NO') = 0
THEN RETURN 'Invalid LEAVEOPEN() parm value'
IF _leavealloc = '' THEN _leavealloc = _leaveopen /*set LEAVEALLOC(NO)*/
IF WORDPOS(_leavealloc,'YES NO') = 0
THEN RETURN 'Invalid LEAVEALLOC() parm value'
IF _records = '' THEN _records = 'ALL'      /* Default RECORDS(ALL)   */
IF _records <> 'ALL' THEN IF DATATYPE(_records) <> 'NUM'
THEN RETURN 'Invalid RECORDS() parm value'
IF _stem = '' THEN _stem = 'line.'          /* Default STEM(LINE.)    */
IF RIGHT(_stem,1) <> '.' THEN _stem = _stem'.'
IF _tokenvar = '' THEN
  IF _leaveopen = 'YES' | _leavealloc = 'YES'
  THEN RETURN 'Missing TOKENVAR() parm, required if LEAVEALLOC(YES) or',
              'LEAVEOPEN(YES) specified'
CALL IOSUBS_GETTOKEN                    /* Initialize _status         */
_ddnm = _ddname                         /* Copy caller-passed DDNAME  */
IF _ddname = '' THEN                    /* DDNAME(xx) passed or saved?*/
  IF _tokenvar <> ''                    /* No. Was token passed?      */
  THEN _ddnm = LEFT(_tokenvar,8)        /*  Yes, use as DDNAME        */
  ELSE _ddnm = 'IORD'RANDOM(9999)       /*  No, Generate random DDNAME*/
IF _use = '' THEN _use = 'SHR'              /* Default USE(SHR)       */
IF WORDPOS(_use,'SHR EXCL') = 0
THEN RETURN 'Invalid USE() parm value'
_ioread_rc = 0                         /* Initialize return code      */
CALL VALUE _stem'0',0                  /* Initialize stem.0           */
/*--------------------------------------------------------------------*/
/* P C - B A S E D  R E X X   S E G M E N T  (O S / 2,  D O S,  E T C)*/
/*--------------------------------------------------------------------*/
IF WORDPOS(RIGHT(GETENV(),3),'OS2 DOS WNT W95 ONT') = 0
THEN SIGNAL IOREAD_NOTOS2

IF _status = 'OPEN'                    /* Was file left open?         */
THEN SIGNAL IOREAD_OS2_READIT          /* Yes, start reading it.      */
/* Warning, calling QUERY EXISTS in NT on open file resets read ptr!  */
IF STREAM(_filename,'C','QUERY EXISTS') = ''   /* Does file exist?    */
THEN RETURN 'File not found'                   /* No, can't read it.  */
IF _use = 'SHR'  THEN _o = STREAM(_filename,'C','OPEN READ')
IF _use = 'EXCL' THEN _o = STREAM(_filename,'C','OPEN')
IF _o = 'NOTREADY:32'                  /* File in use by another pgm? */
THEN RETURN 'File in use'              /* Yes, return error text      */
IF ABBREV(_o,'READY') <> 1             /* Is file ready?              */
THEN RETURN 'File not ready:'_o        /* No, return error text       */
CALL LINEIN _filename,1,0              /* Position file to line 1     */
IOREAD_OS2_READIT:
  DO _i = 1 BY 1 WHILE LINES(_filename) > 0  /* Don't read past EOF   */
  IF _records <> 'ALL' THEN            /* Do we have RECORDS(n) limit?*/
    IF _i > _records                   /* Yes, are we about to exceed?*/
    THEN SIGNAL IOREAD_OS2_SET0        /* Exit if exceeds record count*/
  _data = LINEIN(_filename)            /* Read a line from the file.  */
  CALL VALUE _stem''_i,_data           /* Store the data in stem var  */
  END _i /* DO _i = 1 BY 1  */
IF _records <> 'ALL' THEN _ioread_rc = 'EOF' /*Only EOF if RECORDS(n) */

IOREAD_OS2_SET0:
CALL VALUE _stem'0',_i-1               /* Save lines read in stem.0   */
IF _leaveopen <> 'YES' THEN            /* Are we to leave file open?  */
  DO
  CALL STREAM _dsname,'C','CLOSE'      /* No, close the file          */
  CALL IOSUBS_PUTTOKEN ''              /* Remove STATUS from token    */
  END
ELSE                                   /* If we are leaving file open,*/
  CALL IOSUBS_PUTTOKEN 'STATUS(OPEN)'  /*  add STATUS(OPEN) to token. */
DROP _status _tokenvar _t1 _t2 _dsname _leaveopen _stem _i _records,
     _data _filename _o _leavealloc _leaveopen _stem _use
RETURN _ioread_rc
IOREAD_NOTOS2:

/*--------------------------------------------------------------------*/
/* I S P F   c o d e   s e g m e n t   f o r   I O R E A D.           */
/*--------------------------------------------------------------------*/
IF ISPFLMF() <> 'YES' THEN SIGNAL IOREAD_NOTISPF
ADDRESS ISPEXEC 'CONTROL ERRORS RETURN'
IF SYMBOL('ZDATAIDZ') = 'LIT' THEN
  DO
  ok = '8'
  IF _ddname <> ''                     /* Was DDNAME() passed in?     */
  THEN ADDRESS ISPEXEC 'LMINIT DATAID(ZDATAIDZ) DDNAME('_ddname')'
  ELSE ADDRESS ISPEXEC 'LMINIT DATAID(ZDATAIDZ) ENQ(SHR)',
                       "DATASET('"_dsname"')"
  IF rc > 0 THEN RETURN STRIP(ZERRSM)  /* LMINIT failed, return error */
  CALL IOSUBS_PUTTOKEN 'DATAID('VALUE(ZDATAIDZ)')' /* Save dataid     */
  END
/* Extract the LRECL of the dataset we are reading                    */
ok = 4                             /* rc=4 if some vars are blank     */
ADDRESS ISPEXEC 'LMQUERY DATAID('ZDATAIDZ') OPEN(ZOPENZ)'
IF rc > 4 THEN RETURN STRIP(ZERRSM)
IF _status = 'OPEN'                    /* Was file left open?         */
THEN SIGNAL IOREAD_SPF_READIT          /* Yes, start reading it.      */
ADDRESS ISPEXEC 'LMOPEN DATAID('ZDATAIDZ') OPTION(INPUT) LRECL(ZLRECLZ)'
IF rc > 0 THEN RETURN STRIP(ZERRLM)
IF _member <> '' THEN
  DO
  IF _tokenvar <> ''             /* If token was passed,              */
  THEN _stats = 'YES'            /* then copy stats to token          */
  ELSE _stats = 'NO'             /* Else don't bother.                */
  /*------------------------------------------------------------------*/
  /* Position to desired member.                                      */
  /*------------------------------------------------------------------*/
  OK='8 12';ADDRESS ISPEXEC 'LMMFIND DATAID('ZDATAIDZ')',
                            'MEMBER('_member')',
                            'STATS('_stats')'; DROP OK
  IF rc >= 8 THEN
    DO
    IF rc > 8 THEN
      IF SYMBOL('ZERRLM') = 'VAR'
      THEN _ioread_rc = STRIP(ZERRLM)
      ELSE _ioread_rc = 'LMMFIND FAILED RC='rc
    ELSE _ioread_rc = 'Member not found'
    _i = 1
    SIGNAL IOREAD_SPF_SET0    /* Exit if exceeds record count    */
    END
  IF _stats = 'YES' THEN
    DO
    _statlist = 'zlvers   zlmod    zlcdate  zlmdate  zlmtime',
                'zlmsec   zlcnorc  zlinorc  zlmnorc  zluser'
      DO _i = 1 TO WORDS(_statlist)
      _stat = WORD(_statlist,_i)
      IF SYMBOL(_stat) = 'VAR'
      THEN CALL IOSUBS_PUTTOKEN _stat'('VALUE(_stat)')'
      END _i
    END
  END
IOREAD_SPF_READIT:
  DO _i = 1 BY 1                   /* Read each record from the file  */
  IF _records <> 'ALL' THEN        /* Do we have RECORDS(n) limit?    */
    IF _i > _records               /* Yes, are we about to exceed?    */
    THEN SIGNAL IOREAD_SPF_SET0    /* Exit if exceeds record count    */
  ok = 8
  ADDRESS ISPEXEC 'LMGET DATAID('ZDATAIDZ') MODE(INVAR)',
                  'DATALOC(ZDATAZ) DATALEN(ZDATALNZ) MAXLEN('ZLRECLZ')'
  ok = 0
  IF RC = 8 THEN                   /* End of file...                  */
    DO
    IF _records <> 'ALL'           /* Was RECORDS(n) specified?       */
    THEN _ioread_rc = 'EOF'        /* Yes, return 'EOF'.              */
    LEAVE
    END
  CALL VALUE _stem''_i,ZDATAZ
  END _i /* DO _i = 1 BY 1  */
IOREAD_SPF_SET0:
CALL VALUE _stem'0',_i-1
IF _leaveopen <> 'YES' THEN            /* Are we to leave file open?  */
  DO                                   /* No, close it.               */
  ADDRESS ISPEXEC 'LMCLOSE DATAID('ZDATAIDZ')'
  CALL IOSUBS_PUTTOKEN 'STATUS(ALLOC)' /* Change to STATUS(ALLOC)     */
  END
ELSE                                   /* If we are leaving file open,*/
  CALL IOSUBS_PUTTOKEN 'STATUS(OPEN)'  /*  add STATUS(OPEN) to token. */
IF _leavealloc <> 'YES' THEN
  DO
  ADDRESS ISPEXEC 'LMFREE  DATAID('ZDATAIDZ')'
  CALL IOSUBS_PUTTOKEN ''              /* Remove all data from token  */
  END
DROP _status _tokenvar _t1 _t2 _dsname _leaveopen _stem _i _records,
     _data _filename _o _leavealloc _leaveopen _stem _use zdataidz,
     _tokenvar _tempid
RETURN _ioread_rc
IOREAD_NOTISPF:
/*--------------------------------------------------------------------*/
/* T S O   c o d e   s e g m e n t   f o r   I O R E A D.             */
/*--------------------------------------------------------------------*/
IF RIGHT(GETENV(),3) <> 'TSO' & POS(GETENV(),'OPSREXX') = 0
THEN SIGNAL IOREAD_NOTTSO

IF WORDPOS(_status,'ALLOC OPEN') > 0 THEN  /* File already ALLOCd?    */
  SIGNAL IOREAD_TSO_ALLOCD                 /* Yes, skip validation.   */
IF _ddname <> '' THEN                  /* Was DDNAME() passed in?     */
  DO                                   /* Yes.  Is it allocated?      */
  IF RIGHT(GETENV(),3) = 'TSO' THEN    /* Running in TSO/E?           */
    DO                                 /* Use TSO/E LISTDSI() function*/
    INTERPRET "rc = LISTDSI('"_ddname" FILE NODIRECTORY NORECALL')"
    IF rc > 4
    THEN RETURN LISTDSIREASON(sysreason)
    END
  IF POS(GETENV(),'OPSREXX') > 0 THEN
    IF LEFT(OPSINFO('VERSION'),5) >= '04.01' THEN
      INTERPRET "IF OPSDD2DS(_ddname) = ''",
                "THEN RETURN 'DDNAME('_ddname') not allocated'"
    ELSE
      DO
      CALL OPSCLEDQ
      ok = '12'
      ADDRESS TSO "LISTALC STATUS"
      _ddfound = 0
      _search4 = '  'LEFT(_ddname,8,' ')' '
        DO WHILE QUEUED() > 0
        PARSE UPPER PULL (_search4) _msg
        IF _msg <> '' THEN _ddfound = 1
        END
      IF _ddfound <> 1
      THEN RETURN 'DDNAME('_ddname') not allocated'
      END
  SIGNAL IOREAD_TSO_ALLOCD             /* Start reading it...         */
  END
_disp = _use
IF _use = 'EXCL' THEN _disp = 'OLD'
IF RIGHT(GETENV(),3) = 'TSO' THEN      /* Running in TSO/E?           */
  DO                                   /* Use TSO/E SYSDSN() function */
  INTERPRET "_msg_status=MSG('OFF')"/*Interpret to hide from OPS/REXX */
  INTERPRET "rc = SYSDSN('''"_filename"''')"
  IF rc <> 'OK' THEN
    IF rc = 'UNAVAILABLE DATASET' THEN RETURN 'File in use'
    ELSE RETURN rc
  INTERPRET "_savtrap = OUTTRAP()" /* Is outtrap active?              */
  IF _savtrap = 'OFF'
  THEN _savtrap = "x = OUTTRAP('OFF')"/*No, build outtrap shutoff cmd */
  ELSE
    DO
    INTERPRET "_symbol = SYMBOL('"_savtrap"MAX')"
    IF _symbol = 'VAR'             /* Active, but restore data avail  */
    THEN _savtrap = "x=OUTTRAP("_savtrap","_savtrap"MAX,"_savtrap"CON)"
    ELSE
      DO                           /* Outtrap restore data not exposed*/
      RETURN 'IOREAD error: OUTTRAP() Active and cannot be used'
      END
    END

  INTERPRET "x = OUTTRAP('_outtrap.','*','NOCONCAT')"
  INTERPRET "CALL MSG('ON')"
  ok = '12'
  ADDRESS TSO "ALLOC FILE("_ddnm") DSNAME('"_filename"')",
    "REUSE "_disp
  END
IF POS(GETENV(),'OPSREXX') > 0 THEN
  DO
  IF _member <> '' THEN                /* Is this a PDS?              */
    DO                                 /* Yes                         */
    _rc = OPSPDS('EXISTS', _dsname, _member)
    IF _rc <> 0 THEN RETURN 'Member not found'
    END
  IF LEFT(OPSINFO('VERSION'),5) >= '04.01' THEN
    DO
    rc = OPSSVC99('ALLOC',_ddnm,_filename,_disp)
    IF rc <> 0 THEN
      DO; _ioread_rc = 'Allocate failed'; SIGNAL IOREAD_TSO_EXIT; END
    END
  ELSE
    DO
    CALL OPSCLEDQ
    ok = '12'
    ADDRESS TSO "ALLOC FILE("_ddnm") DSNAME('"_filename"')",
      "REUSE "_disp
      DO _i = 1 BY 1 WHILE QUEUED() > 0
      PARSE UPPER PULL _msg
      _outtrap._i = _msg
      END _i
    _outtrap.0 = _i-1
    END
  END
IF rc <> 0 THEN
  DO
  _i = _outtrap.0
  _ioread_rc = _outtrap._i
  IF _ioread_rc = 'DATA SET IS ALLOCATED TO ANOTHER JOB OR USER'
  THEN _ioread_rc = 'File in use'
  IF _i = 0
  THEN _ioread_rc = 'Allocate failed'
  SIGNAL IOREAD_TSO_EXIT
  END
IOREAD_TSO_ALLOCD:
_howmany = _records
IF _records = 'ALL' THEN _howmany = '*'
_options = ''
IF _leaveopen <> 'YES' THEN _options = _options'FINIS '
ok = '2'
ADDRESS TSO 'EXECIO '_howmany' DISKR '_ddnm,
  ' ('_options' STEM '_stem')'
IF rc = 2 THEN ioread_rc = 'EOF'

IF _leavealloc <> 'YES' THEN
  DO
  IF POS(GETENV(),'OPSREXX') > 0 THEN
    IF LEFT(OPSINFO('VERSION'),5) >= '04.01'
    THEN INTERPRET "CALL OPSSVC99 'FREE',_ddnm"
    ELSE ADDRESS TSO 'FREE FILE('_ddnm')'
  ELSE ADDRESS TSO 'FREE FILE('_ddnm')'
  CALL IOSUBS_PUTTOKEN ''              /* Remove all data from token  */
  END
ELSE                                   /* Leaving file OPEN or ALLOC? */
  IF _leaveopen = 'YES'                /* Yes, update the TOKEN       */
  THEN
    DO
    CALL IOSUBS_PUTTOKEN 'DDNAME('_ddnm')'
    CALL IOSUBS_PUTTOKEN 'STATUS(OPEN)'
    END
  ELSE
    DO
    CALL IOSUBS_PUTTOKEN 'DDNAME('_ddnm')'
    CALL IOSUBS_PUTTOKEN 'STATUS(ALLOC)'
    END
IOREAD_TSO_EXIT:
IF SYMBOL('_savtrap') = 'VAR'
THEN INTERPRET _savtrap            /* Restore caller's OUTTRAP status */
IF SYMBOL('_msg_status') = 'VAR'
THEN INTERPRET "CALL MSG _msg_status" /* Restore caller's MSG() status*/
DROP _msg_status _savtrap _tokenvar _tempid _ddfound _search4
DROP _status _tokenvar _t1 _t2 _dsname _leaveopen _stem _i _records,
     _data _filename _o _leavealloc _leaveopen _stem _use
RETURN _ioread_rc
IOREAD_NOTTSO:
/*--------------------------------------------------------------------*/
/* N E T V I E W   c o d e   s e g m e n t   f o r   I O R E A D.     */
/*--------------------------------------------------------------------*/
IF GETENV() <> 'NETVMVS'
THEN SIGNAL IOREAD_NOTNETV

IF WORDPOS(_status,'ALLOC OPEN') <> 0  /* File already ALLOCd?        */
THEN SIGNAL IOREAD_NETV_ALLOCD         /* Yes, skip validation.       */
IF _ddname <> '' THEN                  /* Was DDNAME() passed in?     */
  DO                                   /* Yes.  Is it allocated?      */
  /*------------------------------------------------------------------*/
  /* CNM271I FOOBAR DD STATEMENT MISSING                              */
  /* -or-                                                             */
  /* CNM299I                                                          */
  /* DDNAME   DATA SET NAME                                       DISP*/
  /* -------- --------------------------------------------------- --- */
  /* DSIPARM  DC2P.NETVIEW.V3R1.NETOG.DSIPARM                     SHR */
  /*------------------------------------------------------------------*/
  ADDRESS NETVIEW 'PIPE NETVIEW LISTA '_ddname,
    ' | SEPARATE ',                /* Convert multi-line to single    */
    ' | STEM _ioreadout.'          /* Place results into global vars  */
  IF ABBREV(_ioreadout.1,'CNM271I') = 1 THEN
    RETURN 'DDNAME('_ddname') not allocated'
  IF ABBREV(_ioreadout.1,'CNM299I') <> 1 THEN
    RETURN 'DDNAME('_ddname') not allocated'
  SIGNAL IOREAD_NETV_ALLOCD            /* Start reading it...         */
  END
_disp = _use
IF _use = 'EXCL' THEN _disp = 'OLD'
/*--------------------------------------------------------------------*/
/* CNM272I TEST IS NOW ALLOCATED                                      */
/* DSI370I ALLOCATE COMMAND FAILED, 'IORD2941' IS ALREADY IN USE      */
/* CNM277I DATA SET DKZB2CC.FLA NOT FOUND                             */
/* CNM278I DATA SET DKZB2CC.CLIST UNAVAILABLE                         */
/*--------------------------------------------------------------------*/
  DO _ioreadi = 1 TO 2
  'PIPE NETVIEW ALLOC FILE('_ddnm') DS('_filename') '_disp,
    ' | SEPARATE ',                /* Convert multi-line to single    */
    ' | STEM _ioreadout.'          /* Place results into global vars  */
  IF ABBREV(_ioreadout.1,'DSI370I') <> 1 THEN LEAVE _ioreadi
  IF _ioreadi = 1 THEN
    DO
    ADDRESS NETVIEW 'PIPE NETVIEW FREE FILE('_ddnm')'
    ITERATE _ioreadi
    END
  _ioread_rc = 'Unable to REUSE File('_ddnm')'
  SIGNAL IOREAD_NETV_EXIT
  END _ioreadi

_i = _ioreadout.0                  /* -> last line of ALLOC output    */
  SELECT
  WHEN ABBREV(_ioreadout._i,'CNM272I') = 1 THEN
    SIGNAL IOREAD_NETV_ALLOCD
  WHEN ABBREV(_ioreadout._i,'CNM278I') = 1 THEN
    _ioread_rc = 'File in use'
  WHEN _i = 0 THEN
    _ioread_rc = 'Allocate failed'
  OTHERWISE
  _ioread_rc = SUBWORD(_ioreadout._i,2)
  END
SIGNAL IOREAD_NETV_EXIT

IOREAD_NETV_ALLOCD:
_howmany = _records
IF _records = 'ALL' THEN _howmany = '*'
_options = ''
IF _leaveopen <> 'YES' THEN _options = _options'FINIS '
ok = '2'
ADDRESS MVS 'EXECIO '_howmany' DISKR '_ddnm,
  ' ('_options' STEM '_stem')'
IF rc = 2 THEN ioread_rc = 'EOF'

IF _leavealloc <> 'YES' THEN
  DO
  ADDRESS NETVIEW 'PIPE NETVIEW FREE FILE('_ddnm')'
  CALL IOSUBS_PUTTOKEN ''              /* Remove all data from token  */
  END
ELSE             /* If we are leaving file around, save data in token */
  IF _leaveopen = 'YES'
  THEN
    DO
    CALL IOSUBS_PUTTOKEN 'DDNAME('_ddnm')'
    CALL IOSUBS_PUTTOKEN 'STATUS(OPEN)'
    END
  ELSE
    DO
    CALL IOSUBS_PUTTOKEN 'DDNAME('_ddnm')'
    CALL IOSUBS_PUTTOKEN 'STATUS(ALLOC)'
    END
IOREAD_NETV_EXIT:
IF SYMBOL('_savtrap') = 'VAR'
THEN INTERPRET _savtrap            /* Restore caller's OUTTRAP status */
IF SYMBOL('_msg_status') = 'VAR'
THEN INTERPRET "CALL MSG _msg_status" /* Restore caller's MSG() status*/
DROP _msg_status _savtrap _tokenvar _tempid _ddfound _search4
DROP _status _tokenvar _t1 _t2 _dsname _leaveopen _stem _i _records,
     _data _filename _o _leavealloc _leaveopen _stem _use
RETURN _ioread_rc
IOREAD_NOTNETV:
RETURN 'Unsupported environment 'GETENV()
/*--------------------------------------------------------------------*/
/*:IOWRITE Function - writes to a sequential file or MVS PDS member   */
/* from a stem variable.  This function is cross-platform, supporting:*/
/* TSO/E REXX, OPS/REXX, MVS ISPF, and OS/2.                          */
/* Parms:                                                             */
/*   DDNAME('ddname')      MVS only.  Mutually exclusive w/ FILENAME()*/
/*                         If under ISPF, must be true sequential.    */
/*   FILENAME('fully qualified name of a partitioned dataset')        */
/*            '<OR> relative or full path name of a file.'            */
/*   LEAVEOPEN(YES | NO)   If yes, file is kept open so that          */
/*                         additional records can be added.           */
/*                         Default: LEAVEOPEN(NO).                    */
/*   LEAVEALLOC(YES | NO)  If yes, file is kept allocated to speed up */
/*                         future access to same file.                */
/*                         Default: LEAVEALLOC(NO).                   */
/*   MODE(REPLACE | APPEND)  Controls whether file is overwritten or  */
/*                         data is added to end. Default:MODE(REPLACE)*/
/*   STEM(line.)           Stem variable name with data to be written.*/
/*                         Default: STEM(LINE.).                      */
/*   TOKENVAR('rexx variable name')  A token is required when you will*/
/*                         make several related IOREAD() or IOWRITE() */
/*                         calls for the same file, using             */
/*                         LEAVEOPEN(YES) or LEAVEALLOC(YES).         */
/*                         Default: no token.                         */
/*   USE(SHR | EXCL)       Controls serialization of the file. Ignored*/
/*                         if running outside of MVS.                 */
/*                         Default: USE(EXCL).                        */
/* Example: rc=IOWRITE('FILENAME(SYS1.PARMLIB(CONSOL00))              */
/* Returns: 0:    Data written okay.                                  */
/*          text: Error occured, text gives the details.              */
/*  Note 1: All variables used in this routine should be _hidden.     */
/*--------------------------------------------------------------------*/
IOWRITE:
TRACE N
PARSE UPPER ARG 1 ' DEBUG' +0 _debug . ,
  1 'DDNAME(' _ddname ')'         1 'FILENAME(' _filename ')',
  1 'LEAVEALLOC(' _leavealloc ')' 1 'LEAVEOPEN(' _leaveopen ')',
  1 'MODE(' _mode ')'             1 'STEM(' _stem ')',
  1 'TOKENVAR(' _tokenvar ')'     1 'USE(' _use ')'
IF _debug <> '' THEN TRACE I
IF _filename = '' & _ddname = ''
THEN RETURN 'Missing FILENAME() or DDNAME() parm'
/* See if filename is an MVS PDS name.  If so, isolate member name    */
PARSE VAR _filename _dsname '(' _member ')'
/* If dataset is a PDS, add trailing paren to terminate member name   */
IF _member <> '' THEN _filename = _filename')'

IF _leavealloc = '' THEN _leavealloc = 'NO' /* Default LEAVEALLOC(NO) */
IF WORDPOS(_leavealloc,'YES NO') = 0
THEN RETURN 'Invalid LEAVEALLOC() parm value'
IF _leaveopen = '' THEN _leaveopen = 'NO'   /* Default LEAVEOPEN(NO)  */
IF WORDPOS(_leaveopen,'YES NO') = 0
THEN RETURN 'Invalid LEAVEOPEN() parm value'
IF _leaveopen = 'YES' THEN _leavealloc = 'YES' /* Set LEAVEALLOC()    */
IF _mode = '' THEN _mode = 'REPLACE'        /* Default MODE(REPLACE)  */
IF WORDPOS(_mode,'REPLACE APPEND') = 0
THEN RETURN 'Invalid MODE() parm value'
IF _stem = '' THEN _stem = 'line.'          /* Default STEM(LINE.)    */
IF RIGHT(_stem,1) <> '.' THEN _stem = _stem'.'
IF SYMBOL(_stem'0') <> 'VAR'
THEN RETURN 'INVALID STEM() parm value, '_stem'0 not numeric'
IF _tokenvar = '' THEN
  IF _leaveopen = 'YES' | _leavealloc = 'YES'
  THEN RETURN 'Missing TOKENVAR() parm, required if LEAVEALLOC(YES) or',
              'LEAVEOPEN(YES) specified'
CALL IOSUBS_GETTOKEN                    /* Initialize _status         */
_ddnm = _ddname                         /* Copy DDNAME() parm value   */
IF _ddname = '' THEN                    /* DDNAME(xx) passed or saved?*/
  IF _tokenvar <> ''                    /* No. Was token passed?      */
  THEN _ddnm = LEFT(_tokenvar,8)        /*  Yes, use as DDNAME        */
  ELSE _ddnm = 'IOWR'RANDOM(9999)       /*  No, Generate random DDNAME*/
IF _use = '' THEN _use = 'EXCL'             /* Default USE(EXCL)      */
IF WORDPOS(_use,'SHR EXCL') = 0
THEN RETURN 'Invalid USE() parm value'
_iowrite_rc = 0                        /* Initialize return code      */
/*--------------------------------------------------------------------*/
/* P C - B A S E D  R E X X   S E G M E N T  (O S / 2,  D O S,  E T C)*/
/*--------------------------------------------------------------------*/
IF WORDPOS(RIGHT(GETENV(),3),'OS2 DOS WNT W95 ONT') = 0
THEN SIGNAL IOWRITE_NOTOS2
IF SYMBOL('_SysFileDelete') <> 'VAR' THEN  /* Is utility registered?  */
  DO                                   /* No.  See if we need it.     */
  IF WORDPOS(RIGHT(GETENV(),3),'OS2 WNT W95') <> 0
  THEN INTERPRET "CALL RxFuncAdd",
                 "'SysFileDelete','RexxUtil','SysFileDelete'"
  _SysFileDelete = 1
  END
IF _status = 'OPEN'                    /* Was file left open?         */
THEN SIGNAL IOREAD_OS2_WRITEIT         /* Yes, start writing it.      */
IF _mode = 'REPLACE' THEN                        /* Replace mode?     */
  IF STREAM(_filename,'C','QUERY EXISTS')<>'' THEN /* Does file exist?*/
    DO
    IF RIGHT(GETENV(),3) = 'ONT'
    THEN ADDRESS CMD "del "_filename   /* Delete file to clear (AP/NT)*/
    IF WORDPOS(RIGHT(GETENV(),3),'OS2 WNT W95') <> 0
    THEN INTERPRET "rc=SysFileDelete(_filename)" /* Delete file to clr*/
    IF RIGHT(GETENV(),3) = 'DOS'
    THEN INTERPRET "rc=RXDELETE(_filename)"      /* Delete file to clr*/
    IF rc > 3 THEN RETURN 'SysFileDelete/RXDELETE error rc='rc
    END
_o = STREAM(_filename,'C','OPEN WRITE')
IF _o = 'NOTREADY:32'                  /* File in use by another pgm? */
THEN RETURN 'File in use'              /* Yes, return error text      */
IF ABBREV(_o,'READY') <> 1             /* Is file ready?              */
THEN RETURN 'File not ready:'_o        /* No, return error text       */
IF _mode = 'APPEND' THEN               /* Are we in append mode?      */
  IF STREAM(_filename,'C','QUERY SIZE')>0 THEN /* Any data in file?   */
    DO
    PARSE VERSION _iov1 .
    IF _iov1 = 'OBJREXX' THEN
      DO                               /* Use OPEN APPEND if available*/
      CALL STREAM _filename,'C','CLOSE'
      CALL STREAM _filename,'C','OPEN APPEND'
      END
    ELSE CALL STREAM _filename,'C','SEEK <0' /* Yes, seek to end      */
    END
IOREAD_OS2_WRITEIT:
  DO _i = 1 TO VALUE(_stem'0')
  rc = LINEOUT(_filename, VALUE(_stem''_i))
  IF rc > 0
  THEN RETURN 'Error 'rc           /* I/O failed, return w/error      */
  END
IF _leaveopen <> 'YES' THEN            /* Are we to leave file open?  */
  DO
  CALL STREAM _dsname,'C','CLOSE'      /* No, close the file          */
  CALL IOSUBS_PUTTOKEN ''              /*  and clean out the token.   */
  END
ELSE                                   /* If we are leaving file open,*/
  CALL IOSUBS_PUTTOKEN 'STATUS(OPEN)'  /*  add STATUS(OPEN) to token. */
DROP _status _tokenvar _t1 _t2 _dsname _leaveopen _stem _i _records,
     _data _filename _o _leavealloc _leaveopen _stem _use
RETURN _iowrite_rc
IOWRITE_NOTOS2:
/*--------------------------------------------------------------------*/
/* I S P F   c o d e   s e g m e n t   f o r   I O W R I T E.         */
/*--------------------------------------------------------------------*/
IF ISPFLMF() <> 'YES' THEN SIGNAL IOWRITE_NOTISPF
ADDRESS ISPEXEC 'CONTROL ERRORS RETURN'
DROP ZDATAIDZ
IF _status = 'OPEN'                    /* Was file left open?         */
THEN SIGNAL IOWRITE_ISPF_NOAPPEND      /* Yes, resume writing it      */

IF SYMBOL('ZDATAIDZ') = 'LIT' THEN
  DO
  _disp = _use
  IF _use = 'EXCL' THEN _disp = 'EXCLU'
  ok = '8'
  IF _ddname <> ''                     /* Was DDNAME() passed in?     */
  THEN ADDRESS ISPEXEC 'LMINIT DATAID(ZDATAIDZ) DDNAME('_ddname')'
  ELSE ADDRESS ISPEXEC 'LMINIT DATAID(ZDATAIDZ) ENQ('_disp')',
                       "DATASET('"_dsname"')"
  IF rc > 0 THEN RETURN STRIP(ZERRSM)
  /* Save value of dataid for future calls                            */
  CALL IOSUBS_PUTTOKEN 'DATAID('VALUE(ZDATAIDZ)') '
  END
/* Extract information about the dataset that we are writing...       */
ok = 4                             /* rc=4 if some vars are blank     */
ADDRESS ISPEXEC 'LMQUERY DATAID('zdataidz') LRECL(ZLRECLZ)',
  'OPEN(ZOPENZ) DSORG(ZDSORGZ)'
IF rc > 4 THEN RETURN STRIP(zerrsm)
/* Experience shows that ZOPENZ isn't valid for new members...        */
IF SYMBOL('ZOPENZ') <> 'VAR'           /* Do we have open status?     */
THEN ZOPENZ = ''                       /* No, must be closed.         */
IF ZOPENZ = 'INPUT' THEN               /* File left open for input?   */
  DO                                   /* Yes, close it before reopen */
  ADDRESS ISPEXEC 'LMCLOSE DATAID('ZDATAIDZ')'
  ZOPENZ = ''                          /* Indicate file not open      */
  END
IF ZOPENZ = '' THEN                    /* File needs opened?          */
  DO
  ADDRESS ISPEXEC 'LMOPEN DATAID('ZDATAIDZ') OPTION(OUTPUT)',
                  'LRECL(ZLRECLZ)'
  IF rc > 0 THEN RETURN 'LMOPEN FAILED'
  IF _mode <> 'APPEND'              /* Are we in append mode?         */
  THEN SIGNAL IOWRITE_ISPF_NOAPPEND /* No, skip around append code.   */
  ok = '8'                          /* Get temporary dataid           */
  ADDRESS ISPEXEC 'LMINIT DATAID(ZTEMPIDZ) ENQ(SHR)',
                  "DATASET('"_dsname"')"
  IF rc > 0 THEN RETURN STRIP(ZERRSM)
  ADDRESS ISPEXEC 'LMOPEN DATAID('ZTEMPIDZ') OPTION(INPUT)'
  IF rc > 0 THEN RETURN STRIP(ZERRLM)
  _done = 0
  IF _member <> '' THEN
    DO
    OK='8 12';ADDRESS ISPEXEC 'LMMFIND DATAID('ZTEMPIDZ')',
                              'MEMBER('_member')',
                              'STATS(YES)'; DROP OK
    IF rc >= 8
    THEN _done = 1
    END

    DO _i = 1 BY 1 WHILE _done=0   /* Read each record from the file  */
    ok = 8
    ADDRESS ISPEXEC 'LMGET DATAID('ZTEMPIDZ') MODE(INVAR)',
                    'DATALOC(ZDATAZ)',
                    'DATALEN(ZDATALNZ) MAXLEN('ZLRECLZ')'
    IF rc = 8 THEN LEAVE           /* End of file...                  */
    ok = 0
    ADDRESS ISPEXEC 'LMPUT DATAID('ZDATAIDZ') MODE(INVAR)',
                    'DATALOC(ZDATAZ) DATALEN('ZLRECLZ')'
    END _i /* DO _i = 1 BY 1  */
  ADDRESS ISPEXEC 'LMCLOSE DATAID('ZTEMPIDZ')'
  ADDRESS ISPEXEC 'LMFREE  DATAID('ZTEMPIDZ')'
  END
IOWRITE_ISPF_NOAPPEND:

  DO _i = 1 TO VALUE(_stem'0')     /* Loop thru each record to write  */
  ZDATAZ = VALUE(_stem''_i)
  ADDRESS ISPEXEC 'LMPUT DATAID('ZDATAIDZ') MODE(INVAR)',
                  'DATALOC(ZDATAZ) DATALEN('ZLRECLZ')'
  END _i /* _i = 1 TO VALUE(_stem'0') */
IF _leaveopen <> 'YES' THEN      /* Are we to leave file open?        */
  DO                             /* No, write it,  close it, exit     */
  IF _member <> '' THEN
    DO
    IF SYMBOL('zlvers')  = 'LIT' THEN zlvers  = ''  /* Init stats if  */
    IF SYMBOL('zlmod')   = 'LIT' THEN zlmod   = ''  /*  not read in   */
    IF SYMBOL('zlcdate') = 'LIT' THEN zlcdate = ''  /*   from the     */
    IF SYMBOL('zlmsec')  = 'LIT' THEN zlmsec  = ''  /*    TOKENVAR()  */
    IF SYMBOL('zlinorc') = 'LIT' THEN zlinorc = ''
    zlmdate = DATE("O")              /* Last changed date             */
    zlmtime = SUBSTR(TIME("N"),1,5)  /* Last changed time             */
    IF RIGHT(GETENV(),3) = 'TSO'
    THEN INTERPRET "zluser = SYSVAR('SYSUID')"
    IF POS(GETENV(),'OPSREXX') > 0
    THEN zluser = OPSINFO('JOBNAME')
    zlmnorc = 1                      /* Dummy number of changed recs  */
    zlcnorc = MIN(VALUE(_stem'0'),65535)   /* Current or max # records*/
    IF zlinorc = '' THEN zlinorc = zlcnorc /* Set initial size        */
    IF zlvers  = '' THEN zlvers = 1  /* Set initial version           */
    IF zlmod   = ''
    THEN zlmod = 0                   /* Set initial change level      */
    ELSE
      IF zlmod < 99
      THEN zlmod = zlmod + 1         /* Increment chanage level       */
    IF zlcdate = '' THEN zlcdate = zlmdate /* Set creation date       */
    /*----------------------------------------------------------------*/
    /* Replace or create the desired member...                        */
    /*----------------------------------------------------------------*/
    OK='8 12'
    ADDRESS ISPEXEC 'LMMREP DATAID('ZDATAIDZ') MEMBER('_member')',
                    'STATS(YES)'; DROP OK
    IF rc > 8 THEN
      IF SYMBOL('ZERRSM') = 'VAR'
      THEN _iowrite_rc = STRIP(ZERRSM)
      ELSE _iowrite_rc = 'LMMREP FAILED'
    END /* IF _member <> '' THEN */
  ADDRESS ISPEXEC 'LMCLOSE DATAID('ZDATAIDZ')'
  CALL IOSUBS_PUTTOKEN 'STATUS(ALLOC)' /* Downgrade to STATUS(ALLOC)  */
  END
ELSE                             /* LEAVEOPEN(YES)                    */
  CALL IOSUBS_PUTTOKEN 'STATUS(OPEN)'  /* Set STATUS(OPEN)            */
IF _leavealloc <> 'YES' THEN
  DO
  ADDRESS ISPEXEC 'LMFREE  DATAID('ZDATAIDZ')'
  CALL IOSUBS_PUTTOKEN ''              /* Clear out the TOKENVAR()    */
  END
DROP _status _tokenvar _t1 _t2 _dsname _leaveopen _stem _i _records,
     _data _filename _o _leavealloc _leaveopen _stem _use zdataidz,
     _tokenvar _tempid
RETURN _iowrite_rc
IOWRITE_NOTISPF:
/*--------------------------------------------------------------------*/
/* T S O   c o d e   s e g m e n t   f o r   I O W R I T E.           */
/*--------------------------------------------------------------------*/
IF RIGHT(GETENV(),3) <> 'TSO' & POS(GETENV(),'OPSREXX') = 0
THEN SIGNAL IOWRITE_NOTTSO

IF WORDPOS(_status,'ALLOC OPEN') > 0   /* File already allocated?     */
THEN SIGNAL IOWRITE_TSO_ALLOCD         /* Yes, skip validation.       */
IF _ddname <> '' THEN                  /* Was DDNAME() passed in?     */
  DO                                   /* Yes.  Is it allocated?      */
  IF RIGHT(GETENV(),3) = 'TSO' THEN    /* Running in TSO/E?           */
    DO                                 /* Use TSO/E LISTDSI() function*/
    INTERPRET "rc = LISTDSI('"_ddname" FILE NODIRECTORY NORECALL')"
    IF rc > 4
    THEN RETURN LISTDSIREASON(sysreason)
    END
  IF POS(GETENV(),'OPSREXX') > 0 THEN
    IF LEFT(OPSINFO('VERSION'),5) >= '04.01' THEN
      INTERPRET "IF OPSDD2DS(_ddname) = ''",
                "THEN RETURN 'DDNAME('_ddname') not allocated'"
    ELSE
      DO
      CALL OPSCLEDQ
      ok = '12'
      ADDRESS TSO "LISTALC STATUS"
      _ddfound = 0
      _search4 = '  'LEFT(_ddname,8,' ')' '
        DO WHILE QUEUED() > 0
        PARSE UPPER PULL (_search4) _msg
        IF _msg <> '' THEN _ddfound = 1
        END
      IF _ddfound <> 1
      THEN RETURN 'DDNAME('_ddname') not allocated'
      END
  SIGNAL IOWRITE_TSO_ALLOCD             /* Start writing it...        */
  END
_disp = _use
IF _use = 'EXCL' THEN _disp = 'OLD'
IF RIGHT(GETENV(),3) = 'TSO' THEN      /* Running in TSO/E?           */
  DO                                   /* Use TSO/E SYSDSN() function */
  INTERPRET "_msg_status=MSG('OFF')"/*Interpret to hide from OPS/REXX */
  INTERPRET "rc = SYSDSN('''"_filename"''')"
  IF rc <> 'OK' THEN
    IF rc = 'UNAVAILABLE DATASET' THEN RETURN 'File in use'
    ELSE
      IF rc = 'MEMBER NOT FOUND'   /* Don't care if not found on write*/
      THEN NOP
      ELSE RETURN rc
  INTERPRET "_savtrap = OUTTRAP()" /* Is outtrap active?              */
  IF _savtrap = 'OFF'
  THEN _savtrap = "x = OUTTRAP('OFF')"/*No, build outtrap shutoff cmd */
  ELSE
    DO
    INTERPRET "_symbol = SYMBOL('"_savtrap"MAX')"
    IF _symbol = 'VAR'             /* Active, but restore data avail  */
    THEN _savtrap = "x=OUTTRAP("_savtrap","_savtrap"MAX,"_savtrap"CON)"
    ELSE
      DO                           /* Outtrap restore data not exposed*/
      RETURN 'IOWRITE error: OUTTRAP() Active and cannot be used'
      END
    END

  INTERPRET "x = OUTTRAP('_outtrap.','*','NOCONCAT')"
  INTERPRET "CALL MSG('ON')"
  ok = '12'
  ADDRESS TSO "ALLOC FILE("_ddnm") DSNAME('"_filename"')",
    "REUSE "_disp
  END
IF POS(GETENV(),'OPSREXX') > 0 THEN
  DO
  IF LEFT(OPSINFO('VERSION'),5) >= '04.01' THEN
    DO
    INTERPRET "rc = OPSSVC99('ALLOC',_ddnm,_filename,_disp)"
    IF rc <> 0 THEN
      DO; _ioread_rc = 'Allocate failed'; SIGNAL IOREAD_TSO_EXIT; END
    END
  ELSE
    DO
    CALL OPSCLEDQ
    ok = '12'
    ADDRESS TSO "ALLOC FILE("_ddnm") DSNAME('"_filename"')",
      "REUSE "_disp
      DO _i = 1 BY 1 WHILE QUEUED() > 0
      PARSE UPPER PULL _msg
      _outtrap._i = _msg
      END
    _outtrap.0 = _i-1
    END
  END
IF rc <> 0 THEN
  DO
  _i = _outtrap.0
  _iowrite_rc = _outtrap._i
  IF _iowrite_rc = 'DATA SET IS ALLOCATED TO ANOTHER JOB OR USER'
  THEN _iowrite_rc = 'File in use'
  IF _i = 0
  THEN _iowrite_rc = 'Allocate failed'
  SIGNAL IOWRITE_TSO_EXIT
  END
IOWRITE_TSO_ALLOCD:
IF _mode = 'APPEND' THEN
  DO
  ADDRESS TSO 'EXECIO * DISKRU '_ddnm,
    ' (FINIS STEM _TEMP.)'
  ADDRESS TSO 'EXECIO * DISKW '_ddnm,
    ' (OPEN STEM _TEMP.)'
  END
_options = ''
IF _leaveopen <> 'YES' THEN _options = _options'FINIS '
ADDRESS TSO 'EXECIO 'VALUE(_stem'0')' DISKW '_ddnm,
  ' ('_options' STEM '_stem')'

IF _leavealloc <> 'YES' THEN
  DO
  IF POS(GETENV(),'OPSREXX') > 0 THEN
    IF LEFT(OPSINFO('VERSION'),5) >= '04.01'
    THEN INTERPRET "CALL OPSSVC99 'FREE',_ddnm"
    ELSE ADDRESS TSO 'FREE FILE('_ddnm')'
  ELSE ADDRESS TSO 'FREE FILE('_ddnm')'
  CALL IOSUBS_PUTTOKEN ''              /* Clear out the TOKENVAR      */
  END
ELSE                                   /* If leaving file allocated,  */
  IF _leaveopen = 'YES'
  THEN
    DO
    CALL IOSUBS_PUTTOKEN 'DDNAME('_ddnm')'
    CALL IOSUBS_PUTTOKEN 'STATUS(OPEN)'
    END
  ELSE
    DO
    CALL IOSUBS_PUTTOKEN 'DDNAME('_ddnm')'
    CALL IOSUBS_PUTTOKEN 'STATUS(ALLOC)'
    END
IOWRITE_TSO_EXIT:
IF SYMBOL('_savtrap') = 'VAR'
THEN INTERPRET _savtrap            /* Restore caller's OUTTRAP status */
IF SYMBOL('_msg_status') = 'VAR'
THEN INTERPRET "CALL MSG _msg_status" /* Restore caller's MSG() status*/
DROP _msg_status _savtrap _tokenvar _tempid
RETURN _iowrite_rc
IOWRITE_NOTTSO:
/*--------------------------------------------------------------------*/
/* N E T V I E W   c o d e   s e g m e n t   f o r   I O W R I T E.   */
/*--------------------------------------------------------------------*/
IF GETENV() <> 'NETVMVS'
THEN SIGNAL IOWRITE_NOTNETV
IF WORDPOS(_status,'ALLOC OPEN') > 0   /* File already allocated?     */
THEN SIGNAL IOWRITE_NETV_ALLOCD        /* Yes, skip validation.       */
IF _ddname <> '' THEN                  /* DDNAME passed, is it ALLOCd?*/
  DO
  /*------------------------------------------------------------------*/
  /* CNM271I FOOBAR DD STATEMENT MISSING                              */
  /* -or-                                                             */
  /* CNM299I                                                          */
  /* DDNAME   DATA SET NAME                                       DISP*/
  /* -------- --------------------------------------------------- --- */
  /* DSIPARM  DC2P.NETVIEW.V3R1.NETOG.DSIPARM                     SHR */
  /*------------------------------------------------------------------*/
  ADDRESS NETVIEW 'PIPE NETVIEW LISTA '_ddname,
    ' | SEPARATE ',                /* Convert multi-line to single    */
    ' | STEM _ioreadout.'          /* Place results into global vars  */
  IF ABBREV(_ioreadout.1,'CNM271I') = 1 THEN
    RETURN 'DDNAME('_ddname') not allocated'
  IF ABBREV(_ioreadout.1,'CNM299I') <> 1 THEN
    RETURN 'DDNAME('_ddname') not allocated'
  SIGNAL IOWRITE_NETV_ALLOCD       /* Start writing it...             */
  END
_disp = _use
IF _use = 'EXCL' THEN _disp = 'OLD'
/*--------------------------------------------------------------------*/
/* CNM272I TEST IS NOW ALLOCATED                                      */
/* DSI370I ALLOCATE COMMAND FAILED, 'TEST' IS ALREADY IN USE          */
/* CNM277I DATA SET DKZB2CC.FLA NOT FOUND                             */
/* CNM278I DATA SET DKZB2CC.CLIST UNAVAILABLE                         */
/*--------------------------------------------------------------------*/
  DO _iowritei = 1 TO 2
  'PIPE NETVIEW ALLOC FILE('_ddnm') DS('_filename') '_disp,
    ' | SEPARATE ',                /* Convert multi-line to single    */
    ' | STEM _iowriteout.'         /* Place results into global vars  */
  IF ABBREV(_iowriteout.1,'DSI370I') <> 1 THEN LEAVE _iowritei
  IF _iowritei = 1 THEN
    DO
    ADDRESS NETVIEW 'PIPE NETVIEW FREE FILE('_ddnm')'
    ITERATE _iowritei
    END
  _iowrite_rc = 'Unable to REUSE File('_ddnm')'
  SIGNAL IOWRITE_NETV_EXIT
  END _iowritei

_i = _iowriteout.0               /* -> last line of ALLOC output    */
  SELECT
  WHEN ABBREV(_iowriteout._i,'CNM272I') = 1 THEN
    SIGNAL IOWRITE_NETV_ALLOCD
  WHEN ABBREV(_iowriteout._i,'CNM278I') = 1 THEN
    _iowrite_rc = 'File in use'
  WHEN _i = 0 THEN
    _iowrite_rc = 'Allocate failed'
  OTHERWISE
    _iowrite_rc = SUBWORD(_iowriteout._i,2)  /* Get 2nd-nth word    */
  END
SIGNAL IOWRITE_NETV_EXIT

IOWRITE_NETV_ALLOCD:
IF _mode = 'APPEND' THEN
  DO
  ADDRESS MVS 'EXECIO * DISKRU '_ddnm,
    ' (FINIS STEM _TEMP.)'
  ADDRESS MVS 'EXECIO * DISKW '_ddnm,
    ' (OPEN STEM _TEMP.)'
  END
_options = ''
IF _leaveopen <> 'YES' THEN _options = _options'FINIS '
ADDRESS MVS 'EXECIO 'VALUE(_stem'0')' DISKW '_ddnm,
  ' ('_options' STEM '_stem')'

IF _leavealloc <> 'YES' THEN
  DO
  ADDRESS NETVIEW 'PIPE NETVIEW FREE FILE('_ddnm')'
  CALL IOSUBS_PUTTOKEN ''              /* Clean out the TOKENVAR      */
  END
ELSE                                   /* If leaving file allocated,  */
  IF _leaveopen = 'YES'
  THEN
    DO
    CALL IOSUBS_PUTTOKEN 'DDNAME('_ddnm')'
    CALL IOSUBS_PUTTOKEN 'STATUS(OPEN)'
    END
  ELSE
    DO
    CALL IOSUBS_PUTTOKEN 'DDNAME('_ddnm')'
    CALL IOSUBS_PUTTOKEN 'STATUS(ALLOC)'
    END
IOWRITE_NETV_EXIT:
IF SYMBOL('_savtrap') = 'VAR'
THEN INTERPRET _savtrap            /* Restore caller's OUTTRAP status */
IF SYMBOL('_msg_status') = 'VAR'
THEN INTERPRET "CALL MSG _msg_status" /* Restore caller's MSG() status*/
DROP _msg_status _savtrap _tokenvar _tempid
RETURN _iowrite_rc
IOWRITE_NOTNETV:
RETURN 'Unsupported environment 'GETENV()

/*-Start of IOSUBS_GETTOKEN Subroutine--------------------------------*/
/*:IOSUBS_GETTOKEN Subroutine: Extracts variables from the            */
/* caller-provided TOKENVAR(xx) parm).  Things in the token are:      */
/* STATUS(OPEN | ALLOC)  DDNAME(DDNAME)  DATAID(xxxx)    ZLVERS()     */
/* ZLMOD()   ZLCDATE()   ZLMDATE()       ZLMTIME()       ZLMSEC()     */
/* ZLCNORC() ZLINORC()   ZLMNORC()       ZLUSER()                     */
/*--------------------------------------------------------------------*/
IOSUBS_GETTOKEN:
TRACE N
_status = ''                           /* Initialize _status          */
IF _tokenvar <> '' THEN                /* Was token passed?           */
  IF SYMBOL(_tokenvar) <> 'LIT' THEN   /* Anything stored in token?   */
    DO                                 /* Yes, extract existing data  */
    _tokens = VALUE(_tokenvar)
      DO WHILE _tokens <> ''
      PARSE VAR _tokens _tokenkw '(' _tokenvalue ')' _tokens
      IF WORDPOS(_tokenkw,'STATUS DATAID DDNAME') > 0
      THEN _tokenkw = WORD('_STATUS ZDATAIDZ _DDNM',,
          WORDPOS(_tokenkw,'STATUS  DATAID DDNAME'))
      CALL VALUE _tokenkw,_tokenvalue
      END
    IF SYMBOL('ZDATAIDZ') <> 'LIT' THEN /* Does dataid exist?         */
      IF ZDATAIDZ = ''                  /* Is dataid valid?           */
      THEN DROP ZDATAIDZ                /* No, drop it like hot potato*/
    END
DROP _tokens _tokenkw _tokenvalue
RETURN

/*-Start of IOSUBS_PUTTOKEN Subroutine--------------------------------*/
/*:IOSUBS_PUTTOKEN Subroutine: Stores information in the              */
/* caller-provided TOKENVAR(xx) variable.                             */
/* CALL IOSUBS_PUTTOKEN 'STATUS(OPEN)'  Change STATUS() to OPEN       */
/* CALL IOSUBS_PUTTOKEN 'STATUS()'      Remove STATUS() keyword       */
/* CALL IOSUBS_PUTTOKEN ''              Remove ALL keywords.          */
/*--------------------------------------------------------------------*/
IOSUBS_PUTTOKEN:
TRACE N
PARSE UPPER ARG _tokenkw '(' _tokenvalue ')' _tokenr
IF _tokenr <> '' THEN SAY 'Error: IOSUBS_PUTTOKEN bad args:' ARG(1)
_tokenkw = _tokenkw'('
IF _tokenvar <> '' THEN                /* Was token passed?           */
  DO                                   /* Yes.                        */
  IF SYMBOL(_tokenvar) = 'LIT'         /* Nothing stored in token?   */,
   | _tokenkw = '('                    /*  or request to clear all?   */
  THEN PARSE VALUE '' WITH _tokenl _tokenr
  ELSE PARSE VALUE VALUE(_tokenvar),
    WITH _tokenl (_tokenkw) . ')' _tokenr
  IF _tokenvalue = ''                  /* If null, just remove kw(xx) */
  THEN CALL VALUE _tokenvar,_tokenl''_tokenr
  ELSE CALL VALUE _tokenvar,_tokenl''_tokenkw''_tokenvalue')'_tokenr
  END
DROP _tokenkw _tokenvalue _tokenl _tokenr
RETURN

/*-Start of LISTDSIREASON subroutine----------------------------------*/
/*:LISTDSIREASON function: Returns english text equivalent to a       */
/* SYSREASON return code returned by the LISTDSI() function.          */
/*--------------------------------------------------------------------*/
LISTDSIREASON: PROCEDURE
TRACE N
txt.1  = 'Error parsing the function'
txt.2  = 'Dynamic Allocation processing error'
txt.3  = 'Dataset type cannot be processed'
txt.4  = 'Error determining UNIT name'
txt.5  = 'Dataset not catalogued'
txt.6  = 'Error obtaining dataset name'
txt.7  = 'Error finding device type'
txt.8  = 'Dataset not on DASD'
txt.9  = 'Dataset migrated'
txt.11 = 'Read access denied'
txt.12 = 'VSAM dataset, unsupported'
txt.13 = 'Dataset could not be opened'
txt.14 = 'Device type not found in UCB'
txt.17 = 'Abend occurred'
txt.18 = 'Partial information obtained'
txt.19 = 'Multi-volume dataset'
txt.20 = 'Device type not found in EDT'
txt.21 = 'Catalog error'
txt.22 = 'Volume not mounted'
txt.23 = 'I/O error'
txt.24 = 'Dataset not found'
txt.25 = 'Dataset migrated off of DASD'
txt.27 = 'Dataset has no VOLSER'
txt.28 = 'Invalid DDNAME'
txt.29 = 'Missing DSNAME or DDNAME'
i = STRIP(ARG(1),'LEADING',0)
IF SYMBOL('txt.'i) = 'VAR'
THEN RETURN txt.i
RETURN ''
/*-End of IOSUBS   routines-------------------------------------------*/

/*RXCOPY GETENV NODUP 0 LINES COPIED ON 09-19-03 AT 11:08**************/

/*RXCOPY ISPFLMF NODUP 29 LINES COPIED ON 09-19-03 AT 11:08************/
/*-Start of ISPFLMF  function---------------------------Version-01.04-*/
/*:ISPFLMF Subroutine: Determines if ISPF Library Mgmt is available.  */
/* Returns: YES or NO                                                 */
/* Copyright (C) 1996,2003 ProTech. All rights reserved.              */
/*--------------------------------------------------------------------*/
ISPFLMF: PROCEDURE EXPOSE ispflmf_save the_environment gbl.
TRACE N                            /* Turn off rexx tracing           */
IF SYMBOL('ispflmf_save')='VAR'    /* If we were already called,      */
THEN RETURN ispflmf_save           /* then just return the same answer*/
ispflmf_save = 'NO'                /* Assume LMF not available        */
IF POS(GETENV(),'ATMTSO OPSTSO MVSTSO ATMREXX OPSREXX REQRULE') = 0
THEN SIGNAL ISPFLMF_EXIT
PARSE SOURCE . . . . . . . _ex_addrspc .
IF _ex_addrspc = 'ISPF' THEN SIGNAL ISPFLMF_YES
IF _ex_addrspc <> '' THEN SIGNAL ISPFLMF_EXIT /* Null in OPS/REXX     */
IF GETENV() = 'OPSREXX' THEN
  IF LEFT(OPSINFO('VERSION'),5) >= '04.02' THEN
    INTERPRET "IF OPSINFO('ISPF')='ACTIVE' THEN SIGNAL ISPFLMF_YES;",
              "ELSE SIGNAL ISPFLMF_EXIT"
ok='all';
ADDRESS ISPEXEC "LMINIT DATAID(DUMMY) DDNAME(DUMMY) ENQ(SHR)"
IF rc <> 8 THEN SIGNAL ISPFLMF_EXIT
ISPFLMF_YES:
ispflmf_save = 'YES'
ISPFLMF_EXIT:
RETURN ispflmf_save
/*-End of ISPFLMF  function-------------------------------------------*/

/*RXCOPY GETENV NODUP 0 LINES COPIED ON 09-19-03 AT 11:08**************/

/*RXCOPY KWPARSE NODUP 0 LINES COPIED ON 09-19-03 AT 11:08*************/

/*RXCOPY RXERROR NODUP 129 LINES COPIED ON 09-19-03 AT 11:08***********/
/*START OF RXERROR--------------------------------------Version-01.07-*/
/*:RXERROR SUBROUTINE: Generic REXX error condition handler. This     */
/* routine gets control when a condition is raised, and:              */
/* a. Validates that the condition is ok, and returns quietly, or     */
/* b. Issues diagnostic messages about the error & where it occured.  */
/*                                                                    */
/* To use this routine, code the following near the top of your exec: */
/* CALL   ON ERROR   NAME RXERROR                                     */
/* SIGNAL ON SYNTAX  NAME RXERROR                                     */
/* SIGNAL ON NOVALUE NAME RXERROR                                     */
/*                                                                    */
/* In addition, set the variable 'ok' to any return code values       */
/* that are acceptable for host commands.  For example:               */
/*                                                                    */
/* ok=4; ADDRESS TSO 'GETVARL GLOBAL_*'; DROP ok                      */
/* ok='4 8';"host cmd"; DROP ok <-- return codes 4 or 8 are ok        */
/* ok='all';"host cmd"; DROP ok <-- all return codes are acceptable   */
/*                                                                    */
/* The first example permits GETVARL to get rc 4 and not fail or      */
/* issue any error messages.  Note that "ok=0" is always implied      */
/* because the REXX ERROR condition is not raised if rc=0.            */
/*------------------------------------------------------------------- */
/*NOTES: This subroutine does not use the PROCEDURE instruction, so   */
/*       variable names used within it must be _hidden.               */
/*                                                                    */
/*       If an error occurs that's not one of the 'OK' values,        */
/*       execution will fall thru this subroutine and any statements  */
/*       following it will be executed.  This is a good place to put  */
/*       cleanup logic, or a signal to your "cleanup-and-exit" label. */
/*                                                                    */
/*       Variables _RXERRORMSG1 and _RXERRORMSG2 are created when     */
/*       RXERROR falls thru, and may be used to send error msgs to    */
/*       other destinations, such as a GUI MSGBOX or ADDRESS AXC WTXC.*/
/*                                                                    */
/*       As a side effect, RXERROR sets ISPF "CONTROL ERRORS RETURN". */
/*       If your routine doesn't run this way, you'll need to restore */
/*       your ISPF CONTROL ERRORS setting.                            */
/* Copyright (C) 1996,2003 ProTech. All rights reserved.              */
/*--------------------------------------------------------------------*/

RXERROR: TRACE N                  /* Turn off tracing for this func.  */
_sigl = sigl
RXERROR1: TRACE N                 /* Turn off tracing for this func.  */
CALL   OFF ERROR
SIGNAL OFF SYNTAX
IF SYMBOL('rc') = 'VAR' THEN _rc = rc
ELSE _rc = 'n/a'
PARSE SOURCE _EX_ENV . _EX_NAME . . . . _EX_ADDRSPC .
IF POS(CONDITION('C'),'ERROR FAILURE') > 0 THEN  /* Error or Failure? */
                                       /* Yes. Were we CALLed?        */
  IF CONDITION('I') = 'CALL' | _EX_ENV = 'OPS/REXX' THEN
    IF SYMBOL('OK') = 'VAR' THEN       /* Yes.  Is OK a variable?     */
      IF WORDPOS(_rc,ok)>0 | TRANSLATE(ok)='ALL' THEN /* Is error ok? */
        DO                                            /* Yes, return  */
        CALL   ON ERROR   NAME RXERROR /*  Restore the                */
        SIGNAL ON SYNTAX  NAME RXERROR /*   Error handler             */
        DROP ZERRLM                    /* Toss any ISPF error msg     */
        rc = _rc                       /* Restore orig RC for caller  */
        RETURN                         /* Return to point of error    */
        END
IF SYMBOL('_errtext') = 'LIT'
THEN _errtext = '';                /* Initialize error text           */
IF CONDITION('C') = 'SYNTAX' THEN  /* If a REXX syntax error,         */
  IF _rc >= 0 & _rc < 100          /*  and rc is within valid range,  */
  THEN _errtext = ' ('ERRORTEXT(_rc)')';/* then get REXX error text.  */
  ELSE NOP;
ELSE
  IF CONDITION('C') = 'NOVALUE' THEN /* See if undefined variable     */
    DO;
    _errtext = ' (No value for variable 'CONDITION('D')')';
    _rc = 'n/a';                   /* RC not set for NOVALUE          */
    END
  ELSE
    IF POS(CONDITION('C'),'ERROR FAILURE') > 0 THEN /*Hostcmd problem?*/
      DO   /* Extract host cmd name... */
      _cmd = STRIP(STRIP(WORD(CONDITION('D'),1),'B','"'),'B',"'")
      _errtext = ' (Host command '_cmd')'
      _addr = ADDRESS()            /* Find environment of failing cmd */
      IF _sigl <= SOURCELINE() THEN/* Is source code avail?           */
        IF TRANSLATE(WORD(SOURCELINE(_sigl),1)) = 'ADDRESS'
        THEN _addr = TRANSLATE(WORD(SOURCELINE(_sigl),2))
      _addr = STRIP(TRANSLATE(_addr,,'!@#$%&*()_-+=;:,./?"'"'",' '))
      IF _addr = 'PPQ' & SYMBOL('PPQ.ERROR') = 'VAR'
      THEN _errtext = ' (Host command PPQ, 'ppq.error')'
      IF _addr = 'VOX' & SYMBOL('VOX.ERROR') = 'VAR'
      THEN _errtext = ' (Host command VOX, 'vox.error')'
      IF _addr = 'ASODDE' | SYMBOL('ASODDE.ERROR') = 'VAR'
      THEN _errtext = ' (Host command ASODDE, 'asodde.error')'
      IF SYMBOL('SQLCODE') = 'VAR'
      THEN _errtext = ' ( SQLCODE=' sqlcode')'
      END
    ELSE IF CONDITION('C') <> '' THEN
      _errtext = ' (Condition='CONDITION('C')', Description=',
        CONDITION('D')')'

_rxerrormsg1 = "RXERROR Error RC "_rc""_errtext" at line "_sigl,
               "in EXEC" _ex_name
IF _sigl <= SOURCELINE()           /* Is source code avail?           */
THEN _rxerrormsg2 = "RXERROR Line "_sigl": "STRIP(SOURCELINE(_sigl))
ELSE _rxerrormsg2 = ""

IF _ex_addrspc = 'ISPF' THEN       /* Running under ISPF?             */
  DO                               /* Yes, issue short & long msgs... */
  ADDRESS ISPEXEC "CONTROL ERRORS RETURN" /* Capture all ISPF RCs     */
  zedsmsg = ''                     /* Format ISPF short message       */
  zedlmsg = "Error RC "_rc""_errtext" at line "_sigl" in EXEC" _ex_name
  IF _sigl <= SOURCELINE()         /* Is source code avail?           */
  THEN zedlmsg = LEFT(zedlmsg': ',78)STRIP(SOURCELINE(_sigl))
  IF SYMBOL('ZERRLM') = 'VAR'
  THEN zedlmsg = LEFT(zedlmsg,156) 'ISPF Error: 'STRIP(ZERRLM)
  ADDRESS ISPEXEC "SETMSG MSG(ISRZ001)"
  IF rc = 12 THEN                  /* ISPMLIB MESSAGE found?          */
    DO                             /* No, use SAY instead.            */
    SAY 'RXERROR ISPMLIB Message ISRZ001 Not Found'
    SIGNAL _SAY_ERRMSG;
    END
  SIGNAL _SAY_SQLMSG;
  END

_SAY_ERRMSG:
SAY _rxerrormsg1; IF _rxerrormsg2 <> '' THEN SAY _rxerrormsg2; SAY ''
_SAY_SQLMSG:
IF SYMBOL('SQLCODE') = 'VAR' & QUEUED() > 0 THEN
  IF WORDPOS(sqlcode,'0 100') = 0 THEN
    DO _i = 1 BY 1 WHILE QUEUED() > 0
    PULL _stack
    SAY 'SQL STACK:'RIGHT(_i,2)':'_stack
    END
/*END OF RXERROR------------------------------------------------------*/
max_rc = 12
SIGNAL EXIT