home *** CD-ROM | disk | FTP | other *** search
/ ftp.barnyard.co.uk / 2015.02.ftp.barnyard.co.uk.tar / ftp.barnyard.co.uk / cpm / walnut-creek-CDROM / MBUG / MBUG059.ARC / PEDIGREE.BAS < prev    next >
BASIC Source File  |  1979-12-31  |  23KB  |  644 lines
  1. 100 TITLE$ = "Pedigree 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(31), 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 Pedigree 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 reset all Printer Defaults
  85. 1090 'LPRINT CHR$(18); 'Normal Printing
  86. 1100 'LPRINT CHR$(27)"9";  'Paper Sensing ON
  87. 1110 WIDTH "lpt1:", 132  'For printing Genealogy Forms
  88. 1120 REM Ask User about his Printer
  89. 1130 LOCATE 20,1 : PRINT "How Wide is the Paper";
  90. 1140 LOCATE 21,3 : COLOR 0,7 : PRINT "1"; : COLOR 7,0
  91. 1150 LOCATE 21,6 : PRINT "8 - 1/2 inches";
  92. 1160 LOCATE 22,3 : COLOR 0,7 : PRINT "2"; : COLOR 7,0
  93. 1170 LOCATE 22,6 : PRINT "14 inches";
  94. 1180 LOCATE 23,1 : PRINT SPACE$(79);
  95. 1190 LOCATE 23,1 : INPUT "Enter 1 or 2"; REPLY$
  96. 1200 REM verify input
  97. 1210 IF VAL(REPLY$) = 1 OR VAL(REPLY$) = 2 THEN 1240
  98. 1220 LOCATE 19,1 : PRINT "Error in Previous Reply";
  99. 1230 GOTO 1130
  100. 1240 LOCATE 19,1 : PRINT SPACE$(79);
  101. 1250 LOCATE 20,1 : PRINT SPACE$(79);
  102. 1260 LOCATE 21,1 : PRINT SPACE$(79);
  103. 1270 LOCATE 22,1 : PRINT SPACE$(79);
  104. 1280 LOCATE 23,1 : PRINT SPACE$(79);
  105. 1290 WIDE = VAL(REPLY$)
  106. 1300 LOCATE 3,1
  107. 1310 IF WIDE = 1 THEN PRINT "Using 8-1/2 inch width paper"; : GOTO 1330
  108. 1320 PRINT "Using 14 inch width paper";
  109. 1330 LOCATE 20,1 : PRINT "How Long is the Paper";
  110. 1340 LOCATE 21,3 : COLOR 0,7 : PRINT "1"; : COLOR 7,0
  111. 1350 LOCATE 21,6 : PRINT "8 - 1/2 inches";
  112. 1360 LOCATE 22,3 : COLOR 0,7 : PRINT "2"; : COLOR 7,0
  113. 1370 LOCATE 22,6 : PRINT "11 inches";
  114. 1380 LOCATE 23,1 : PRINT SPACE$(79);
  115. 1390 LOCATE 23,1 : INPUT "Enter 1 or 2"; REPLY$
  116. 1400 REM verify input
  117. 1410 IF VAL(REPLY$) = 1 OR VAL(REPLY$) = 2 THEN 1440
  118. 1420 LOCATE 19,1 : PRINT "Error in Previous Reply";
  119. 1430 GOTO 1330
  120. 1440 LOCATE 19,1 : PRINT SPACE$(79);
  121. 1450 LOCATE 20,1 : PRINT SPACE$(79);
  122. 1460 LOCATE 21,1 : PRINT SPACE$(79);
  123. 1470 LOCATE 22,1 : PRINT SPACE$(79);
  124. 1480 LOCATE 23,1 : PRINT SPACE$(79);
  125. 1490 LENGTH = VAL(REPLY$)
  126. 1500 LOCATE 5,1
  127. 1510 IF LENGTH = 1 THEN PRINT "Using 8-1/2 inch length paper"; : GOTO 1530
  128. 1520 PRINT "Using 11 inch length paper";
  129. 1530 LOCATE 20,1 : PRINT "Describe the Forms to be Used";
  130. 1540 LOCATE 21,3 : COLOR 0,7 : PRINT "1"; : COLOR 7,0
  131. 1550 LOCATE 21,6 : PRINT "Continuous";
  132. 1560 LOCATE 22,3 : COLOR 0,7 : PRINT "2"; : COLOR 7,0
  133. 1570 LOCATE 22,6 : PRINT "Single Sheets";
  134. 1580 LOCATE 23,1 : PRINT SPACE$(79);
  135. 1590 LOCATE 23,1 : INPUT "Enter 1 or 2"; REPLY$
  136. 1600 REM verify input
  137. 1610 IF VAL(REPLY$) = 1 OR VAL(REPLY$) = 2 THEN 1640
  138. 1620 LOCATE 19,1 : PRINT "Error in Previous Reply";
  139. 1630 GOTO 1530
  140. 1640 LOCATE 19,1 : PRINT SPACE$(79);
  141. 1650 LOCATE 20,1 : PRINT SPACE$(79);
  142. 1660 LOCATE 21,1 : PRINT SPACE$(79);
  143. 1670 LOCATE 22,1 : PRINT SPACE$(79);
  144. 1680 LOCATE 23,1 : PRINT SPACE$(79);
  145. 1690 FORMS = VAL(REPLY$)
  146. 1700 LOCATE 7,1
  147. 1710 IF FORMS = 1 THEN PRINT "Using Continuous Forms"; : GOTO 1730
  148. 1720 PRINT "Using Single Sheets";
  149. 1730 LOCATE 20,1 : PRINT "Is the above information correct?"
  150. 1740 LOCATE 21,1 : INPUT "Enter 'y' or 'n' for 'yes' or 'no'"; REPLY$
  151. 1750 IF LEFT$(REPLY$,1) = "y" OR LEFT$(REPLY$,1) = "Y" THEN 1760 ELSE 1070
  152. 1760 CLS
  153. 1770 REM By:  Melvin O. Duke.  Updated December 1982.
  154. 1780 REM Read the Marriage Index
  155. 1790 LOCATE 7,1 : PRINT "Open the Marriage Index";
  156. 1800 OPEN "a:mindex" FOR INPUT AS #2
  157. 1810 INPUT #2, M.COUNT
  158. 1820 FOR I = 1 TO M.COUNT
  159. 1830 LOCATE 8,1 : PRINT "Reading Marriage Index Record #:";I:
  160. 1840  INPUT #2,PERS.NO(I), M.NO(I)
  161. 1850 NEXT I
  162. 1860 CLOSE #2
  163. 1870 REM Open the Persons File
  164. 1880 LOCATE 10,1 : PRINT "Open the Persons File"
  165. 1890 OPEN "a:persfile" AS #1 LEN = 256
  166. 1900 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$
  167. 1910 REM open the Marriages File
  168. 1920 LOCATE 12,1 : PRINT "Open the Marriage File"
  169. 1930 OPEN "a:marrfile" AS #2 LEN = 128
  170. 1940 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$
  171. 1950 REM Obtain a Person Record from the User
  172. 1960 LOCATE 20,1 : INPUT "Enter the Record-number of a Person";PERS(1)
  173. 1970 IF PERS(1) = 0 THEN 6570
  174. 1980 IF PERS(1) < 1 OR PERS(1) > 400 THEN CLS: GOTO 1950
  175. 1990 REM
  176. 2000 REM Reset the Printer characteristics for next page if required.
  177. 2010 IF FORMS = 1 THEN 2050  'Don't stop if forms are continuous
  178. 2020 REM process single sheets
  179. 2030 PRINT "Press any key when next form is ready"
  180. 2040 A$ = INKEY$ : IF A$ = "" THEN 2040
  181. 2050 REM Reset paper sensing if required
  182. 2060 IF FORMS = 2 THEN LPRINT CHR$(27)"8";
  183. 2070 REM Reset paper length if required
  184. 2080 IF LENGTH = 1 THEN LPRINT CHR$(27)"C51";
  185. 2090 REM Reset Condensed printing if required
  186. 2100 IF WIDE = 1 THEN LPRINT CHR$(15);
  187. 2110 CLS
  188. 2120 GOTO 2770
  189. 2130 REM Routine to Extract Personal Information
  190. 2140 T1 = CVS(F1$)
  191. 2150 TEMP1$ = F2$ : TEMP2$ = F2$ : GOSUB 2420  'Rtrim
  192. 2160 T2$ = TEMP2$
  193. 2170 TEMP1$ = F3$ : TEMP2$ = F3$ : GOSUB 2420  'Rtrim
  194. 2180 T3$ = TEMP2$
  195. 2190 T4$ = F4$
  196. 2200 IF LEFT$(T4$,1) = "M" THEN T4$ = "Male"
  197. 2210 IF LEFT$(T4$,1) = "F" THEN T4$ = "Female"
  198. 2220 T5 = CVS(F5$)
  199. 2230 T6 = CVS(F6$)
  200. 2240 T7 = CVS(F7$)
  201. 2250 T8$ = F8$
  202. 2260 TEMP1$ = F9$ : TEMP2$ = F9$ : GOSUB 2420  'Rtrim
  203. 2270 T9$ = TEMP2$
  204. 2280 T10$ = F10$
  205. 2290 TEMP1$ = F11$ : TEMP2$ = F11$ : GOSUB 2420  'Rtrim
  206. 2300 T11$ = TEMP2$
  207. 2310 T12$ = F12$
  208. 2320 TEMP1$ = F13$ : TEMP2$ = F13$ : GOSUB 2420  'Rtrim
  209. 2330 T13$ = TEMP2$
  210. 2340 T14$ = F14$
  211. 2350 TEMP1$ = F15$ : TEMP2$ = F15$ : GOSUB 2420  'Rtrim
  212. 2360 T15$ = TEMP2$
  213. 2370 T16$ = F16$
  214. 2380 T17$ = F17$
  215. 2390 T18$ = F18$
  216. 2400 T19$ = F19$
  217. 2410 RETURN
  218. 2420 REM General RTRIM$ Routine
  219. 2430 FOR J = 1 TO LEN(TEMP1$)-1
  220. 2440  IF RIGHT$(TEMP2$,1) = " " THEN TEMP2$ = LEFT$(TEMP2$,LEN(TEMP2$)-1) ELSE J = LEN(TEMP1$)-1
  221. 2450 NEXT J
  222. 2460 RETURN
  223. 2470 REM Blank out a Record
  224. 2480 T1 = 0
  225. 2490 T2$ = ""
  226. 2500 T3$ = ""
  227. 2510 T4$ = ""
  228. 2520 T5 = 0
  229. 2530 T6 = 0
  230. 2540 T7 = 0
  231. 2550 T8$ = ""
  232. 2560 T9$ = ""
  233. 2570 T10$ = ""
  234. 2580 T11$ = ""
  235. 2590 T12$ = ""
  236. 2600 T13$ = ""
  237. 2610 T14$ = ""
  238. 2620 T15$ = ""
  239. 2630 T16$ = ""
  240. 2640 T17$ = ""
  241. 2650 T18$ = ""
  242. 2660 T19$ = ""
  243. 2670 RETURN
  244. 2680 REM Routine to extract a name
  245. 2690 MID$(FORM$(ROW),COL,LEN(T2$+T3$)+2)=T2$+", "+T3$
  246. 2700 RETURN
  247. 2710 REM Routine to extract a birth-location
  248. 2720 MID$(FORM$(ROW),COL,LEN(T9$+T11$)+2)=T9$+", "+T11$
  249. 2730 RETURN
  250. 2740 REM Routine to extract a death-location
  251. 2750 MID$(FORM$(ROW),COL,LEN(T13$+T15$)+2)=T13$+", "+T15$
  252. 2760 RETURN
  253. 2770 REM Routine to Produce a Pedigree Chart
  254. 2780 REM Start with all Spaces
  255. 2790 FOR I = 1 TO 49
  256. 2800  FORM$(I) = SPACE$(131)
  257. 2810 NEXT I
  258. 2820 REM get 1
  259. 2830 LOCATE 20,1 : PRINT "Processing Person # 1 on the Chart"
  260. 2840 IF PERS(1) = 0 THEN GOSUB 2470 : GOTO 2940
  261. 2850 GET #1, PERS(1) : GOSUB 2130  'Extract 1
  262. 2860 IF T2$ = " " AND T3$ = " " THEN 2880
  263. 2870 ROW=23: COL=1: GOSUB 2680
  264. 2880 MID$(FORM$(24),3,11) = T8$
  265. 2890 IF T9$ = " " AND T11$ = " " THEN 2910
  266. 2900 ROW=25: COL=3: GOSUB 2710
  267. 2910 MID$(FORM$(27),3,11) = T12$
  268. 2920 IF T13$ = " " AND T15$ = " " THEN 2940
  269. 2930 ROW=28: COL=3: GOSUB 2740
  270. 2940 PERS(2) = T6
  271. 2950 PERS(3) = T7
  272. 2960 REM get 11
  273. 2970 LOCATE 20,20: PRINT " 2";
  274. 2980 IF PERS(2) = 0 THEN GOSUB 2470 : GOTO 3080
  275. 2990 GET #1, PERS(2) : GOSUB 2130  'Extract 11
  276. 3000 IF T2$ = " " AND T3$ = " " THEN 3020
  277. 3010 ROW=12: COL=24: GOSUB 2680
  278. 3020 MID$(FORM$(13),27,11) = T8$
  279. 3030 IF T9$ = " " AND T11$ = " " THEN 3050
  280. 3040 ROW=14: COL=27: GOSUB 2710
  281. 3050 MID$(FORM$(16),27,11) = T12$
  282. 3060 IF T13$ = " " AND T15$ = " " THEN 3080
  283. 3070 ROW=17: COL=27: GOSUB 2740
  284. 3080 PERS(4) = T6
  285. 3090 PERS(5) = T7
  286. 3100 REM get 10
  287. 3110 LOCATE 20,20: PRINT " 3";
  288. 3120 IF PERS(3) = 0 THEN GOSUB 2470 : GOTO 3220
  289. 3130 GET #1, PERS(3) : GOSUB 2130  'Extract 10
  290. 3140 IF T2$ = " " AND T3$ = " " THEN 3160
  291. 3150 ROW=36: COL=24: GOSUB 2680
  292. 3160 MID$(FORM$(37),27,11) = T8$
  293. 3170 IF T9$ = " " AND T11$ = " " THEN 3190
  294. 3180 ROW=38: COL=27: GOSUB 2710
  295. 3190 MID$(FORM$(39),27,11) = T12$
  296. 3200 IF T13$ = " " AND T15$ = " " THEN 3220
  297. 3210 ROW=40: COL=27: GOSUB 2740
  298. 3220 PERS(6) = T6
  299. 3230 PERS(7) = T7
  300. 3240 REM get 111
  301. 3250 LOCATE 20,20: PRINT " 4";
  302. 3260 IF PERS(4) = 0 THEN GOSUB 2470 : GOTO 3360
  303. 3270 GET #1, PERS(4) : GOSUB 2130  'Extract 111
  304. 3280 IF T2$ = " " AND T3$ = " " THEN 3300
  305. 3290 ROW=6: COL=49: GOSUB 2680
  306. 3300 MID$(FORM$(7),52,11) = T8$
  307. 3310 IF T9$ = " " AND T11$ = " " THEN 3330
  308. 3320 ROW=8: COL=52: GOSUB 2710
  309. 3330 MID$(FORM$(10),52,11) = T12$
  310. 3340 IF T13$ = " " AND T15$ = " " THEN 3360
  311. 3350 ROW=11: COL=52: GOSUB 2740
  312. 3360 PERS(8) = T6
  313. 3370 PERS(9) = T7
  314. 3380 REM get 110
  315. 3390 LOCATE 20,20: PRINT " 5";
  316. 3400 IF PERS(5) = 0 THEN GOSUB 2470 : GOTO 3500
  317. 3410 GET #1, PERS(5) : GOSUB 2130  'Extract 110
  318. 3420 IF T2$ = " " AND T3$ = " " THEN 3440
  319. 3430 ROW=18: COL=49: GOSUB 2680
  320. 3440 MID$(FORM$(19),52,11) = T8$
  321. 3450 IF T9$ = " " AND T11$ = " " THEN 3470
  322. 3460 ROW=20: COL=52: GOSUB 2710
  323. 3470 MID$(FORM$(21),52,11) = T12$
  324. 3480 IF T13$ = " " AND T15$ = " " THEN 3500
  325. 3490 ROW=22: COL=52: GOSUB 2740
  326. 3500 PERS(10) = T6
  327. 3510 PERS(11) = T7
  328. 3520 REM get 101
  329. 3530 LOCATE 20,20: PRINT " 6";
  330. 3540 IF PERS(6) = 0 THEN GOSUB 2470 : GOTO 3640
  331. 3550 GET #1, PERS(6) : GOSUB 2130  'Extract 101
  332. 3560 IF T2$ = " " AND T3$ = " " THEN 3580
  333. 3570 ROW=30: COL=49: GOSUB 2680
  334. 3580 MID$(FORM$(31),52,11) = T8$
  335. 3590 IF T9$ = " " AND T11$ = " " THEN 3610
  336. 3600 ROW=32: COL=52: GOSUB 2710
  337. 3610 MID$(FORM$(34),52,11) = T12$
  338. 3620 IF T13$ = " " AND T15$ = " " THEN 3640
  339. 3630 ROW=35: COL=52: GOSUB 2740
  340. 3640 PERS(12) = T6
  341. 3650 PERS(13) = T7
  342. 3660 REM get 100
  343. 3670 LOCATE 20,20: PRINT " 7";
  344. 3680 IF PERS(7) = 0 THEN GOSUB 2470 : GOTO 3780
  345. 3690 GET #1, PERS(7) : GOSUB 2130  'Extract 100
  346. 3700 IF T2$ = " " AND T3$ = " " THEN 3720
  347. 3710 ROW=42: COL=49: GOSUB 2680
  348. 3720 MID$(FORM$(43),52,11) = T8$
  349. 3730 IF T9$ = " " AND T11$ = " " THEN 3750
  350. 3740 ROW=44: COL=52: GOSUB 2710
  351. 3750 MID$(FORM$(45),52,11) = T12$
  352. 3760 IF T13$ = " " AND T15$ = " " THEN 3780
  353. 3770 ROW=46: COL=52: GOSUB 2740
  354. 3780 PERS(14) = T6
  355. 3790 PERS(15) = T7
  356. 3800 REM get 1111
  357. 3810 LOCATE 20,20: PRINT " 8";
  358. 3820 IF PERS(8) = 0 THEN GOSUB 2470 : GOTO 3920
  359. 3830 GET #1, PERS(8) : GOSUB 2130  'Extract 1111
  360. 3840 IF T2$ = " " AND T3$ = " " THEN 3860
  361. 3850 ROW=3: COL=74: GOSUB 2680
  362. 3860 MID$(FORM$(4),77,11) = T8$
  363. 3870 IF T9$ = " " AND T11$ = " " THEN 3890
  364. 3880 ROW=5: COL=77: GOSUB 2710
  365. 3890 MID$(FORM$(7),77,11) = T12$
  366. 3900 IF T13$ = " " AND T15$ = " " THEN 3920
  367. 3910 ROW=8: COL=77: GOSUB 2740
  368. 3920 PERS(16) = T6
  369. 3930 PERS(17) = T7
  370. 3940 REM get 1110
  371. 3950 LOCATE 20,20: PRINT " 9";
  372. 3960 IF PERS(9) = 0 THEN GOSUB 2470 : GOTO 4060
  373. 3970 GET #1, PERS(9) : GOSUB 2130  'Extract 1110
  374. 3980 IF T2$ = " " AND T3$ = " " THEN 4000
  375. 3990 ROW=9: COL=74: GOSUB 2680
  376. 4000 MID$(FORM$(10),77,11) = T8$
  377. 4010 IF T9$ = " " AND T11$ = " " THEN 4030
  378. 4020 ROW=11: COL=77: GOSUB 2710
  379. 4030 MID$(FORM$(12),77,11) = T12$
  380. 4040 IF T13$ = " " AND T15$ = " " THEN 4060
  381. 4050 ROW=13: COL=77: GOSUB 2740
  382. 4060 PERS(18) = T6
  383. 4070 PERS(19) = T7
  384. 4080 REM get 1101
  385. 4090 LOCATE 20,20: PRINT "10";
  386. 4100 IF PERS(10) = 0 THEN GOSUB 2470 : GOTO 4200
  387. 4110 GET #1, PERS(10) : GOSUB 2130  'Extract 1101
  388. 4120 IF T2$ = " " AND T3$ = " " THEN 4140
  389. 4130 ROW=15: COL=74: GOSUB 2680
  390. 4140 MID$(FORM$(16),77,11) = T8$
  391. 4150 IF T9$ = " " AND T11$ = " " THEN 4170
  392. 4160 ROW=17: COL=77: GOSUB 2710
  393. 4170 MID$(FORM$(19),77,11) = T12$
  394. 4180 IF T13$ = " " AND T15$ = " " THEN 4200
  395. 4190 ROW=20: COL=77: GOSUB 2740
  396. 4200 PERS(20) = T6
  397. 4210 PERS(21) = T7
  398. 4220 REM get 1100
  399. 4230 LOCATE 20,20: PRINT "11";
  400. 4240 IF PERS(11) = 0 THEN GOSUB 2470 : GOTO 4340
  401. 4250 GET #1, PERS(11) : GOSUB 2130  'Extract 1100
  402. 4260 IF T2$ = " " AND T3$ = " " THEN 4280
  403. 4270 ROW=21: COL=74: GOSUB 2680
  404. 4280 MID$(FORM$(22),77,11) = T8$
  405. 4290 IF T9$ = " " AND T11$ = " " THEN 4310
  406. 4300 ROW=23: COL=77: GOSUB 2710
  407. 4310 MID$(FORM$(24),77,11) = T12$
  408. 4320 IF T13$ = " " AND T15$ = " " THEN 4340
  409. 4330 ROW=25: COL=77: GOSUB 2740
  410. 4340 PERS(22) = T6
  411. 4350 PERS(23) = T7
  412. 4360 REM get 1011
  413. 4370 LOCATE 20,20: PRINT "12";
  414. 4380 IF PERS(12) = 0 THEN GOSUB 2470 : GOTO 4480
  415. 4390 GET #1, PERS(12) : GOSUB 2130  'Extract 1010
  416. 4400 IF T2$ = " " AND T3$ = " " THEN 4420
  417. 4410 ROW=27: COL=74: GOSUB 2680
  418. 4420 MID$(FORM$(28),77,11) = T8$
  419. 4430 IF T9$ = " " AND T11$ = " " THEN 4450
  420. 4440 ROW=29: COL=77: GOSUB 2710
  421. 4450 MID$(FORM$(31),77,11) = T12$
  422. 4460 IF T13$ = " " AND T15$ = " " THEN 4480
  423. 4470 ROW=32: COL=77: GOSUB 2740
  424. 4480 PERS(24) = T6
  425. 4490 PERS(25) = T7
  426. 4500 REM get 1010
  427. 4510 LOCATE 20,20: PRINT "13";
  428. 4520 IF PERS(13) = 0 THEN GOSUB 2470 : GOTO 4620
  429. 4530 GET #1, PERS(13) : GOSUB 2130  'Extract 1010
  430. 4540 IF T2$ = " " AND T3$ = " " THEN 4560
  431. 4550 ROW=33: COL=74: GOSUB 2680
  432. 4560 MID$(FORM$(34),77,11) = T8$
  433. 4570 IF T9$ = " " AND T11$ = " " THEN 4590
  434. 4580 ROW=35: COL=77: GOSUB 2710
  435. 4590 MID$(FORM$(36),77,11) = T12$
  436. 4600 IF T13$ = " " AND T15$ = " " THEN 4620
  437. 4610 ROW=37: COL=77: GOSUB 2740
  438. 4620 PERS(26) = T6
  439. 4630 PERS(27) = T7
  440. 4640 REM get 1001
  441. 4650 LOCATE 20,20: PRINT "14";
  442. 4660 IF PERS(14) = 0 THEN GOSUB 2470 : GOTO 4760
  443. 4670 GET #1, PERS(14) : GOSUB 2130  'Extract 1001
  444. 4680 IF T2$ = " " AND T3$ = " " THEN 4700
  445. 4690 ROW=39: COL=74: GOSUB 2680
  446. 4700 MID$(FORM$(40),77,11) = T8$
  447. 4710 IF T9$ = " " AND T11$ = " " THEN 4730
  448. 4720 ROW=41: COL=77: GOSUB 2710
  449. 4730 MID$(FORM$(43),77,11) = T12$
  450. 4740 IF T13$ = " " AND T15$ = " " THEN 4760
  451. 4750 ROW=44: COL=77: GOSUB 2740
  452. 4760 PERS(28) = T6
  453. 4770 PERS(29) = T7
  454. 4780 REM get 1001
  455. 4790 LOCATE 20,20: PRINT "15";
  456. 4800 IF PERS(15) = 0 THEN GOSUB 2470 : GOTO 4900
  457. 4810 GET #1, PERS(15) : GOSUB 2130  'Extract 1000
  458. 4820 IF T2$ = " " AND T3$ = " " THEN 4840
  459. 4830 ROW=45: COL=74: GOSUB 2680
  460. 4840 MID$(FORM$(46),77,11) = T8$
  461. 4850 IF T9$ = " " AND T11$ = " " THEN 4870
  462. 4860 ROW=47: COL=77: GOSUB 2710
  463. 4870 MID$(FORM$(48),77,11) = T12$
  464. 4880 IF T13$ = " " AND T15$ = " " THEN 4900
  465. 4890 ROW=49: COL=77: GOSUB 2740
  466. 4900 PERS(30) = T6
  467. 4910 PERS(31) = T7
  468. 4920 REM get 11111
  469. 4930 LOCATE 20,20: PRINT "16";
  470. 4940 IF PERS(16) = 0 THEN GOSUB 2470 : GOTO 4970
  471. 4950 GET #1, PERS(16) : GOSUB 2130  'Extract 11111
  472. 4960 ROW=1: COL=98: GOSUB 2680
  473. 4970 REM get 11110
  474. 4980 LOCATE 20,20: PRINT "17";
  475. 4990 IF PERS(17) = 0 THEN GOSUB 2470 : GOTO 5020
  476. 5000 GET #1, PERS(17) : GOSUB 2130  'Extract 11110
  477. 5010 ROW=4: COL=98: GOSUB 2680
  478. 5020 REM get 11101
  479. 5030 LOCATE 20,20: PRINT "18";
  480. 5040 IF PERS(18) = 0 THEN GOSUB 2470 : GOTO 5070
  481. 5050 GET #1, PERS(18) : GOSUB 2130  'Extract 11101
  482. 5060 ROW=7: COL=98: GOSUB 2680
  483. 5070 REM get 11100
  484. 5080 LOCATE 20,20: PRINT "19";
  485. 5090 IF PERS(19) = 0 THEN GOSUB 2470 : GOTO 5120
  486. 5100 GET #1, PERS(19) : GOSUB 2130  'Extract 11100
  487. 5110 ROW=10: COL=98: GOSUB 2680
  488. 5120 REM get 11011
  489. 5130 LOCATE 20,20: PRINT "20";
  490. 5140 IF PERS(20) = 0 THEN GOSUB 2470 : GOTO 5170
  491. 5150 GET #1, PERS(20) : GOSUB 2130  'Extract 11011
  492. 5160 ROW=13: COL=98: GOSUB 2680
  493. 5170 REM get 11010
  494. 5180 LOCATE 20,20: PRINT "21";
  495. 5190 IF PERS(21) = 0 THEN GOSUB 2470 : GOTO 5220
  496. 5200 GET #1, PERS(21) : GOSUB 2130  'Extract 11010
  497. 5210 ROW=16: COL=98: GOSUB 2680
  498. 5220 REM get 11001
  499. 5230 LOCATE 20,20: PRINT "22";
  500. 5240 IF PERS(22) = 0 THEN GOSUB 2470 : GOTO 5270
  501. 5250 GET #1, PERS(22) : GOSUB 2130  'Extract 11001
  502. 5260 ROW=19: COL=98: GOSUB 2680
  503. 5270 REM get 11000
  504. 5280 LOCATE 20,20: PRINT "23";
  505. 5290 IF PERS(23) = 0 THEN GOSUB 2470 : GOTO 5320
  506. 5300 GET #1, PERS(23) : GOSUB 2130  'Extract 11000
  507. 5310 ROW=22: COL=98: GOSUB 2680
  508. 5320 REM get 10111
  509. 5330 LOCATE 20,20: PRINT "24";
  510. 5340 IF PERS(24) = 0 THEN GOSUB 2470 : GOTO 5370
  511. 5350 GET #1, PERS(24) : GOSUB 2130  'Extract 10111
  512. 5360 ROW=25: COL=98: GOSUB 2680
  513. 5370 REM get 10110
  514. 5380 LOCATE 20,20: PRINT "25";
  515. 5390 IF PERS(25) = 0 THEN GOSUB 2470 : GOTO 5420
  516. 5400 GET #1, PERS(25) : GOSUB 2130  'Extract 10110
  517. 5410 ROW=28: COL=98: GOSUB 2680T3$)+2) = T2$+", "+T3$
  518. 5420 REM get 10101
  519. 5430 LOCATE 20,20: PRINT "26";
  520. 5440 IF PERS(26) = 0 THEN GOSUB 2470 : GOTO 5470
  521. 5450 GET #1, PERS(26) : GOSUB 2130  'Extract 10101
  522. 5460 ROW=31: COL=98: GOSUB 2680
  523. 5470 REM get 10100
  524. 5480 LOCATE 20,20: PRINT "27";
  525. 5490 IF PERS(27) = 0 THEN GOSUB 2470 : GOTO 5520
  526. 5500 GET #1, PERS(27) : GOSUB 2130  'Extract 10100
  527. 5510 ROW=34: COL=98: GOSUB 2680
  528. 5520 REM get 10011
  529. 5530 LOCATE 20,20: PRINT "28";
  530. 5540 IF PERS(28) = 0 THEN GOSUB 2470 : GOTO 5570
  531. 5550 GET #1, PERS(28) : GOSUB 2130  'Extract 10011
  532. 5560 ROW=37: COL=98: GOSUB 2680
  533. 5570 REM get 10010
  534. 5580 LOCATE 20,20: PRINT "29";
  535. 5590 IF PERS(29) = 0 THEN GOSUB 2470 : GOTO 5620
  536. 5600 GET #1, PERS(29) : GOSUB 2130  'Extract 10010
  537. 5610 ROW=40: COL=98: GOSUB 2680
  538. 5620 REM get 10001
  539. 5630 LOCATE 20,20: PRINT "30";
  540. 5640 IF PERS(30) = 0 THEN GOSUB 2470 : GOTO 5670
  541. 5650 GET #1, PERS(30) : GOSUB 2130  'Extract 10001
  542. 5660 ROW=43: COL=98: GOSUB 2680
  543. 5670 REM get 10000
  544. 5680 LOCATE 20,20: PRINT "31";
  545. 5690 IF PERS(31) = 0 THEN GOSUB 2470 : GOTO 5720
  546. 5700 GET #1, PERS(31) : GOSUB 2130  'Extract 10000
  547. 5710 ROW=46: COL=98: GOSUB 2680
  548. 5720 GOTO 5780
  549. 5730 REM Extract Marriage Information
  550. 5740 TT2 = CVS(M2$)  'Husband
  551. 5750 TT3 = CVS(M3$)  'Wife
  552. 5760 TT5$ = M5$      'Marriage date
  553. 5770 RETURN
  554. 5780 REM Find Marriage of Person (1)
  555. 5790 CLS
  556. 5800 LOCATE 20,1 : PRINT "Processing Marriage of # 1 on Chart"
  557. 5810 FOUND = 0
  558. 5820 FOR L = 1 TO M.COUNT
  559. 5830  IF PERS(1) > PERS.NO(L) THEN 5890
  560. 5840  IF PERS(1) < PERS.NO(L) THEN L = M.COUNT : GOTO 5890
  561. 5850  REM found the marriage
  562. 5860  FOUND = 1
  563. 5870  GET #2, M.NO(L)
  564. 5880  L = M.COUNT
  565. 5890 NEXT L
  566. 5900 IF FOUND = 0 THEN 6000
  567. 5910 REM extract marriage information
  568. 5920 GOSUB 5730  'extract
  569. 5930 MID$(FORM$(26),12,11) = TT5$
  570. 5940 REM identify the spouse
  571. 5950 IF TT2 = PERS(1) THEN SPOUSE = TT3
  572. 5960 IF TT3 = PERS(1) THEN SPOUSE = TT2
  573. 5970 GET #1, SPOUSE
  574. 5980 GOSUB 2130  'Extract Person Info
  575. 5990 MID$(FORM$(29),1,LEN(T2$+T3$)+2) = T2$ + ", " + T3$
  576. 6000 GOTO 6150
  577. 6010 REM find a marriage
  578. 6020 FOUND = 0
  579. 6030 IF HUSB = 0 THEN 6140  'return
  580. 6040 FOR L = 1 TO M.COUNT
  581. 6050  IF HUSB > PERS.NO(L) THEN  6130  'next l
  582. 6060  IF HUSB < PERS.NO(L) THEN L = M.COUNT : GOTO 6130  'next l
  583. 6070  REM found one marriage
  584. 6080  GET #2, M.NO(L)
  585. 6090  GOSUB 5730  'Extract marriage info
  586. 6100  IF TT3 <> WIFE THEN 6130 'next l
  587. 6110  FOUND = 1
  588. 6120  L = M.COUNT
  589. 6130 NEXT L
  590. 6140 RETURN
  591. 6150 LOCATE 20,25: PRINT " 2";
  592. 6160 HUSB = PERS(2) : WIFE = PERS(3)
  593. 6170 GOSUB 6010  'Look for marriage
  594. 6180 IF FOUND = 0 THEN 6200
  595. 6190 MID$(FORM$(15),32,11) = TT5$
  596. 6200 LOCATE 20,25: PRINT " 4";
  597. 6210 HUSB = PERS(4) : WIFE = PERS(5)
  598. 6220 GOSUB 6010  'Look for marriage
  599. 6230 IF FOUND = 0 THEN 6250
  600. 6240 MID$(FORM$(9),57,11) = TT5$
  601. 6250 LOCATE 20,25: PRINT " 6";
  602. 6260 HUSB = PERS(6) : WIFE = PERS(7)
  603. 6270 GOSUB 6010  'Look for marriage
  604. 6280 IF FOUND = 0 THEN 6300
  605. 6290 MID$(FORM$(33),57,11) = TT5$
  606. 6300 LOCATE 20,25: PRINT " 8";
  607. 6310 HUSB = PERS(8) : WIFE = PERS(9)
  608. 6320 GOSUB 6010  'Look for marriage
  609. 6330 IF FOUND = 0 THEN 6350
  610. 6340 MID$(FORM$(6),82,11) = TT5$
  611. 6350 LOCATE 20,25: PRINT "10";
  612. 6360 HUSB = PERS(10) : WIFE = PERS(11)
  613. 6370 GOSUB 6010  'Look for marriage
  614. 6380 IF FOUND = 0 THEN 6400
  615. 6390 MID$(FORM$(18),82,11) = TT5$
  616. 6400 LOCATE 20,25: PRINT "12";
  617. 6410 HUSB = PERS(12) : WIFE = PERS(13)
  618. 6420 GOSUB 6010  'Look for marriage
  619. 6430 IF FOUND = 0 THEN 6450
  620. 6440 MID$(FORM$(30),82,11) = TT5$
  621. 6450 LOCATE 20,25: PRINT "14";
  622. 6460 HUSB = PERS(14) : WIFE = PERS(15)
  623. 6470 GOSUB 6010  'Look for marriage
  624. 6480 IF FOUND = 0 THEN 6500
  625. 6490 MID$(FORM$(42),82,11) = TT5$
  626. 6500 REM All Marriages found
  627. 6510 REM Print the Pedigree Chart
  628. 6520 FOR I = 1 TO 49
  629. 6530  LPRINT FORM$(I)
  630. 6540 NEXT I
  631. 6550 LPRINT CHR$(12);
  632. 6560 GOTO 1950  'for next chart
  633. 6570 REM Wrapup
  634. 6580 LPRINT CHR$(18);     'Normal Printing
  635. 6590 LPRINT CHR$(27)"9";  'Paper Sensing ON
  636. 6600 LPRINT CHR$(27)"A";  'Normal Page of 66 Lines
  637. 6610 CLOSE #1
  638. 6620 CLOSE #2
  639. 6630 CLS : LOCATE 21,1
  640. 6640 PRINT "End of Program"
  641. 6650 LPRINT CHR$(12);  'Page Eject
  642. 6660 LPRINT CHR$(12);  'Page Eject
  643. 6670 END
  644. 6$, 5 AS F7$, 11 AS F8$, 18 AS F9$, 16 AS F10$, 16 AS F11$, 11 AS F12$