home *** CD-ROM | disk | FTP | other *** search
/ The AGA Experience 2 / agavol2.iso / rexx / printpedigree.rexx < prev    next >
OS/2 REXX Batch file  |  1995-09-21  |  21KB  |  741 lines
  1. /****************************************************************************
  2.  *                                                                          *
  3.  * $VER: PrintPedigree 2.03 (9 Sep 1995)
  4.  *                                                                          *
  5.  *                      Written by Freddy Ariës                             *
  6.  *                                                                          *
  7.  * Output options:                                                          *
  8.  *  1. Pedigree Chart - male ancestor line only [Dutch: stamreeks]          *
  9.  *  2. Pedigree Chart - all ancestors, no siblings [Dutch: kwartierstaat]   *
  10.  *  3. Pedigree Chart - all ancestors, only siblings of last generation     *
  11.  *  4. Pedigree Chart - all ancestors, all siblings                         *
  12.  *                                                                          *
  13.  * This script uses (by default) the rexxreqtools.library (which requires   *
  14.  * a version of reqtools larger than 2.0 and rexxsyslib.library)            *
  15.  * If you do not have these, you need to supply the NOREQ argument (for     *
  16.  * Shell output), or the QUIET argument (for no output at all).             *
  17.  *                                                                          *
  18.  * As of v2 of this script, and Scion V4, the current person on Scion's     *
  19.  * Personal Window will be used to determine where the search starts.       *
  20.  * Scion 3.13 can still be used, though, in which case the user will be     *
  21.  * asked at which IRN he wants to start.                                    *
  22.  *                                                                          *
  23.  * TO DO (low priority, unless someone really wants this):                  *
  24.  *  - count the number of lines output and give a formfeed after a          *
  25.  *    certain number (ie. skip page breaks)                                 *
  26.  *  - Add a menu option for the maximum number of generations to print      *
  27.  *  - allow user to specify if he wants burial data, occupation, comments,  *
  28.  *    references fields, etc. printed                                       *
  29.  *  - option: include empty fields                                          *
  30.  *  - find a good way to handle sex-fields with value '?' (see below)       *
  31.  *  - Suggestions, comments, bugreports, donations, etc. are appreciated.   *
  32.  *                                                                          *
  33.  * Known Bugs/Problems:                                                     *
  34.  *  - This script is dog slow for large databases (ie. more than, say, 10   *
  35.  *    generations), even on Amigas with a Turboboard!                       *
  36.  *  - Incorrect assumptions may be made (with regard to father/mother) when *
  37.  *    there are persons in the database whose sex-field has value '?'       *
  38.  *                                                                          *
  39.  ****************************************************************************/
  40.  
  41. options results
  42. arg prtin outname noirn mgen outval
  43.  
  44. versionstr = "2.03"
  45. usereq = 1; /* change this to 0 if you don't want to use reqtools */
  46. outp = 1; useirn = 1; prtdev = stdout; prtopt = 0
  47. plwidth = 78;  /* linewidth of the printer */
  48. NL = '0A'x
  49. PSCR = 'SCIONGEN'; /* public screen to open the requesters on */
  50.  
  51. numpers = 1
  52.  
  53. DbtGen = 12; /* Suggested value for 68000: 10, with Turbo-boards: 12 */
  54. /* From this generation onwards, every generation needs a confirm */
  55. /* Note: 12 generations means (up to) 4096 persons!!! */
  56.  
  57. signal on IOERR
  58.  
  59. /* parse command line options, to allow calling the script automatically,
  60.  * eg. from a function key
  61.  */
  62.  
  63. do while prtin = '?'
  64.   Tell("NUMOPT/A/N,OUTFILE/A,NOIRN/S,MAXGEN/N,QUIET/S,NOREQ/S: ")
  65.   pull prtin outname noirn mgen outval
  66. end
  67.  
  68. ParseArguments()
  69.  
  70. if usereq & ~show('l','rexxreqtools.library') then do
  71.   if exists('libs:rexxreqtools.library') then
  72.     call addlib('rexxreqtools.library',0,-30,0)
  73.   else do
  74.     usereq = 0; outp = 1
  75.     Tell("Unable to open rexxreqtools.library - using text output")
  76.   end
  77. end
  78.  
  79. /* These first few lines were stolen from Peter Billings - thanks Peter ;-) */
  80. if ~show('P','SCIONGEN') then do
  81.   TermError('I am sorry to say that the SCION Genealogist' || NL ||,
  82.     'database is not available. Please start the' || NL ||,
  83.     'SCION program BEFORE using this script!')
  84. end
  85.  
  86. myport = "SCIONGEN"
  87. address value myport
  88. GETDBNAME
  89. dbname = upper(RESULT)
  90. GETPROGVERSION
  91. progvers = RESULT
  92.  
  93. if progvers >= 4 then do
  94.   GETCURRENTIRN
  95.   irn = RESULT
  96. end
  97.  
  98. if outp & ~usereq then do
  99.   Tell("*** PrintPedigree version "||versionstr||" ***")
  100.   Tell("***       by Freddy Ariës      ***")
  101.   Tell("Current database: "||dbname||NL)
  102. end
  103. if prtopt = 0 then do
  104.   /* No use in asking for input if we're not allowed to output anything */
  105.   if usereq then do
  106.     prtopt = rtezrequest('Current Scion database: '||dbname||NL||,
  107.       NL||'Please make your choice: '||,
  108.       NL||'1. Pedigree Chart - male ancestor line only'||,
  109.       NL||'2. Pedigree Chart - all ancestors, no siblings'||,
  110.       NL||'3. Pedigree Chart - all ancestors, only last generation siblings'||,
  111.       NL||'4. Pedigree Chart - all ancestors, all siblings'||,
  112.       '',' _1 | _2 | _3 | _4 |E_xit','PrintPedigree v'||versionstr||' by Freddy Ariës','rt_pubscrname = '||PSCR)
  113.     if prtopt = 0 then
  114.       EXIT
  115.  
  116.     if progvers < 4 then do
  117.       irn = rtgetlong(,'Enter the IRN of the person whose'||,
  118.             NL||'ancestors you want to print: '||,
  119.             NL,'Input Request:','_Continue','rt_pubscrname = '||PSCR)
  120.       if irn = '' then
  121.         EXIT
  122.       irn = abs(irn)
  123.     end
  124.  
  125.     useirn = rtezrequest('Do you want to output the IRNs'||,
  126.               NL||'(the record numbers) as well?'||,
  127.               '',' _Yes| _No ','Input Request:','rt_pubscrname = '||PSCR)
  128.   end
  129.   else do
  130.     Tell("1. Pedigree Chart - male ancestor line only")
  131.     Tell("2. Pedigree Chart - all ancestors, no siblings")
  132.     Tell("3. Pedigree Chart - all ancestors, only siblings of last generation")
  133.     Tell("4. Pedigree Chart - all ancestors, all siblings")
  134.     TellNN("Your choice: ")
  135.     pull prtopt
  136.     prtopt = CheckAnswer(prtopt)
  137.  
  138.     if progvers < 4 then do
  139.       TellNN("Enter the IRN of the person whose ancestors you want to print: ")
  140.       pull irn
  141.     end
  142.  
  143.     TellNN("Do you want to output the IRN (numbers) as well (y/n)? ")
  144.     pull instr
  145.     Tell("")
  146.     if left(instr, 1) = "Y" | left(inp, 1) = "y" then useirn = 1
  147.     else useirn = 0
  148.   end
  149. end
  150.  
  151. if progvers < 4 then do
  152.   irn = CheckIRN(irn)
  153. end
  154.  
  155. EXISTPERSON irn
  156. if RESULT ~= 'YES' then
  157. do
  158.   if progvers >= 4 then
  159.     TermError("Unable to determine current person in the database.")
  160.   else
  161.     TermError("No person with IRN "||irn||" in the current database.")
  162. end
  163.  
  164. if outp then do
  165.   pname = GetNameStr(irn, 0)
  166.   if usereq then do
  167.     valcont = rtezrequest('The selected person is: '||NL||pname||'.'||,
  168.       NL||'Continue?','_Continue| _Abort','PrintPedigree Request:','rt_pubscrname = '||PSCR)
  169.     if valcont = 0 then
  170.       EXIT
  171.   end
  172.   else do
  173.     TellNN("Current person is "||pname||". Continue? (y/n) ")
  174.     pull valcont
  175.     if left(valcont, 1) ~= 'Y' then
  176.       TermError("Ok.")
  177.   end
  178. end
  179.  
  180. if outp & outname = "" then do
  181.   if usereq then do
  182.     odev = rtezrequest('Current Scion database: '||dbname||,
  183.       NL||'Where should the output be sent to?'||,
  184.       NL,' _File |_Printer|_Screen|_Nowhere','PrintPedigree v'||versionstr||' by Freddy Ariës','rt_pubscrname = '||PSCR)
  185.     select
  186.       when odev = 1 then do
  187.         /* We need a file requester for further data */
  188.         dblen = length(dbname)
  189.         if dblen>6 & right(dbname, 6)=".SCION" then
  190.           dbname=left(dbname, dblen - 6)
  191.         outname = rtfilerequest(,dbname||'.PED','Output filename',,'rtfi_buffer = true   rt_pubscrname = '||PSCR||'   rtfi_initialpath = RAM:',)
  192.         if outname = '' then
  193.           outname = dbname||'.PED'
  194.       end
  195.       when odev = 2 then
  196.         outname = 'PRT:'
  197.       when odev = 3 then
  198.         outname = 'STDOUT'
  199.       otherwise
  200.         EXIT
  201.         /* You selected 'Nowhere' */
  202.     end
  203.   end
  204.   else do
  205.     Tell("Enter output file (filename with complete path, or PRT: for printer,")
  206.     TellNN("or STDOUT for screen): ")
  207.     pull outname
  208.     if outname = "" then
  209.       outname = "STDOUT"
  210.   end
  211. end
  212.  
  213. /* Anyone know a better way to translate numbers into Roman? */
  214. GenerationS.1 = "I II III IV V VI VII VIII IX X XI XII XIII XIV XV XVI XVII XVIII XIX XX"
  215. GenerationS.2 = "XXI XXII XXIII XXIV XXV XXVI XXVII XXVIII XXIX XXX XXXI XXXII XXXIII XXXIV XXXV XXXVI XXXVII XXXVIII IXL XL"
  216.  
  217. /* Printer Codes (some of which are currently unused): */
  218. ESC = '1B'x
  219. prtinit = ESC||"#1";     /* ESC#1 initialize      */
  220. prtundon = ESC||"[4m";   /* ESC[4m underline on   */
  221. prtundoff = ESC||"[24m"; /* ESC[24m underline off */
  222. prtdson = ESC||"[1m";    /* ESC[1m boldface on    */
  223. prtdsoff = ESC||"[22m";  /* ESC[22m boldface off  */
  224. prtnlqon = ESC||"[2"||'22'x||"z";  /* ESC[2"z NLQ on  */
  225. prtnlqoff = ESC||"[1"||'22'x||"z"; /* ESC[1"z NLQ off */
  226.  
  227. if ~usereq then
  228.   Tell("Building ancestor table...")
  229.  
  230. currgen = 1
  231. GENTREE.1 = irn
  232.  
  233. /* Build the ancestor table */
  234. do until ~foundone
  235.   foundone = 0
  236.   currgen = currgen + 1
  237.   numpers = 2 * numpers
  238.   /* = 2 ** (currgen - 1) */
  239.   if currgen <= MaxGens then
  240.   do
  241.     if currgen > DbtGen then
  242.     do
  243.       if usereq then
  244.       do
  245.         docont = rtezrequest('Also parse generation '||currgen||' ?'||,
  246.               NL||'(this may take *very* long!)'||,
  247.               '',' _Yes| _No ','Input Request:','rt_pubscrname = '||PSCR)
  248.       end
  249.       else
  250.       do
  251.         Tell("Also parse generation '||currgen||' ?' (this may take *very* long!)")
  252.         pull inp
  253.         Tell("")
  254.         if left(inp, 1) = "Y" | left(inp, 1) = "y" then docont = 1
  255.         else docont = 0
  256.  
  257.       end
  258.     end
  259.     else docont = 1
  260.  
  261.     if docont then
  262.     do
  263.       if prtopt = 1 then
  264.         endnum = numpers+1
  265.         /* no use to build the entire table, if we need only this little */
  266.       else
  267.         endnum = 2*numpers-1
  268.       /*
  269.        * TO DO: at the moment, all the numbers are parsed, even if there
  270.        *  is only one family group with ancestors in this generation
  271.        *  This means that thousands of fields may be checked, to find
  272.        *  two persons. This also makes the program dog slow!
  273.        *  I must find a better method to do this. Suggestions welcome...
  274.        */
  275.       do ct = numpers to endnum by 2
  276.         ct1 = ct % 2
  277.         irn = GENTREE.ct1
  278.         ct1 = ct + 1
  279.         GENTREE.ct = 0
  280.         GENTREE.ct1 = 0
  281.         if irn ~= 0 then do
  282.           GETPARENTS irn
  283.           fgrn = RESULT
  284.           EXISTFAMILY fgrn
  285.           if RESULT = 'YES' then do
  286.             foundone = 1
  287.             GetParentsIRN(fgrn, ct, ct1)
  288.           end
  289.         end
  290.       end
  291.     end
  292.   end
  293.   else do
  294.     if usereq then
  295.       rtezrequest('Maximum number of'||NL||'generations reached.'||NL||,
  296.     NL||'Output truncated','_Continue','PrintPedigree Message:','rt_pubscrname = '||PSCR)
  297.     else
  298.      Tell("Maximum number of generations reached. Output may be truncated.")
  299.   end
  300. end
  301. numgens = currgen - 1
  302.  
  303. /* Now print all the ancestors */
  304. if ~usereq then
  305.   Tell("Printing data...")
  306.  
  307. OpenPrinter()
  308.  
  309. if prtopt = 1 then do
  310.   /* print only male ancestors */
  311.   fill = 7
  312.   np = numpers%2
  313.   currgen = 1
  314.   do while np > 1
  315.     g1 = GetGenStr(currgen, fill)
  316.     ct1 = np + 1
  317.     ct2 = np % 2
  318.     /* get the husband's data */
  319.     g1 = g1||GetPersonStr(GENTREE.np)
  320.  
  321.     GETPARENTS GENTREE.ct2
  322.     mf1 = RESULT
  323.     EXISTFAMILY mf1
  324.     if RESULT = 'YES' then
  325.       m1 = GetMarriageStr(mf1)
  326.     else
  327.       m1 = ""
  328.  
  329.     if m1 ~= "" then
  330.       m1 = g1||", m: "||m1
  331.     else m1 = g1
  332.     g1 = copies(' ',fill)
  333.     PrintLines(m1, fill)
  334.     /* get the wife's data */
  335.     m1 = g1||GetPersonStr(GENTREE.ct1)
  336.     PrintLines(m1, fill)
  337.     PrintLF()  
  338.     currgen = currgen + 1
  339.     np = np % 2
  340.   end
  341.   g1 = GetGenStr(currgen, fill)||GetPersonStr(GENTREE.np)
  342.   g1 = g1||GetMarriages(GENTREE.np)
  343.   PrintLines(g1, fill)
  344.   PrintLF()  
  345. end
  346. else do
  347.   /* print all */
  348.   currgen = currgen - 1
  349.   fill = 6
  350.  
  351.   g1 = center("Generation: "||GetGenStr(currgen, fill), plwidth-1)
  352.   PrintLines(g1, fill)
  353.   g1 = "1.    "||GetPersonStr(GENTREE.1)
  354.   g1 = g1||GetMarriages(GENTREE.1)
  355.   PrintLines(g1, fill)
  356.   if prtopt > 2 then
  357.     PrintSiblings(GENTREE.1, 1)
  358.   PrintLF()  
  359.  
  360.   np = 2
  361.   currgen = currgen - 1
  362.   do while np < numpers
  363.     g1 = center("Generation: "||GetGenStr(currgen, fill), plwidth)
  364.     PrintLines(g1, fill)
  365.     endnum = 2*np-1
  366.     do ct = np to endnum by 2
  367.       ct1 = ct + 1
  368.       ct2 = ct % 2
  369.       /* print the principal data */
  370.       if GENTREE.ct ~= 0 then do
  371.         g1 = left(ct||".    ",fill)||GetPersonStr(GENTREE.ct)
  372.  
  373.     GETPARENTS GENTREE.ct2
  374.     mf1 = RESULT
  375.     EXISTFAMILY mf1
  376.     if RESULT = 'YES' then
  377.       m1 = GetMarriageStr(mf1)
  378.     else
  379.       m1 = ""
  380.  
  381.         if m1 ~= "" then
  382.           m1 = g1||", m: "||m1
  383.         else m1 = g1
  384.         g1 = copies(' ',fill)
  385.         PrintLines(m1, fill)
  386.         if prtopt = 4 then
  387.           PrintSiblings(GENTREE.ct, ct)
  388.       end
  389.       /* print the spouse data */
  390.       if GENTREE.ct1 ~= 0 then do
  391.         m1 = left(ct1||".    ",fill)||GetPersonStr(GENTREE.ct1)
  392.         PrintLines(m1, fill)
  393.         if prtopt = 4 then
  394.           PrintSiblings(GENTREE.ct1, ct1)
  395.       end
  396.     end
  397.     PrintLF()  
  398.     currgen = currgen - 1
  399.     np = np * 2
  400.   end
  401. end
  402. if numgens = 1 then
  403.   PrintLines("No ancestors are recorded for this person.", 0)
  404.  
  405. if usereq then
  406.   rtezrequest('Output ready.','_Continue','PrintPedigree Message:','rt_pubscrname = '||PSCR)
  407. else
  408.   Tell("Done.")
  409.  
  410. writeln(prtdev, prtnlqoff); /* ESC[1"z NLQ off */
  411. close(prtdev)
  412. EXIT
  413.  
  414. /* Parse command line arguments and set the appropriate global variables */
  415. ParseArguments:
  416. if noirn = "NOIRN" then useirn = 0
  417. else if noirn = "QUIET" || noirn = "NOREQ" then do
  418.   outval = noirn
  419.   noirn = ""
  420. end
  421. else do
  422.   outval = mgen
  423.   mgen = noirn
  424.   noirn = ""
  425. end
  426. if mgen = "QUIET" || mgen = "NOREQ" then do
  427.   outval = mgen
  428.   mgen = ""
  429. end
  430.  
  431. MaxGens = 20
  432. /* due to the Roman numbers, we can't handle more than 40 */
  433. /* but due to speed limitations, I don't advise using more than 20 */
  434. if mgen ~= "" then do
  435.   if DATATYPE(mgen, 'w') & mgen > 0 & mgen < MaxGens then
  436.     MaxGens = mgen
  437. end
  438.  
  439. if outval = "QUIET" then do
  440.   usereq = 0
  441.   outp = 0
  442. end
  443. else if outval = "NOREQ" then
  444.   usereq = 0
  445.  
  446. /* if outname = "" then */
  447. /*  outname = "STDOUT"  */
  448.  
  449. if prtin = "" then do
  450.   prtopt = 0
  451.   if ~outp then TermError("Requires argument is missing.")
  452.     /* actually, with outp = 0, all it does is EXIT */
  453. end
  454. else do
  455.   prtopt = CheckAnswer(prtin)
  456.   /* Note that it was important to establish outp before calling these */
  457. end  
  458.  
  459. return 0
  460.  
  461. OpenPrinter:
  462. /* Open the printer device and print out a nice header */
  463. if outname = "STDOUT" then
  464.   prtdev = stdout
  465. else do
  466.   prtdev = "PRINTER"
  467.   if ~open(prtdev, outname, 'w') then
  468.     TermError("ERROR: Failed to open output file!")
  469. end
  470. writeln(prtdev, prtinit||prtnlqon)
  471. if prtopt = 1 then
  472.   prtstr = "PEDIGREE CHART - MALE ANCESTOR LINE ONLY"
  473. else if prtopt = 2 then
  474.   prtstr = "PEDIGREE CHART - ALL ANCESTORS, NO SIBLINGS"
  475. else if prtopt = 3 then
  476.   prtstr = "PEDIGREE CHART - ALL ANCESTORS, ONLY SIBLINGS OF LAST GENERATION"
  477. else
  478.   prtstr = "PEDIGREE CHART - ALL ANCESTORS, ALL SIBLINGS"
  479. prtstr = prtundon||prtdson||prtstr||prtdsoff||prtundoff
  480. writeln(prtdev, prtstr)
  481. prtstr = prtdson||"Report printed on: "||date()||prtdsoff
  482. writeln(prtdev, prtstr)
  483. prtstr = copies('=', plwidth)
  484. writeln(prtdev, prtstr)
  485. return 0
  486.  
  487. PrintLines: PROCEDURE EXPOSE prtdev plwidth prtopt
  488. parse arg ostr, fill
  489. /* TO DO:
  490.  * if there are control strings within ostr (like prtdson or prtdsoff)
  491.  * don't include them in the length count
  492.  */
  493. do while ostr ~= ""
  494.   nnl = plwidth+1
  495.   if length(ostr) > plwidth then do
  496.     do until pc = ' ' | nnl = 1
  497.       pc = substr(ostr, nnl, 1)
  498.       nnl = nnl - 1
  499.     end
  500.     if nnl = 1 then do
  501.       prtstr = left(ostr, plwidth)
  502.       ostr = delstr(ostr, 1, nnl)
  503.     end
  504.     else do
  505.       prtstr = left(ostr, nnl)
  506.       ostr = delstr(ostr, 1, nnl+1)
  507.     end
  508.   end
  509.   else do
  510.     prtstr = ostr
  511.     ostr = ""
  512.   end
  513.   writeln(prtdev, prtstr)
  514.   if ostr ~= "" then
  515.     ostr = copies(' ',fill)||ostr
  516. end
  517. return 0
  518.  
  519. PrintLF:
  520. writeln(prtdev, "")
  521. return 0
  522.  
  523. PrintSiblings: PROCEDURE EXPOSE prtdev plwidth prtopt useirn
  524. parse arg inum, prenum
  525. GETPARENTS inum
  526. famfgrn = RESULT
  527. EXISTFAMILY famfgrn
  528. if RESULT ~= 'YES' then return 0; /* no parents, then no siblings */
  529. ix = 0; chnum = 0
  530. do until ischld ~= 'YES'
  531.   GETCHILD famfgrn ix
  532.   prsn = RESULT
  533.   EXISTPERSON prsn
  534.   ischld = RESULT
  535.   if ischld = 'YES' & prsn ~= inum then do
  536.     chnum = chnum + 1
  537.     ostr = copies(' ',7)||prenum||D2C(chnum+96)". "||GetPersonStr(prsn)
  538.     PrintLines(ostr, 11)
  539.     if chnum = 26 then return 0; /* 'z': can't handle more than 26 children */
  540.   end
  541.   ix = ix + 1
  542. end
  543. return 0
  544.  
  545. GetGenStr: PROCEDURE EXPOSE prtopt GenerationS.
  546. parse arg gnum, fill
  547. if gnum <= 20 then
  548.   gstr = word(GenerationS.1, gnum)
  549. else if gnum <= 40 then
  550.   gstr = word(GenerationS.2, gnum)
  551. else
  552.   return ""
  553. if prtopt = 1 then gstr = left(gstr||".     ",fill)
  554. return gstr
  555.  
  556. GetPersonStr: PROCEDURE EXPOSE useirn
  557. parse arg irn
  558. if irn ~= 0 then do
  559.   nstr = GetNameStr(irn)
  560.   nstr = nstr||GetBirthStr(irn)
  561.   nstr = nstr||GetDeathStr(irn)
  562. end
  563. else
  564.   nstr = "UNKNOWN"
  565. return nstr
  566.  
  567. GetNameStr: PROCEDURE EXPOSE useirn
  568. parse arg gnum
  569. /* prtdson = '1B'x||"[1m";    * ESC[1m boldface on    */
  570. /* prtdsoff = '1B'x||"[22m";  * ESC[22m boldface off  */
  571. GETFIRSTNAME gnum
  572. name = RESULT
  573. if name ~= "" then name = name||" "
  574. GETLASTNAME gnum
  575. lname = RESULT
  576. if lname = "" then lname = "UNKNOWN"
  577. name = name||lname
  578. /* another option: name = name||prtdson||lname||prtdsoff
  579.  * Problem: see PrintLines
  580.  */
  581. if useirn then name = name||" ["gnum"]"
  582. return name
  583.  
  584. GetBirthStr: PROCEDURE
  585. parse arg gnum
  586. GETBIRTHPLACE gnum
  587. bstr = RESULT
  588. GETBIRTHDATE gnum
  589. bdat = RESULT
  590. if bdat ~= "" & bstr ~= "" then bstr = bstr||" "
  591. bstr = bstr||bdat
  592. if bstr ~= "" then bstr = ", b: "||bstr
  593. return bstr
  594.  
  595. GetDeathStr: PROCEDURE
  596. parse arg gnum
  597. GETDEATHPLACE gnum
  598. dstr = RESULT
  599. GETDEATHDATE gnum
  600. ddat = RESULT
  601. if ddat ~= "" & dstr ~= "" then dstr = dstr||" "
  602. dstr = dstr||ddat
  603. if dstr ~= "" then dstr = ", d: "||dstr
  604. return dstr
  605.  
  606. GetMarriages: PROCEDURE EXPOSE useirn
  607. parse arg irn
  608. mstr = ""
  609. GETMARRIAGE irn 0
  610. mf = RESULT
  611. EXISTFAMILY mf
  612. if RESULT = 'YES' then do
  613.   mtrue = 1
  614.   GETMARRIAGE irn 1
  615.   m2 = RESULT
  616.   EXISTFAMILY m2
  617.   if RESULT = 'YES' then mset = 1
  618.   else mset = 0
  619. end
  620. else
  621.   mtrue = 0  
  622. mnum = 0
  623. do while mtrue
  624.   m1 = GetMarriageStr(mf)
  625.   if m1 ~= "" then m1  = m1||' '
  626.   ptn = GetPartnerIRN(mf, irn)
  627.   m1 = m1||GetPersonStr(ptn)
  628.  
  629.   mnum = mnum + 1
  630.   if mset then mstr = mstr||", m("||mnum||"): "||m1
  631.   else mstr = mstr||", m: "||m1
  632.  
  633.   GETMARRIAGE irn mnum
  634.   mf = RESULT
  635.   EXISTFAMILY mf
  636.   if RESULT ~= 'YES' then mtrue = 0
  637. end
  638. return mstr
  639.  
  640. GetMarriageStr: PROCEDURE
  641. parse arg mf
  642. GETMARRYPLACE mf
  643. mstr = RESULT
  644. GETMARRYDATE mf
  645. mdat = RESULT
  646. if mdat ~= "" & mstr ~= "" then mstr = mstr||" "
  647. mstr = mstr||mdat
  648. return mstr
  649.  
  650. GetParentsIRN: PROCEDURE EXPOSE GENTREE.
  651. parse arg fnum, ct, ct1
  652. fath = 0; moth = 0
  653. GETSPOUSE fnum
  654. sps = RESULT
  655. EXISTPERSON sps
  656. if RESULT = 'YES' then do
  657.   GETSEX sps
  658.   if RESULT = 'M' then
  659.     fath = sps
  660.   else moth = sps
  661. end
  662. GETPRINCIPAL fnum
  663. prn = RESULT
  664. /* If there are two mothers, or two fathers, then name the principal
  665.  * as 'father' and the spouse as 'mother'
  666.  */
  667. EXISTPERSON prn
  668. if RESULT = 'YES' then do
  669.   GETSEX prn
  670.   if RESULT = 'M' then do
  671.     if fath ~= 0 then
  672.       moth = sps
  673.     fath = prn
  674.   end
  675.   else if moth ~= 0 then
  676.     fath = prn
  677.   else
  678.     moth = prn
  679. end
  680. GENTREE.ct = fath
  681. GENTREE.ct1 = moth
  682. return 0
  683.  
  684. GetPartnerIRN: PROCEDURE
  685. parse arg fnum, inum
  686. GETPRINCIPAL fnum
  687. prn = RESULT
  688. GETSPOUSE fnum
  689. sps = RESULT
  690. if inum = prn then pnum = sps
  691. else if inum = sps then pnum = prn
  692. else pnum = 0
  693. return pnum
  694.  
  695. CheckAnswer: PROCEDURE EXPOSE outp prtdev usereq
  696. parse arg str
  697. str = left(str, 1)
  698. if ~DATATYPE(str, 'w') then
  699.   TermError("Arg(1): not a valid option number.")
  700. if str < 1 | str > 4 then
  701.   TermError("Arg(1): not a valid option number.")
  702. return  str
  703.  
  704. CheckIRN: PROCEDURE EXPOSE outp prtdev usereq
  705. parse arg str
  706. if ~DATATYPE(str, 'w') then
  707.   TermError("Arg(2): not a valid IRN..")
  708. return str
  709.  
  710. Tell: PROCEDURE EXPOSE outp
  711. parse arg str
  712. if outp then
  713.   writeln(stdout, str)
  714. return 0
  715.  
  716. TellNN: PROCEDURE EXPOSE outp
  717. /* Tell, No Newline */
  718. parse arg str
  719. if outp then
  720.   writech(stdout, str)
  721. return 0
  722.  
  723. TermError: PROCEDURE EXPOSE outp prtdev usereq PSCR
  724. parse arg str
  725. /* If you turned off stdout, no error messages will be shown! */
  726. if usereq then
  727.   rtezrequest(str,'E_xit','PrintPedigree Message:','rt_pubscrname = '||PSCR)
  728. else do
  729.   Tell(str || '0A'x)
  730. end
  731. close(prtdev)
  732. EXIT
  733.  
  734. /* Let's make sure you get a nice message when you turn off the printer :-) */
  735.  
  736. IOERR:
  737.   bline = SIGL
  738.   say "I/O error #"||RC||" detected in line "||bline||":"
  739.   say sourceline(bline)
  740.   EXIT
  741.