Fresh Fish 10/Fresh_Fish_10_2352.bin/new/biz/dbase/genealogist/scionarexx.lha/GEDCOM2Scion.rexx

OS/2 REXX Batch file | 1995-06-02 | 29.6 KB | 1,011 lines

/****************************************************************************
 *                                                                          *
 *                                                                          *
 * $VER: GEDCOM2Scion.rexx 2.11 (23 May 1995)
 *                                                                          *
 *                      Written by Freddy Ariës                             *
 *                                                                          *
 * This program was created to import GEDCOM data into the Scion database.  *
 * It is still very basic, which means it will only be able to parse the    *
 * most basic GEDCOM files, and I can't even guarantee that it will handle  *
 * these correctly...                                                       *
 *                                                                          *
 * This version 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, you need to supply the NOREQ argument (for     *
 * Shell output), or the QUIET argument (for no output at all).             *
 *                                                                          *
 * Even though this script does no parsing of dates, it's safer if they are *
 * in the exact format "DD MMM YYYY".                                       *
 * All unrecognized fields or fields that Scion doesn't use, are skipped.   *
 * The database must be running for this AREXX script to work.              *
 *                                                                          *
 * New (requested by Robbie): progress indicator, using rexxarplib.library  *
 *                                                                          *
 * NOTE: The program generates a file DATABASE.err (where DATABASE is the   *
 *  name of the GEDCOM file read), in the directory where the GEDCOM file   *
 *  is located. This .err file contains parsing info about which lines were *
 *  skipped and which non-fatal errors were encountered. It may be a good   *
 *  idea to read this file!                                                 *
 *  FAMS and FAMC fields, and EVEN structures will always be skipped,       *
 *  because I use another method of establishing family (spouse & children) *
 *  relationships. If no relationships are established, this probably means *
 *  that the imported file does not support that other method. If you       *
 *  encounter such a file, please send it to me, and tell me what program   *
 *  generated it. If this happens a lot, I will add support for the parsing *
 *  of these relations in a future version.                                 *
 *                                                                          *
 * (still TO DO, but low priority, unless someone really wants this):       *
 *  - Better parsing of dates                                               *
 *    Recognition and use of ABT, BEF, AFT notations                        *
 *  - Add support for EVEN(t) structures                                    *
 *  - I'm thinking of a way to allow modifying an existing database. The    *
 *    current version will only add to a database, and doesn't care for     *
 *    double entries.                                                       *
 *                                                                          *
 ****************************************************************************/

options failat 20; options results
arg inname inval

versionstr = "2.11"
lnum = 0; outp = 1; output = stdout
usereq = 1; /* change this to 0 if you don't want to use reqtools */
prgrs = 1; pgopen = 0; /* use RexxArp progress indicator */
  /* change prgrs to 0 for not using it */
NL = '0A'x

signal on IOERR

/* parse command line options, to enable calling the script automatically,
 * eg. from a function key
 */

do while inname = '?'
  writeln(stdout, "INFILE/A,QUIET/S,NOREQ/S ")
  pull inname inval
end

if inname ~= "" then do
  if inname = "QUIET" | inname = "NOREQ" then do
    inval = inname; inname = ""
  end
end

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

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

if ~usereq then prgrs = 0

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

/* These first few lines are stolen from Peter Billings - thanks Peter ;-) */
if ~show('P','SCIONGEN') then do
  TermError('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)

if outp & ~usereq then do
  Tell("GEDCOM to Scion conversion script v"||versionstr||" by Freddy Ariës")
  Tell("Scion (output) database: "||dbname)
end

if inname = "" then do
  /* ignore the value of outp; if we can't ask for the input file,
   * we can't do anything!
   */
  if usereq then do
    /* We need a file requester for further data */
    inname = rtfilerequest(,,'GEDCOM Input File',,'rtfi_buffer = true   rt_pubscrname = SCIONGEN   rtfi_initialpath = RAM:',)
  end
  else do
    Tell("Please enter the filename (with complete path) of the GEDCOM file:")
    TellNN("Input file: ")
    pull inname
  end
  if inname = '' then
    TermError("ERROR: No Input File!")
end

if ~open(infile, inname, "r") then
  TermError("ERROR: Input file '"inname"' not found!")

if ~usereq then
  Tell("Be patient - this may take a while...")

/* Initialize line count, individual counter and family counter */
ink = GetNextLine()
if left(ink, 6) ~= "0 HEAD" then do
  close(infile)
  TermError("ERROR: Invalid beginning of file - not a valid GEDCOM format")
end

lvlstr = '0'; lvl = 1; atlvl = 1
IRNArr. = 0; FGRNArr. = 0

/* Read the "HEAD" section until we find something else of level "0" */

prstot = ""
ink = ParseHeader(atlvl)
GETPROGVERSION
prsr = RESULT
prsr = "Destination:   Scion Genealogist "||prsr
if ~usereq then
  Tell(prsr)
else
  prstot = prstot||prsr||NL
prsr = "Dest. file:    "||dbname
if ~usereq then
  Tell(prsr)
else do
  prstot=prstot||prsr||NL||NL||"Parsing will take a while - be patient."||,
    NL||"Click `Continue' to start parsing..."
  rv = rtezrequest(prstot,'_Continue| _Abort ','Converter Message:','rt_pubscrname = SCIONGEN')
  if rv = 0 then EXIT
end

/* TO DO: if inname ends on .GED, strip the extension */
if ~open(errfile, inname||".err", "w") then
  errfile = stdout

/* Now scan the following level "0" fields for individuals;
 * skip the families, for the moment
 */

irn = 0

if prgrs then do
  Postmsg(10, 10, "GEDCOM to Scion (by Freddy Ariës)\Database: "||,
    StripPath(inname)||"\Persons parsed: "||irn||"\", "SCIONGEN")
  pgopen = 1
end

replay = 0
do while ~eof(infile)
  lvlstr = word(ink, 1)
  lvl = GetNumType(lvlstr)

  if lvl = atlvl then do
    tagstr = upper(word(ink, words(ink)))
    if tagstr = "INDI" then do
      nstr = strip(word(ink, 2),'B','@'||xrange('A','Z'))
      if DATATYPE(nstr) = 'NUM' then do
        tp = GGetIRN(nstr)
        if tp ~= 0 then
          writeln(errfile, "ERROR: Duplicate person encountered: "||nstr||" (IRN "||tp||") (line: "||lnum||")")
        irn = irn + 1
    if pgopen then Postmsg(,, "\\Persons parsed: "||irn||"\", "SCIONGEN")
        ink = ParsePerson(nstr, lvl)
        if ink ~= "" then replay = 1
      end
      else TermError("ERROR: Cannot determine the Individual Record Number! (line: "||lnum||")")
    end
  end
  /* Skip all lines with level ~= current level (0) */
  if replay = 0 then ink = GetNextLine()
  else replay = 0
end

if ~usereq then do
  Tell("Number of persons parsed: "||irn)
  GETTOTALIRN
  tot = RESULT

/* optional, as extra check:
  Tell("Total number of persons in the Scion database: "||tot)
 */
end

/* Now rescan the entire file for families; I know it is quite
 * inefficient this way, but it's better to add all the persons first,
 * and then establish the relations...
 */

close(infile)
if ~open(infile, inname, "r") then
  TermError("ERROR: Unable to read relations!")

if ~usereq then
  Tell("Scanning file again to establish relations...")

lvlstr = '0'; lvl = 1; atlvl = 1
fgrn = 0; lnum = 0; fxs = 0; finp = 0; ffile = 0

if pgopen then Postmsg(,, "\\\Families parsed: "||fgrn, "SCIONGEN")

replay = 0
do while ~eof(infile)
  if replay = 0 then ink = GetNextLine()
  else replay = 0

  lvlstr = word(ink, 1)
  lvl = GetNumType(lvlstr)

  if lvl = atlvl then do
    tagstr = upper(word(ink, words(ink)))
    if tagstr = "FAM" then do
      nstr = strip(word(ink, 2),'B','@'||xrange('A','Z'))
      if DATATYPE(nstr) = 'NUM' then do
        fp = GGetFGRN(nstr)
        if fp ~= 0 then
          writeln(errfile, "WARNING: Duplicate family encountered: "||nstr||" (FGRN "||fp||") (line: "||lnum||")")
        /* TO DO: if the above necessary? Or can we go on parsing? */
        else
          fgrn = fgrn + 1
    if pgopen then Postmsg(,, "\\\Families parsed: "||fgrn, "SCIONGEN")
        ink = ParseFamily(nstr, lvl)
        if ink ~= "" then replay = 1
      end
      else TermError("ERROR: Cannot determine the Family Group Record Number! (line: "||lnum||")")
    end
    else if tagstr = "TRLR" then do
      close(infile)
      if pgopen then do
        Postmsg()
        pgopen = 0
      end
      GETTOTALFGRN
      ftot = RESULT
      if usereq then do
    GETTOTALIRN
    itot = RESULT
        TermError("PARSING DONE:"||NL||"Number of persons parsed: "||irn||,
          NL||"Number of families parsed: "||fgrn||,
      NL||NL||"DON'T FORGET TO SAVE YOUR SCION FILE!!!")

/* optional, as extra check:
      NL||"Total number of persons in the Scion database: "||itot||,
      NL||"Total number of families in the Scion database: "||ftot||,
 */

      end
      else do
    Tell("Number of families parsed: "||fgrn)
        TermError("DONE! DON'T FORGET TO SAVE YOUR SCION FILE!!!")

/* optional, as extra check:
    Tell("Total number of families in the Scion database: "||ftot)
 */
      end
    end
  end
  /* Skip all the fields at lvl ~= this level */
end
close(infile)
if ink ~= "0 TRLR" then
  TermError("ERROR: Unexpected end of file")
else
  TermError("ERROR: Trailer not recognized! (line: "||lnum||")")

ParseHeader: PROCEDURE EXPOSE infile prstot NL outp usereq lnum
parse arg inilvl
do while ~eof(infile)
  ins = GetNextLine()
  if ins = "" then
    TermError("ERROR: Unexpected end of file")
  lvlstr = word(ins, 1)
  lvl = GetNumType(lvlstr)
  if lvl <= inilvl then RETURN ins
  if lvl = inilvl+1 then do
    lstr = strip(delstr(ins, 1, length(lvlstr)))
    curr = upper(word(lstr, 1))
    if curr = "SOUR" then do
      lstr = strip(delstr(lstr, 1, length(curr)))
      prsr = "Source system: "||lstr
      if ~usereq then
    Tell(prsr)
      else
        prstot = prstot||prsr||NL
      ins = ParseSource(lvl)
      lvlstr = word(ins, 1)
      lvl = lvlstr + 1
      if lvl <= inilvl then RETURN ins
      if lvl = inilvl+1 then do
        lstr = strip(delstr(ins, 1, length(lvlstr)))
        curr = upper(word(lstr, 1))
      end
      else TermError("ERROR: This should never happen [1] (line: "||lnum||")")
    end
    if curr = "DATE" then do
      lstr = strip(delstr(lstr, 1, length(curr)))
      prsr = "Creation date: "||lstr
      if ~usereq then
    Tell(prsr)
      else
        prstot = prstot||prsr||NL
    end
    else if curr = "FILE" then do
      lstr = strip(delstr(lstr, 1, length(curr)))
      prsr = "Source file:   "||lstr
      if ~usereq then
    Tell(prsr)
      else
        prstot = prstot||prsr||NL
    end
    /* add COPR (copyright) and GEDC VERS parsing
     */
  end
end
TermError("ERROR: Unexpected end of file")

ParseSource: PROCEDURE EXPOSE infile prstot NL outp usereq lnum
parse arg namlvl
/* Scan for "NAME" and "VERS" */
do while ~eof(infile)
  ins = GetNextLine()
  if ins = "" then
    TermError("ERROR: Unexpected end of file")
  lvlstr = word(ins, 1)
  lvl = GetNumType(lvlstr)
  if lvl <= namlvl then RETURN ins
  if lvl = namlvl+1 then do
    lstr = strip(delstr(ins, 1, length(lvlstr)))
    curr = upper(word(lstr, 1))
    if curr = "VERS" then do
      lstr = strip(delstr(lstr, 1, length(curr)))
      prsr = "Version:       "||lstr
      if ~usereq then
        Tell(prsr)
      else
        prstot = prstot||prsr||NL
    end
    else if curr = "NAME" then do
      lstr = strip(delstr(lstr, 1, length(curr)))
      prsr = "Created by:    "||lstr
      if ~usereq then
        Tell(prsr)
      else
        prstot = prstot||prsr||NL
    end
  end
end
TermError("ERROR: Unexpected end of file")

ParsePerson: PROCEDURE EXPOSE infile IrnArr. errfile outp usereq lnum
parse arg pnum, inilvl
replay = 0
prn = GetNewPerson()
IRNArr.pnum = prn
do while ~eof(infile)
  if replay = 0 then ins = GetNextLine()
  else replay = 0
  if ins = "" then
    TermError("ERROR: Unexpected end of file")

  lvlstr = word(ins, 1)
  lvl = GetNumType(lvlstr)
  if lvl <= inilvl then RETURN ins
  if lvl = inilvl + 1 then do
    lstr = strip(delstr(ins, 1, length(lvlstr)))
    curr = upper(word(lstr, 1))
  end

  if curr = "NAME" then StorePersName(strip(delstr(lstr, 1, length(curr))), prn)
  else if curr = "SEX" then StorePersSex(strip(delstr(lstr, 1, length(curr))), prn)
  else if curr = "BIRT" | curr = "DEAT" | curr = "BURI" then do
    ins = ParsePersDatePlace(curr, prn, lvl)
    replay = 1
  end
  else if curr = "CHR" | curr = "BAPM" | curr = "BAPL" | curr = "CHRA" | curr = "CONF" then
  do
    /* only here because it made the 'BIRT' line too long :-( */
    ins = ParsePersDatePlace(curr, prn, lvl)
    replay = 1
  end
  else if curr = "OCCU" then StoreOccup(strip(delstr(lstr, 1, length(curr))), prn)
  else if curr = "EDUC" then StoreEduc(strip(delstr(lstr, 1, length(curr))), prn)
  else if curr = "RELI" then StoreRelig(strip(delstr(lstr, 1, length(curr))), prn)
  else if curr = "STIL" then StoreCOD("stillborn", prn)
    /* Note: 'STIL' is not part of the official GEDCOM standard */
  else if curr = "NOTE" then do
    ins = StorePersComment(strip(delstr(lstr, 1, length(curr))), prn, lvl)
    replay = 1
  end
  else if curr = "FAMC" | curr = "FAMS" | curr = "NUMB" then do
    /* nothing - children and spouse relationships are established later
     * and NUMB fields are irrelevant
     * Note: we do not output a "Skipped" message for these fields.
     */
  end
  else if curr = "CHAN" then do
    ins = SkipChanged(lvl)
    replay = 1
    /* no 'SKIPPED' message for these fields */
  end
  else do
    olv = lvl - 1
    writeln(errfile, "SKIPPED: Level "||olv||" field "||curr||" for person "||prn||"! (line: "||lnum||")")
  end
end
TermError("ERROR: Unexpected end of file")

ParseFamily: PROCEDURE EXPOSE infile ffile errfile outp usereq lnum fxs finp FGRNArr. IRNArr.
parse arg fnum, inilvl
replay = 0; fxs = 0; finp = 0; fins = 0

/* replay: parse the currently read line, don't read the next one
 * fxs   : family exists; if 0, only allow HUSB and WIFE, rest to tempfile
 *       ~= 0, then contains FGRN (family number)
 * finp  : file input; 0 = from sourcefile (GEDCOM), 1 = from tempfile
 */

open(ffile, "T:Scion.GPF", "w")

do while (finp = 0 & ~eof(infile)) | (finp = 1 & ~eof(ffile))
  if replay = 0 then ins = GetNextFLine()
  else
    replay = 0

  if ins = "" & finp = 0 then
    TermError("ERROR: Unexpected end of file!")

  if finp = 1 & eof(ffile) then do
    close(ffile)
    RETURN fins
  end

  lvlstr = word(ins, 1)
  lvl = GetNumType(lvlstr)
  if (lvl <= inilvl) & (finp = 0) then do
    finp = 1
    close(ffile)
    if ~open(ffile, "T:Scion.GPF", "r") | eof(ffile) then do
      close(ffile)
      RETURN ins
    end
    fins = ins
    ITERATE
  end
  if lvl = inilvl + 1 then do
    lstr = strip(delstr(ins, 1, length(lvlstr)))
    curr = upper(word(lstr, 1))
  end

  if curr = "HUSB" then fxs = StoreFamHusband(strip(delstr(lstr, 1, length(curr)), 'B', ' @'), fnum)
  else if curr = "WIFE" then fxs = StoreFamWife(strip(delstr(lstr, 1, length(curr)), 'B', ' @'), fnum)
  else if curr = "CHIL" then do
    if lvl > inilvl + 1 then do
      /* TO DO: for now, "ADOP" etc. fields are skipped */
      olv = lvl - 1
      lostr = upper(word(strip(delstr(ins, 1, length(lvlstr))), 1))
      writeln(errfile, "SKIPPED: Level "||olv||" field "||lostr||" for family "||fnum||"! (line: "||lnum||")")
      ITERATE
    end
    if fxs = 0 then do
      if finp = 1 then
        writeln(errfile, "ERROR: Family for "||lstr||" does not exist!")
      else
        FOutput(ins)
    end
    else StoreFamChild(strip(delstr(lstr, 1, length(curr)), 'B', ' @'), fxs)
  end
  else if curr = "MARR" | curr = "DIV" | curr = "ANUL" | curr = "ENGA" then do
    if fxs = 0 then do
      if finp = 1 then
        writeln(errfile, "ERROR: Family for "||lstr||" does not exist!")
      else
        FOutput(ins)
    end
    ins = ParseFamDatePlace(curr, fxs, lvl)
    if ins ~= 0 then
      replay = 1
  end
  else if curr = "NOTE" then do
    if lvl > inilvl + 1 then do
      olv = lvl - 1
      lostr = upper(word(strip(delstr(ins, 1, length(lvlstr))), 1))
      writeln(errfile, "SKIPPED: Level "||olv||" field "||lostr||" for family "||fnum||"! (line: "||lnum||")")
      ITERATE
    end
    if fxs = 0 then do
      if finp = 1 then
        writeln(errfile, "ERROR: Family for "||lstr||" does not exist!")
      else
        FOutput(ins)
    end
    ins = StoreFamComment(strip(delstr(lstr, 1, length(curr))), fxs, lvl)
    replay = 1
  end
  else if curr = "NUMB" then do
    /* nothing - NUMB fields are irrelevant
     * Note: we do not output a "Skipped" message for these fields.
     */
  end
  else if curr = "CHAN" then do
    ins = SkipChanged(lvl)
    replay = 1
    /* no 'SKIPPED' message for these fields */
  end
  else do
    olv = lvl - 1
    writeln(errfile, "SKIPPED: Level "||olv||" field "||curr||" in family "||fnum||"! (line: "||lnum||")")
  end
end
close(ffile)
if finp = 1 then
  RETURN fins
TermError("ERROR: Unexpected end of file!")

GetNumType: PROCEDURE EXPOSE outp infile usereq lnum
parse arg str
if DATATYPE(str) ~= 'NUM' then
  TermError("ERROR: Level indicator expected -> error in GEDCOM specification? String is "||str||" (line: "||lnum||")")
return str + 1

GetNextFLine: PROCEDURE EXPOSE infile ffile lnum finp
if finp = 0 then return GetNextLine()
ignl = ""
do while ignl = "" & ~eof(ffile)
  ignl = readln(ffile)
  if ignl ~= "" then ignl = strip(ignl)
  /* so we can check if strip(ignl) is still ~= "" */
end
return ignl

GetNextLine: PROCEDURE EXPOSE infile lnum
lnum = lnum + 1
ignl = ""
do while ignl = "" & ~eof(infile)
  ignl = readln(infile)
  if ignl ~= "" then ignl = strip(ignl)
  /* so we can check if strip(ignl) is still ~= "" */
end
return ignl

FOutput: PROCEDURE EXPOSE ffile errfile
parse arg iline
if ~exists("T:Scion.GPF") then do
  writeln(errfile, "ERROR: no tempfile for line: "||iline)
  return 0
end
else writeln(ffile, iline)
return 0

StorePersName: PROCEDURE
parse arg nstr, pnum
nstr = strip(nstr, 'B', '/')
ps = pos('/', nstr)
if ps = 0 then do
  fname = ""
  lname = nstr
end
else do
  fname = left(nstr, ps-1)
  lname = right(nstr, length(nstr)-ps)
end
PUTLASTNAME pnum lname
PUTFIRSTNAME pnum fname
return 1

StorePersSex: PROCEDURE
parse arg nstr, pnum
 sxstr = upper(left(nstr, 1))
 if sxstr ~= 'M' then sxstr = 'F'
PUTSEX pnum sxstr
return 1

ParsePersDatePlace: PROCEDURE EXPOSE infile outp usereq lnum
parse arg idstr, pnum, inilvl
datstr = ""
plcstr = ""
causestr = ""
do while ~eof(infile)
  ins = GetNextLine()
  if eof(infile) then
    TermError("ERROR: Unexpected end of file!")
  lvlstr = word(ins, 1)
  lvl = GetNumType(lvlstr)
  if lvl <= inilvl then do
    select
      when idstr = "BIRT" then do
    if datstr ~= "" then
      PUTBIRTHDATE pnum datstr
    if plcstr ~= "" then
      PUTBIRTHPLACE pnum plcstr
      end
      when idstr = "DEAT" then do
    if datstr ~= "" then
      PUTDEATHDATE pnum datstr
    if plcstr ~= "" then
      PUTDEATHPLACE pnum plcstr
    if causestr ~= "" then
      PUTDIEDOF pnum causestr
      end
      when idstr = "BURI" then do
    if datstr ~= "" then
      PUTBURIALDATE pnum datstr
    if plcstr ~= "" then
      PUTBURIALPLACE pnum plcstr
      end
      when idstr = "BAPL" | idstr = "BAPM" | idstr = "CHR" | idstr = "CHRA" | idstr = "CONF" then do
    if datstr ~= "" then
      PUTBAPTISMDATE pnum datstr
    if plcstr ~= "" then
      PUTBAPTISMPLACE pnum plcstr
      end
      otherwise
        /* do nothing */
    end
    RETURN ins
  end
  if lvl = inilvl+1 then do
    lstr = strip(delstr(ins, 1, length(lvlstr)))
    curr = upper(word(lstr, 1))
    if curr = "DATE" then do
      datstr = strip(delstr(lstr, 1, length(curr)))
    end
    else if curr = "PLAC" then do
      plcstr = strip(delstr(lstr, 1, length(curr)))
    end
    else if curr = "QUAY" then do
      lstr = strip(delstr(lstr, 1, length(curr)))
      if DATATYPE(lstr) = 'NUM' & lstr < 2 then do
        if datstr ~= "" then datstr = datstr||'?'
        if plcstr ~= "" then plcstr = plcstr||'?'
      end
    end
    else if curr = "CAUS" then do
      causestr = strip(delstr(lstr, 1, length(curr)))
    end
  end
  /* Skip all fields of lvl > inilvl */
end
return 0

ParseFamDatePlace: PROCEDURE EXPOSE infile ffile errfile outp usereq lnum finp FGRNArr.
parse arg idstr, ff, inilvl
datstr = ""; plcstr = ""; clbrnt = ""
do while ~eof(infile) | ~eof(ffile)
  ins = GetNextFLine()

  if finp = 0 & ins = "" then
    TermError("ERROR: Unexpected end of file (Parsing Family Events)!")

  if finp = 1 & eof(ffile) then do
    if ff ~= 0 then do
      if idstr = "MARR" then do
        if datstr ~= "" then
        PUTMARRYDATE ff datstr
        if plcstr ~= "" then
        PUTMARRYPLACE ff plcstr
        if clbrnt ~= "" then
          PUTCELEBRANT ff clbrnt
      end
      else if idstr = "ANUL" then do
        if datstr ~= "" then
        PUTENDDATE ff datstr
        if plcstr ~= "" then
        PUTENDPLACE ff plcstr
    PUTENDING ff 4
      end
      else if idstr = "DIV" then do
        if datstr ~= "" then
        PUTENDDATE ff datstr
        if plcstr ~= "" then
        PUTENDPLACE ff plcstr
        PUTENDING ff 2
    /* TO DO: if 'DIV' has a "2 TYPE SEPARAT*" line behind it,
     * set ending to 'Separation'
     */
      end
      else if idstr = "ENGA" then do
        if datstr ~= "" then
        PUTENGAGEDATE ff datstr
        if plcstr ~= "" then
        PUTENGAGEPLACE ff plcstr
      end
    end
    RETURN 0
  end

  lvlstr = word(ins, 1)
  lvl = GetNumType(lvlstr)
  if lvl <= inilvl then do
    if ff ~= 0 then do
      if idstr = "MARR" then do
        if datstr ~= "" then
      PUTMARRYDATE ff datstr
        if plcstr ~= "" then
      PUTMARRYPLACE ff plcstr
        if clbrnt ~= "" then
          PUTCELEBRANT ff clbrnt
      end
      else if idstr = "DIV" | idstr = "ANUL" then do
        if datstr ~= "" then
        PUTENDDATE ff datstr
        if plcstr ~= "" then
        PUTENDPLACE ff plcstr
        if idstr = "DIV" then PUTENDING ff 2
    else idstr = "ANUL" then PUTENDING ff 4
      end
      else if idstr = "ENGA" then do
        if datstr ~= "" then
        PUTENGAGEDATE ff datstr
        if plcstr ~= "" then
        PUTENGAGEPLACE ff plcstr
      end
    end
    RETURN ins
  end
  if finp = 0 & ff = 0 then FOutput(ins)
  else do
    if lvl = inilvl+1 then do
      lstr = strip(delstr(ins, 1, length(lvlstr)))
      curr = upper(word(lstr, 1))
      if curr = "DATE" then do
        datstr = strip(delstr(lstr, 1, length(curr)))
      end
      else if curr = "PLAC" then do
        plcstr = strip(delstr(lstr, 1, length(curr)))
      end
      else if curr = "OFFI" then do
        clbrnt = strip(delstr(lstr, 1, length(curr)))
        /* only for "MARR" */
      end
      else if curr = "QUAY" then do
        lstr = strip(delstr(lstr, 1, length(curr)))
        if DATATYPE(lstr) = 'NUM' & lstr <= 1 then do
          if datstr ~= "" then datstr = datstr||'?'
          if plcstr ~= "" then plcstr = plcstr||'?'
        end
      end
    end
    /* Skip all fields of lvl > inilvl */
  end
end
TermError("ERROR: Unexpected end of file (Parsed Family Events)!")

GetNewPerson: PROCEDURE EXPOSE infile outp usereq
  PUTNEWPERSON
  newpnum = RESULT
  if newpnum = 0 then TermError("ERROR: Cannot allocate new person!")
  /* if you want to see Scion in action, uncomment the next line */
  /* GETPERSONWIN newpnum */
return newpnum

GetNewFamily: PROCEDURE EXPOSE infile outp usereq
parse arg irn
  PUTNEWFAMILY irn
  newfnum = RESULT
  if newfnum = 0 then TermError("ERROR: Cannot allocate new family!")
  /* if you want to see Scion in action, uncomment the next line */
  /* GETFAMILYWIN newfnum */
return newfnum

StoreOccup: PROCEDURE
parse arg nstr, pnum
 PUTOCCUPATION pnum nstr
return 1

StoreEduc: PROCEDURE
parse arg nstr, pnum
 PUTEDUCATION pnum nstr
return 1

StoreRelig: PROCEDURE
parse arg nstr, pnum
 PUTRELIGION pnum nstr
return 1

StoreCOD: PROCEDURE
parse arg nstr, pnum
 PUTDIEDOF pnum nstr
return 1

StorePersComment: PROCEDURE EXPOSE infile outp usereq lnum
parse arg nstr, pnum, lvl
 PUTPERSCOMMENT pnum nstr
 l1 = lvl||" CONT"
 l2 = length(l1)
 ins = GetNextLine()
 if length(ins) > l2 & left(ins, l2) = l1 then do
   StorePersRefs(right(ins, length(ins)-l2), pnum)
   ins = GetNextLine()
 end
return ins

StorePersRefs: PROCEDURE
parse arg nstr, pnum
 PUTPERSREFS pnum nstr
return 1

StoreFamHusband: PROCEDURE EXPOSE errfile infile outp usereq lnum IRNArr. FGRNArr.
parse arg nstr, fnum
  nstr = strip(nstr,'B','@'||xrange('A','Z'))
  ff = 0
  if DATATYPE(nstr) = 'NUM' then
  do
    ii = GGetIRN(nstr)
    if ii = 0 then
      writeln(errfile, "ERROR: Missing Personal Record for HUSBAND "||nstr||" (line: "||lnum||")")
    else do
      ff = GGetFGRN(fnum)
      if ff = 0 then do
        ff = GetNewFamily(ii)
        FGRNArr.fnum = ff
      end
      else do
    /* There already is a family, so there is a principal; assume
     * that that is the wife - add the husband as spouse
     */
        PUTSPOUSE ff ii
    ers = RESULT
    if ers ~= 1 then do
          writeln(errfile, "ERROR "||ers||" in PUTSPOUSE (HUSB) "||ff||' '||ii)
      GETPRINCIPAL ff
      prc = RESULT
      GETSPOUSE ff
      spc = RESULT
      writeln(errfile, "Principal: "||prc||", Spouse: "||spc)
    end
      end
    end
  end
return ff

StoreFamWife: PROCEDURE EXPOSE errfile infile outp usereq lnum IRNArr. FGRNArr.
parse arg nstr, fnum
  nstr = strip(nstr,'B','@'||xrange('A','Z'))
  ff = 0
  if DATATYPE(nstr) = 'NUM' then
  do
    ii = GGetIRN(nstr)
    if ii = 0 then
      writeln(errfile, "ERROR: Missing Personal Record for WIFE "||nstr||" (line: "||lnum||")")
    else do
      ff = GGetFGRN(fnum)
      if ff = 0 then do
        ff = GetNewFamily(ii)
        FGRNArr.fnum = ff
      end
      else do
        PUTSPOUSE ff ii
    ers = RESULT
    if ers ~= 1 then do
          writeln(errfile, "ERROR "||ers||" in PUTSPOUSE (WIFE) "||ff||' '||ii)
      GETPRINCIPAL ff
      prc = RESULT
      GETSPOUSE ff
      spc = RESULT
      writeln(errfile, "Principal: "||prc||", Spouse: "||spc)
    end
      end
    end
  end
return ff

StoreFamChild: PROCEDURE EXPOSE errfile infile outp usereq lnum IRNArr. FGRNArr.
parse arg nstr, fnum
/* TO DO: improve this function, to allow definition of children here,
 *      instead of in a separate personal record. Also look for "ADOP"
 *      field (adopted children)
 */
  if fnum = 0 then RETURN 0
    /* we cannot parse a child when there is no family yet */
  nstr = strip(nstr,'B','@'||xrange('A','Z'))
  if DATATYPE(nstr) = 'NUM' then
  do
    ii = GGetIRN(nstr)
    if ii = 0 then
      writeln(errfile, "ERROR: Missing Personal Record for CHILD "||nstr||" (line: "||lnum||")")
    else do
      PUTCHILD fnum ii
      ers = RESULT
      if ers ~= 1 then
        writeln(errfile, "ERROR "||ers||" in PUTCHILD "||fnum||' '||ii||" (line: "||lnum||")")
    end
  end
return 1

StoreFamRefs: PROCEDURE EXPOSE infile outp usereq
parse arg nstr, fnum
if fnum ~= 0 then
  PUTFAMREFS fnum nstr
 /* Note: I use it as a CONT field for comments */
return 1

StoreFamComment: PROCEDURE EXPOSE infile ffile outp usereq lnum finp FGRNArr.
parse arg nstr, ff, lvl
  if ff ~= 0 then
    PUTFAMCOMMENT ff nstr
  l1 = lvl||" CONT"
  l2 = length(l1)
  ins = GetNextFLine()
  if length(ins) > l2 & left(ins, l2) = l1 then do
    if finp = 0 & ff = 0 then
      FOutput(ins)
    else
      StoreFamRefs(right(ins, length(ins)-l2), ff)
    ins = GetNextFLine()
  end
return ins

/* Return the Scion IRN belonging to the GEDCOM Personal number pnum */
/* If there is no entry yet, allocate one! */
GGetIRN: PROCEDURE EXPOSE IRNArr.
parse arg pnum
return IRNArr.pnum

/* Return the Scion FGRN belonging to the GEDCOM Family number fnum */
GGetFGRN: PROCEDURE EXPOSE lnum FGRNArr.
parse arg fnum
if FGRNArr.fnum = '' then
  writeln(stdout, "ERROR: empty field in FGRN Array (line: "||lnum||")")
return FGRNArr.fnum

SkipChanged: PROCEDURE EXPOSE infile lnum
parse arg inlvl
lvl = inlvl + 1
do until lvl <= inlvl
  ins = GetNextLine()
  lvlstr = word(ins, 1)
  lvl = GetNumType(lvlstr)
end
return ins

/*
 * Procedure to strip the directory path from the string,
 * only leaving the filename
 */
StripPath: PROCEDURE
parse arg str
  p = lastpos('/', str)
  if p > 0 then ret1 = delstr(str,1,p)
  else ret1 = str
  p = lastpos(':', ret1)
  if p > 0 then retstr = delstr(ret1,1,p)
  else retstr = ret1
return retstr

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

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

TermError: PROCEDURE EXPOSE infile outp usereq pgopen
parse arg str
if pgopen then Postmsg()
/* If you turned off stdout, no error messages will be shown! */
if usereq then
  rtezrequest(str,'E_xit','Converter Message:','rt_pubscrname = SCIONGEN')
else
  Tell(str || '0A'x)
close(infile)
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)
  if pgopen then Postmsg()
  EXIT