* To export a Gedcom compatible text file
* Feb 2004
* Laurie Bingaman Lackey, ISIS
        
set alternate to \&xSparks\&xStud\gedcom.txt
set alternate on
 
name = ''
bplace=''
birthdate=''
dplace=''
living=''
ddate=ctod('  /  /  ')
age=0
famc=''
fams=''

? '0 HEAD'
? '1 SOUR SPARKS'
? '2 VERS v1.55'
? '2 CORP ISIS'
? '1 DATE '+dmy(date())
? '1 FILE'
? '1 FILE \'+xSparks+'\'+xstud+'\'+xstud+'.ged'

sele master
select distinct master.sire_id,master.dam_id into table \&xSparks\&xstud\families.dbf from master order by sire_id, dam_id
locate for sire_id = '   UNK' and dam_id = '   UNK'
if not eof()
  delete
endif
locate for sire_id = '  MULT' and dam_id = '  MULT'
if not eof()
  delete
endif
pack

sele master
go top
do while not eof()
  ? '0 @I'+alltrim(stud_id)+'@ INDI'
  do name with stud_id,name
  ? '1 NAME Studbook '+alltrim(stud_id)+'  '+name
  ? '1 SEX '+iif(alltrim(str(sex)) $'126','M',iif(alltrim(str(sex)) $'037','F','U'))
  birthdate=bdate
  do places with stud_id,bplace,dplace,ddate,living,age
  ? '1 BIRT'
  ? '2 DATE '+dmy(bdate)
  ? '2 PLAC at '+bplace
  if not empty(ddate)
    ? '1 DEAT'
    ? '2 DATE '+iif(not empty(ddate),(dmy(ddate)),'')
    ? '2 PLAC at '+dplace
    ? '2 AGE '+age
    do cause with stud_id
  else
    ? '1 RESI '+living
    * ? '1 CENS '+living
  endif  
  do famc with stud_id, sire_id, dam_id, famc
  ? '1 FAMC @F'+alltrim(str(famc))+'@'
  do fams with stud_id, sire_id, dam_id, sex
  sele master
  skip
enddo

? '0 @IWILD@ INDI'
? '1 NAME WILD-CAUGHT ANIMALS'
sele families
set filter to sire_id = '  WILD'
go top
do while not eof()
  ? '1 FAMS @F'+alltrim(str(recno()))+'@'
  skip
enddo
set filter to dam_id = '  WILD'
go top
do while not eof()
  ? '1 FAMS @F'+alltrim(str(recno()))+'@'
  skip
enddo
set filter to


* List the families
sele families
go top
do while not eof()
  ? '0 @F'+alltrim(str(recno()))+'@ FAM'
  if not alltrim(sire_id) $ 'UNK MULT' and not empty(alltrim(sire_id))
    ? '1 HUSB @I'+alltrim(sire_id)+'@'
  endif
  if not alltrim(dam_id) $ 'UNK MULT' and not empty(alltrim(dam_id))
    ? '1 WIFE @I'+alltrim(dam_id)+'@'
  endif
  sele master
  set filter to sire_id = families.sire_id and dam_id = families.dam_id
  go top
  do while not eof()
    ? '1 CHIL @I'+alltrim(stud_id)+'@'
    skip
  enddo
  set filter to
  sele families
  skip
enddo  
  
* End the file
? '0 TRLR'

sele families
use 
sele master

set alternate off
close alternate

dele file \&xSparks\&xStud\&xStud..ged
xx = 'rename \'+xsparks+'\'+xstud+'\gedcom.txt to \'+xsparks+'\'+xstud+'\'+xstud+'.ged'
&xx


  
****************
Procedure Name
parameters ID,name  
name = ''
sele specials
seek ID
do while not eof() and stud_id = ID
  if code = 'SJ' and not alltrim(upper(comment))$name
    name = name+'/'+alltrim(upper(comment))
  endif
  skip
enddo
sele master  


******************
Procedure Places
parameters ID,bplace,dplace,ddate,living,age

bplace=''
dplace=''
living = ''
ddate=ctod('  /  /  ')
sele moves
set filter to physical and not tran_code$'2I,2O,2S,DI,DO'
seek ID
do while stud_id = ID and not eof()
  do case
    case tran_code = 'AA'
      bplace = alltrim(location)
      if rdate_est = 'U'
        living = 'lost-to-followup on '+dmy(tran_date)
      endif
    case tran_code = 'AB'
      bplace = 'Wild-caught at '+alltrim(location)
    case tran_code = 'BA'
      dplace = alltrim(location)
      ddate = tran_date
      do case
        case ddate - birthdate < 30
          age = alltrim(str(ddate-birthdate))+' days'
        case ddate - birthdate < 365
          age = alltrim(str((ddate-birthdate)/30.4))+iif((ddate-birthdate)/30.25=1,' month',' months')
        otherwise
          age = alltrim(str((ddate-birthdate)/365.25))+iif((ddate-birthdate)/365.25=1,' year',' years')
      endcase
      do case
        case subst(tdate_est,1,1) $ 'DMY'
          age = '~'+age
        case subst(tdate_est,1,1) $ 'U'
          age = 'Unknown'
      endcase
    case tran_code = 'BI'
      living = 'Released to '+alltrim(location)+' on '+dmy(tran_date)
  endcase
  if rdate_est = 'U'
    living = 'lost-to-followup on '+dmy(tran_date)
  endif
  skip
enddo
if empty(bplace)
  bplace = 'Unknown'
endif
skip -1
if empty(dplace) and stud_id = ID
  living = 'Living at '+alltrim(location)+' since '+dmy(tran_date)
endif
set filter to
sele master


***********************
Procedure Cause
parameter ID

sele moves
seek ID
do while not eof() and stud_id = ID
  skip
enddo
skip -1
if tran_code = 'BA'
  do case
    case subst(local_id,1,1) = 'E'
      ? '2 CAUS Old age'
    case subst(local_id,1,1) = 'I'
      ? '2 CAUS Stillborn'
    case subst(local_id,1,1) = 'J'
      ? '2 CAUS Premature birth'
  endcase
endif

sele master
    
    
**********************
Procedure FAMC
parameter ID, sire, dam, famc
famc = ''
sele families    
locate for sire = sire_id and dam = dam_id
famc = recno()
sele master

**********************
Procedure FAMS
parameter ID, sire, dam, sex
sele families    
do case
 case alltrim(str(sex)) $ '126'
  set filter to ID = sire_id
  go top
  do while not eof()
    ? '1 FAMS @F'+alltrim(str(recno()))+'@'
    skip
  enddo
 case alltrim(str(sex)) $ '037'
  set filter to ID = dam_id 
  go top
  do while not eof()
    ? '1 FAMS @F'+alltrim(str(recno()))+'@'
    skip
  enddo
 otherwise 
   ? '2 CONT This animal has at least one parent that is not sexed.'
endcase
set filter to
sele master