home *** CD-ROM | disk | FTP | other *** search
/ CP/M / CPM_CDROM.iso / mbug / mbug059.arc / FAMILY.BAS < prev    next >
BASIC Source File  |  1979-12-31  |  20KB  |  510 lines
  1. 100 TITLE$ = "Family Group Sheet Program"
  2. 105 TITLE$ = TITLE$ + " ON DISPLAY"
  3. 110 VERSION$ = "Version 1.3"
  4. 115 COPY1$ = "Copyright (c) 1983, by:"
  5. 120 COPY2$ = "Melvin O. Duke"
  6. 125 PRICE$ = "$35"
  7. 130 ADDR1$ = "Melvin O. Duke"
  8. 135 ADDR2$ = "P. O. Box 20836"
  9. 140 ADDR3$ = "San Jose, CA  95160"
  10. 145 REM Dimension Statements go here
  11. 150 DIM PA.ID(800), CH.ID(800), PERS.NO(400), M.NO(400)
  12. 160 DIM PERS(2), FORM$(49)
  13. 170 REM Produce the first screen
  14. 175 KEY OFF : CLS
  15. 180 REM Draw the outer double box
  16. 185 R1 = 1 : C1 = 1 : R2 = 24 : C2 = 79 : GOSUB 400
  17. 190 REM Find the title location
  18. 195 TITLE.POS = 40 - INT(LEN(TITLE$)/2)
  19. 200 REM Draw the title box
  20. 205 R1=3:C1=TITLE.POS-2:R2=6:C2=TITLE.POS+LEN(TITLE$)+1:GOSUB 600
  21. 210 REM Print the title
  22. 215 LOCATE 4,TITLE.POS : PRINT TITLE$
  23. 220 LOCATE 5,40-INT(LEN(VERSION$)/2) :  PRINT VERSION$;
  24. 225 REM Draw the Contribution box
  25. 230 R1 = 8 : C1 = 19 : R2 = 17 : C2 = 62 : GOSUB 400
  26. 235 REM Request the Contribution
  27. 240 LOCATE 9,23 : PRINT "If you are using these programs, and"
  28. 245 LOCATE 10,21 : PRINT "finding them of value, your contribution"
  29. 250 LOCATE 11,23 : PRINT "("+PRICE$+" suggested) will be appreciated."
  30. 255 REM Draw the Mailing Label
  31. 260 R1 = 12 : C1 = 28 : R2 = 16 : C2 = 52 : GOSUB 600
  32. 265 REM Print the Name and Address
  33. 270 LOCATE 13,40-INT(LEN(ADDR1$)/2) :  PRINT ADDR1$;
  34. 275 LOCATE 14,40-INT(LEN(ADDR2$)/2) :  PRINT ADDR2$;
  35. 280 LOCATE 15,40-INT(LEN(ADDR3$)/2) :  PRINT ADDR3$;
  36. 285 REM Draw the Copyright box
  37. 290 R1 = 19 : C1 = 27 : R2 = 22 : C2 = 53 : GOSUB 400
  38. 295 REM Print the Copyright
  39. 300 LOCATE 20,40-INT(LEN(COPY1$)/2) :  PRINT COPY1$;
  40. 305 LOCATE 21,40-INT(LEN(COPY2$)/2) :  PRINT COPY2$;
  41. 310 GOTO 740
  42. 400 REM subroutine to print a double box
  43. 410 FOR I = R1 + 1 TO R2 - 1
  44. 420  LOCATE I, C1 : PRINT CHR$(186);
  45. 430  LOCATE I, C2 : PRINT CHR$(186);
  46. 440 NEXT I
  47. 450 FOR J = C1 + 1 TO C2 - 1
  48. 460  LOCATE R1, J : PRINT CHR$(205);
  49. 470  LOCATE R2, J : PRINT CHR$(205);
  50. 480 NEXT J
  51. 490  LOCATE R1, C1 : PRINT CHR$(201);
  52. 500  LOCATE R1, C2 : PRINT CHR$(187);
  53. 510  LOCATE R2, C1 : PRINT CHR$(200);
  54. 520  LOCATE R2, C2 : PRINT CHR$(188);
  55. 530 RETURN
  56. 600 REM subroutine to print a single box
  57. 610 FOR I = R1 + 1 TO R2 - 1
  58. 620  LOCATE I, C1 : PRINT CHR$(179);
  59. 630  LOCATE I, C2 : PRINT CHR$(179);
  60. 640 NEXT I
  61. 650 FOR J = C1 + 1 TO C2 - 1
  62. 660  LOCATE R1, J : PRINT CHR$(196);
  63. 670  LOCATE R2, J : PRINT CHR$(196);
  64. 680 NEXT J
  65. 690  LOCATE R1, C1 : PRINT CHR$(218);
  66. 700  LOCATE R1, C2 : PRINT CHR$(191);
  67. 710  LOCATE R2, C1 : PRINT CHR$(192);
  68. 720  LOCATE R2, C2 : PRINT CHR$(217);
  69. 730 RETURN
  70. 740 REM ask user to press a key to continue
  71. 750 LOCATE 25,1
  72. 760 PRINT "Press any key to continue";
  73. 770 K$ = INKEY$ : IF K$ = "" THEN 770
  74. 780 CLS
  75. 840 CLS
  76. 1000 REM Family Group Sheet Program.
  77. 1010 REM By:  Melvin O. Duke.  Updated 26 June, 1983.
  78. 1020 REM Routine to obtain Printer Information
  79. 1030 LOCATE 21,1 : PRINT "Make sure that the Printer is On and Ready"
  80. 1040 LOCATE 22,1 : PRINT "Make sure that the correct Diskettes are in place"
  81. 1050 LOCATE 23,1 : PRINT "Then press any key"
  82. 1060 A$ = INKEY$ : IF A$ = "" THEN 1060
  83. 1070 CLS
  84. 1080 REM Set for Wide Printing.
  85. 1110 WIDTH "lpt1:",132  'For printing Genealogy Forms
  86. 1120 REM Ask user about his Printer
  87. 1130 LOCATE 20,1 : PRINT "How wide is the Paper";
  88. 1140 LOCATE 21,3 : COLOR 0,7 : PRINT "1"; : COLOR 7,0
  89. 1150 LOCATE 21,6 : PRINT "8 - 1/2 inches";
  90. 1160 LOCATE 22,3 : COLOR 0,7 : PRINT "2"; : COLOR 7,0
  91. 1170 LOCATE 22,6 : PRINT "14 inches";
  92. 1180 LOCATE 23,1 : PRINT SPACE$(79);
  93. 1190 LOCATE 23,1 : INPUT "Enter 1 or 2"; REPLY$
  94. 1200 REM verify input
  95. 1210 IF VAL(REPLY$) = 1 OR VAL(REPLY$) = 2 THEN 1240
  96. 1220 LOCATE 19,1 : PRINT "Error in Previous Reply";
  97. 1230 GOTO 1130
  98. 1240 LOCATE 19,1 : PRINT SPACE$(79);
  99. 1250 LOCATE 20,1 : PRINT SPACE$(79);
  100. 1260 LOCATE 21,1 : PRINT SPACE$(79);
  101. 1270 LOCATE 22,1 : PRINT SPACE$(79);
  102. 1280 LOCATE 23,1 : PRINT SPACE$(79);
  103. 1290 WIDE = VAL(REPLY$)
  104. 1300 LOCATE 3,1
  105. 1310 IF WIDE = 1 THEN PRINT "Using 8-1/2 inch width paper"; : GOTO 1330
  106. 1320 PRINT "Using 14 inch width paper";
  107. 1330 LOCATE 20,1 : PRINT "How Long is the Paper";
  108. 1340 LOCATE 21,3 : COLOR 0,7 : PRINT "1"; : COLOR 7,0
  109. 1350 LOCATE 21,6 : PRINT "8 - 1/2 inches";
  110. 1360 LOCATE 22,3 : COLOR 0,7 : PRINT "2"; : COLOR 7,0
  111. 1370 LOCATE 22,6 : PRINT "11 inches";
  112. 1380 LOCATE 23,1 : PRINT SPACE$(79);
  113. 1390 LOCATE 23,1 : INPUT "Enter 1 or 2"; REPLY$
  114. 1400 REM verify input
  115. 1410 IF VAL(REPLY$) = 1 OR VAL(REPLY$) = 2 THEN 1440
  116. 1420 LOCATE 19,1 : PRINT "Error in Previous Reply";
  117. 1430 GOTO 1330
  118. 1440 LOCATE 19,1 : PRINT SPACE$(79);
  119. 1450 LOCATE 20,1 : PRINT SPACE$(79);
  120. 1460 LOCATE 21,1 : PRINT SPACE$(79);
  121. 1470 LOCATE 22,1 : PRINT SPACE$(79);
  122. 1480 LOCATE 23,1 : PRINT SPACE$(79);
  123. 1490 LENGTH = VAL(REPLY$)
  124. 1500 LOCATE 5,1
  125. 1510 IF LENGTH = 1 THEN PRINT "Using 8-1/2 inch length paper"; : GOTO 1530
  126. 1520 PRINT "Using 11 inch length paper";
  127. 1530 LOCATE 20,1 : PRINT "Describe the Forms to be used";
  128. 1540 LOCATE 21,3 : COLOR 0,7 : PRINT "1"; : COLOR 7,0
  129. 1550 LOCATE 21,6 : PRINT "Continuous";
  130. 1560 LOCATE 22,3 : COLOR 0,7 : PRINT "2"; : COLOR 7,0
  131. 1570 LOCATE 22,6 : PRINT "Single Sheets";
  132. 1580 LOCATE 23,1 : PRINT SPACE$(79);
  133. 1590 LOCATE 23,1 : INPUT "Enter 1 or 2"; REPLY$
  134. 1600 REM verify input
  135. 1610 IF VAL(REPLY$) = 1 OR VAL(REPLY$) = 2 THEN 1640
  136. 1620 LOCATE 19,1 : PRINT "Error in Previous Reply";
  137. 1630 GOTO 1530
  138. 1640 LOCATE 19,1 : PRINT SPACE$(79);
  139. 1650 LOCATE 20,1 : PRINT SPACE$(79);
  140. 1660 LOCATE 21,1 : PRINT SPACE$(79);
  141. 1670 LOCATE 22,1 : PRINT SPACE$(79);
  142. 1680 LOCATE 23,1 : PRINT SPACE$(79);
  143. 1690 FORMS = VAL(REPLY$)
  144. 1700 LOCATE 7,1
  145. 1710 IF FORMS = 1 THEN PRINT "Using Continuous forms"; : GOTO 1730
  146. 1720 PRINT "Using Single Sheets";
  147. 1730 LOCATE 20,1 : PRINT "Is the above information correct?"
  148. 1740 LOCATE 21,1 : INPUT "Enter 'y' or 'n' for 'yes' or 'no'"; REPLY$
  149. 1750 IF LEFT$(REPLY$,1) = "y" OR LEFT$(REPLY$,1) = "Y" THEN 1760 ELSE 1070
  150. 1760 CLS
  151. 1780 REM Read the Parent/Child Index
  152. 1790 OPEN "a:pcindex" FOR INPUT AS #1
  153. 1800 LOCATE 4,1 : PRINT "Open the Parent/Child Index";
  154. 1810 INPUT #1, PC.COUNT
  155. 1820 FOR I = 1 TO PC.COUNT
  156. 1830 LOCATE 5,1 : PRINT "Reading Index Record #:";I;
  157. 1840  INPUT #1, PA.ID(I), CH.ID(I)
  158. 1850 NEXT I
  159. 1860 CLOSE #1
  160. 1870 REM Read the Marriage Index
  161. 1880 LOCATE 7,1 : PRINT "Open the Marriage Index";
  162. 1890 OPEN "a:mindex" FOR INPUT AS #2
  163. 1900 INPUT #2, M.COUNT
  164. 1910 FOR I = 1 TO M.COUNT
  165. 1920 LOCATE 8,1 : PRINT "Reading Marriage Index Record #:";I:
  166. 1930  INPUT #2,PERS.NO(I), M.NO(I)
  167. 1940 NEXT I
  168. 1950 CLOSE #2
  169. 1960 REM Open the Persons File
  170. 1970 LOCATE 10,1 : PRINT "Open the Persons File"
  171. 1980 OPEN "a:persfile" AS #1 LEN = 256
  172. 1990 FIELD 1, 5 AS F1$, 20 AS F2$, 30 AS F3$, 2 AS F4$, 5 AS F5$, 5 AS F6$, 5 AS F7$, 11 AS F8$, 18 AS F9$, 16 AS F10$, 16 AS F11$, 11 AS F12$, 18 AS F13$, 16 AS F14$, 16 AS F15$, 11 AS F16$, 18 AS F17$, 16 AS F18$, 16 AS F19$
  173. 2000 REM open the Marriages File
  174. 2010 LOCATE 12,1 : PRINT "Open the Marriage File"
  175. 2020 OPEN "a:marrfile" AS #2 LEN = 128
  176. 2030 FIELD 2, 5 AS M1$, 5 AS M2$, 5 AS M3$, 5 AS M4$, 11 AS M5$, 18 AS M6$, 16 AS M7$, 16 AS M8$, 45 AS M9$
  177. 2040 REM Open the Ordinance File
  178. 2050 LOCATE 14,1 : PRINT "Open the Ordinances File";
  179. 2060 OPEN "b:ordfile" AS #3 LEN = 256
  180. 2070 FIELD 3,5ASO1$,11ASO2$,11ASO3$,11ASO4$,5ASO5$,5ASO6$,11ASO7$,11ASO8$,11ASO9$,11ASO10$,11ASO11$,5ASO12$,11ASO13$,11ASO14$,11ASO15$,11ASO16$,11ASO17$,11ASO18$,11ASO19$,11ASO20$,11ASO21$,11ASO22$,11ASO23$,26ASO24$
  181. 2080 REM Obtain a Person Record from the User
  182. 2090 CLS : LOCATE 20,1
  183. 2100 INPUT "Enter the Record-number of a Marriage";MARRIAGE
  184. 2110 IF MARRIAGE = 0 THEN 5040
  185. 2120 IF MARRIAGE < 1 OR MARRIAGE > 200 THEN CLS: GOTO 2080
  186. 2130 GOSUB 2140 : GOTO 2850
  187. 2140 REM Reset the Printer Characterisitcs for next page if required.
  188. 2150 IF FORMS = 1 THEN 2190  'Don't stop if forms are continuous
  189. 2160 REM Process Single Sheets
  190. 2170 PRINT "Press any key when next form is ready"
  191. 2180 A$ = INKEY$ : IF A$ = "" THEN 2180
  192. 2190 REM Reset paper sensing if required
  193. 2200 IF FORMS = 2 THEN LPRINT CHR$(27)"8";
  194. 2210 REM Reset paper length if required
  195. 2220 IF LENGTH = 1 THEN LPRINT CHR$(27)"C51";
  196. 2230 REM Reset Condensed Printing if required
  197. 2240 IF WIDE = 1 THEN LPRINT CHR$(15);
  198. 2250 RETURN
  199. 2260 REM Routine to do a Right-trim
  200. 2270 FOR J = 1 TO LEN(TEMP1$)-1
  201. 2280  IF RIGHT$(TEMP2$,1) = " " THEN TEMP2$ = LEFT$(TEMP2$,LEN(TEMP2$)-1) ELSE J = LEN(TEMP1$)-1
  202. 2290 NEXT J
  203. 2300 RETURN
  204. 2310 REM Routine to Extract Personal Information
  205. 2320 T1 = CVS(F1$)
  206. 2330 TEMP1$ = F2$ : TEMP2$ = F2$ : GOSUB 2260
  207. 2340 T2$ = TEMP2$
  208. 2350 TEMP1$ = F3$ : TEMP2$ = F3$ : GOSUB 2260
  209. 2360 T3$ = TEMP2$
  210. 2370 IF LEFT$(F4$,1) = "M" THEN T4$ = "M"
  211. 2380 IF LEFT$(F4$,1) = "F" THEN T4$ = "F"
  212. 2390 T5 = CVS(F5$)
  213. 2400 T6 = CVS(F6$)
  214. 2410 T7 = CVS(F7$)
  215. 2420 T8$ = F8$
  216. 2430 TEMP1$ = F9$ : TEMP2$ = F9$ : GOSUB 2260
  217. 2440 T9$ = TEMP2$
  218. 2450 TEMP1$ = F10$ : TEMP2$ = F10$ : GOSUB 2260
  219. 2460 T10$ = TEMP2$
  220. 2470 TEMP1$ = F11$ : TEMP2$ = F11$ : GOSUB 2260
  221. 2480 T11$ = TEMP2$
  222. 2490 T12$ = F12$
  223. 2500 TEMP1$ = F13$ : TEMP2$ = F13$ : GOSUB 2260
  224. 2510 T13$ = TEMP2$
  225. 2520 TEMP1$ = F14$ : TEMP2$ = F14$ : GOSUB 2260
  226. 2530 T14$ = TEMP2$
  227. 2540 TEMP1$ = F15$ : TEMP2$ = F15$ : GOSUB 2260
  228. 2550 T15$ = TEMP2$
  229. 2560 T16$ = F16$
  230. 2570 TEMP1$ = F17$ : TEMP2$ = F17$ : GOSUB 2260
  231. 2580 T17$ = TEMP2$
  232. 2590 TEMP1$ = F18$ : TEMP2$ = F18$ : GOSUB 2260
  233. 2600 T18$ = TEMP2$
  234. 2610 TEMP1$ = F19$ : TEMP2$ = F19$ : GOSUB 2260
  235. 2620 T19$ = TEMP2$
  236. 2630 RETURN
  237. 2640 REM Routine to Extract Ordinance Information
  238. 2645 U2$ = O2$  'Christening Date
  239. 2650 U4$ = O4$  'Sealed to Parents
  240. 2660 U7$ = O7$  'Baptism
  241. 2670 U10$ = O10$  'Endowment
  242. 2680 U11$ = O11$  'Sealed to Spouse
  243. 2690 TEMP1$ = O24$ : TEMP2$ = O24$ : GOSUB 2260
  244. 2700 U24$ = TEMP2$  'Occupation
  245. 2710 RETURN
  246. 2720 REM Extraction of Marriage Information
  247. 2730 TT1 = CVS(M1$)  'Rec.no
  248. 2740 TT2 = CVS(M2$)  'Husband
  249. 2750 TT3 = CVS(M3$)  'Wife
  250. 2760 TT4 = CVS(M4$)  'Code
  251. 2770 TT5$ = M5$  'Marriage Date
  252. 2780 TEMP1$ = M6$ : TEMP2$ = M6$ : GOSUB 2260
  253. 2790 TT6$ = TEMP2$   'City
  254. 2800 TEMP1$ = M7$ : TEMP2$ = M7$ : GOSUB 2260
  255. 2810 TT7$ = TEMP2$   'County
  256. 2820 TEMP1$ = M8$ : TEMP2$ = M8$ : GOSUB 2260
  257. 2830 TT8$ = TEMP2$   'State
  258. 2840 RETURN
  259. 2850 REM Routine to Fill with Spaces
  260. 2860 FOR I = 1 TO 49
  261. 2870  FORM$(I) = SPACE$(132)
  262. 2880 NEXT I
  263. 2890 REM Routine to Produce a Family Group Sheet
  264. 2900 REM get the marriage record
  265. 2910 GET #2, MARRIAGE
  266. 2920 PRINT "Obtaining Marriage Record"
  267. 2930 GOSUB 2720  'Extract Marriage Information
  268. 2940 HUSB = TT2 : WIFE = TT3
  269. 2950 REM Verify that record contains information
  270. 2960 IF HUSB = 0 OR WIFE = 0 THEN CLS : GOTO 2080
  271. 2961 REM
  272. 2962 REM Marriage Information onto line 4
  273. 2963 PRINT "Locate Marriage Information"
  274. 2964 MID$(FORM$(4),5,11) = TT5$
  275. 2965 IF TT6$ = " " AND TT7$ = " " AND TT8$ = " " THEN 2970
  276. 2966 MID$(FORM$(4),28,LEN(TT6$+TT7$+TT8$)+4) = TT6$+", "+TT7$+", "+TT8$
  277. 2970 REM Obtain the Husband's Information
  278. 2980 GET #1, HUSB
  279. 2990 PRINT "Obtaining Husband's Information"
  280. 3000 GOSUB 2310  'Extract Persons Information
  281. 3010 REM Now move the Husband's Information
  282. 3020 IF T2$ = " " AND T3$ = " " THEN 3050
  283. 3030 MID$(FORM$(1),10,LEN(T2$+T3$)+2) = T2$ + ", " + T3$
  284. 3040 MID$(FORM$(1),84,LEN(T2$+T3$)+2) = T2$ + ", " + T3$
  285. 3050 MID$(FORM$(2),5,11) = T8$
  286. 3060 IF T9$ = " " AND T10$ = " " AND T11$ = " " THEN 3080
  287. 3070 MID$(FORM$(2),28,LEN(T9$+T10$+T11$)+4) = T9$+", "+T10$+", "+T11$
  288. 3080 MID$(FORM$(5),5,11) = T12$
  289. 3090 IF T13$ = " " AND T14$ = " " AND T15$ = " " THEN 3110
  290. 3100 MID$(FORM$(5),28,LEN(T13$+T14$+T15$)+4) = T13$+", "+T14$+", "+T15$
  291. 3110 MID$(FORM$(6),5,11) = T16$
  292. 3120 IF T17$ = " " AND T18$ = " " AND T19$ = " " THEN 3140
  293. 3130 MID$(FORM$(6),28,LEN(T17$+T18$+T19$)+4) = T17$+", "+T18$+", "+T19$
  294. 3140 FATHER = T6 : MOTHER = T7
  295. 3150 IF FATHER = 0 THEN 3210
  296. 3160 GET #1, FATHER
  297. 3170 PRINT "Obtaining Husband's Father"
  298. 3180 GOSUB 2310  'Extract Father's Information
  299. 3190 IF T2$ = " " AND T3$ = " " THEN 3210
  300. 3200 MID$(FORM$(7),12,LEN(T2$+T3$)+2) = T2$+", "+T3$
  301. 3210 IF MOTHER = 0 THEN 3270
  302. 3220 GET #1, MOTHER
  303. 3230 PRINT "Obtaining Husband's Mother"
  304. 3240 GOSUB 2310  'Extract Mother's Information
  305. 3250 IF T2$ = " " AND T3$ = " " THEN 3270
  306. 3260 MID$(FORM$(7),58,LEN(T2$+T3$)+2) = T2$ + ", " + T3$
  307. 3270 REM
  308. 3280 REM Look for Husband's Other Wives
  309. 3290 PRINT "Look for Other Wives"
  310. 3300 XWIFE.COL = 0
  311. 3310 FOR W = 1 TO M.COUNT
  312. 3320  IF HUSB > PERS.NO(W) THEN 3460  'next w
  313. 3330  IF HUSB < PERS.NO(W) THEN W = M.COUNT : GOTO 3460
  314. 3340  REM found a wife, skip if wife of this marriage
  315. 3350  IF M.NO(W) = 0 THEN 3460
  316. 3360  GET #2, M.NO(W)
  317. 3370  GOSUB 2720  'extract marriage info
  318. 3380  IF WIFE = TT3 THEN 3460  'skip if same
  319. 3390  REM found another wife
  320. 3400  IF TT3 = 0 THEN 3460
  321. 3410  GET #1, TT3  'get wife's information
  322. 3420  GOSUB 2310  'extract personal info.
  323. 3430  IF T2$ = " " AND T3$ = " " THEN 3460  'skip if empty
  324. 3440  MID$(FORM$(8),12+XWIFE.COL,LEN(T2$+T3$)+2) = T2$+", "+T3$
  325. 3450  XWIFE.COL = XWIFE.COL + LEN(T2$+T3$)+4
  326. 3460 NEXT W
  327. 3470 REM Obtain the Wife's Information
  328. 3475 GET #1, WIFE
  329. 3480 PRINT "Obtaining Wife's Information"
  330. 3490 GOSUB 2310  'Extract Wife's Information
  331. 3500 REM Now move the Wife's Information
  332. 3510 IF T2$ = " " AND T3$ = " " THEN 3540
  333. 3520 MID$(FORM$(10),10,LEN(T2$+T3$)+2) = T2$ + ", " + T3$
  334. 3530 MID$(FORM$(2),84,LEN(T2$+T3$)+2) = T2$ + ", " + T3$
  335. 3540 MID$(FORM$(11),5,11) = T8$
  336. 3550 IF T9$ = " " AND T10$ = " " AND T11$ = " " THEN 3570
  337. 3560 MID$(FORM$(11),28,LEN(T9$+T10$+T11$)+4) = T9$+", "+T10$+", "+T11$
  338. 3570 MID$(FORM$(13),5,11) = T12$
  339. 3580 IF T13$ = " " AND T14$ = " " AND T15$ = " " THEN 3600
  340. 3590 MID$(FORM$(13),28,LEN(T13$+T14$+T15$)+4) = T13$+", "+T14$+", "+T15$
  341. 3600 MID$(FORM$(14),5,11) = T16$
  342. 3610 IF T17$ = " " AND T18$ = " " AND T19$ = " " THEN 3630
  343. 3620 MID$(FORM$(14),28,LEN(T17$+T18$+T19$)+4) = T17$+", "+T18$+", "+T19$
  344. 3630 FATHER = T6 : MOTHER = T7
  345. 3640 IF FATHER = 0 THEN 3700
  346. 3650 GET #1, FATHER
  347. 3660 PRINT "Obtaining Wife's Father"
  348. 3670 GOSUB 2310  'Extract Father's Information
  349. 3680 IF T2$ = " " AND T3$ = " " THEN 3700
  350. 3690 MID$(FORM$(15),12,LEN(T2$+T3$)+2) = T2$+", "+T3$
  351. 3700 IF MOTHER = 0 THEN 3760
  352. 3710 GET #1, MOTHER
  353. 3720 PRINT "Obtaining Wife's Mother"
  354. 3730 GOSUB 2310  'Extract Mother's Information
  355. 3740 IF T2$ = " " AND T3$ = " " THEN 3760
  356. 3750 MID$(FORM$(15),58,LEN(T2$+T3$)+2) = T2$ + ", " + T3$
  357. 3760 REM
  358. 3820 REM
  359. 3830 REM Look for Wife's Other Husbands
  360. 3840 PRINT "Look for Other Husbands"
  361. 3850 XHUSB.COL = 0
  362. 3860 FOR H = 1 TO M.COUNT
  363. 3870  IF WIFE > PERS.NO(H) THEN 4010  'next h
  364. 3880  IF WIFE < PERS.NO(H) THEN H = M.COUNT : GOTO 4010
  365. 3890  REM found a husband.  Skip if husband of this marriage
  366. 3900  IF M.NO(H) = 0 THEN 4010
  367. 3910  GET #2, M.NO(H)
  368. 3920  GOSUB 2720  'extract marriage info
  369. 3930  IF HUSB = TT2 THEN 4010  'skip if same
  370. 3940  REM found another husband
  371. 3950  IF TT2 = 0 THEN 4010
  372. 3960  GET #1, TT2  'get husband's information
  373. 3970  GOSUB 2310  'extract personal info.
  374. 3980  IF T2$ = " " AND T3$ = " " THEN 4010  'skip if empty
  375. 3990  MID$(FORM$(16),12+XHUSB.COL,LEN(T2$+T3$)+2) = T2$+", "+T3$
  376. 4000  XHUSB.COL = XHUSB.COL + LEN(T2$+T3$)+4
  377. 4010 NEXT H
  378. 4020 REM Obtain Husband's Ordinances
  379. 4030 PRINT "Obtaining Husband's Ordinances"
  380. 4040 IF HUSB = 0 THEN 4130
  381. 4050 GET #3, HUSB
  382. 4060 GOSUB 2640  'Extract Ordinances
  383. 4065 MID$(FORM$(3),5,11) = U2$
  384. 4070 MID$(FORM$(17),100,11) = U7$
  385. 4080 MID$(FORM$(17),111,11) = U10$
  386. 4090 REM get Husband's Occupation
  387. 4100 PRINT "Obtaining Husband's Occupation"
  388. 4110 IF U24$ = " " THEN 4150
  389. 4120 MID$(FORM$(1),55,LEN(U24$)+2) = "("+U24$+")"
  390. 4130 REM Obtain Wife's Ordinances
  391. 4140 IF WIFE = 0 THEN 4250
  392. 4150 GET #3, WIFE
  393. 4160 PRINT "Obtaining Wife's Ordinances"
  394. 4170 GOSUB 2640  'Extract Ordinances
  395. 4175 MID$(FORM$(12),5,11) = U2$
  396. 4180 MID$(FORM$(19),100,11) = U7$
  397. 4190 MID$(FORM$(19),111,11) = U10$
  398. 4200 MID$(FORM$(17),122,11) = U11$
  399. 4210 REM get Wife's Occupation
  400. 4220 PRINT "Obtaining Wife's Occupation"
  401. 4230 IF U24$ = " " THEN 4250
  402. 4240 MID$(FORM$(10),55,LEN(U24$)+2) = "("+U24$+")"
  403. 4250 REM Now obtain the information about the Children
  404. 4260 CHILD.COUNT = 0
  405. 4300 REM Search the Parent/Child Index
  406. 4310 PRINT "Look for Children"
  407. 4320 XMARRCT = 0
  408. 4330 FOR LL = 1 TO PC.COUNT
  409. 4340  IF HUSB > PA.ID(LL) THEN 4930
  410. 4350  IF HUSB < PA.ID(LL) THEN LL = PC.COUNT : GOTO 4930
  411. 4360  REM found a child
  412. 4370  IF CH.ID(LL) = 0 THEN 4910
  413. 4380  GET #1, CH.ID(LL)
  414. 4390  GOSUB 2310  'Extract Personal Info.
  415. 4400  REM verify that Mother is the same
  416. 4410  IF WIFE <> T7 THEN 4930
  417. 4420  REM Found a valid child
  418. 4421  CHILD.COUNT = CHILD.COUNT + 1
  419. 4422  SHOW.COUNT = CHILD.COUNT
  420. 4423  IF CHILD.COUNT > 11 THEN SHOW.COUNT = CHILD.COUNT - 11
  421. 4424  IF CHILD.COUNT > 22 THEN SHOW.COUNT = CHILD.COUNT - 22
  422. 4425  IF CHILD.COUNT > 33 THEN SHOW.COUNT = CHILD.COUNT - 33
  423. 4426  IF CHILD.COUNT > 44 THEN SHOW.COUNT = CHILD.COUNT - 44
  424. 4430  REM test for more than 11 children
  425. 4431  IF CHILD.COUNT = 1 THEN 4458
  426. 4432  IF (CHILD.COUNT-1) MOD 11 = 0 THEN 4433 ELSE 4458
  427. 4433  GOSUB 4940 'print the current form, then blank out children
  428. 4434  FOR II = 20 TO 49
  429. 4435   FORM$(II) = SPACE$(132)
  430. 4436  NEXT II
  431. 4437  GOSUB 2140  'Next form
  432. 4438  SHOW.COUNT = 1
  433. 4439  XMARRCT = 0
  434. 4458  SEX$ = T4$
  435. 4459  PRINT "Processing Child #";CHILD.COUNT
  436. 4460  MID$(FORM$(19+(2*SHOW.COUNT)),2,1) = T4$
  437. 4470  MID$(FORM$(19+(2*SHOW.COUNT)),4,LEN(T2$+T3$)+2) = T2$+", "+T3$
  438. 4480  MID$(FORM$(19+(2*SHOW.COUNT)),28,11) = T8$
  439. 4490  MID$(FORM$(19+(2*SHOW.COUNT)),41,LEN(T9$)) = T9$
  440. 4500  MID$(FORM$(19+(2*SHOW.COUNT)),60,4) = LEFT$(T10$,4)
  441. 4510  MID$(FORM$(19+(2*SHOW.COUNT)),66,4) = LEFT$(T11$,4)
  442. 4520  MID$(FORM$(19+(2*SHOW.COUNT)-1),85,11) = T12$
  443. 4530  REM Now get Child's Ordinances
  444. 4540  GET #3, CH.ID(LL)
  445. 4550  PRINT "Obtain Child's Ordinances"
  446. 4560  GOSUB 2640  'Extract Ordinances
  447. 4570  MID$(FORM$(19+(2*SHOW.COUNT)),100,11) = U7$
  448. 4580  MID$(FORM$(19+(2*SHOW.COUNT)),111,11) = U10$
  449. 4590  MID$(FORM$(19+(2*SHOW.COUNT)),122,11) = U4$
  450. 4600  REM Now look for Child's Marriage
  451. 4610  PRINT "Look for Child's Marriage"
  452. 4620  FOUND = 0
  453. 4630  FOR L = 1 TO M.COUNT
  454. 4640   IF CH.ID(LL) > PERS.NO(L) THEN 4920
  455. 4650   IF CH.ID(LL) < PERS.NO(L) THEN L = M.COUNT : GOTO 4920
  456. 4660   REM Found a Marriage
  457. 4670   IF M.NO(L) = 0 THEN 4910
  458. 4680   FOUND = FOUND + 1
  459. 4690   GET #2, M.NO(L)
  460. 4700   GOSUB 2720  'Extract Marriage Information
  461. 4710   IF FOUND <> 1 THEN 4730
  462. 4720   MID$(FORM$(19+(2*SHOW.COUNT)-1),72,11) = TT5$
  463. 4730   REM get spouse
  464. 4740   SPOUSE = 0
  465. 4750   IF SEX$ = "M" THEN SPOUSE = TT3
  466. 4760   IF SEX$ = "F" THEN SPOUSE = TT2
  467. 4770   IF SPOUSE = 0 THEN 4910
  468. 4780   GET #1, SPOUSE
  469. 4790   GOSUB 2310  'Extract Spouse's Information
  470. 4800   IF FOUND = 1 THEN 4890
  471. 4810   XMARRCT = XMARRCT + 1
  472. 4820   CH$ = SPACE$(4)
  473. 4830   RSET CH$ = (STR$(CHILD.COUNT))
  474. 4840   MID$(FORM$(42+XMARRCT),60,LEN(CH$)) = CH$
  475. 4850   IF T2$ = " " AND T3$ = " " THEN 4880
  476. 4860   MID$(FORM$(42+XMARRCT),77,LEN(T2$+T3$)+2) = T2$+", "+T3$
  477. 4870   MID$(FORM$(42+XMARRCT),65,LEN(TT5$)) = TT5$
  478. 4880   GOTO 4910
  479. 4890   IF T2$ = " " AND T3$ = " " THEN 4910
  480. 4900   MID$(FORM$(19+(2*SHOW.COUNT)),72,LEN(T2$+T3$)+2) = T2$+", "+T3$
  481. 4910  REM finished with this child
  482. 4920  NEXT L
  483. 4930 NEXT LL
  484. 4935 GOSUB 4940 : GOTO 5030
  485. 4940 REM enter sources
  486. 4950 COMM$ = "Genealogy ON DISPLAY Computerized Data Base"
  487. 4960 MID$(FORM$(43),2,LEN(COMM$)) = COMM$
  488. 4970 PRINT "Ready to Print"
  489. 4980 REM Print the Family Group Sheet
  490. 4990 FOR I = 1 TO 49
  491. 5000  LPRINT FORM$(I);
  492. 5010 NEXT I
  493. 5020 LPRINT CHR$(12);
  494. 5025 RETURN
  495. 5030 GOTO 2080  'for Next Group Sheet
  496. 5040 REM Wrapup
  497. 5050 LPRINT CHR$(18);     'Normal Printing
  498. 5060 LPRINT CHR$(27)"9";  'Paper Sensing ON
  499. 5070 LPRINT CHR$(27)"A";  'Normal Page of 66 Lines
  500. 5080 CLOSE #1
  501. 5090 CLOSE #2
  502. 5100 CLOSE #3
  503. 5110 CLS : LOCATE 21,1
  504. 5120 PRINT "End of Program"
  505. 5130 LPRINT CHR$(12);     'Page Eject
  506. 5140 LPRINT CHR$(12);     'Page Eject
  507. 5150 END
  508. fy input
  509. 1210 IF VAL(REPLY$) = 1 OR VAL(REPLY$) = 2 THEN 1240
  510. 1220 LOCATE 19,1 : PRINT "Error in