home *** CD-ROM | disk | FTP | other *** search
/ PC-Blue - MS DOS Public Domain Library / PC-Blue MS-DOS Public Domain Library - NYACC.iso / vol218 / display.bas (.txt) < prev    next >
Encoding:
GW-BASIC  |  1986-11-30  |  23.3 KB  |  821 lines
  1. 100  REM DISPLAY Program.
  2. 110  REM Displays Genealogical Information
  3. 120  REM By:  Melvin O. Duke.  Last Updated 20 February 1986.
  4. 200  REM Screen Definitions
  5. 210  WIDTH "scrn:", 80
  6. 220  SCREEN S1,S2,S3,S4
  7. 600  REM Titles
  8. 610  TITLE$ = "Display Program"
  9. 620  TITLE$ = TITLE$ + " ON DISPLAY"
  10. 700  REM Terminate if not called from the Menu
  11. 710  IF DD.MENU$ <> "" THEN 770
  12. 720  COLOR 7,0 : KEY ON : CLS : LOCATE 15,1
  13. 730  PRINT "Cannot run the"
  14. 740  PRINT TITLE$
  15. 750  PRINT "Program, unless selected from the MENU"
  16. 760  END
  17. 770  REM OK
  18. 900  REM Dimension Statements
  19. 910  DIM PA.ID(2*MAX.PER), CH.ID(2*MAX.PER), PERS.NO(2*MAX.MAR), M.NO(2*MAX.MAR)
  20. 920  DIM PERS(15), CH(55)
  21. 1000  REM Produce the first screen
  22. 1010  KEY ON : CLS : KEY OFF
  23. 1020  REM Draw the outer double box
  24. 1030  R1 = 1 : C1 = 1 : R2 = 24 : C2 = 79 : GOSUB 1300
  25. 1040  REM Find the title location
  26. 1050  TITLE.POS = 40 - INT(LEN(TITLE$)/2)
  27. 1060  REM Draw the title box
  28. 1070  R1=3:C1=TITLE.POS-2:R2=6:C2=TITLE.POS+LEN(TITLE$)+1:GOSUB 1500
  29. 1080  REM Print the title
  30. 1090  LOCATE 4,TITLE.POS : PRINT TITLE$
  31. 1100  LOCATE 5,40-INT(LEN(VERSION$)/2) :  PRINT VERSION$;
  32. 1230  REM Draw the Copyright box
  33. 1240  R1 = 19 : C1 = 21 : R2 = 22 : C2 = 59 : GOSUB 1300
  34. 1250  REM Print the Copyright
  35. 1260  LOCATE 20,40-INT(LEN(COPY1$)/2) :  PRINT COPY1$;
  36. 1270  LOCATE 21,40-INT(LEN(COPY2$)/2) :  PRINT COPY2$;
  37. 1280  GOTO 1700
  38. 1300  REM subroutine to print a double box
  39. 1310  COLOR P
  40. 1320  FOR I = R1 + 1 TO R2 - 1
  41. 1330   LOCATE I, C1 : PRINT CHR$(186);
  42. 1340   LOCATE I, C2 : PRINT CHR$(186);
  43. 1350  NEXT I
  44. 1360  FOR J = C1 + 1 TO C2 - 1
  45. 1370   LOCATE R1, J : PRINT CHR$(205);
  46. 1380   LOCATE R2, J : PRINT CHR$(205);
  47. 1390  NEXT J
  48. 1400   LOCATE R1, C1 : PRINT CHR$(201);
  49. 1410   LOCATE R1, C2 : PRINT CHR$(187);
  50. 1420   LOCATE R2, C1 : PRINT CHR$(200);
  51. 1430   LOCATE R2, C2 : PRINT CHR$(188);
  52. 1440  COLOR W
  53. 1450  RETURN
  54. 1500  REM subroutine to print a single box
  55. 1510  COLOR B
  56. 1520  FOR I = R1 + 1 TO R2 - 1
  57. 1530   LOCATE I, C1 : PRINT CHR$(179);
  58. 1540   LOCATE I, C2 : PRINT CHR$(179);
  59. 1550  NEXT I
  60. 1560  FOR J = C1 + 1 TO C2 - 1
  61. 1570   LOCATE R1, J : PRINT CHR$(196);
  62. 1580   LOCATE R2, J : PRINT CHR$(196);
  63. 1590  NEXT J
  64. 1600   LOCATE R1, C1 : PRINT CHR$(218);
  65. 1610   LOCATE R1, C2 : PRINT CHR$(191);
  66. 1620   LOCATE R2, C1 : PRINT CHR$(192);
  67. 1630   LOCATE R2, C2 : PRINT CHR$(217);
  68. 1640  COLOR W
  69. 1650  RETURN
  70. 1700  REM ask user to press a key to continue
  71. 1710  LOCATE 25,1
  72. 1720  PRINT "Have Data Diskette(s) in Place, then Press any key to continue.";
  73. 1730  K$ = INKEY$ : IF K$ = "" THEN 1730
  74. 1740  KEY ON : CLS
  75. 1750  GOTO 3570
  76. 2000  REM DISPLAY Program Starts Here.
  77. 2010  REM Draw the form on the display
  78. 2020  R1= 1 : C1= 1 : R2=21 : C2=79: GOSUB 1300 'Double box
  79. 2030  R1= 3 : C1= 1 : R2= 3 : C2=79: GOSUB 3210 'Horizontal Double
  80. 2040  LOCATE 2,3 : PRINT "Pedigree Chart for:"
  81. 2050  LOCATE 4,68 : COLOR N : PRINT "Birthdate:" : COLOR W
  82. 2060  LOCATE 12, 3 : I = 1 : GOSUB 2470
  83. 2070  LOCATE  8,11 : COLOR B : PRINT CHR$(218)+CHR$(196);
  84. 2080  LOCATE  9,11 : PRINT CHR$(179);
  85. 2090  LOCATE 10,11 : PRINT CHR$(179);
  86. 2100  LOCATE 11,11 : PRINT CHR$(179);
  87. 2110  LOCATE  8,13 : I = 2 : GOSUB 2510
  88. 2120  LOCATE 16,11 : COLOR B : PRINT CHR$(192)+CHR$(196);
  89. 2130  LOCATE 13,11 : PRINT CHR$(179);
  90. 2140  LOCATE 14,11 : PRINT CHR$(179);
  91. 2150  LOCATE 15,11 : PRINT CHR$(179);
  92. 2160  LOCATE 16,13 : I = 3 : GOSUB 2510
  93. 2170  LOCATE  6,21 : COLOR B : PRINT CHR$(218)+CHR$(196);
  94. 2180  LOCATE  7,21 : PRINT CHR$(179);
  95. 2190  LOCATE  6,23 : I = 4 : GOSUB 2540
  96. 2200  LOCATE 10,21 : COLOR B : PRINT CHR$(192)+CHR$(196);
  97. 2210  LOCATE  9,21 : PRINT CHR$(179);
  98. 2220  LOCATE 10,23 : I = 5 : GOSUB 2540
  99. 2230  LOCATE 14,21 : COLOR B : PRINT CHR$(218)+CHR$(196);
  100. 2240  LOCATE 15,21 : PRINT CHR$(179);
  101. 2250  LOCATE 14,23 : I = 6 : GOSUB 2540
  102. 2260  LOCATE 18,21 : COLOR B : PRINT CHR$(192)+CHR$(196);
  103. 2270  LOCATE 17,21 : PRINT CHR$(179);
  104. 2280  LOCATE 18,23 : I = 7 : GOSUB 2540
  105. 2290  LOCATE  5,31 : COLOR B : PRINT CHR$(218)+CHR$(196);
  106. 2300  LOCATE  5,33 : I = 8 : GOSUB 2570
  107. 2310  LOCATE  7,31 : COLOR B : PRINT CHR$(192)+CHR$(196);
  108. 2320  LOCATE  7,33 : I = 9 : GOSUB 2570
  109. 2330  LOCATE  9,31 : COLOR B : PRINT CHR$(218)+CHR$(196);
  110. 2340  LOCATE  9,33 : I = 10 : GOSUB 2570
  111. 2350  LOCATE 11,31 : COLOR B : PRINT CHR$(192)+CHR$(196);
  112. 2360  LOCATE 11,33 : I = 11 : GOSUB 2570
  113. 2370  LOCATE 13,31 : COLOR B : PRINT CHR$(218)+CHR$(196);
  114. 2380  LOCATE 13,33 : I = 12 : GOSUB 2570
  115. 2390  LOCATE 15,31 : COLOR B : PRINT CHR$(192)+CHR$(196);
  116. 2400  LOCATE 15,33 : I = 13 : GOSUB 2570
  117. 2410  LOCATE 17,31 : COLOR B : PRINT CHR$(218)+CHR$(196);
  118. 2420  LOCATE 17,33 : I = 14 : GOSUB 2570
  119. 2430  LOCATE 19,31 : COLOR B : PRINT CHR$(192)+CHR$(196);
  120. 2440  LOCATE 19,33 : I = 15 : GOSUB 2570
  121. 2450  COLOR W,K
  122. 2460  RETURN
  123. 2470  REM Routine to print the lines
  124. 2480  COLOR K,W : PRINT RIGHT$(STR$(I),2);
  125. 2490  COLOR B,K : PRINT STRING$(62,95);
  126. 2500  RETURN
  127. 2510  COLOR K,W : PRINT RIGHT$(STR$(I),2);
  128. 2520  COLOR B,K : PRINT STRING$(52,95);
  129. 2530  RETURN
  130. 2540  COLOR K,W : PRINT RIGHT$(STR$(I),2);
  131. 2550  COLOR B,K : PRINT STRING$(42,95);
  132. 2560  RETURN
  133. 2570  COLOR K,W : PRINT RIGHT$(STR$(I),2);
  134. 2580  COLOR B,K : PRINT STRING$(32,95); : COLOR W,K
  135. 2590  RETURN
  136. 2600  REM Draw the Personal Information Chart
  137. 2610  KEY OFF
  138. 2620  R1 = 1 : C1 = 1 : R2 = 21 : C2 = 79 : GOSUB 1300  'Double box
  139. 2630  R1 = 3 : C1 = 1 : R2 = 3 : C2 = 79 : GOSUB 3210  'Horizontal double
  140. 2640  LOCATE 2,3 : PRINT "Personal Information for:"
  141. 2650  R1 = 3 : C1 = 40 : R2 = 21 : C2 = 40 : GOSUB 3390  'Vertical Double
  142. 2660  LOCATE 4,3 : COLOR N : PRINT "Person:";
  143. 2670  LOCATE 5,3 : COLOR O : PRINT "Record-no.:";
  144. 2680  LOCATE 6,3 : PRINT "Surname:";
  145. 2690  LOCATE 7,3 : PRINT "Given-names:";
  146. 2700  LOCATE 8,3 : PRINT "Sex:";
  147. 2710  R1 = 9 : C1 = 1 : R2 =11 : C2 = 40 : GOSUB 3210  'Horizontal Double
  148. 2720  LOCATE 10,3 : COLOR N : PRINT "Person's Father:";
  149. 2730  LOCATE 11,3 : COLOR O : PRINT "Record-no.:";
  150. 2740  LOCATE 12,3 : PRINT "Surname:";
  151. 2750  LOCATE 13,3 : PRINT "Given-names:";
  152. 2760  LOCATE 14,3 : PRINT "Birth-date:";
  153. 2770  R1 = 15 : C1 = 1 : R2 = 15 : C2 = 40 : GOSUB 3300  'Horizontal Single
  154. 2780  LOCATE 16,3 : COLOR N : PRINT "Person's Mother:";
  155. 2790  LOCATE 17,3 : COLOR O : PRINT "Record-no.:";
  156. 2800  LOCATE 18,3 : PRINT "Surname:";
  157. 2810  LOCATE 19,3 : PRINT "Given-names:";
  158. 2820  LOCATE 20,3 : PRINT "Birth-date:";
  159. 2830  LOCATE 4,42 : COLOR N : PRINT "Person's Vital Statistics:";
  160. 2840  LOCATE 6,42 : COLOR O : PRINT "Birth-date:";
  161. 2850  LOCATE 7,42 : PRINT "Birth-city:";
  162. 2860  LOCATE 8,42 : PRINT "Birth-county:";
  163. 2870  LOCATE 9,42 : PRINT "Birth-state:";
  164. 2880  LOCATE 11,42 : PRINT "Death-date:";
  165. 2890  LOCATE 12,42 : PRINT "Death-city:";
  166. 2900  LOCATE 13,42 : PRINT "Death-county:";
  167. 2910  LOCATE 14,42 : PRINT "Death-state:";
  168. 2920  LOCATE 16,42 : PRINT "Burial-date:";
  169. 2930  LOCATE 17,42 : PRINT "Burial-city:";
  170. 2940  LOCATE 18,42 : PRINT "Burial-county:";
  171. 2950  LOCATE 19,42 : PRINT "Burial-state:"; : COLOR W,K
  172. 2960  RETURN
  173. 2970  REM draw a Family Group Sheet
  174. 2980  KEY OFF
  175. 2990  R1 = 1 : C1 = 1 : R2 = 21 : C2 = 79 : GOSUB 1300  'Double box
  176. 3000  R1 = 3 : C1 = 1 : R2 = 3 : C2 = 79 : GOSUB 3210  'Double Horizontal
  177. 3010  LOCATE 2,3 : PRINT "Family Group Record";
  178. 3020  LOCATE 2,64 : PRINT "Marriage:";
  179. 3030  LOCATE 4,3 : COLOR O : PRINT "Father:";
  180. 3040  LOCATE 4,56 : PRINT "Birthdate:";
  181. 3050  LOCATE 5,3 : PRINT "Mother:";
  182. 3060  LOCATE 5,56 : PRINT "Birthdate:";
  183. 3070  R1 = 6 : C1 = 1 : R2 = 6 : C2 = 79 : GOSUB 3300  'Single Horizontal
  184. 3080  LOCATE 7,3 : COLOR O : PRINT "Marriage Date:";
  185. 3090  LOCATE 7,35 : PRINT "Location:";
  186. 3100  R1 = 8 : C1 = 1 : R2 = 8 : C2 = 79 : GOSUB 3210  'Double Horizontal
  187. 3110  R1 = 8 : C1 = 4 : R2 = 21 : C2 = 4 : GOSUB 3480  'Single Vertical
  188. 3120  R1 = 8 : C1 = 6 : R2 = 21 : C2 = 6 : GOSUB 3480  'Single Vertical
  189. 3130  R1 = 8 : C1 = 40 : R2 = 21 : C2 = 40 : GOSUB 3480  'Single Vertical
  190. 3140  LOCATE 9,2 : COLOR N : PRINT "NO";
  191. 3150  LOCATE 9,5 : PRINT "S";
  192. 3160  LOCATE 9,7 : PRINT "Children:";
  193. 3170  LOCATE 9,41 : PRINT "Birthdate:";
  194. 3180  R1 = 8 : C1 = 52 : R2 = 21 : C2 = 52 : GOSUB 3480  'Single Vertical
  195. 3190  LOCATE 9,53 : COLOR N : PRINT "Birth Location:"; : COLOR W
  196. 3200  RETURN
  197. 3210  REM Subroutine to draw a double horizontal line.  Attach to double.
  198. 3220  COLOR P
  199. 3230  FOR J = C1 + 1 TO C2 - 1
  200. 3240   LOCATE R1,J : PRINT CHR$(205);
  201. 3250  NEXT J
  202. 3260  LOCATE R1,C1 : PRINT CHR$(204);
  203. 3270  LOCATE R1,C2 : PRINT CHR$(185);
  204. 3280  COLOR W
  205. 3290  RETURN
  206. 3300  REM Subroutine to draw a single horizontal line.  Attach to double.
  207. 3310  COLOR P
  208. 3320  FOR J = C1 + 1 TO C2 - 1
  209. 3330   LOCATE R1,J : PRINT CHR$(196);
  210. 3340  NEXT J
  211. 3350  LOCATE R1,C1 : PRINT CHR$(199);
  212. 3360  LOCATE R1,C2 : PRINT CHR$(182);
  213. 3370  COLOR W
  214. 3380  RETURN
  215. 3390  REM Subroutine to draw a double vertical line.  Attach to double.
  216. 3400  COLOR P
  217. 3410  FOR I = R1 + 1 TO R2 - 1
  218. 3420   LOCATE I,C1 : PRINT CHR$(186);
  219. 3430  NEXT I
  220. 3440  LOCATE R1,C1 : PRINT CHR$(203);
  221. 3450  LOCATE R2,C1 : PRINT CHR$(202);
  222. 3460  COLOR W
  223. 3470  RETURN
  224. 3480  REM Subroutine to draw a single vertical line.  Attach to double.
  225. 3490  COLOR P
  226. 3500  FOR I = R1 + 1 TO R2 - 1
  227. 3510   LOCATE I,C1 : PRINT CHR$(179);
  228. 3520  NEXT I
  229. 3530  LOCATE R1,C1 : PRINT CHR$(209);
  230. 3540  LOCATE R2,C1 : PRINT CHR$(207);
  231. 3550  COLOR W
  232. 3560  RETURN
  233. 3570  REM Program begins here
  234. 3580  REM By:  Melvin O. Duke.
  235. 3590  REM Read the Parent/Child Index
  236. 3600  OPEN DD.PCIDX$+"pcindex" FOR INPUT AS #1
  237. 3610  KEY OFF
  238. 3620  LOCATE 4,1 : PRINT "Open the Parent/Child Index";
  239. 3630  INPUT #1, PC.COUNT
  240. 3640  FOR I = 1 TO PC.COUNT
  241. 3650  LOCATE 5,1 : PRINT "Reading Index Record #:";I;
  242. 3660   INPUT #1, PA.ID(I), CH.ID(I)
  243. 3670  NEXT I
  244. 3680  CLOSE #1
  245. 3690  REM Read the Marriage Index
  246. 3700  LOCATE 7,1 : PRINT "Open the Marriage Index";
  247. 3710  OPEN DD.MARIDX$+"mindex" FOR INPUT AS #2
  248. 3720  INPUT #2, M.COUNT
  249. 3730  FOR I = 1 TO M.COUNT
  250. 3740  LOCATE 8,1 : PRINT "Reading Marriage Index Record #:";I:
  251. 3750   INPUT #2,PERS.NO(I), M.NO(I)
  252. 3760  NEXT I
  253. 3770  CLOSE #2
  254. 3780  REM Open the Persons File
  255. 3790  LOCATE 10,1 : PRINT "Open the Persons File"
  256. 3800  OPEN DD.PERS$+"persfile" AS #1 LEN = 256
  257. 3810  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$
  258. 3820  REM open the Marriages File
  259. 3830  LOCATE 12,1 : PRINT "Open the Marriage File"
  260. 3840  OPEN DD.MARR$+"marrfile" AS #2 LEN = 128
  261. 3850  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$
  262. 3860  REM Open the Ordinance File
  263. 3870  IF DD.ORD$ = "no" THEN 3910
  264. 3880  LOCATE 14,1 : PRINT "Open the Ordinances File";
  265. 3890  OPEN DD.ORD$+"ordfile" AS #3 LEN = 256
  266. 3900  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$
  267. 3910  REM Obtain a Person Record from the User
  268. 3920  LOCATE 20,1 : PRINT SPACE$(79);: LOCATE 20,1
  269. 3930  INPUT "Enter the Record-number of a Person (0 to quit)";REPLY$
  270. 3940  IF REPLY$ = "0" THEN 9180
  271. 3950  PERS(1) = VAL(REPLY$)
  272. 3960  IF PERS(1) < 1 OR PERS(1) > MAX.PER THEN KEY ON : CLS : KEY OFF : LOCATE 19,1 : PRINT "Number is out of range"; : GOTO 3910
  273. 3970  REM Obtain the information about a person
  274. 3980  GET #1, PERS(1)
  275. 3990  KEY ON : CLS
  276. 4000  GOSUB 4560  'Extract Personal Information
  277. 4010  GOSUB 2600
  278. 4020  LOCATE 2,30 : COLOR W : PRINT LEFT$(T3$ + " " + T2$,35);
  279. 4030  LOCATE 2,66 : PRINT "Person:";T1
  280. 4040  LOCATE 5,16 : COLOR G : PRINT T1
  281. 4050  LOCATE 6,16 : PRINT T2$;
  282. 4060  LOCATE 7,16 : PRINT LEFT$(T3$,24);
  283. 4070  LOCATE 8,16 : PRINT T4$;
  284. 4080  LOCATE 6,57 : PRINT T8$;
  285. 4090  LOCATE 7,57 : PRINT T9$;
  286. 4100  LOCATE 8,57 : PRINT T10$;
  287. 4110  LOCATE 9,57 : PRINT T11$;
  288. 4120  LOCATE 11,57 : PRINT T12$;
  289. 4130  LOCATE 12,57 : PRINT T13$;
  290. 4140  LOCATE 13,57 : PRINT T14$;
  291. 4150  LOCATE 14,57 : PRINT T15$;
  292. 4160  LOCATE 16,57 : PRINT T16$;
  293. 4170  LOCATE 17,57 : PRINT T17$;
  294. 4180  LOCATE 18,57 : PRINT T18$;
  295. 4190  LOCATE 19,57 : PRINT T19$;
  296. 4200  PERS(2) = T6
  297. 4210  PERS(3) = T7
  298. 4220  COLOR W
  299. 4230  REM Check if Father is known
  300. 4240  IF PERS(2) = 0 THEN GOSUB 4910 : GOTO 4270
  301. 4250  GET #1, PERS(2)
  302. 4260  GOSUB 4560  'Extract
  303. 4270  LOCATE 11,16 : COLOR G : PRINT T1;
  304. 4280  LOCATE 12,16 : PRINT T2$;
  305. 4290  LOCATE 13,16 : PRINT LEFT$(T3$,24);
  306. 4300  LOCATE 14,16 : PRINT T8$;
  307. 4310  COLOR W
  308. 4320  REM Check if Mother is known
  309. 4330  IF PERS(3) = 0 THEN GOSUB 4910 : GOTO 4360
  310. 4340  GET #1, PERS(3)
  311. 4350  GOSUB 4560  'Extract
  312. 4360  LOCATE 17,16 : COLOR G : PRINT T1;
  313. 4370  LOCATE 18,16 : PRINT T2$;
  314. 4380  LOCATE 19,16 : PRINT LEFT$(T3$,24);
  315. 4390  LOCATE 20,16 : PRINT T8$;
  316. 4400  COLOR W,K : LOCATE 23,1 : PRINT SPACE$(79);
  317. 4410  LOCATE 24,1 : PRINT SPACE$(79);
  318. 4420  LOCATE 24,1 : PRINT "(Possible Requests:  ps, pc, fg, ";
  319. 4430  IF DD.ORD$ = "no" THEN 4450
  320. 4440  PRINT "o, ";
  321. 4450  PRINT "p1...pn, m1...mn, q)";
  322. 4460  LOCATE 23,1 : INPUT "Type a Request.  Then press the 'enter' key."; REPLY$
  323. 4470  IF REPLY$ = "ps" OR REPLY$ = "PS" THEN GOSUB 7800 : GOTO 4400
  324. 4480  IF REPLY$ = "pc" OR REPLY$ = "PC" THEN 5120  'Pedigree Chart
  325. 4490  IF REPLY$ = "fg" OR REPLY$ = "FG" THEN 6620  'Family Group
  326. 4500  IF DD.ORD$ = "no" THEN 4520
  327. 4510  IF REPLY$ = "o" OR REPLY$ = "O" THEN 7940  'Ordinances
  328. 4520  IF LEFT$(REPLY$,1) = "p" OR LEFT$(REPLY$,1) = "P" THEN PERS(1) = VAL(RIGHT$(REPLY$,LEN(REPLY$)-1)) : KEY ON : CLS : KEY OFF : GOTO 3960
  329. 4530  IF LEFT$(REPLY$,1) = "m" OR LEFT$(REPLY$,1) = "M" THEN 9050
  330. 4540  IF LEFT$(REPLY$,1) = "q" OR LEFT$(REPLY$,1) = "Q" THEN 9180
  331. 4550  LOCATE 22,1 : PRINT "Error in Previous Reply ";REPLY$; : GOTO 4400
  332. 4560  REM Routine to Extract Personal Information
  333. 4570  T1 = CVS(F1$)
  334. 4580  T2$ = F2$
  335. 4590  FOR J = 1 TO LEN(F2$) -1
  336. 4600   IF RIGHT$(T2$,1)=" " THEN T2$ = LEFT$(T2$,LEN(T2$)-1) ELSE J = LEN(F2$)-1
  337. 4610  NEXT J
  338. 4620  T3$ = F3$
  339. 4630  FOR J = 1 TO LEN(F3$) -1
  340. 4640   IF RIGHT$(T3$,1)=" " THEN T3$ = LEFT$(T3$,LEN(T3$)-1) ELSE J = LEN(F3$)-1
  341. 4650  NEXT J
  342. 4660  T4$ = F4$
  343. 4670  IF LEFT$(T4$,1) = "M" THEN T4$ = "Male"
  344. 4680  IF LEFT$(T4$,1) = "F" THEN T4$ = "Female"
  345. 4690  T5 = CVS(F5$)
  346. 4700  T6 = CVS(F6$)
  347. 4710  T7 = CVS(F7$)
  348. 4720  T8$ = F8$
  349. 4730  T9$ = F9$
  350. 4740  FOR J = 1 TO LEN(F9$) -1
  351. 4750   IF RIGHT$(T9$,1)=" " THEN T9$ = LEFT$(T9$,LEN(T9$)-1) ELSE J = LEN(F9$)-1
  352. 4760  NEXT J
  353. 4770  T10$ = F10$
  354. 4780  T11$ = F11$
  355. 4790  FOR J = 1 TO LEN(F11$) -1
  356. 4800   IF RIGHT$(T11$,1)=" " THEN T11$ = LEFT$(T11$,LEN(T11$)-1) ELSE J = LEN(F11$)-1
  357. 4810  NEXT J
  358. 4820  T12$ = F12$
  359. 4830  T13$ = F13$
  360. 4840  T14$ = F14$
  361. 4850  T15$ = F15$
  362. 4860  T16$ = F16$
  363. 4870  T17$ = F17$
  364. 4880  T18$ = F18$
  365. 4890  T19$ = F19$
  366. 4900  RETURN
  367. 4910  REM Blank out a Record
  368. 4920  T1 = 0
  369. 4930  T2$ = ""
  370. 4940  T3$ = ""
  371. 4950  T4$ = ""
  372. 4960  T5 = 0
  373. 4970  T6 = 0
  374. 4980  T7 = 0
  375. 4990  T8$ = ""
  376. 5000  T9$ = ""
  377. 5010  T10$ = ""
  378. 5020  T11$ = ""
  379. 5030  T12$ = ""
  380. 5040  T13$ = ""
  381. 5050  T14$ = ""
  382. 5060  T15$ = ""
  383. 5070  T16$ = ""
  384. 5080  T17$ = ""
  385. 5090  T18$ = ""
  386. 5100  T19$ = ""
  387. 5110  RETURN
  388. 5120  REM Routine to Produce a Pedigree Chart
  389. 5130  KEY ON : CLS : KEY OFF
  390. 5140  GOSUB 2000 'Draw the Chart
  391. 5150  GET #1, PERS(1)
  392. 5160  GOSUB 4560  'Extract the Person
  393. 5170  LOCATE 2,23 : COLOR W : PRINT LEFT$(T3$ + " " + T2$,42);
  394. 5180  LOCATE 2,66 : PRINT "Person:"; PERS(1);
  395. 5190  THIS.PERS = PERS(1) : GOSUB 9260
  396. 5200  LOCATE 12,6 : COLOR G : PRINT LEFT$(VALUE$,61);
  397. 5210  LOCATE 12,68 : PRINT T8$;
  398. 5220  PERS(2) = T6
  399. 5230  PERS(3) = T7
  400. 5240  REM Get 11
  401. 5250  IF PERS(2) = 0 THEN GOSUB 4910 : GOTO 5310
  402. 5260  GET #1, PERS(2)
  403. 5270  GOSUB 4560  'Extract
  404. 5280  THIS.PERS = PERS(2) : GOSUB 9260
  405. 5290  LOCATE 8,16 : PRINT LEFT$(VALUE$,51);
  406. 5300  LOCATE 8,68 : PRINT T8$;
  407. 5310  PERS(4) = T6
  408. 5320  PERS(5) = T7
  409. 5330  REM Get 10
  410. 5340  IF PERS(3) = 0 THEN GOSUB 4910 : GOTO 5400
  411. 5350  GET #1, PERS(3)
  412. 5360  GOSUB 4560  'Extract
  413. 5370  THIS.PERS = PERS(3): GOSUB 9260
  414. 5380  LOCATE 16,16 : PRINT LEFT$(VALUE$,51);
  415. 5390  LOCATE 16,68 : PRINT T8$;
  416. 5400  PERS(6) = T6
  417. 5410  PERS(7) = T7
  418. 5420  REM Get 111
  419. 5430  IF PERS(4) = 0 THEN GOSUB 4910 : GOTO 5490
  420. 5440  GET #1, PERS(4)
  421. 5450  GOSUB 4560  'Extract
  422. 5460  THIS.PERS = PERS(4): GOSUB 9260
  423. 5470  LOCATE 6,26 : PRINT LEFT$(VALUE$,41);
  424. 5480  LOCATE 6,68 : PRINT T8$;
  425. 5490  PERS(8) = T6
  426. 5500  PERS(9) = T7
  427. 5510  REM Get 110
  428. 5520  IF PERS(5) = 0 THEN GOSUB 4910 : GOTO 5580
  429. 5530  GET #1, PERS(5)
  430. 5540  GOSUB 4560  'Extract
  431. 5550  THIS.PERS = PERS(5): GOSUB 9260
  432. 5560  LOCATE 10,26 : PRINT LEFT$(VALUE$,41);
  433. 5570  LOCATE 10,68 : PRINT T8$;
  434. 5580  PERS(10) = T6
  435. 5590  PERS(11) = T7
  436. 5600  REM Get 101
  437. 5610  IF PERS(6) = 0 THEN GOSUB 4910 : GOTO 5670
  438. 5620  GET #1, PERS(6)
  439. 5630  GOSUB 4560  'Extract
  440. 5640  THIS.PERS = PERS(6): GOSUB 9260
  441. 5650  LOCATE 14,26 : PRINT LEFT$(VALUE$,41);
  442. 5660  LOCATE 14,68 : PRINT T8$;
  443. 5670  PERS(12) = T6
  444. 5680  PERS(13) = T7
  445. 5690  REM Get 100
  446. 5700  IF PERS(7) = 0 THEN GOSUB 4910 : GOTO 5760
  447. 5710  GET #1, PERS(7)
  448. 5720  GOSUB 4560  'Extract
  449. 5730  THIS.PERS = PERS(7): GOSUB 9260
  450. 5740  LOCATE 18,26 : PRINT LEFT$(VALUE$,41);
  451. 5750  LOCATE 18,68 : PRINT T8$;
  452. 5760  PERS(14) = T6
  453. 5770  PERS(15) = T7
  454. 5780  REM Get 1111
  455. 5790  IF PERS(8) = 0 THEN GOSUB 4910 : GOTO 5850
  456. 5800  GET #1, PERS(8)
  457. 5810  GOSUB 4560  'Extract
  458. 5820  THIS.PERS = PERS(8): GOSUB 9260
  459. 5830  LOCATE  5,36 : PRINT LEFT$(VALUE$,31);
  460. 5840  LOCATE  5,68 : PRINT T8$;
  461. 5850  REM
  462. 5860  REM Get 1110
  463. 5870  IF PERS(9) = 0 THEN GOSUB 4910 : GOTO 5930
  464. 5880  GET #1, PERS(9)
  465. 5890  GOSUB 4560  'Extract
  466. 5900  THIS.PERS = PERS(9): GOSUB 9260
  467. 5910  LOCATE  7,36 : PRINT LEFT$(VALUE$,31);
  468. 5920  LOCATE  7,68 : PRINT T8$;
  469. 5930  REM
  470. 5940  REM Get 1101
  471. 5950  IF PERS(10) = 0 THEN GOSUB 4910 : GOTO 6010
  472. 5960  GET #1, PERS(10)
  473. 5970  GOSUB 4560  'Extract
  474. 5980  THIS.PERS = PERS(10): GOSUB 9260
  475. 5990  LOCATE  9,36 : PRINT LEFT$(VALUE$,31);
  476. 6000  LOCATE  9,68 : PRINT T8$;
  477. 6010  REM
  478. 6020  REM Get 1100
  479. 6030  IF PERS(11) = 0 THEN GOSUB 4910 : GOTO 6090
  480. 6040  GET #1, PERS(11)
  481. 6050  GOSUB 4560  'Extract
  482. 6060  THIS.PERS = PERS(11): GOSUB 9260
  483. 6070  LOCATE 11,36 : PRINT LEFT$(VALUE$,31);
  484. 6080  LOCATE 11,68 : PRINT T8$;
  485. 6090  REM
  486. 6100  REM Get 1011
  487. 6110  IF PERS(12) = 0 THEN GOSUB 4910 : GOTO 6170
  488. 6120  GET #1, PERS(12)
  489. 6130  GOSUB 4560  'Extract
  490. 6140  THIS.PERS = PERS(12): GOSUB 9260
  491. 6150  LOCATE 13,36 : PRINT LEFT$(VALUE$,31);
  492. 6160  LOCATE 13,68 : PRINT T8$;
  493. 6170  REM
  494. 6180  REM Get 1010
  495. 6190  IF PERS(13) = 0 THEN GOSUB 4910 : GOTO 6250
  496. 6200  GET #1, PERS(13)
  497. 6210  GOSUB 4560  'Extract
  498. 6220  THIS.PERS = PERS(13): GOSUB 9260
  499. 6230  LOCATE 15,36 : PRINT LEFT$(VALUE$,31);
  500. 6240  LOCATE 15,68 : PRINT T8$;
  501. 6250  REM
  502. 6260  REM Get 1001
  503. 6270  IF PERS(14) = 0 THEN GOSUB 4910 : GOTO 6330
  504. 6280  GET #1, PERS(14)
  505. 6290  GOSUB 4560  'Extract
  506. 6300  THIS.PERS = PERS(14): GOSUB 9260
  507. 6310  LOCATE 17,36 : PRINT LEFT$(VALUE$,31);
  508. 6320  LOCATE 17,68 : PRINT T8$;
  509. 6330  REM
  510. 6340  REM Get 1000
  511. 6350  IF PERS(15) = 0 THEN GOSUB 4910 : GOTO 6410
  512. 6360  GET #1, PERS(15)
  513. 6370  GOSUB 4560  'Extract
  514. 6380  THIS.PERS = PERS(15): GOSUB 9260
  515. 6390  LOCATE 19,36 : PRINT LEFT$(VALUE$,31);
  516. 6400  LOCATE 19,68 : PRINT T8$;
  517. 6410  COLOR W
  518. 6420  LOCATE 23,1 : PRINT SPACE$(79);
  519. 6430  LOCATE 24,1 : PRINT SPACE$(79);
  520. 6440  LOCATE 24,1 : PRINT "(Possible Requests:  ps, pc, fg, l1...ln, p1...pn, m1...mn, q)";
  521. 6450  LOCATE 23,1 : INPUT "Type a Request.  Then press the 'enter' key."; REPLY$
  522. 6460  IF REPLY$ = "ps" OR REPLY$ = "PS" THEN GOSUB 7800 : GOTO 6420
  523. 6470  IF REPLY$ = "pc" OR REPLY$ = "PC" THEN 5120
  524. 6480  IF REPLY$ = "fg" OR REPLY$ = "FG" THEN 6620
  525. 6490  IF LEFT$(REPLY$,1) = "l" OR LEFT$(REPLY$,1) = "L" THEN 6500 ELSE 6580
  526. 6500  WHO = (VAL(RIGHT$(REPLY$,LEN(REPLY$)-1)))
  527. 6510  IF WHO < 1 OR WHO > 15 THEN 6520 ELSE 6570
  528. 6520  KEY ON : CLS : KEY OFF
  529. 6530  LOCATE 20,1 : PRINT "Line-number is out of range"
  530. 6540  LOCATE 22,1 : PRINT "Press any key to continue"
  531. 6550  A$ = INKEY$ : IF A$ = "" THEN 6550
  532. 6560  GOTO 3960
  533. 6570  PERS(1) = PERS(WHO) : GOTO 3960
  534. 6580  IF LEFT$(REPLY$,1) = "p" OR LEFT$(REPLY$,1) = "P" THEN PERS(1) = VAL(RIGHT$(REPLY$,LEN(REPLY$)-1)) : GOTO 3960
  535. 6590  IF LEFT$(REPLY$,1) = "m" OR LEFT$(REPLY$,1) = "M" THEN 9050
  536. 6600  IF LEFT$(REPLY$,1) = "q" OR LEFT$(REPLY$,1) = "Q" THEN 9180
  537. 6610  LOCATE 22,1 : PRINT "Error in Previous Reply ";REPLY$; : GOTO 6420
  538. 6620  REM Routine to Produce a Family Group Record
  539. 6630  KEY ON : CLS
  540. 6640  GOSUB 2970  'Draw the form
  541. 6650  REM search the marriage index for the Person's Marriage
  542. 6660  FOUND = 0
  543. 6670  FOR L = 1 TO M.COUNT
  544. 6680   IF PERS(1) > PERS.NO(L) THEN 6740
  545. 6690   IF PERS(1) < PERS.NO(L) THEN L = M.COUNT : GOTO 6740
  546. 6700   REM found a Marriage
  547. 6710   FOUND = 1
  548. 6720   GET #2, M.NO(L)
  549. 6730   L = M.COUNT
  550. 6740  NEXT L
  551. 6750  IF FOUND = 1 THEN 6810
  552. 6760  REM No marriage found
  553. 6770  LOCATE 22,1 : COLOR W,K : PRINT "No Marriage Found";
  554. 6780  LOCATE 23,1 : PRINT "Press any key to continue";
  555. 6790  A$ = INKEY$ : IF A$ = "" THEN 6790
  556. 6800  KEY ON : CLS : KEY OFF : GOTO 3970
  557. 6810  REM extract Information from the Marriage Record
  558. 6820  TT1 = CVS(M1$)
  559. 6830  IF TT1 < 1 THEN 6760
  560. 6840  TT2 = CVS(M2$)
  561. 6850  TT3 = CVS(M3$)
  562. 6860  TT4 = CVS(M4$)
  563. 6870  TT5$ = M5$
  564. 6880  TT6$ = M6$
  565. 6890  REM Right-trim
  566. 6900  FOR J = 1 TO LEN(M6$) -1
  567. 6910   IF RIGHT$(TT6$,1)=" " THEN TT6$ = LEFT$(TT6$,LEN(TT6$)-1) ELSE J = LEN(M6$)-1
  568. 6920  NEXT J
  569. 6930  TT7$ = M7$
  570. 6940  TT8$ = M8$
  571. 6950  REM Right-trim
  572. 6960  FOR J = 1 TO LEN(M8$) -1
  573. 6970   IF RIGHT$(TT8$,1)=" " THEN TT8$ = LEFT$(TT8$,LEN(TT8$)-1) ELSE J = LEN(M8$)-1
  574. 6980  NEXT J
  575. 6990  TT9$ = M9$
  576. 7000  REM print the Marriage Information
  577. 7010  LOCATE 2,73 : COLOR W : PRINT TT1
  578. 7020  LOCATE 7,18 : COLOR G : PRINT TT5$
  579. 7030  IF TT6$ = " " AND TT8$ = " " THEN 7050
  580. 7040  LOCATE 7,45 : PRINT LEFT$(TT6$+", "+TT8$,34)
  581. 7050  REM get the Husband's Record
  582. 7060  GET #1, TT2
  583. 7070  GOSUB 4560  'Extract
  584. 7080  THIS.PERS = TT2 : GOSUB 9260
  585. 7090  LOCATE 4,11 : COLOR G : PRINT LEFT$(VALUE$,44);
  586. 7100  LOCATE 4,67 : PRINT T8$;
  587. 7110  REM get the Wife's Record
  588. 7120  GET #1, TT3
  589. 7130  GOSUB 4560  'Extract
  590. 7140  THIS.PERS = TT3 : GOSUB 9260
  591. 7150  LOCATE 5,11 : COLOR G : PRINT LEFT$(VALUE$,44);
  592. 7160  LOCATE 5,67 : PRINT T8$;
  593. 7170  REM now find the children
  594. 7180  CHILD.COUNT = 0
  595. 7190  FOR IC = 1 TO 55
  596. 7200   CH(IC) = 0
  597. 7210  NEXT IC
  598. 7220  REM search the parent/child index
  599. 7230  FOR LL = 1 TO PC.COUNT
  600. 7240   IF TT2 > PA.ID(LL) THEN 7620
  601. 7250   IF TT2 < PA.ID(LL) THEN LL = PC.COUNT : GOTO 7620
  602. 7260   REM found a child
  603. 7270   GET #1, CH.ID(LL)
  604. 7280   GOSUB 4560  'Extract
  605. 7290   REM verify that Mother is the same
  606. 7300   IF TT3 <> T7 THEN 7620
  607. 7310   REM Found a valid child
  608. 7320   CHILD.COUNT = CHILD.COUNT + 1
  609. 7330   SHOW.COUNT = CHILD.COUNT
  610. 7340   IF CHILD.COUNT = 1 THEN 7510
  611. 7350   IF CHILD.COUNT > 11 THEN SHOW.COUNT = CHILD.COUNT - 11
  612. 7360   IF CHILD.COUNT > 22 THEN SHOW.COUNT = CHILD.COUNT - 22
  613. 7370   IF CHILD.COUNT > 33 THEN SHOW.COUNT = CHILD.COUNT - 33
  614. 7380   IF CHILD.COUNT > 44 THEN SHOW.COUNT = CHILD.COUNT - 44
  615. 7390   IF (CHILD.COUNT-1) MOD 11 = 0 THEN 7400 ELSE 7510
  616. 7400   LOCATE 23,1 : PRINT SPACE$(79);
  617. 7410   LOCATE 23,1 : PRINT "Press p to Print Screen, or any other key to continue"
  618. 7420   A$ = INKEY$ : IF A$ = "" THEN 7420
  619. 7430   IF A$ = "P" OR A$ = "p" THEN GOSUB 7800 : GOTO 7420
  620. 7440   REM blank the previous children
  621. 7450   FOR ROW = 9 TO 20
  622. 7460    LOCATE ROW,2 : PRINT SPACE$(77);
  623. 7470   NEXT ROW
  624. 7480   REM restore the rest of the display
  625. 7490   GOSUB 3110
  626. 7500   LOCATE 23,1 : PRINT SPACE$(79)
  627. 7510   CH(CHILD.COUNT) = CH.ID(LL)
  628. 7520   LOCATE 9+SHOW.COUNT,2 : COLOR K,W
  629. 7530   PRINT RIGHT$(STR$(CHILD.COUNT),2); : COLOR G,K
  630. 7540   LOCATE 9+SHOW.COUNT,5 : PRINT LEFT$(F4$,1);  'Sex
  631. 7550  NM$ = T2$+", "+T3$
  632. 7560  IF T2$ = " " OR T3$ = " " THEN NM$ = T2$+T3$
  633. 7570   LOCATE 9+SHOW.COUNT,7 : PRINT LEFT$(NM$,33);
  634. 7580   LOCATE 9+SHOW.COUNT,41 : PRINT T8$;
  635. 7590   IF T9$ = " " AND T11$ = " " THEN 7610
  636. 7600   LOCATE 9+SHOW.COUNT,53 : PRINT LEFT$(T9$+", "+T11$,26);
  637. 7610   COLOR W,K
  638. 7620  NEXT LL
  639. 7630  LOCATE 23,1 : PRINT SPACE$(79);
  640. 7640  LOCATE 24,1 : PRINT SPACE$(79);
  641. 7650  LOCATE 24,1 : PRINT "(Possible Requests: ps, f, m, p1...pn, c1...cn, m1...mn, q)";
  642. 7660  LOCATE 23,1 : INPUT "Type a Request.  Then press the 'enter' key."; REPLY$
  643. 7670  IF REPLY$ = "ps" OR REPLY$ = "PS" THEN GOSUB 7800 : GOTO 7630
  644. 7680  IF REPLY$ = "pc" OR REPLY$ = "PC" THEN LOCATE 22,1 : PRINT "Error in Previous Reply ";REPLY$; : GOTO 7630
  645. 7690  IF REPLY$ = "f" OR REPLY$ = "F" THEN PERS(1) = TT2 : GOTO 3970
  646. 7700  IF REPLY$ = "m" OR REPLY$ = "M" THEN PERS(1) = TT3 : GOTO 3970
  647. 7710  IF LEFT$(REPLY$,1) = "p" OR LEFT$(REPLY$,1) = "P" THEN PERS(1) = VAL(RIGHT$(REPLY$,LEN(REPLY$)-1)) : GOTO 3960
  648. 7720  IF LEFT$(REPLY$,1) = "c" OR LEFT$(REPLY$,1) = "C" THEN 7730 ELSE 7770
  649. 7730  CHLD = VAL(RIGHT$(REPLY$,LEN(REPLY$)-1))
  650. 7740  IF CHLD < 1 OR CHLD > CHILD.COUNT THEN 7790
  651. 7750  PERS(1) = CH(CHLD)
  652. 7760  GOTO 3970  'for personal
  653. 7770  IF LEFT$(REPLY$,1) = "m" OR LEFT$(REPLY$,1) = "M" THEN 9050 'marriage
  654. 7780  IF LEFT$(REPLY$,1) = "q" OR LEFT$(REPLY$,1) = "Q" THEN 9180
  655. 7790  LOCATE 22,1 : PRINT "Error in Previous Reply ";REPLY$; : GOTO 7630
  656. 7800  REM Routine to Print the Screen
  657. 7810  REM Accessed by users 'ps' reply
  658. 7820  FOR ROW = 1 TO 20
  659. 7830   THIS$ = SPACE$(79)
  660. 7840   FOR COL = 1 TO 79
  661. 7850    X = SCREEN(ROW,COL)
  662. 7860    IF X > 125 THEN X = 32
  663. 7870    IF X < 32 THEN X = 32
  664. 7880    MID$(THIS$,COL,1) = CHR$(X)
  665. 7890   NEXT COL
  666. 7900   LPRINT THIS$
  667. 7910  NEXT ROW
  668. 7920  LPRINT FORM.FEED$;
  669. 7930  RETURN
  670. 7940  REM Routine to Display the Ordinances
  671. 7950  KEY ON : CLS
  672. 7960  GET #1, PERS(1) : GOSUB 4560
  673. 7970  GET #3, PERS(1)
  674. 7980  SEX$ = LEFT$(T4$,1)
  675. 7990  REM Extract the Ordinance Information
  676. 8000  U1 = CVS(O1$)
  677. 8010  REM Blank Ordinances of no Ordinance Record Present
  678. 8020  IF U1 = 0 THEN GOSUB 9360 : GOTO 8260
  679. 8030  U2$ = O2$
  680. 8040  U3$ = O3$
  681. 8050  U4$ = O4$
  682. 8060  U5  = CVS(O5$)
  683. 8070  U6  = CVS(O6$)
  684. 8080  U7$ = O7$
  685. 8090  U8$ = O8$
  686. 8100  U9$ = O9$
  687. 8110  U10$ = O10$
  688. 8120  U11$ = O11$
  689. 8130  U12  = CVS(O12$)
  690. 8140  U13$ = O13$
  691. 8150  U14$ = O14$
  692. 8160  U15$ = O15$
  693. 8170  U16$ = O16$
  694. 8180  U17$ = O17$
  695. 8190  U18$ = O18$
  696. 8200  U19$ = O19$
  697. 8210  U20$ = O20$
  698. 8220  U21$ = O21$
  699. 8230  U22$ = O22$
  700. 8240  U23$ = O23$
  701. 8250  U24$ = O24$
  702. 8260  KEY OFF
  703. 8270  R1 = 1 : C1 = 1 : R2 = 21 : C2 = 79 : GOSUB 1300  'Double Box
  704. 8280  R1 = 3 : C1 = 1 : R2 = 3 : C2 = 79 : GOSUB 3210  'Horizontal Double
  705. 8290  R1 = 19 : C1 = 1 : R2 = 19 : C2 = 79 : GOSUB 3210  'Horizontal Double
  706. 8300  LOCATE 2,3 : PRINT "Ordinances of:";
  707. 8310  LOCATE 4,7 : COLOR N : PRINT "Personal Record"; : COLOR O
  708. 8320  LOCATE 5,3 : PRINT "Christening:";
  709. 8330  LOCATE 6,3 : PRINT "Blessing:";
  710. 8340  LOCATE 7,3 : PRINT "Sealed to Parents:";
  711. 8350  LOCATE 8,5 : PRINT "Father's Rec.no:";
  712. 8360  LOCATE 9,6 : PRINT "Name:";
  713. 8370  LOCATE 10,5 : PRINT "Mother's Rec.no:";
  714. 8380  LOCATE 11,6 : PRINT "Name:";
  715. 8390  LOCATE 12,3 : PRINT "Baptism:";
  716. 8400  LOCATE 13,3 : PRINT "Confirmation:";
  717. 8410  LOCATE 14,3 : PRINT "Patriarchal Blessing:";
  718. 8420  LOCATE 15,3 : PRINT "Endowment:";
  719. 8430  REM Test for male.  Skip if male.
  720. 8440  IF SEX$ = "M" THEN 8480
  721. 8450  LOCATE 16,3 : PRINT "Sealed to Husband:";
  722. 8460  LOCATE 17,5 : PRINT "Husband's Rec.no:";
  723. 8470  LOCATE 18,6 : PRINT "Name:";
  724. 8480  REM Test for Male.  Skip if not
  725. 8490  IF SEX$ <> "M" THEN 8630
  726. 8500  R1 = 3 : R2 = 19 : C1 = 51 : C2 = 51 : GOSUB 3390  "Vertical Double
  727. 8510  LOCATE 4,57 : COLOR N : PRINT "Priesthood Record"; : COLOR O
  728. 8520  LOCATE 5,53 : PRINT "Aaronic:";
  729. 8530  LOCATE 6,55 : PRINT "Deacon:";
  730. 8540  LOCATE 7,55 : PRINT "Teacher:";
  731. 8550  LOCATE 8,55 : PRINT "Priest:";
  732. 8560  LOCATE 10,53 : PRINT "Melchizedek:";
  733. 8570  LOCATE 11,55 : PRINT "Elder:";
  734. 8580  LOCATE 12,55 : PRINT "Seventy:";
  735. 8590  LOCATE 13,55 : PRINT "High Priest:";
  736. 8600  LOCATE 15,53 : PRINT "Bishop:";
  737. 8610  LOCATE 16,53 : PRINT "Patriarch:";
  738. 8620  LOCATE 17,53 : PRINT "Apostle:";
  739. 8630  LOCATE 20,3  : PRINT "Occupation:";
  740. 8640  REM Print the Information Currently Present
  741. 8650  LOCATE 2,18 : COLOR W : PRINT LEFT$(T3$ + " " + T2$,47);
  742. 8660  LOCATE 2,66 : PRINT "Rec.no:";T1;
  743. 8670  LOCATE 5,28 : COLOR G : PRINT U2$;
  744. 8680  LOCATE 6,28 : PRINT U3$;
  745. 8690  LOCATE 7,28 : PRINT U4$;
  746. 8700  IF SEX$ = "M" THEN NO.SP = 38 ELSE NO.SP = 51
  747. 8710  LOCATE 8,27 : PRINT U5;
  748. 8720  IF U5 = 0 THEN 8750
  749. 8730  GET #1, U5 : GOSUB 4560  'Extract Father Information
  750. 8740  LOCATE 9,12 : PRINT LEFT$(T3$ + " " + T2$,NO.SP);
  751. 8750  LOCATE 10,27 : PRINT U6;
  752. 8760  IF U6 = 0 THEN 8790
  753. 8770  GET #1, U6 : GOSUB 4560  'Extract Mother Information
  754. 8780  LOCATE 11,12 : PRINT LEFT$(T3$ + " " + T2$,NO.SP);
  755. 8790  LOCATE 12,28 : PRINT U7$;
  756. 8800  LOCATE 13,28 : PRINT U8$;
  757. 8810  LOCATE 14,28 : PRINT U9$;
  758. 8820  LOCATE 15,28 : PRINT U10$;
  759. 8830  REM Test for male.  Skip if male.
  760. 8840  IF SEX$ = "M" THEN 8900
  761. 8850  LOCATE 16,28 : PRINT U11$;
  762. 8860  LOCATE 17,27 : PRINT U12;
  763. 8870  IF U12 = 0 THEN 8900
  764. 8880  GET #1, U12 : GOSUB 4560  'Extract Spouse Information
  765. 8890  LOCATE 18,12 : PRINT T3$ + " " + T2$;
  766. 8900  REM Test for Male.  Bypass if not.
  767. 8910  IF SEX$ <> "M" THEN 9030
  768. 8920  LOCATE 5,67 : PRINT U13$;
  769. 8930  LOCATE 6,67 : PRINT U14$;
  770. 8940  LOCATE 7,67 : PRINT U15$;
  771. 8950  LOCATE 8,67 : PRINT U16$;
  772. 8960  LOCATE 10,67 : PRINT U17$;
  773. 8970  LOCATE 11,67 : PRINT U18$;
  774. 8980  LOCATE 12,67 : PRINT U19$;
  775. 8990  LOCATE 13,67 : PRINT U20$;
  776. 9000  LOCATE 15,67 : PRINT U21$;
  777. 9010  LOCATE 16,67 : PRINT U22$;
  778. 9020  LOCATE 17,67 : PRINT U23$;
  779. 9030  LOCATE 20,15 : PRINT U24$;
  780. 9040  GOTO 4400  'For User Action
  781. 9050  REM Marriage was requested by Number
  782. 9060  MARRIAGE = VAL(RIGHT$(REPLY$,LEN(REPLY$)-1))
  783. 9070  KEY ON : CLS : KEY OFF
  784. 9080  IF MARRIAGE > 0 AND MARRIAGE <= MAX.MAR THEN 9150
  785. 9090  LOCATE 22,1 : PRINT SPACE$(79);
  786. 9100  LOCATE 22,1 : PRINT "Invalid Marriage Number";
  787. 9110  LOCATE 23,1 : PRINT SPACE$(79);
  788. 9120  LOCATE 23,1 : PRINT "Press any key to continue."
  789. 9130  A$ = INKEY$ : IF A$ = "" THEN 9130
  790. 9140  GOTO 3970
  791. 9150  GOSUB 2970  'Print the form
  792. 9160  GET #2, MARRIAGE
  793. 9170  GOTO 6810
  794. 9180  REM Wrapup
  795. 9190  CLOSE #1
  796. 9200  CLOSE #2
  797. 9210  IF DD.ORD$ = "no" THEN 9230
  798. 9220  CLOSE #3
  799. 9230  KEY ON : CLS : KEY OFF : LOCATE 21,1 : COLOR W,K
  800. 9240  PRINT "End of Program"
  801. 9250  RUN DD.MENU$+"menu"
  802. 9260  REM Routine to Convert a number to a string.  This.pers is input
  803. 9270  REM value$ is output, with record number and persons name.
  804. 9280  VALUE$ = STR$(THIS.PERS)
  805. 9290  WIDE = LEN(VALUE$)
  806. 9300  VALUE$ = RIGHT$(VALUE$,WIDE-1)
  807. 9310  NM$ = T2$+", "+T3$
  808. 9320  IF T2$ = " " OR  T3$ = " " THEN NM$ = T2$+T3$
  809. 9330  IF T2$ = " " AND T3$ = " " THEN NM$ = ""
  810. 9340  VALUE$ = "("+VALUE$+") "+NM$
  811. 9350  RETURN
  812. 9360  REM Blank Ordinances if No Ord Record
  813. 9370  U2$  = "" : U3$  = "" : U4$  = ""
  814. 9380  U5   = 0  : U6   = 0  : U12  = 0
  815. 9390  U7$  = "" : U8$  = "" : U9$  = "" : U10$ = ""
  816. 9400  U11$ = "" : U13$ = "" : U14$ = "" : U15$ = ""
  817. 9410  U16$ = "" : U17$ = "" : U18$ = "" : U19$ = ""
  818. 9420  U20$ = "" : U21$ = "" : U22$ = "" : U23$ = ""
  819. 9430  U24$ = ""
  820. 9440  RETURN
  821.