/*                                                                   rexx
 Subroutine using dynamic display area and table as data source

 Syntax and parameter description

 XTBDISD parameters
   AREA(name)    Name of the dynamic area in the panel.
   LCLIST(list)  List of line commands to pass to the external proc named
                 by the LCPROC parameter.
   LCPROC(name)  Name of external proc to be called for line commands.
   NBL(list)     LIst of build-in line commands to ignore (negate).
   PANEL(name)   Display panel having dynamic area.
   PAS(text)     Use text as selection for point-and-shoot.
   PCPROC(name)  Name of external proc to be called for primary commands.
   PROC(name)    Name of external proc to be called for both primary and
                 and line commands.
   RETCMD(list)  List of primary command causing return to the caller.
   SFD(text w)   Select field definition. Optional width (w).
   TABLE(name)   Table containing the data to display.
                 The table must contain 3 variables named XTBDSEL, XTBDATTR
                 and XTBDTEXT, for the line selection, attribute and text in
                 the dynamic area. If parameter TXTBLD is not specified, then
                 the XTBDTEXT variable must contain the line defintion incl
                 color codes, but minus the selection field.
   TEXTBLD(text) String defining how the program should build the text line
                 instead of using the XTBDTEXT variable.
                 I.e. TEXTBLD('clr1 || left(dsn,44) || clr2 || status')
                 where all fields are part of the table.
                 Note that the XTBDTEXT variable is still required for FIND,
                 ONLY etc commands.
   VARTBL(name)  Table name containing caller's global variables. Table is
                 TBGETed before and TBPUTed after table display.
   WIDTH(val)    Panel width, default is 80.

 Built-in primary commands
  ALL                     Show all lines.
  Find text (NEXT PREV)   Find text forward (NEXT) or backward (PREV).
                          Default direction is NEXT.
  eXclude text            Leave only lines not containing text.
  Hide text               Leave only lines not containing text.
  Locate text             Position at next line starting with text.
  Only text               Leave only lines with text.
  UNHide text             Show lines previously hidden, containing text.

 History
  2019-12-10  Initial
  2019-12-13  Add point-and-shoot, isolate tbget/tbskip/tbput to avoid
              possible conflict between table- and program variables.
  2019-12-15  Fix problem with rewrite of null lcmd
  2019-12-17  Add shared varibles for # lines, # hidden lines
              New parm NBL - negate builtin linecmds
  2019-12-26  Change 'exit' to 'return', allow to use as internal.
              Add $passtxt parameter.
              Reposition cursor in display when error
  2019-12-27  Block line commands
  2019-12-28  Editorial changes, new required table var XTBDATTR
              Fix point-and-shoot and passtext problem
  2020-01-05  Fix problem with block commands and sorted table.
  2020-01-08  Use table for external variables
  2020-01-15  Add support for caller varariale table (VARTBL)
  2020-01-16  Externalize panel position through var XTBDPPOS
  2020-01-29  Mostly fixing listing position with hidden lines.
              Change the primary cmd call to preserve quotes
  2020-02-05  Chgange pos after SORT and IF, some bug fixes.
  2020-02-05  Fix reposition after successsful Find
  2020-04-15  Redo how cursor is repositioned in screen body
  2020-07-13  New option TEXTBLD. Parm parser changed.
  2020-07-14  Fix block command XX not working.
              Add width option to SFD.

 Author
  Willy Jensen
  Email  willy@harders-jensen.com
  Web    http://harders-jensen.com/wjtech/zprograms.html
*/

 xtbdisdver='2020-07-14.2'
 if translate(arg(1))='VER' then return xtbdisdver
 parse source sys type whoami ddn whereami .
 parse value '' with $table $panel $sfd $sfdw proc $lcproc $pcproc $lclist,
  findsave zverb zscrolln zscrolla zscreenc $pcsrpos $pcursor $retcmd $pas,
  $nbllist $passtxt $textbld $width $vartbl $xlst.
 billist='X'       /* built in line commands */
 bilblst='XX'      /* built in block line commands */
 parse value 0 0 with $chgn $csrpos
 vl='AREA WIDTH TABLE VARTBL SFD PANEL PCPROC LCPROC TEXTBLD',
    'PROC LCLIST LCBLST RETCMD NBL PAS PASSTXT',
    '$lcproc $pcproc'
 Interpret "parse value '' with" vl
 Interpret XtbdXParse(translate(arg(1)),vl,'pfx($)')
 if cc<>0 then return 8 'Parse rc' cc err
 if $proc<>'' & $lcproc $pcproc='' then,
   parse value $proc $proc with $lcproc $pcproc
 if $passtxt<>'' then $passtxt=';'space($passtxt)
 if $sfd    ='' then return XtbdXmsg('$sfd missing',8)
 if $table  ='' then return XtbdXmsg('table name missing',8)
 if $panel  ='' then return XtbdXmsg('panel name missing',8)
 if $area='' then return XtbdXmsg('area name missing',8)

 $infotbl = 'XI'XtbdUnique()
 if words($sfd) = 2 then parse var $sfd $sfd $sfdw .
 if $sfdw<>'' then $sfd=$sfd''left(' ',$sfdw)
 if length($sfd)=1 then $sfd=$sfd' ' /* must be at least one char */
 parse var $sfd sfa +1 sfc
 sfdl=length($sfd)                   /* select field len incl attr */
 sfcl=length(sfc)                    /* select field len   */
 sfc =left(sfc,1)                    /* get 1st field char */

/* setup enviroment       */
 Address ispexec
 "control errors return"
 "tbcreate" $infotbl   "names(xtbdrecn xtbdhidn xtbdppos xtbdlpos xtbdwdth",
            "xtbdblkc xtbduser)"
 parse value 0 0 1 1 80 with  xtbdrecn xtbdhidn xtbdppos xtbdlpos xtbdwdth,
             xtbdblkc xtbduser
 "tbadd" $infotbl
 cc=XTBDDisplay()
 "tbend" $infotbl
 Return cc

/* display */
XTBDDisplay:
 "vget (zscrmaxd zscrmaxw) shared"
 "tbquery" $table "rownum(tblrows)"
 xtbdrecn = tblrows          /* # lines */
 $plvline=0
 $pcsrpos=0
 if $width='' then do
   "pquery panel("$panel") areaname("$area") width($width)"
   if rc<>0 then return XtbdXmsg('query panel('$panel') rc' rc zerrlm,8)
 end
 xtbdwdth=$width
 if rc<>0 then return XtbdXmsg('display panel('$panel') rc' rc zerrlm,8)
 "tbput" $infotbl
 "control nondispl enter"
 "display panel("$panel")"
 "tbget" $infotbl

 $trace=0
 Do $main=1 to 99999 until displaycc<>0
   trace off
   $dynsize=xtbdwdth*$plvline
   "tbget" $infotbl
   if xtbdppos<1 then xtbdppos=1
   "tbput" $infotbl
   drop rowid.
   parse value '0 0 ?' with $chgn rowidn rowid. dynarea
   "tbtop" $table
   rc=XTBDTblJump($table,'number('xtbdppos')',$textbld)

   /* make panel variable */
   lcsr=0
   do while rc=0
     line=''
     Select
       when XTBDATTR='X' then nop
       when XTBDATTR='*' then line=XTBDTEXT
       when XTBDSEL<>'' then line=sfa''left(XTBDSEL,sfcl,sfc)XTBDTEXT
       otherwise line=$sfd''XTBDTEXT
     End
     trace off
     if line<>'' then do
       if zrowid=xtbdlpos then lcsr=length(dynarea)+2
       dynarea=dynarea''left(line,xtbdwdth)
       parse value rowidn+1 zrowid with rowidn rowid.rowidn
     end
     if length(dynarea)>=$dynsize then leave
     rc=XTBDTblJump($table,,$textbld)
   end
   rowid.0=rowidn
   dynshad=dynarea
   drop $xlst.

   /* show panel, control response */
   do until displaycc<>0
     $csrpos=0
     zcmd=''
     zz=Value($area,dynarea)
     /* set cursor position in screen */
     $csrpos=0
  /* say 'lcsr='lcsr
     n=xtbdlpos-xtbdppos
     n=2+(n*xtbdwdth)
     if n>0 then $csrpos=n   */
     if lcsr>0 then $csrpos=lcsr
     /* set cursor on line with error */
     do n=2 to $dynsize-1 by xtbdwdth /* until $csrpos>0 */
       if substr(dynarea,n,1)='?' then $csrpos=n
     end
     if $pcursor<>'DYNAREA' then $csrpos=0

     /* display */
     "tbget" $infotbl
     if symbol($xlst.0)<>'VAR' then xtbdhidn=XTBDCountX($table)
     if $vartbl<>'' then "tbget" $vartbl
     saveppos=xtbdppos
     "display panel("$panel")"
     cc=rc
     cm=zerrlm
     if $vartbl<>'' then "tbput" $vartbl
     if cc>8 then return XtbdXmsg('panel error rc' cc cm,8)
     if cc=8 then leave $main
     dynarea=Value($area)
     displaycc=rc
     "tbput" $infotbl    /*in case fields were updated by the panel */
     "vget (zverb zscrolln zscrolla zscreenc)"

     /* handle primary commands */
     parse value XTBDDoCmd(zcmd) with cc text
     if cc<>0 then return cc text
     "tbget" $infotbl
     xtbdlpos=0

     /* handle line commands */
     if XTBDDoPanel()<>0 then leave $main
     "tbget" $infotbl
     if datatype($xlst.0)<>'NUM' then do
       xtbdhidn=XTBDCountX($table)
       "tbput" $infotbl
     end

     /* handle srolling */
     if wordpos(zverb,'DOWN UP')>0 then do
       vs=space(zverb zscrolla,0) /* verb & scroll */
       Select
         when vs='UPMAX'   then xtbdppos=1
         when vs='DOWNMAX' then xtbdppos=tblrows-$plvline+1
         when zverb='UP'   then do /* xtbdppos=xtbdppos-zscrolln */
           n=zscrolln
           lp=xtbdppos
           do p=xtbdppos to 1 by -1 while n>0
             if \$xlst.p then parse value n-1 p with n lp
           end
           xtbdppos=lp
           $pcursor='ZCMD'
         end
         when zverb='DOWN' then do /* xtbdppos=xtbdppos+zscrolln */
           n=zscrolln
           do p=xtbdppos to tblrows while n>0
             if \$xlst.p then n=n-1
           end
           xtbdppos=p
           $pcursor='ZCMD'
         end
         otherwise nop
       end
       zscrolln=''
       if xtbdppos<1 then xtbdppos=1
       if xtbdppos>tblrows then xtbdppos=tblrows
       "tbput" $infotbl
       iterate $main
     end
     if $chgn<>0 | xtbdppos<>saveppos then iterate $main
   end
 End
 Return 0

/* pull modified data from panel */
XTBDDoPanel:
 address ispexec
 parse value '0' sfdl with rown txtp
 seln=0
 Do dap=1 to ($plvline*xtbdwdth)-1 by xtbdwdth
 /*say 'dap:' dap 'plvline:' $plvline 'xtbdwdth:' xtbdwdth  */
   rown=rown+1
   if substr(dynarea,dap,xtbdwdth)=substr(dynshad,dap,xtbdwdth),
     then iterate
   parse value substr(dynarea,dap+1,xtbdwdth-1) with asel =(txtp) atext
   asel=translate(space(translate(asel,' ',sfc),0))
   if asel='*' then iterate
   parse value substr(dynshad,dap+1,xtbdwdth-1) with ssel =(txtp) stext
   ssel=translate(space(translate(ssel,' ',sfc),0))
   seln=seln+1
 /* say 'asel:' asel 'ssel:' ssel   */
   "tbget" $infotbl
   xtbdlpos=rowid.rown
   "tbput" $infotbl
   Select
     when asel=''  then do
       "tbget" $infotbl
       Call XTBDTblPut $table,'row('rowid.rown')','',atext
       if xtbdblkc='' then leave
       if wordpos(rowid.rown,xtbdblkc)=0 then leave
       xtbdblkc=delword(xtbdblkc,wordpos(rowid.rown,xtbdblkc),1)
       if (words(xtbdblkc)=2 & word(xtbdblkc,2)=rowid.rown),
       |  words(xtbdblkc)=1 then xtbdblkc=''
       "tbput" $infotbl
     end
     when wordpos(asel,$nbllist)=0 & asel='X' ,
          then cc=XTBDLCmdX('X row('rowid.rown')')
     when wordpos(asel,$nbllist)=0 & asel='XX' then cc=XTBDLCmdBlk('XX')
     when $lcproc<>'' & wordpos(asel,$lcblst)>0 then cc=XTBDLCmdBlk(asel)
     when $lcproc<>'' & ($lclist='' | wordpos(asel,$lclist)>0) then do
       Call XTBDTblPut $table,'row('rowid.rown')','',atext
       Address TSO,
         $lcproc 'XTBDISD SEL' $table $infotbl rowid.rown asel''$passtxt
       $chgn=$chgn+1             /* something might have changed */
       if rc=2 then return 2     /* 2020-04-13 */
       if rc>7 then Call XTBDTblPut $table,'row('rowid.rown')','?'asel,atext
  /*   else         Call XTBDTblPut $table,'row('rowid.rown')','!',atext*/
     end
     otherwise do
       call XTBDIspMsg('Invalid selection' asel)
       Call XTBDTblPut $table,'row('rowid.rown')','?'asel,atext
     end
   End
 End
 if zverb='' & seln=0 & $pcursor=$area & $pas<>'' & $lcproc<>'' then nop
 else return 0
 /* point-and-shoot */
 rown=($pcsrpos%xtbdwdth)+1
 if rown>rowid.0 then return 0
 rc=XTBDTblJump($table,'row('rowid.rown')')
 if XTBATTRL='*' then return 0                /* dont process comment */
 /* run command     */
 Address TSO $lcproc 'XTBDISD SEL' $table $infotbl rowid.rown $pas''$passtxt
 "tbget" $infotbl
 xtbdlpos=rowid.rown
 "tbput" $infotbl
 return 0

/* handle primary commands */
XTBDDoCmd:
 arg cmd
 Do Forever
   wn=words(cmd)
   parse var cmd w1 rest
   if wordpos(w1,$retcmd)>0 then return 1 cmd
   Select
     when cmd='' then nop
     when wn=1 & Abbrev('FIND',cmd,1)     then Call XTBDTblRFind
     when wn=1 & Abbrev('RFIND',cmd,2)    then Call XTBDTblRFind
     when Abbrev('FIND',w1,1)             then Call XTBDTblFind rest
     when Abbrev('LOCATE',w1,1)           then Call XTBDTblLoc rest
     when Abbrev('HIDE',w1,1)             then Call XTBDTblHide rest
     when Abbrev('UNHIDE',w1,3)           then Call XTBDTblUnHide rest
     when cmd='ALL'                       then Call XTBDTblUnHide
     when Abbrev('ONLY',w1,1)             then Call XTBDTblOnly rest
     when w1='X' | Abbrev('EXCLUDE',w1,3) then Call XTBDTblHide rest
     when Abbrev('RESET',w1,3)            then Call XTBDTblReset
     when $pcproc<>'' then do
       drop $xlst.   /* force count redrive */
       Interpret "Parse value" $pcproc"(""XTBDISD CMD",
         $table $infotbl cmd""$passtxt""") with cc cmd"
       if cc=1 then iterate
       if cc=2 then xtbdppos=0
       leave
     end
     otherwise call XTBDIspMsg 'Invalid command' cmd
   End
   leave
 End
 $chgn=$chgn+1 /* as we cannot know if something was changed */
 return 0

/* subs */
XtbdXmsg: if arg(1)<>'' then say arg(1);return word(arg(2) 0,1)
XtbdUnique: return,   /* 6 byte pretty unique within 10 days */
  d2x(right(date('c'),1)left(space(translate(time('l'),' ','.:'),0),6))

/* set value by a function */
XtbdSetVal: zz=Value(arg(1),arg(2));return word(arg(3) 0,1)

XTBDVget: Procedure /* external name, pool */
 address ispexec "vget" arg(1) arg(2)
 return value(arg(1))

XTBDVput: Procedure /* external name, value, pool */
 zz=Value(arg(1),arg(2))
 address ispexec "vput" arg(1) arg(3)
 return 0

XTBDLCmdX: /* hide row, parm is rowid. parm=X|XX ROW(nn) */
 "tbget" $infotbl
 if word(arg(1),1)='X' & xtbdblkc<>'' then,
   return XTBDTblPut($table,word(arg(1),2),'?X',''),
   +      xispmsg('Line cmd not valid while block cmd' xtbdblkc 'is pending')
 xtbdhidn=xtbdhidn+1
 "tbput" $infotbl
 drop $xlst.   /* force count redrive */
 Return XTBDTblPut($table,word(arg(1),2),,'X')+1

/* find row with text anywhere */
XTBDTblRFind: Return XTBDTblFind('*')
XTBDTblFind:
 parse var findsave fspos fsdir fstxt
 parse arg txt
 if fstxt txt='' then return XTBDIspMsg('No find arg set')
 parse value '' with locn dir

 if txt<>'' then do forever
   pwn=words(txt)
   pwp=wordindex(txt,pwn)
   select
     when wordpos(translate(word(txt,1)),'NEXT PREV')>0 then ,
       parse var txt dir txt
     when wordpos(translate(word(txt,pwn)),'NEXT PREV')>0 then ,
       parse var txt txt =(pwp) dir
     otherwise leave
   end
 end
 txt=strip(txt)
 if txt='*' then do
   dir=translate(word(dir fsdir,1))
   txt=fstxt
 end
 else dir=translate(word(dir 'NEXT',1))
 if left(txt,1)="'" then txt=substr(txt,2,length(txt)-2)
 if txt='' then return XTBDIspMsg('No find arg set')

 if dir='PREV' then locn='NUMBER(-1)'
 rc=XTBDTblJump($table,'row('rowid.1')')     /* position */
 findsave=rid dir txt
 parse var findsave pos dir txt
 Do forever
   rc=XTBDTblJump($table,locn)
   if rc<>0 then return XTBDIspMsg(txt dir 'not found')
   if wordpos(XTBDATTR,'X *')=0 & pos(txt,translate(XTBDTEXT))>0 then do
     "tbget" $infotbl
     xtbdppos=zrowid
     "tbput" $infotbl
     findsave=zrowid dir txt
     return 0
   end
 End
 Return 999

/* locate row with text starting with argument */
XTBDTblLoc:
 "tbtop"  $table
 arg p
 l=length(p)
 Do forever
   if XTBDTblJump($table)<>0 then return XTBDIspMsg(p 'not located')
   if wordpos(XTBDATTR,'X *')>0 then iterate
   if translate(substr(XTBDTEXT,2,l))=p then leave
 End
 "tbget"  $infotbl
 xtbdppos=zrowid
 "tbput"  $infotbl
 Return 0

/* suppress lines with XTBDTEXT */
XtbdTblNHide: Return XTBDTblHide('NOT' arg(1))
XTBDTblHide:
 arg p
 if p='' then return XTBDIspMsg('No HIDE arg set')
 cond='IS'
 if word(p,1)='NOT' then parse var p cond p
 pn=0
 "tbtop"  $table
 do forever
   "tbskip" $table "rowid(trowid) position(tcsr)"
   if rc<>0 then leave
   if wordpos(XTBDATTR,'X *')>0 then iterate
   ok=(pos(p,translate(XTBDTEXT))>0)
   if (cond='NOT' & \ok) | (cond='IS' & ok) then do
     XTBDATTR='X'
     Call XTBDTblPut $table,,XTBDSEL,XTBDATTR,XTBDTEXT
     pn=pn+1
   end
 End
 "tbput" $infotbl
 drop $xlst.   /* force count redrive */
 call XTBDIspMsg pn 'lines hidden'
 Return 0

XTBDTblUnHide: /* reveal hidden lines */
 arg p
 if p='ALL' then p=''
 pn=0
 "tbquery" $table "rownum(rows)"
 "tbtop" $table
 do rows
   "tbskip" $table
   if XTBDATTR<>'X' then iterate
   if p='' | pos(p,translate(XTBDTEXT))>0 then do
     XTBDATTR=''
     "tbput" $table
     pn=pn+1
   end
 End
 call XTBDIspMsg pn 'lines revealed'
 xtbdhidn = xtbdhidn - pn
 "tbput" $infotbl
 drop $xlst.   /* force count redrive */
 Return 0

XTBDTblOnly: /* show only lines with text */
 "tbtop"  $table
 arg p
 n=0
 do forever
   if XTBDTblJump($table)<>0 then leave
   if XTBDATTR='X' | XTBDATTR='*' then iterate
   if pos(p,translate(XTBDTEXT))>0 then XTBDATTR=''
   else XTBDATTR='X'
   if XTBDATTR='X' then n=n+1
   Call XTBDTblPut $table,,XTBDSEL,XTBDATTR,XTBDTEXT
 End
 xtbdppos=0
 xtbdhidn = xtbdhidn + n
 "tbput" $infotbl
 call XTBDIspMsg n 'lines hidden'
 drop $xlst.   /* force count redrive */
 Return 0

XTBDTblReset: /* show all */
 "tbtop" $table
 "tbquery" $table "rownum(rown)"
 do rown
   "tbskip" $table
   if XTBDATTR='*' then iterate  /* comment */
   XTBDATTR=''
   "tbput" $table
 End
 xtbdhidn=0
 xtbdblkc=''
 if mlcadef<>'' then do
   mlclib1=word(mlcadef,2)
   mlclib2=word(mlcadef,3)
   mlcadef=''
 end
 "tbput" $infotbl
 drop $xlst.   /* force count redrive */
 Return 0

/* count number of hidden rows */
XTBDCountX: Procedure expose $table $xlst.
 trace off
 address ispexec
 "tbtop" arg(1)
 "tbquery" arg(1) "rownum(rows)"
 hidn=0
 xtbdattr='X'
 drop $xlst.
 $xlst. =0
 if datatype(rows)<>'NUM' then rows=0
 $xlst.0=rows +0
 do until rc<>0
   "tbscan" $table "arglist(xtbdattr) condlist(eq) noread position(p)"
   if rc=0 then do
     hidn=hidn+(rc=0)
     p=p+0
     $xlst.p=1
   end
 end
 return hidn

/* jump and retrieve table row */
XTBDTblJump: Procedure expose XTBDSEL XTBDATTR XTBDTEXT zrowid zrowcsr
 address ispexec "tbskip" arg(1) arg(2) "rowid(zrowid) position(zrowcsr)"
 if rc<>0 | arg(3)='' | xtbdattr='*' then return rc
 interpret "XTBDTEXT="arg(3)
 address ispexec "tbput" arg(1)
 return rc

/* update $table */
XTBDTblPut: Procedure expose $chgn zrowid /* parm: table,pos,sel,attr,text */
 if arg(2)<>'' then address ispexec "tbskip" arg(1) arg(2)
 else address ispexec "tbget" arg(1)
 XTBDSEL = arg(3)
 XTBDATTR= arg(4)
 if arg(5)<>'' then XTBDTEXT= arg(5)
 address ispexec "tbput" arg(1)
 $chgn=$chgn+1
 return rc

/* issue message to screen */
XTBDIspMsg: Procedure
 parse arg zedlmsg,cc
 address ispexec "vput zedlmsg"
 address ispexec "setmsg msg(isrz000) cond"
 Return word(cc 0,1)

/* handle block line cmds  */
XTBDLCmdBlk:
 arg blkid
 "tbget" $infotbl
 if xtbdblkc<>'' & word(xtbdblkc,1)<>blkid then Return,
   XTBDIspMsg(blkid 'ignored, other block command' word(xtbdblkc,1),
   'in progress'),
   + XTBDTblPut($table,'row('rowid.rown')','?'blkid)
 if xtbdblkc='' then do
   xtbdblkc=blkid rowid.rown
   "tbput" $infotbl
   "tbskip" $table "row("rowid.rown") rowid(rid)"
   XTBDSEL=blkid
   "tbput"  $table
   Return 0
 end
 if words(xtbdblkc)>=3 then return,
   XTBDIspMsg('Blockcmd def is full, please reset and retry')
 xtbdblkc=xtbdblkc rowid.rown
 "tbput" $infotbl
 parse var xtbdblkc . rowid1 rowid2 .
 /* ensure right order */
 "tbskip" $table "row("rowid1") position(p1)"  /* position */
 "tbskip" $table "row("rowid2") position(p2)"  /* position */
 if p1>p2 then parse value rowid1 rowid2 with rowid2 rowid1 /* reverse */

 /* do over block */
 "tbskip" $table "row("rowid1") rowid(rid)"  /* position */
 if rc<>0 then return XTBDIspMsg('tbskip rc' rc zerrlm)
 blkc=substr(blkid,2)
 cc=XTBDTblPut($table,'row('rowid2')',blkid)

 Do forever
   $tbattr=''
   if wordpos(XTBDATTR,'* X')=0 then do
     if wordpos(blkid,bilblst)>0 then do /* internal */
       Interpret "cc=XTBDLcmd"blkc"('"blkid" row("rid")')"
       if blkc='X' then $tbattr='X'    /* special case, store in table */
     end
     else do                            /* external */
       Address TSO $lcproc 'XTBDISD SEL' $table $infotbl rid blkid''$passtxt
       cc=rc
     end
     $chgn=$chgn+1             /* something might have changed */
     "tbget" $infotbl
     xtbdblkc=blkid rid word(xtbdblkc,3)
     "tbput" $infotbl
     if cc>4 then do
       if word(xtbdblkc,2)=word(xtbdblkc,3) then do
         xtbdblkc=''
         "tbput" $infotbl
       end
       Return XTBDTblPut($table,'row('rid')','?'blkid)
     end
     if cc<=4 then cc=XTBDTblPut($table,'row('rid')','',$tbattr)
   end
   if rid=rowid2 then leave
   "tbskip" $table "row("rid") noread"  /* reposition */
   "tbskip" $table "rowid(rid)"         /* next       */
   if rc=0 then iterate
   say 'tbskip' $table 'rc' rc
   leave
 end

 "tbget" $infotbl
 xtbdblkc=''
 "tbput" $infotbl
 return 0
/*
 Parse parameter with imedded paranthesis like  dsn(sys1.linklib(ieasys00))
 Org: XPARSE
*/
XtbdXParse: Procedure
 parse arg _str,_val,_opt                               /* parm,verbs,options */
 parse var _opt . 'pfx(' _pfx ')' . 0 . 'def(' _def . ')' .,  /* note lowcase */
              0 . 'suf(' _suf ')' .
 _ret=''
 upper _val
 do while _str<>''
   _str=strip(_str)' '
   _p=Verify(_str,'() ','m')
   if substr(_str,_p,1)=' ' & _def<>'' then _str=Insert('('_def')',_str,_p-1)
   else if substr(_str,_p+1,1)=')' then _str=Insert(' ',_str,_p)
   else if substr(_str,_p,1)=')' then,                    /* excessive rights */
     return _ret";cc=1;err=""Excessive right at:" strip(left(_str,20))""""
   _n=1
   do until _n=0
     _p=Verify(_str,"()'",'m',_p+1)
     if _p>0 then if substr(_str,_p,1)="'" then do
       _p=pos("'",_str,_p+1)                                      /* quoted */
       iterate
     end
     if _p=0 then return _ret";cc=2;err=""Error at:" strip(left(_str,20))""""
     if substr(_str,_p,1)='(' then _n=_n+1;else _n=_n-1
   end
   parse var _str _vrb '(' _data =(_p) +1 _str
   if _val<>'' then if wordpos(translate(_vrb),_val)=0,
     then return _ret";cc=3;err='Invalid verb at:" _vrb"('"
   _data=strip(_data)
   if left(_data,1)="'" then _data=substr(_data,2,length(_data)-2)
   _ret=_ret';'_pfx''translate(_vrb)''_suf'="'_data'"'
 end
 return _ret";cc=0;err=''"