Aminet 10/aminetcdnumber101996.iso/Aminet/util/rexx/ScionRexx.lha/PrintDescendant.rexx

OS/2 REXX Batch file | 1995-10-31 | 22KB | 766 lines

/****************************************************************************
 *                                                                          *
 * $VER: PrintDescendant 2.03 (30 Oct 1995)
 *                                                                          *
 *                      Written by Freddy Ariës                             *
 * Address: Lindeboomweg 7, NL-7135 KE Harreveld, The Netherlands.          *
 *                                                                          *
 * Output options:                                                          *
 *  1. Descendant Chart - all descendants [Dutch: parenteel]                *
 *  2. Descendant Chart - male descendants (mention daughters, no children) *
 *     [Dutch: genealogie - nageslacht van zonen, maar vermelding dochters] *
 *  3. Descendant Chart - male descendants (leave out daughters)            *
 *     [Dutch: stamboom - nageslacht van zonen, geen vermelding dochters]   *
 *                                                                          *
 * This script uses (by default) the rexxreqtools.library (which requires   *
 * a version of reqtools larger than 2.0 and rexxsyslib.library)            *
 * If you do not have these, run SetDefaults.rexx to change the settings.   *
 *                                                                          *
 * As of v2 of this script, and Scion V4, the current person on Scion's     *
 * Personal Window will be used to determine where the search starts.       *
 * Scion 3.13 can still be used, though, in which case the user will be     *
 * asked at which IRN he wants to start.                                    *
 *                                                                          *
 * So why this PrintDescendant script when Scion already has a print option *
 * for descendant charts? Well, the reason is simple: the format of the     *
 * descendant charts generated by Scion does not conform to the guidelines  *
 * of the Dutch CBG (Central Bureau for Genealogy) and NGV (Nederlandse     *
 * Genealogische Vereniging; Dutch Genealogical Society). So I created my   *
 * own PrintDescendant script, that *does* follow their guidelines.         *
 *                                                                          *
 * DONE:                                                                    *
 *  - Now uses preference file for default settings                         *
 *  - count the number of lines output and give a linefeed after a certain  *
 *    number (ie. skip page breaks)                                         *
 *                                                                          *
 * TO DO (mostly low priority, unless someone really wants this):           *
 *  - allow user to select output format (Dutch CGB, New England Register   *
 *    system (NEHGR) or New England Record system (NGS), a modified Henry   *
 *    System, etc.                                                          *
 *  - find a good way to handle the people with sex '?'                     *
 *  - add a menu option for the maximum number of generations to print      *
 *  - allow user to specify if he wants burial data, occupation, comments,  *
 *    references fields, etc. printed.                                      *
 *  - option: if the person has multiple marriages, output a list to the    *
 *    screen and let the user select one (1..x), or all (0).                *
 *  - Suggestions, comments, bugreports, donations, etc. are appreciated.   *
 *                                                                          *
 ****************************************************************************/

options results
arg prtin outname noirn mgen outval

versionstr = "2.03"

/* Don't change the settings here! Run SetDefaults.rexx instead! */
usereq = 1; outp = 1; useirn = 1
prtdev = stdout; prtopt = 0; scrdev = stdout
plwidth = 78; pgsize = 0
PSCR = 'SCIONGEN'

scrname = "CON:0//639//Scion Output/AUTO/SCREEN"
pgline = 1
NL = '0A'x

signal on IOERR

do while prtin = '?'
  Tell("NUMOPT/A/N,OUTFILE/A,NOIRN/S,MAXGEN/N,NOREQ/S,QUIET/S: ")
  pull prtin outname noirn mgen outval
end

/* read preferences file */

if open(pfile, 'ENV:Scion/ScionRexx.prefs', 'r') then do
  do while ~eof(pfile)
    inln = readln(pfile)
    if inln ~= "" then do
      wstr = upper(word(inln, 1))
      if wstr = "USEREQ" then
        usereq = 1
      else if wstr = "NOUSEREQ" then
        usereq = 0
      else if wstr = "PUBSCREEN" then
        pscr = strip(delstr(inln, 1, length(wstr)), 'b', ' "')
      else if wstr = "LINEWIDTH" then do
        wstr = word(inln, 2)
        if datatype(wstr, 'w') then plwidth = wstr
      end
      else if wstr = "PAGESIZE" then do
        wstr = word(inln, 2)
        if datatype(wstr, 'w') then pgsize = wstr
      end
    end
  end
  close(pfile)
end

if pscr = "" | (pscr ~= "WORKBENCH" & ~show('p', pscr)) then
  pscr = "SCIONGEN"
scrname = scrname||pscr

/* Command line options get priority over global settings */

ParseArguments()

if ~show('l','rexxarplib.library') then do
  if exists('libs:rexxarplib.library') then
    call addlib('rexxarplib.library',0,-30,0)
end

screentofront(pscr)

if usereq & ~show('l','rexxreqtools.library') then do
  if exists('libs:rexxreqtools.library') then
    call addlib('rexxreqtools.library',0,-30,0)
  else do
    usereq = 0; outp = 1
    Tell("Unable to open rexxreqtools.library - using text output")
  end
end

/* Originally stolen from Peter Billing - thanks Peter ;-) */
if ~show('P','SCIONGEN') then do
  EndString('I am sorry to say that the SCION Genealogist' || NL ||,
    'database is not available. Please start the' || NL ||,
    'SCION program BEFORE using this script!')
end

myport = "SCIONGEN"
address value myport
GETDBNAME
dbname = upper(RESULT)
fill = 7;        /* number of spaces at the beginning of lines */
malesex = 'M';   /* as of V4, sexes are always 'M', 'F' or '?' */
femalesex = 'F'
GETPROGVERSION
progvers = RESULT

if progvers >= 4 then do
  GETCURRENTIRN
  irn = RESULT
end

if outp & ~usereq then do
  if pscr ~= "WORKBENCH" then do
    scrdev = 'SCNDSCSCR'
    if ~open(scrdev, scrname, 'w') then scrdev = stdout
  end
  Tell("*** PrintDescendant version "||versionstr||" ***")
  Tell("***        by Freddy Ariës       ***")
  Tell("Current database: "||dbname||NL)
end
if prtopt = 0 then do
  if usereq then do
    prtopt = rtezrequest('Current Scion database: '||dbname||NL||,
      NL||'Please make your choice: '||,
      NL||' 1. Descendant Chart - all descendants'||,
      NL||' 2. Descendant Chart - male descendants'||,
      NL||'    (mention daughters, without children)'||,
      NL||' 3. Descendant Chart - male descendants'||,
      NL||'    (leave out daughters)'||,
      '',' _1 | _2 | _3 |E_xit','PrintDescendant v'||versionstr||' by Freddy Ariës','rt_pubscrname = '||PSCR)
    if prtopt = 0 then EXIT

    if progvers < 4 then do
      irn = rtgetlong(,'Enter the IRN of the person whose'||,
            NL||'descendants you want to print: '||,
            NL,'Input Request:','_Continue','rt_pubscrname = '||PSCR)
      if irn = '' then EndString("No IRN - aborted.")
      irn = abs(irn)
    end

    useirn = rtezrequest('Do you want to output the IRNs'||,
              NL||'(the record numbers) as well?'||,
              '',' _Yes| _No ','Input Request:','rt_pubscrname = '||PSCR)
  end
  else do
    /* No use in asking for input if we're not allowed to output anything */
    Tell("1. Descendant Chart - all descendants")
    Tell("2. Descendant Chart - male descendants (mention daughters, without children)")
    Tell("3. Descendant Chart - male descendants (leave out daughters)")
    TellNN("Your choice: ")
    prtopt = readln(scrdev)
    prtopt = CheckAnswer(upper(word(prtopt, 1)))

    if progvers < 4 then do
      TellNN("Enter the IRN of the person whose descendants you want to print: ")
      irn = readln(scrdev)
      irn = upper(word(irn, 1))
    end

    TellNN("Do you want to output the IRNs (numbers) as well (y/n)? ")
    instr = readln(scrdev)
    instr = upper(left(instr, 1))
    Tell("")
    if instr = "Y" then useirn = 1
    else useirn = 0
  end
end

if progvers < 4 then do
  irn = CheckIRN(irn)
end

EXISTPERSON irn
if RESULT ~= 'YES' then
do
  if progvers >= 4 then
    EndString("Unable to locate current person in the current database.")
  else
    EndString("No person with IRN "||irn||" in the current database.")
end

if prtopt > 1 then do
  GETSEX irn
  parsex = RESULT
  if prtopt = 3 & parsex = femalesex then
    EndString("Person isn't male - nothing to print.")
end

if outp then do
  /* No use trying to get input if we're not allowed to ask anything */
  pname = GetNameStr(irn, 0)
  if prtopt = 1 | parsex = malesex then do
    if usereq then do
      valcont = rtezrequest('The selected person is: '||NL||pname||'.'||,
        NL||'Continue?','_Continue| _Abort','PrintDescendant Request:','rt_pubscrname = '||PSCR)
      if valcont = 0 then EndString("Aborted.")
    end
    else do
      TellNN("Current person is "||pname||". Continue? (y/n) ")
      valcont = readln(scrdev)
      valcont = upper(left(valcont, 1))
      if valcont ~= 'Y' then EndString("Ok.")
    end
  end
  else do
    /* with prtopt = 2, we would only print the (generation I) female and
     * her husbands, but no children!
     */
    if usereq then do
      valcont = rtezrequest("WARNING!!! Person "||NL||pname||,
        NL||"is not male! Continue anyway?",'_Continue| _Abort','PrintDescendant Request:','rt_pubscrname = '||PSCR)
      if valcont = 0 then EndString("Aborted.")
    end
    else do
      Tell("WARNING! Person "||pname||" isn't male!")
      TellNN("Continue anyway? (y/n) ")
      valcont = readln(scrdev)
      valcont = upper(left(valcont, 1))
      if valcont ~= 'Y' then EndString("Ok.")
    end
  end
end

/* TO DO: (at this location:)
 * If the person has multiple marriages, output the spouse name, IRN
 * and FGRN to screen, and let the user select one (1..x), or all (0)
 */

if outp & outname = "" then do
  if usereq then do
    odev = rtezrequest('Current Scion database: '||dbname||,
      NL||'Where should the output be sent to?'||,
      NL,' _File |_Printer|_Screen|_Nowhere','PrintDescendant v'||versionstr||' by Freddy Ariës','rt_pubscrname = '||PSCR)
    select
      when odev = 1 then do
        /* We need a file requester for further data */
        dblen = length(dbname)
        if dblen>6 & right(dbname, 6)=".SCION" then
          dbname=left(dbname, dblen - 6)
        outname = rtfilerequest(,dbname||'.DSC','Output filename',,'rtfi_buffer = true   rt_pubscrname = '||PSCR||'   rtfi_initialpath = RAM:',)
        if outname = '' then
          outname = dbname||'.DSC'
      end
      when odev = 2 then
        outname = 'PRT:'
      when odev = 3 then
        outname = 'STDOUT'
      otherwise EndString("No output - aborted.")
        /* You selected 'Nowhere' */
    end
  end
  else do
    Tell("Enter output file (filename with complete path, or PRT: for printer,")
    TellNN("or STDOUT for screen): ")
    outname = readln(scrdev)
    outname = strip(outname, 'b', ' "')
    if outname = "" then outname = 'STDOUT'
  end
end

/* Anyone know a better way to translate numbers into Roman? */
GenerationS.1 = "I II III IV V VI VII VIII IX X XI XII XIII XIV XV XVI XVII XVIII XIX XX"
GenerationS.2 = "XXI XXII XXIII XXIV XXV XXVI XXVII XXVIII XXIX XXX XXXI XXXII XXXIII XXXIV XXXV XXXVI XXXVII XXXVIII IXL XL"
MaxChild = 26

/* Printer Codes, some of which are currently unused: */
ESC = '1B'x
prtinit = ESC||"#1";     /* ESC#1 initialize      */
prtundon = ESC||"[4m";   /* ESC[4m underline on   */
prtundoff = ESC||"[24m"; /* ESC[24m underline off */
prtdson = ESC||"[1m";    /* ESC[1m boldface on    */
prtdsoff = ESC||"[22m";  /* ESC[22m boldface off  */
prtnlqon = ESC||"[2"||'22'x||"z"; /* ESC[2"z NLQ on */
prtnlqoff = ESC||"[1"||'22'x||"z"; /* ESC[1"z NLQ off */

if ~usereq then
  Tell("Printing...")

OpenPrinter()

childnums = irn; childgens = "1"
alcount = 0; chcount = 0

do while childnums ~= ""
  irn = word(childnums, 1)
  cgen = word(childgens, 1)
  if cgen ~= currgen then do
    alcount = 0
    /* New generation: reset alfabet counter */
    currgen = cgen
    genchild = 0
  end
  childnums = delstr(childnums, 1, length(irn)+1)
  childgens = delstr(childgens, 1, length(currgen)+1)

  ccnt = 1
  /* Sex to use with options 2 and 3 */
  GETSEX irn
  parsex = RESULT

  g1 = GetPersonStr(irn)
  mnum = 0
  GETMARRIAGE irn mnum
  fgrn = RESULT
  EXISTFAMILY fgrn
  ftrue = RESULT

  do while ftrue = 'YES'
    m1 = GetMarriageStr(fgrn)
    ptn = GetPartnerIRN(fgrn, irn)
    if ptn ~= 0 then do
      if m1 ~= "" then m1 = m1||' '
      m1 = m1||GetPersonStr(ptn)
    end
    if m1 ~= "" then m1 = ", m: "||m1
    if ccnt = 1 then do
      ggs = GetGenStr(currgen, 0)
      if currgen > 1 then do
        alcount = alcount + 1
    /* TO DO: only if this person has any siblings who have children,
     *      or if there are other persons (with children) on this
     *      generation
     */
        ggs = ggs||D2C(alcount+96)
      end
      ggs = left(ggs||".       ", fill)
      m1 = ggs||g1||m1||'.'
      ccnt = 0
    end
    else
      m1 = copies(' ',fill)||g1||m1||'.'
    PrintLines(m1, fill)
    if prtopt ~= 3 | parsex = malesex then
      chcount = chcount + PrintChildren(fgrn, parsex)
    PrintLF()
    mnum = mnum + 1
    GETMARRIAGE irn mnum
    fgrn = RESULT
    EXISTFAMILY fgrn
    ftrue = RESULT
  end
  if mnum = 0 then do
    m1 = GetGenStr(currgen,fill)||g1
    PrintLines(m1, fill)
    if currgen = 1 then
      PrintLines("No marriages are recorded for this person.", 0)
    PrintLF()
  end
end
if currgen = 1 & chcount = 0 then do
  if prtopt = 1 then
    PrintLines("No descendants are recorded for person.")
  else
    PrintLines("No male descendants are recorded for person.")
end

writech(prtdev, prtnlqoff)
EndString("Done.")

EXIT

/* Parse command line arguments */
ParseArguments:
if noirn = "NOIRN" then useirn = 0
else if noirn = "QUIET" || noirn = "NOREQ" then do
  outval = noirn
  noirn = ""
end
else do
  outval = mgen
  mgen = noirn
  noirn = ""
end
if mgen = "QUIET" || mgen = "NOREQ" then do
  outval = mgen
  mgen = ""
end

MaxGens = 40; /* due to the Roman numbers, we can't handle more */
if mgen ~= "" then do
  if DATATYPE(mgen, 'w') & mgen > 0 & mgen < MaxGens then
    MaxGens = mgen
end

if outval = "QUIET" then do
  usereq = 0
  outp = 0
end
else if outval = "NOREQ" then
  usereq = 0

if prtin = "" then do
  prtopt = 0
  if ~outp then EndString("Requires argument is missing.")
    /* actually, with outp = 0, all it does is EXIT */
end
else do
  prtopt = CheckAnswer(prtin)
  /* Note that it was important to establish outp before calling these */
end
return 0

OpenPrinter:
/* Open the printer device and print out a nice header */
if outname = 'STDOUT' then
  prtdev = scrdev
else do
  prtdev = 'PRINTER'
  if ~open(prtdev, outname, 'w') then
    EndString("ERROR: Failed to open output file!")
end
writech(prtdev, prtinit||prtnlqon)
if prtopt = 1 then
  prtstr = "DESCENDANT CHART - ALL DESCENDANTS"
else if prtopt = 2 then
  prtstr = "DESCENDANT CHART - ONLY MALE DESCENDANTS (TYPE I)"
else
  prtstr = "DESCENDANT CHART - ONLY MALE DESCENDANTS (TYPE II)"
prtstr = prtundon||prtdson||prtstr||prtdsoff||prtundoff
DoWrite(prtdev, prtstr)
prtstr = prtdson||"Report printed on: "||date()||prtdsoff
DoWrite(prtdev, prtstr)
prtstr = copies('=', plwidth)
DoWrite(prtdev, prtstr)
return 0

PrintLines: PROCEDURE EXPOSE prtdev plwidth prtopt pgline pgsize
parse arg ostr, fill
/* TO DO:
 * if there are control strings within ostr (like prtdson or prtdsoff)
 * don't include them in the length count
 */
do while ostr ~= ""
  nnl = plwidth+1
  if length(ostr) > plwidth then do
    do until pc = ' ' | nnl = 1
      pc = substr(ostr, nnl, 1)
      nnl = nnl - 1
    end
    if nnl = 1 then do
      prtstr = left(ostr, plwidth)
      ostr = delstr(ostr, 1, nnl)
    end
    else do
      prtstr = left(ostr, nnl)
      ostr = delstr(ostr, 1, nnl+1)
    end
  end
  else do
    prtstr = ostr
    ostr = ""
  end
  DoWrite(prtdev, prtstr)
  if ostr ~= "" then
    ostr = copies(' ',fill)||ostr
end
return 0

PrintLF:
DoWrite(prtdev, "")
return 1

/*
 * output at most #pgsize lines per page to the print device
 * if pgsize = 0, this feature is turned off (unlimited #lines per page)
 */
DoWrite: PROCEDURE EXPOSE pgline pgsize
parse arg prtdev, ostr
if pgsize ~= 0 & pgline > pgsize then do
  writech(prtdev, '0C'x); /* CTRL-L; next page */
  pgline = 0
end
writeln(prtdev, ostr)
pgline = pgline + 1
return 0

PrintChildren:
parse arg ffnum, parsx
/* If we turn this into a PROCEDURE, we'll have to EXPOSE quite a bit!
 * The disadvantage now is that we have to be extremely careful
 * not to overwrite any global variables by accident!
 */
cidx = 0; cham = 0
GETCHILD ffnum cidx
chld = RESULT
EXISTPERSON chld
ctrue = RESULT
nextgen = currgen + 1
if nextgen > MaxGens then return cham
  /* Maximum number of generations reached! */
do while ctrue = 'YES'
  cidx = cidx + 1
  if prtopt > 1 then do
    GETSEX chld
    csx = RESULT
  end
  if prtopt ~= 3 | csx = malesex then do
    cham = cham + 1
    m1 = copies(' ',8)||cham||". "||GetChildStr(chld)
    if (prtopt = 1 | csx = malesex) & HasChild(chld) then do
      childnums = childnums||chld||' '
      childgens = childgens||nextgen||' '
      genchild = genchild + 1
      if genchild > MaxChild then return 1
      /* Maximum number of children reached! */
      /* TO DO: if genchild = 1 and the current person has no siblings,
       *    or none of his siblings have any children of their own,
       *    and if there are no other persons with children on this
       *    generation, then leave off the D2C part
       */
      m1 = m1||", see "||GetGenStr(nextgen, 0)||D2C(genchild+96)
    end
    else
      m1 = m1||GetDeathStr(chld)||GetMarriages(chld)
    PrintLines(m1||'.', 11)
  end
  GETCHILD ffnum cidx
  chld = RESULT
  EXISTPERSON chld
  ctrue = RESULT
end
return cham

GetGenStr: PROCEDURE EXPOSE GenerationS.
parse arg gnum, fill
if gnum <= 20 then
  gstr = word(GenerationS.1, gnum)
else if gnum <= 40 then
  gstr = word(GenerationS.2, gnum)
else
  return ""
if fill > 0 then
  gstr = left(gstr||".       ",fill)
return gstr

GetPersonStr: PROCEDURE EXPOSE useirn
parse arg irn
if irn ~= 0 then do
  nstr = GetNameStr(irn)
  nstr = nstr||GetBirthStr(irn)
  nstr = nstr||GetDeathStr(irn)
end
else
  nstr = "UNKNOWN"
return nstr

GetChildStr: PROCEDURE EXPOSE useirn
parse arg irn
if irn ~= 0 then do
  nstr = GetNameStr(irn)
  nstr = nstr||GetBirthStr(irn)
end
else
  nstr = "UNKNOWN"
return nstr

/* check all marriages for children; only accept male children for option 3 */
HasChild: PROCEDURE EXPOSE prtopt malesex
parse arg irn
mnum = 0
GETMARRIAGE irn mnum
marr = RESULT
EXISTFAMILY marr
mtrue = RESULT
do while mtrue = 'YES'
  chnxt = 0
  GETCHILD marr chnxt
  ch = RESULT
  EXISTPERSON ch
  ct = RESULT
  if prtopt < 3 then do
    if ct = 'YES' then return 1
  end
  else do
    /* For option 3: search for male children */
    do while ct = 'YES'
      GETSEX ch
      csx = RESULT
      if csx = malesex then return 1
      chnxt = chnxt + 1
      GETCHILD marr chnxt
      ch = RESULT
      EXISTPERSON ch
      ct = RESULT
    end
  end
  mnum = mnum + 1
  GETMARRIAGE irn mnum
  marr = RESULT
  EXISTFAMILY marr
  mtrue = RESULT
end
return 0

GetNameStr: PROCEDURE EXPOSE useirn
parse arg gnum
GETFIRSTNAME gnum
name = RESULT
if name ~= "" then name = name||" "
GETLASTNAME gnum
lname = RESULT
if lname = "" then lname = "UNKNOWN"
name = name||lname
if useirn then name = name||" ["gnum"]"
return name

GetBirthStr: PROCEDURE
parse arg gnum
GETBIRTHPLACE gnum
bstr = RESULT
GETBIRTHDATE gnum
bdat = RESULT
if bdat ~= "" & bstr ~= "" then bstr = bstr||" "
bstr = bstr||bdat
if bstr ~= "" then bstr = ", b: "||bstr
return bstr

GetDeathStr: PROCEDURE
parse arg gnum
GETDEATHPLACE gnum
dstr = RESULT
GETDEATHDATE gnum
ddat = RESULT
if ddat ~= "" & dstr ~= "" then dstr = dstr||" "
dstr = dstr||ddat
if dstr ~= "" then dstr = ", d: "||dstr
return dstr

GetMarriages: PROCEDURE EXPOSE useirn
parse arg irn
mstr = ""
GETMARRIAGE irn 0
mf = RESULT
EXISTFAMILY mf
if RESULT = 'YES' then do
  mtrue = 1
  GETMARRIAGE irn 1
  m2 = RESULT
  EXISTFAMILY m2
  if RESULT = 'YES' then mset = 1
  else mset = 0
end
else
  mtrue = 0
mnum = 0
do while mtrue
  m1 = GetMarriageStr(mf)
  if m1 ~= "" then m1  = m1||' '
  ptn = GetPartnerIRN(mf, irn)
  m1 = m1||GetPersonStr(ptn)

  if mset then mstr = ", m("||mnum||"): "||m1
  else mstr = ", m: "||m1

  mnum = mnum + 1
  GETMARRIAGE irn mnum
  mf = RESULT
  EXISTFAMILY mf
  if RESULT ~= 'YES' then mtrue = 0
end
return mstr

GetMarriageStr: PROCEDURE
parse arg mf
GETMARRYPLACE mf
mstr = RESULT
GETMARRYDATE mf
mdat = RESULT
if mdat ~= "" & mstr ~= "" then mstr = mstr||" "
mstr = mstr||mdat
return mstr

GetPartnerIRN: PROCEDURE
parse arg fnum, inum
GETPRINCIPAL fnum
prn = RESULT
GETSPOUSE fnum
sps = RESULT
if inum = prn then pnum = sps
else if inum = sps then pnum = prn
else pnum = 0
EXISTPERSON pnum
if RESULT ~= 'YES' then pnum = 0
return pnum

CheckAnswer: PROCEDURE EXPOSE outp prtdev usereq scrdev pscr
parse arg str
str = left(str, 1)
if ~DATATYPE(str, 'w') | (str < 1 | str > 3) then
  EndString("Invalid option - aborted.")
return str

CheckIRN: PROCEDURE EXPOSE outp prtdev usereq scrdev pscr
parse arg str
if ~DATATYPE(str, 'w') then
  EndString("Invalid IRN - aborted.")
return str

Tell: PROCEDURE EXPOSE outp scrdev
parse arg str
if outp then
  writeln(scrdev, str)
return 0

TellNN: PROCEDURE EXPOSE outp scrdev
parse arg str
if outp then
  writech(scrdev, str)
return 0

EndString: PROCEDURE EXPOSE outp prtdev usereq scrdev pscr
parse arg str
/* If you turned off stdout, no error messages will be shown! */
if usereq then
  rtezrequest(str,'E_xit','PrintDescendant Message:','rt_pubscrname = '||PSCR)
else do
  Tell(str || '0A'x)
end
if outp & ~usereq & (scrdev ~= stdout) then do
  Tell("Press <return> to exit.")
  readln(scrdev)
  close(scrdev)
end
close(prtdev)
EXIT

/* Let's make sure you get a nice message when you turn off the printer :-) */

IOERR:
bline = SIGL
say "I/O error #"||RC||" detected in line "||bline||":"
say sourceline(bline)
EXIT