home *** CD-ROM | disk | FTP | other *** search
/ The AGA Experience 2 / agavol2.iso / rexx / scion2gedcom.rexx < prev    next >
OS/2 REXX Batch file  |  1995-10-05  |  18KB  |  582 lines
  1. /****************************************************************************
  2.  *                                                                          *
  3.  * $VER: Scion2GEDCOM 2.13 (29 Sep 1995)
  4.  *                                                                          *
  5.  *                      Written by Freddy Ariës                             *
  6.  *                                                                          *
  7.  * This program was created to export the Scion data into the GEDCOM file   *
  8.  * format. It should work pretty good by now, although no guarantees        *
  9.  * whatsoever can be given. If you have any problems using this script,     *
  10.  * please describe them to me, as detailed as possible (and please also     *
  11.  * tell me what program you are using to read the GEDCOM file), then I will *
  12.  * try to work out a solution.                                              *
  13.  *                                                                          *
  14.  * GEDCOM was developed by the Family History Department of the Church of   *
  15.  * Jesus Christ of Latter-day Saints to provide a flexible uniform format   *
  16.  * for exchanging computerized genealogical data.  GEDCOM is an acronym for *
  17.  * GEnealogical Data Communication.  GEDCOM is provided to foster the       *
  18.  * sharing of genealogical information and the development of a wide range  *
  19.  * of inter-operable software products to assist genealogists, historians,  *
  20.  * and other researchers.                                                   *
  21.  *                                                                          *
  22.  * This script uses (by default) the rexxreqtools.library (which requires   *
  23.  * a version of reqtools larger than 2.0 and rexxsyslib.library)            *
  24.  * If you do not have these, you need to supply the NOREQ argument (for     *
  25.  * Shell output), or the QUIET argument (for no output at all).             *
  26.  *                                                                          *
  27.  * + Dates should be in English, and in the format "DD MMM YYYY" or         *
  28.  *   "DD-MMM-YYYY", if you don't want any problems with programs importing  *
  29.  *   the GEDCOM data.                                                       *
  30.  *   If the dates in your database are not in English, please run the       *
  31.  *   Translate.rexx script first!                                           *
  32.  * + The database must be running for this AREXX script to work.            *
  33.  *                                                                          *
  34.  * Now with progress indicator, using rexxarplib.library (requested by      *
  35.  * Master Robbie himself :-) )                                              *
  36.  *                                                                          *
  37.  * TO DO (but low priority, unless someone really wants this[?]):           *
  38.  *  - optional creation of external note-files, whenever necessary          *
  39.  *  - If date or place ends with a '?', remove the questionmark and add a   *
  40.  *    QUAY 1 to the data.                                                   *
  41.  *  - Add support for other character sets (now Amiga extended ASCII codes  *
  42.  *    are assumed, even though the GEDCOM format specifies the ANSEL codes  *
  43.  *    as the default)                                                       *
  44.  *  - Suggestions, comments, bugreports, donations, etc. are appreciated.   *
  45.  *                                                                          *
  46.  ****************************************************************************/
  47.  
  48. options failat 20; options results
  49. arg outname outval
  50.  
  51. versionstr = "2.13"
  52. usereq = 1; /* change this to 0 if you don't want to use reqtools */
  53. prgrs = 1; pgopen = 0; /* use RexxArp progress indicator */
  54.   /* change prgrs to 0 for not using it */
  55. outp = 1; output = stdout
  56. NL = '0A'x
  57.  
  58. signal on IOERR
  59.  
  60. /* parse command line options, to enable calling the script automatically,
  61.  * eg. from a function key
  62.  */
  63.  
  64. do while outname = '?'
  65.   writeln(stdout, "OUTFILE/A,QUIET/S,NOREQ/S ")
  66.   pull outname outval
  67. end
  68.  
  69. if outname ~= "" then do
  70.   if outname = "QUIET" | outname = "NOREQ" then do
  71.     outval = outname; outname = ""
  72.   end
  73. end
  74.  
  75. if outval = "QUIET" then do
  76.   outp = 0; usereq = 0; prgrs = 0
  77. end
  78. else if outval = "NOREQ" then do
  79.   usereq = 0; prgrs = 0
  80. end
  81.  
  82. if usereq & ~show('l','rexxreqtools.library') then do
  83.   if exists('libs:rexxreqtools.library') then
  84.     call addlib('rexxreqtools.library',0,-30,0)
  85.   else do
  86.     usereq = 0; outp = 1
  87.     Tell("Unable to open rexxreqtools.library - using text output")
  88.   end
  89. end
  90.  
  91. if ~usereq then prgrs = 0
  92.  
  93. if prgrs & ~show('l','rexxarplib.library') then do
  94.   if exists('libs:rexxarplib.library') then
  95.     call addlib('rexxarplib.library',0,-30,0)
  96.   else
  97.     prgrs = 0
  98. end
  99.  
  100. /* These first few lines are stolen from Peter Billings - thanks Peter ;-) */
  101. if ~show('P','SCIONGEN') then do
  102.   TermError('I am sorry to say that the SCION Genealogist' || NL ||,
  103.     'database is not available. Please start the' || NL ||,
  104.     'SCION program BEFORE using this script!')
  105. end
  106.  
  107. MyPort = "SCIONGEN"
  108. Address value MyPort
  109. GETDBNAME
  110. dbname = upper(RESULT)
  111.  
  112. if outp & ~usereq then do
  113.   Tell("Scion to GEDCOM conversion script v"||versionstr||" by Freddy Ariës")
  114.   Tell("Database: "||dbname|| NL)
  115. end
  116.  
  117. /* It's a good habit to add the ".scion" extension to Scion database files */
  118. dblen = length(dbname)
  119. if dblen>6 & right(dbname, 6)=".SCION" then dbname=left(dbname, dblen - 6)
  120.  
  121. if outname = "" then do
  122.   if outp then do
  123.     if usereq then do
  124.       odev = rtezrequest('Current Scion database: '||dbname||,
  125.        NL||'Where should the GEDCOM output be sent to?'||,
  126.        NL,' _File |_Printer|_Screen|_Nowhere','Scion to GEDCOM v'||versionstr||' by Freddy Ariës','rt_pubscrname = SCIONGEN')
  127.       select
  128.         when odev = 1 then do
  129.           /* We need a file requester for further data */
  130.           outname = rtfilerequest(,dbname||'.GED','Output filename',,'rtfi_buffer = true   rt_pubscrname = SCIONGEN   rtfi_initialpath = RAM:',)
  131.           if outname = '' then
  132.             outname = dbname||'.GED'
  133.         end
  134.         when odev = 2 then
  135.           outname = 'PRT:'
  136.         when odev = 3 then
  137.           outname = 'STDOUT'
  138.         otherwise
  139.           EXIT
  140.           /* You selected 'Nowhere' */
  141.       end
  142.     end
  143.     else do
  144.       Tell("Enter output file (filename with complete path, or PRT: for printer,")
  145.       TellNN("or STDOUT for screen): ")
  146.       pull outname
  147.       Tell("Destination: "||outname)
  148.       TellNN("Continue (y/n)? ")
  149.       pull conf
  150.       /* Note that left works on empty strings ("") too! */
  151.       if left(conf,1) ~= "Y" then do
  152.         Tell("Goodbye...")
  153.         EXIT
  154.       end
  155.       Tell("")
  156.     end
  157.   end
  158.   else
  159.     outname = "RAM:"dbname".GED"
  160.     /* If we're not allowed to use stdout, default to this filename */
  161. end
  162.  
  163. if outname ~= "STDOUT" then do
  164.   output = 'OUTPUT'
  165.   if ~open(output, outname, "w") then
  166.     TermError("ERROR: Unable to open output file.")
  167. end
  168.  
  169. if ~usereq then
  170.   Tell("Be patient - this may take a while...")
  171.  
  172. GETPROGVERSION
  173. prgvers = RESULT
  174.  
  175. writeln(output, "0 HEAD")
  176. writeln(output, "1 SOUR SCION_AMIGA")
  177. writeln(output, "2 NAME Scion Genealogist")
  178. writeln(output, "2 VERS "||prgvers)
  179. writeln(output, "2 CORP Robbie J. Akins")
  180. writeln(output, "3 ADDR 5 Austin Street, Wellington 6001, New Zealand")
  181.  
  182. str = "1 DATE" upper(date())
  183. writeln(output, str)
  184. writeln(output, "1 @S1@ SUBM")
  185. str = "1 FILE" dbname
  186. writeln(output, str)
  187. writeln(output, "1 GEDC")
  188. writeln(output, "2 VERS 5.3")
  189. writeln(output, "1 CHAR 8-bit Extended ASCII (AMIGA)")
  190.  
  191. if prgrs then do
  192.   Postmsg(10, 10, "Scion to GEDCOM (by Freddy Ariës)\Database: "||dbname||"\Processing person:\ ", "SCIONGEN")
  193.   pgopen = 1
  194. end
  195.  
  196. GETTOTALIRN
  197. TotalIRN = RESULT
  198. do i = 1 to TotalIRN
  199.   if pgopen then Postmsg(,,"\\\"||i||" (of "||TotalIRN||")", "SCIONGEN")
  200.   EXISTPERSON i
  201.   if RESULT = 'YES' then
  202.   do
  203.     str = "0 @I"i"@ INDI"
  204.     writeln(output, str)
  205.     GETFIRSTNAME i
  206.     fnames = RESULT
  207.     fnames = translate(fnames, ';', '/')
  208.     /* Fixed since v2.13: no '/' characters allowed in GEDCOM namestring! */
  209.     GETLASTNAME i
  210.     lname = RESULT
  211.     lname = translate(lname, ';', '/')
  212.     str = "1 NAME "fnames"/"lname"/"
  213.     writeln(output, str)
  214.     GETSEX i
  215.     sx = RESULT
  216.     if sx ~= "M" then do
  217.      sx = "F"
  218.     end
  219.     str = "1 SEX" sx
  220.     writeln(output, str)
  221.     GETBIRTHDATE i
  222.     datestr = ParseDate(upper(RESULT))
  223.     GETBIRTHPLACE i
  224.     placestr = RESULT
  225.     if datestr ~= "" | placestr ~= "" then do
  226.       writeln(output, "1 BIRT")
  227.       if datestr ~= "" then do
  228.         str = "2 DATE" datestr
  229.         writeln(output, str)
  230.       end
  231.       if placestr ~= "" then do
  232.         str = "2 PLAC" placestr
  233.         writeln(output, str)
  234.       end
  235.     end
  236.     GETBAPTISMDATE i
  237.     datestr = ParseDate(upper(RESULT))
  238.     GETBAPTISMPLACE i
  239.     placestr = RESULT
  240.     if datestr ~= "" | placestr ~= "" then do
  241.       writeln(output, "1 BAPM")
  242.       if datestr ~= "" then do
  243.         str = "2 DATE" datestr
  244.         writeln(output, str)
  245.       end
  246.       if placestr ~= "" then do
  247.         str = "2 PLAC" placestr
  248.         writeln(output, str)
  249.       end
  250.     end
  251.     GETDEATHDATE i
  252.     datestr = ParseDate(RESULT)
  253.     GETDEATHPLACE i
  254.     placestr = RESULT
  255.     GETDIEDOF i
  256.     diedofstr = RESULT
  257.     if datestr ~= "" | placestr ~= "" | diedofstr ~= "" then do
  258.       writeln(output, "1 DEAT")
  259.       if datestr ~= "" then do
  260.     str = "2 DATE" datestr
  261.     writeln(output, str)
  262.       end
  263.       if placestr ~= "" then do
  264.     str = "2 PLAC" placestr
  265.     writeln(output, str)
  266.       end
  267.       if datestr ~= "" then do
  268.     str = "2 CAUS" diedofstr
  269.     writeln(output, str)
  270.       end
  271.     end
  272.     GETBURIALDATE i
  273.     datestr = ParseDate(RESULT)
  274.     GETBURIALPLACE i
  275.     placestr = RESULT
  276.     if datestr ~= "" | placestr ~= "" then do
  277.       writeln(output, "1 BURI")
  278.       if datestr ~= "" then do
  279.     str = "2 DATE" datestr
  280.     writeln(output, str)
  281.       end
  282.       if placestr ~= "" then do
  283.     str = "2 PLAC" placestr
  284.     writeln(output, str)
  285.       end
  286.     end
  287.     GETOCCUPATION i
  288.     rs1 = RESULT
  289.     if rs1 ~= "" then do
  290.       str = "1 OCCU" rs1
  291.       writeln(output, str)
  292.     end
  293.     GETEDUCATION i
  294.     rs1 = RESULT
  295.     if rs1 ~= "" then do
  296.       str = "1 EDUC" rs1
  297.       writeln(output, str)
  298.     end
  299.     GETRELIGION i
  300.     rs1 = RESULT
  301.     if rs1 ~= "" then do
  302.       str = "1 RELI" rs1
  303.       writeln(output, str)
  304.     end
  305.     GETPERSCOMMENT i
  306.     rs1 = RESULT
  307.     GETPERSREFS i
  308.     rs2 = RESULT
  309.     if rs1 ~= "" then do
  310.       str = "1 NOTE" rs1
  311.       writeln(output, str)
  312.     end
  313.     else if rs2 ~= "" then do
  314.       /* We need some way to separate the Comments data from the
  315.        * References data - (ab)use the NOTE and CONT fields for that
  316.        */
  317.       str = "1 NOTE -"
  318.       writeln(output, str)
  319.     end
  320.     if rs2 ~= "" then do
  321.       str = "2 CONT" rs2
  322.       writeln(output, str)
  323.     end
  324.     GETPARENTS i
  325.     ParFGRN = RESULT
  326.     EXISTFAMILY ParFGRN
  327.     if RESULT = 'YES' then do
  328.       str = "1 FAMC @F"ParFGRN"@"
  329.       writeln(output, str)
  330.     end
  331.     HuwNum = 0
  332.     GETMARRIAGE i HuwNum
  333.     MarrFGRN = RESULT
  334.     do while MarrFGRN ~= ""
  335.       EXISTFAMILY MarrFGRN
  336.       if RESULT = 'YES' then do
  337.         str = "1 FAMS @F"MarrFGRN"@"
  338.         writeln(output, str)
  339.       end
  340.       HuwNum = HuwNum + 1
  341.       GETMARRIAGE i HuwNum
  342.       MarrFGRN = RESULT
  343.     end
  344.   end
  345. end
  346. if ~usereq then
  347.   Tell("Number of persons output: "||TotalIRN)
  348.  
  349. /* Now the list of families... */
  350.  
  351. if pgopen then Postmsg(,, "\\Processing family:\ ", "SCIONGEN")
  352.   
  353. GETTOTALFGRN
  354. TotalFGRN = Result
  355. do i = 1 to TotalFGRN
  356.   if pgopen then Postmsg(,, "\\\"||i||" (of "||TotalFGRN||")", "SCIONGEN")
  357.   EXISTFAMILY i
  358.   if RESULT = 'YES' then do
  359.     str = "0 @F"i"@ FAM"
  360.     writeln(output, str)
  361.     GETPRINCIPAL i
  362.     husb = RESULT
  363.     if husb ~= "" then do
  364.       EXISTPERSON husb
  365.       if RESULT = 'YES' then do
  366.     GETSEX husb
  367.     hsx = RESULT
  368.     /* Note: GEDCOM requires 1 husband (male) and 1 wife (female).
  369.      * Scion allows more unconventional matings as well, so we have
  370.      * to improvise a bit here, and hope the receiving program isn't
  371.      * too strict...
  372.      */
  373.     if hsx = "M" then do
  374.       str = "1 HUSB @I"husb"@"
  375.       writeln(output, str)
  376.       GETSPOUSE i
  377.       wife = RESULT
  378.       if wife ~= "" then do
  379.         EXISTPERSON wife
  380.         if RESULT = 'YES' then do
  381.           /* The principal is male; assume the partner is female */
  382.           str = "1 WIFE @I"wife"@"
  383.           writeln(output, str)
  384.         end
  385.       end    
  386.     end
  387.     else do
  388.       /* The principal isn't male - define the partner as male
  389.          and the principal as female
  390.        */
  391.       if hsx ~= "F" then do
  392.             if usereq then
  393.           rtezrequest('WARNING: Unrecognized Sex for Principal'||NL||,
  394.                 'Sex was:'||hsx||'. Assuming FEMALE!','_Continue','Converter Message:','rt_pubscrname = SCIONGEN')
  395.             else
  396.           Tell("WARNING: Unrecognized Sex for Principal ("||hsx||") - assuming FEMALE")
  397.       end
  398.       GETSPOUSE i
  399.       wife = RESULT
  400.       if wife ~= "" then do
  401.         EXISTPERSON wife
  402.         if RESULT = 'YES' then do
  403.           GETSEX wife
  404.           hsx = RESULT
  405.           if hsx ~= "M" then do
  406.             if usereq then
  407.               rtezrequest('WARNING: No male partner in family!','_Continue','Converter Message:','rt_pubscrname = SCIONGEN')
  408.                 else
  409.           Tell("WARNING: No male partner in family!")
  410.               end
  411.           str = "1 HUSB @I"wife"@"
  412.           writeln(output, str)
  413.         end
  414.       end
  415.       str = "1 WIFE @I"husb"@"
  416.       writeln(output, str)
  417.     end
  418.       end
  419.     end
  420.     GETENGAGEDATE i
  421.     datestr = ParseDate(RESULT)
  422.     GETENGAGEPLACE i
  423.     placestr = RESULT
  424.     if datestr ~= "" | placestr ~= "" then do
  425.       writeln(output, "1 ENGA")
  426.       if datestr ~= "" then do
  427.         str = "2 DATE" datestr
  428.     writeln(output, str)
  429.       end
  430.       if placestr ~= "" then do
  431.     str = "2 PLAC" placestr
  432.     writeln(output, str)
  433.       end
  434.     end
  435.     datestr = ""; placestr = ""
  436.     GETMARRYDATE i
  437.     datestr = ParseDate(RESULT)
  438.     GETMARRYPLACE i
  439.     placestr = RESULT
  440.     GETCELEBRANT
  441.     clbrnt = RESULT
  442.     if datestr ~= "" | placestr ~= "" | clbrnt ~= "" then do
  443.       writeln(output, "1 MARR")
  444.       if datestr ~= "" then do
  445.         str = "2 DATE" datestr
  446.     writeln(output, str)
  447.       end
  448.       if placestr ~= "" then do
  449.     str = "2 PLAC" placestr
  450.     writeln(output, str)
  451.       end
  452.       if clbrnt ~= "" then do
  453.     str = "2 OFFI" clbrnt
  454.     writeln(output, str)
  455.       end
  456.     end
  457.     GETENDING i
  458.     endstr = RESULT
  459.     if endstr = "2" | endstr = "3" | endstr = "4" then do
  460.       if endstr = "2" then do
  461.         writeln(output, "1 DIV")
  462.         writeln(output, "2 TYPE DIVORCED")
  463.       end
  464.       else if endstr = "3" then do
  465.         writeln(output, "1 DIV")
  466.         writeln(output, "2 TYPE SEPARATED")
  467.       end
  468.       else if endstr = "4" then
  469.         writeln(output, "1 ANUL")
  470.       datestr = ""; placestr = ""
  471.       GETENDDATE i
  472.       datestr = ParseDate(RESULT)
  473.       if datestr ~= "" then do
  474.         str = "2 DATE" datestr
  475.     writeln(output, str)
  476.       end
  477.       GETENDPLACE i
  478.       placestr = RESULT
  479.       if placestr ~= "" then do
  480.     str = "2 PLAC" placestr
  481.     writeln(output, str)
  482.       end
  483.       /* TO DO: how do we convert an enddate/place caused by death ? */
  484.     end
  485.     GETFAMREFS i
  486.     rs1 = RESULT
  487.     GETFAMCOMMENT i
  488.     rs2 = RESULT
  489.     if rs2 ~= "" then do
  490.       str = "1 NOTE" rs2
  491.       writeln(output, str)
  492.     end
  493.     else if rs1 ~= "" then do
  494.       /* We need some way to separate the Reference data from the
  495.        * Comments data - (ab)use the NOTE and CONT fields for that
  496.        */
  497.       str = "1 NOTE -"
  498.       writeln(output, str)
  499.     end
  500.     if rs1 ~= "" then do
  501.       str = "2 CONT" rs1
  502.       writeln(output, str)
  503.     end
  504.  
  505.     ChNum = 0
  506.     GETCHILD i ChNum
  507.     ChIRN = RESULT
  508.     do while ChIRN ~= ""
  509.       EXISTPERSON ChIRN
  510.       if RESULT = 'YES' then do
  511.         str = "1 CHIL @I"ChIRN"@"
  512.         writeln(output, str)
  513.       end
  514.       ChNum = ChNum + 1
  515.       GETCHILD i ChNum
  516.       ChIRN = RESULT
  517.     end
  518.     /* optional:
  519.        str = "1 NCHI" ChNum
  520.        writeln(output, str)
  521.      */
  522.   end
  523. end
  524. if pgopen then do
  525.   Postmsg()
  526.   pgopen = 0
  527. end
  528. if usereq then
  529.   rtezrequest('Conversion done.'||NL||'Number of persons output: '||TotalIRN||,
  530.     NL||'Number of families output: '||TotalFGRN||NL,'_Continue','Converter Message:','rt_pubscrname = SCIONGEN')
  531. else
  532.   Tell("Number of families output: "||TotalFGRN)
  533.  
  534. writeln(output, "0 TRLR")
  535. close('OUTPUT')
  536. EXIT
  537.  
  538. ParseDate: PROCEDURE
  539. parse arg datestr
  540.  
  541. /* optional: remove leading zero's */
  542. /* replace all "-" or "/" in the date by " " */
  543. datestr = upper(translate(datestr,'  ','-/'))
  544. /* replace ABOUT by ABT, BEFORE by BEF and AFTER by AFT */
  545. if left(datestr, 5) = "ABOUT" then
  546.   datestr = "ABT"||right(datestr,length(datestr)-5)
  547. else if left(datestr, 6) = "BEFORE" then
  548.   datestr = "BEF"||right(datestr,length(datestr)-6)
  549. else if left(datestr, 5) = "AFTER" then
  550.   datestr = "AFT"||right(datestr,length(datestr)-5)
  551. return datestr
  552.  
  553. Tell: PROCEDURE EXPOSE outp
  554. parse arg str
  555. if outp then writeln(stdout, str)
  556. return 0
  557.  
  558. TellNN: PROCEDURE EXPOSE outp
  559. parse arg str
  560. if outp then writech(stdout, str)
  561. return 0
  562.  
  563. TermError: PROCEDURE EXPOSE outp output usereq pgopen
  564. parse arg str
  565. if pgopen then Postmsg()
  566. /* If you turned off stdout, no error messages will be shown! */
  567. if usereq then
  568.   rtezrequest(str,'E_xit','Converter Message:','rt_pubscrname = SCIONGEN')
  569. else
  570.   Tell(str || '0A'x)
  571. close(output)
  572. EXIT
  573.  
  574. /* Let's make sure you get a nice message when you turn off the printer :-) */
  575.  
  576. IOERR:
  577.   bline = SIGL
  578.   say "I/O error #"||RC||" detected in line "||bline||":"
  579.   say sourceline(bline)
  580.   if pgopen then Postmsg()
  581.   EXIT
  582.