home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / basic / library / zbasic / pia / piacal.bas < prev    next >
BASIC Source File  |  1988-05-04  |  25KB  |  587 lines
  1. 100 DEFINT A,G,I,K,M,N,P,S,T,U,W: DEFDBL B,C,D,L,O
  2. 101 DEFSNG E,F,H,J,Q,R,V,X,Y,Z
  3. 105 REM $INCLUDE: 'COMMON.BAS'
  4. 110 REM $INCLUDE: 'GETSTRN.BAS'
  5. 435 REM 1958 PIB-PIA Conversion Table AME's
  6. 440 DATA 76.,78.,80.,81.,83.,85.,87.,89.,90.,92.,94.,96.,97.,99.,101.
  7. 445 DATA 102.,104.,106.,107.,109.,113.,118.,122.,127.,132.,136.,141.
  8. 450 DATA 146.,150.,155.,160.,164.,169.,174.,178.,183.,188.,193.,197.
  9. 455 DATA 202.,207.,211.,216.,221.,225.,230.,235.,239.,244.,249.,250.
  10. 460 FOR K3=1 TO 51: READ J(1,K3): NEXT K3
  11. 465 REM 1958 PIB-PIA Conversion Table PIB's
  12. 470 DATA 16.2,16.84,17.6,18.4,19.24,20.,20.64,21.28,21.88,22.28,22.68
  13. 475 DATA 23.08,23.44,23.76,24.2,24.6,25.,25.48,25.92,26.4,26.94,27.46
  14. 480 DATA 28.,28.68,29.25,29.68,30.36,30.92,31.36,32.,32.6,33.2,33.88
  15. 485 DATA 34.50,35.,35.80,36.40,37.08,37.6,38.2,39.12,39.68,40.33
  16. 490 DATA 41.12,41.76,42.44,43.20,43.76,44.44,44.58,45.60
  17. 495 FOR K1=1 TO 51: READ J(2,K1): NEXT K1
  18. 1000 REM Print status screen
  19. 1005 CLS: GOSUB 2000: PRINT "   ";: GOSUB 9870
  20. 1010 PRINT STRING$(30," ");"PIA calculation";STRING$(30," ")
  21. 1015 GOSUB 2000: GOSUB 9850: PRINT: PRINT: GOSUB 3000
  22. 1020 X1=D(8,M8): G3=T(2,2)-1951: IF T(2,1)>=6 THEN G3=G3+1
  23. 1025 C9=C5*V6: GOSUB 6700: X2=C9
  24. 1030 IF T(2,2)>1982 OR (T(2,2)=1982 AND T(2,1)>=6) THEN X2=FIX(X2)
  25. 1035 PRINT: IF S2>=S4 THEN 1045
  26. 1040 PRINT "   Warning! Not insured! Has";S2;"QC's, needs";S4;"QC's"
  27. 1045 IF P6+1950>=G2 THEN 1055
  28. 1050 PRINT "   Warning! Earnings after";P6+1950;"not used"
  29. 1055 ON M8 GOTO 1060,1060,1070,1060,1080,1070
  30. 1060 PRINT USING "   Average Monthly Earnings = $$#######";D(5,M8)
  31. 1065 GOTO 1085
  32. 1070 PRINT USING "   Indexed Monthly Earnings = $$#######";D(5,M8)
  33. 1075 GOTO 1085
  34. 1080 PRINT USING "   Years of coverage        =    ######";G6
  35. 1085 PRINT USING "   Primary Insurance Amount = $$####.##";V6
  36. 1090 IF C5<1! THEN 1110
  37. 1095 PRINT USING "   Number of months of increment = ####";I6
  38. 1100 PRINT USING "   Delayed increment factor =   #.#####";C5
  39. 1105 GOTO 1135
  40. 1110 PRINT USING "   Number of months of reduction = ####";I6
  41. 1115 IF A5=2 AND A4=1 THEN 1125
  42. 1120 PRINT "   Actuarial reduction factor =";: GOTO 1130
  43. 1125 PRINT "   Benefit factor =            ";
  44. 1130 PRINT USING " #.#####";C5
  45. 1135 PRINT USING "   Benefit actually payable = $$####.##";X2
  46. 1140 PRINT USING "   Maximum Family Benefit =  $$#####.##";X1
  47. 1145 GOSUB 9860
  48. 1150 PRINT "   Do you want printed output of results? (y or n) > ";
  49. 1155 C$=FNGETSTRN$(1): GOSUB 9860
  50. 1157 IF LEN(C$)<=0 THEN BEEP: GOTO 1150
  51. 1160 GOSUB 7000: IF C$<>"Y" AND C$<>"N" THEN BEEP: GOTO 1150
  52. 1165 IF C$<>"Y" THEN 9900
  53. 1170 CLS: GOSUB 9850
  54. 1175 PRINT "   Loading PIA printout program; please wait..."
  55. 1180 CHAIN "PIAOUT"
  56. 2000 REM Subroutine to draw 75 hyphens
  57. 2005 GOSUB 9860: PRINT "   ";STRING$(75,"-"): RETURN
  58. 3000 REM Subroutine to compute PIA
  59. 3001 GOSUB 9850
  60. 3005 IF G1<1938 THEN 3007
  61. 3006 FOR K1=1937 TO G1-1: O(K1-1936)=0!: G(0,K1-1936)=0: NEXT K1
  62. 3007 IF G2>1935+N5 THEN 3010
  63. 3008 FOR K1=G2+1 TO 1936+N5: IF K1>1936+N6 THEN G(0,K1-1936)=0
  64. 3009 O(K1-1936)=0!: NEXT K1
  65. 3010 C1=0!: IF G1>1950 THEN 3045
  66. 3040 FOR K1=1 TO 14: C1=C1+O(K1): NEXT K1: IF C1>42000! THEN C1=42000!
  67. 3045 GOSUB 4500: REM Calculate total QC's
  68. 3050 IF A5<>2 THEN P6=T(2,2)-1951 ELSE P6=T(3,2)-1950
  69. 3053 IF T(9,3)=0 THEN 3060
  70. 3055 IF P6>T(9,3)-1950 THEN P6=T(9,3)-1950
  71. 3057 IF P6>T(9,3)-1951 AND T(9,1)=1 AND T(9,2)=1 THEN P6=T(9,3)-1951
  72. 3060 A(2,2)=0: IF T(2,2)<=1974 THEN 3075
  73. 3065 A(2,2)=T(2,2)-1975: P7=6: IF T(2,2)>=1983 THEN P7=12
  74. 3070 IF T(2,1)>=P7 THEN A(2,2)=A(2,2)+1
  75. 3075 FOR K1=U3 TO U4: K2=K1-1936: IF K2<15 THEN 3085
  76. 3080 IF O(K2)>B(1,K2) THEN O(K2)=B(1,K2)
  77. 3085 NEXT K1
  78. 3090 P8=U3-1950: IF P8<1 THEN P8=1
  79. 3095 REM Start old-start PIA calculation
  80. 3098 FOR K1=1 TO N5: B(3,K1)=0!: L(1,K1)=0!: NEXT K1
  81. 3100 N8=0: N9=0: A(1,1)=0: D(1,1)=0!: IF C1<1! THEN 3620
  82. 3105 A(1,1)=1: PRINT "   Working on old-start PIA"
  83. 3110 IF T(2,2)>=1961 THEN 3155
  84. 3115 IF A5=1 THEN N8=T(2,2)-1937: GOTO 3140
  85. 3120 IF A5>2 THEN 3135
  86. 3125 IF T(5,3)+22>1937 THEN N8=T(3,2)-T(5,3)-22 ELSE N8=T(3,2)-1937
  87. 3130 GOTO 3140
  88. 3135 IF T(5,3)+22>1937 THEN N8=T(9,3)-T(5,3)-22 ELSE N8=T(9,3)-1937
  89. 3140 IF T(2,2)>=1955 OR T(2,2)=1954 AND T(2,1)>=9 THEN N8=N8-5
  90. 3145 IF N8<2 THEN N8=2
  91. 3150 GOTO 3190
  92. 3155 IF A5=1 THEN 3180
  93. 3160 N8=G9-(T(5,3)-1924): IF N8>G9+9 THEN N8=G9+9
  94. 3165 IF N8>35 THEN N8=35
  95. 3170 IF N8<2 THEN N8=2
  96. 3175 GOTO 3190
  97. 3180 N8=N1+14: IF N8>35 THEN N8=35
  98. 3185 REM Determine correct old-start method to use
  99. 3190 IF T(2,2)<1950 OR T(2,2)=1950 AND T(2,1)<=8 THEN N9=1
  100. 3195 IF T(2,2)=1950 AND T(2,1)>=9 THEN N9=2
  101. 3200 IF T(2,2)>=1951 AND T(2,2)<=1958 THEN N9=2
  102. 3205 IF T(2,2)>=1959 AND T(2,2)<=1967 THEN N9=3
  103. 3210 IF T(2,2)<=1967 THEN 3240
  104. 3215 IF T(5,3)>=1916 AND G9>=27 THEN 3230
  105. 3220 IF T(5,3)<1916 THEN N9=5 ELSE N9=4
  106. 3225 GOTO 3240
  107. 3230 IF G9=27 THEN N9=6 ELSE N9=7
  108. 3235 REM Calculate imputed earnings from 1937 to 1950
  109. 3240 ON N9 GOTO 3245,3245,3245,3245,3250,3280,3280
  110. 3245 FOR K1=1 TO 14: B(3,K1)=O(K1): L(1,K1)=B(3,K1): NEXT K1: GOTO 3300
  111. 3250 IF C1>27000! THEN 3260
  112. 3255 FOR K1=6 TO 14: B(3,K1)=C1/9!: L(1,K1)=B(3,K1): NEXT K1: GOTO 3300
  113. 3260 I2=FIX((C1+.01)/3000!): IF I2>14 THEN I2=14
  114. 3265 I2=15-I2: FOR K1=I2 TO 14: B(3,K1)=3000!: L(1,K1)=B(3,K1): NEXT K1
  115. 3270 IF I2<=1 THEN 3300
  116. 3275 B(3,I2-1)=C1-FIX(C1/3000!)*3000!: L(1,I2-1)=B(3,I2-1): GOTO 3300
  117. 3280 G5=1930-T(5,3): IF G5<1 THEN G5=1
  118. 3285 IF C1/G5>3000! THEN 3260
  119. 3290 I2=15-G5: FOR K1=I2 TO 14: B(3,K1)=C1/G5: L(1,K1)=B(3,K1): NEXT K1
  120. 3295 REM Fill out remainder of earnings
  121. 3300 I1=P6+14: IF N9=7 AND P6>A7 THEN I1=A7+14
  122. 3310 FOR K1=15 TO I1: B(3,K1)=O(K1): L(1,K1)=B(3,K1): NEXT K1
  123. 3315 S3=1: S6=1: S7=P6+14: S8=N8: GOSUB 5500: I9=D(5,1)
  124. 3320 REM Calculate PIB
  125. 3325 H(1,1)=I9: IF H(1,1)>50! THEN H(1,1)=50!
  126. 3330 H(2,1)=I9-50!: IF H(2,1)>200! THEN H(2,1)=200!
  127. 3335 IF H(2,1)<0! THEN H(2,1)=0!
  128. 3340 F1=.4*H(1,1)+.1*H(2,1)
  129. 3345 ON N9 GOTO 3350,3350,3350,3350,3365,3370,3370
  130. 3350 G7=0: FOR K1=1 TO 14
  131. 3355 IF O(K1)>=200! THEN G7=G7+1
  132. 3360 NEXT K1: GOTO 3380
  133. 3365 G7=14: GOTO 3380
  134. 3370 G7=FIX(C1/1650!): IF G7<4 THEN G7=4
  135. 3375 IF G7>14 THEN G7=14
  136. 3380 F1=F1*(1!+CSNG(G7)/100!)
  137. 3385 IF N9>1 THEN 3415
  138. 3390 D(1,1)=F1: IF D(1,1)<10! THEN D(1,1)=10!
  139. 3395 D(8,1)=.8*I9: IF D(8,1)>85! THEN D(8,1)=85!
  140. 3400 IF D(8,1)>2!*D(1,1) THEN D(8,1)=2!*D(1,1)
  141. 3405 IF D(8,1)<20! THEN D(8,1)=20!
  142. 3410 GOTO 3620
  143. 3415 I2=1: IF N9>2 THEN 3530
  144. 3420 J$="OS50PIB.DAT": OPEN "I",1,J$
  145. 3425 FOR K1=1 TO 486: INPUT #1, Z(K1): NEXT K1: CLOSE #1
  146. 3430 IF F1<=Z(I2) THEN 3440
  147. 3435 I2=I2+1: IF I2<486 THEN 3430
  148. 3440 D(2,1)=19.9+CSNG(I2)/10!
  149. 3445 J$="OS50MFB.DAT": OPEN "I",1,J$
  150. 3450 FOR K1=1 TO 486: INPUT #1, Z(K1): NEXT K1: CLOSE #1
  151. 3455 D(8,1)=Z(I2): D(4,1)=D(8,1)
  152. 3460 IF T(2,2)<=1951 OR T(2,2)=1952 AND T(2,1)<=8 THEN 3620
  153. 3465 IF 5!<D(1,1)*1.125 THEN D(1,1)=D(1,1)*1.125 ELSE D(1,1)=D(1,1)+5!
  154. 3470 C9=D(1,1): G3=2: GOSUB 6700: D(1,1)=C9
  155. 3475 J$="OS52MFB.DAT": OPEN "I",1,J$
  156. 3480 FOR K1=1 TO 486: INPUT #1, Z(K1): NEXT K1: CLOSE #1
  157. 3485 D(8,1)=Z(I2)
  158. 3490 IF T(2,2)<=1953 OR T(2,2)=1954 AND T(2,1)<=8 THEN 3620
  159. 3495 IF I2<=329 THEN D(1,1)=D(1,1)+5!: GOTO 3515
  160. 3500 J$="OS54PIA.DAT": OPEN "I",1,J$
  161. 3505 FOR K1=1 TO 157: INPUT #1, Z(K1): NEXT K1: CLOSE #1
  162. 3510 D(1,1)=Z(I2-329)
  163. 3515 J$="OS54MFB.DAT": OPEN "I",1,J$
  164. 3520 FOR K1=1 TO 486: INPUT #1, Z(K1): NEXT K1: CLOSE #1
  165. 3525 D(8,1)=Z(I2): GOTO 3620
  166. 3530 IF F1<=J(2,I2) THEN 3540
  167. 3535 I2=I2+1: IF I2<51 THEN 3530
  168. 3540 D(5,1)=J(1,I2)
  169. 3545 IF N9<>7 THEN 3595
  170. 3550 IF I2=1 AND G9>30 THEN D(5,1)=FIX(F1*76!/16.2+.999)
  171. 3555 T1=28: T2=1: GOSUB 4900
  172. 3564 REM Apply windfall elimination provision
  173. 3565 IF F6<.001 OR G9<=34 THEN 3585
  174. 3570 Q(3,1)=D(2,1): C9=.5*F6: G3=G9: GOSUB 6700
  175. 3575 D(2,1)=Q(3,1)-C9: IF D(2,1)<.5*Q(3,1) THEN D(2,1)=.5*Q(3,1)
  176. 3580 C9=D(2,1): G3=28: GOSUB 6700: D(2,1)=C9: D(1,1)=D(2,1)
  177. 3585 GOSUB 5300: REM Calculate family maximum
  178. 3586 U2=G9: C7=D(1,1): U8=G4: GOSUB 4800: D(1,1)=C7: C7=D(8,1): U8=G4
  179. 3590 GOSUB 4800: D(8,1)=C7: GOTO 3620
  180. 3595 IF T(2,2)<1974 OR (T(2,2)=1974 AND T(2,1)<6) THEN 3615
  181. 3600 A(2,1)=A(2,2)
  182. 3605 T1=24+A(2,1): T2=0: GOSUB 4900
  183. 3610 GOTO 3620
  184. 3615 M9=D(5,1): GOSUB 4600: D(1,1)=X6: D(8,1)=X7
  185. 3620 REM Start special-minimum PIA calculation
  186. 3622 A(1,5)=0: D(1,5)=0!: G6=0: FOR K1=1 TO N5: G(5,K1)=0!: NEXT K1
  187. 3625 IF T(2,2)<1973 THEN 3840
  188. 3630 A(1,5)=1: PRINT "   Working on special-minimum PIA"
  189. 3632 REM Calculate total years of coverage
  190. 3635 G(5,14)=FIX(C1/900!): IF G(5,14)<=0 THEN 3650
  191. 3640 IF G(5,14)>14 THEN G(5,14)=14
  192. 3650 G6=G(5,14): IF U4<1951 THEN 3680
  193. 3655 I1=U3: IF I1<1951 THEN I1=1951
  194. 3660 I2=U4: IF I2>P6+1950 THEN I2=P6+1950
  195. 3665 FOR K3=I1 TO I2: K1=K3-1936
  196. 3670 IF O(K1)>=.25*B(4,K1) THEN G(5,K1)=1
  197. 3675 G6=G6+G(5,K1): NEXT K3
  198. 3677 REM Determine correct dollar amount
  199. 3680 V2=11.5: IF T(2,2)=1973 OR (T(2,2)=1974 AND T(2,1)<=2) THEN V2=8.5
  200. 3685 IF T(2,2)>=1975 AND T(2,2)<=1978 THEN V2=9!
  201. 3690 IF T(2,2)=1974 AND T(2,1)>=3 THEN V2=9!
  202. 3695 M6=G6-10: IF M6>20 THEN M6=20
  203. 3700 IF M6<0 THEN M6=0
  204. 3705 D(1,5)=M6*V2: D(2,5)=D(1,5): IF T(2,2)>=1979 THEN 3785
  205. 3706 REM Calculate MFB from PIA table
  206. 3707 D(5,5)=76: V8=D(1,5): S3=5
  207. 3710 IF T(2,2)>1974 OR (T(2,2)=1974 AND T(2,1)>=6) THEN 3725
  208. 3715 M9=D(5,5): GOSUB 5700: V4=X6: D(8,5)=X7: GOTO 3770
  209. 3725 A(2,5)=A(2,2): T1=24+A(2,5): T2=0: GOSUB 4900
  210. 3765 V4=D(1,5): D(1,5)=V8
  211. 3770 IF D(1,5)-V4-.01<=0 THEN 3840
  212. 3775 D(5,5)=D(5,5)+1: IF D(5,5)>1000 THEN 3840 ELSE 3710
  213. 3780 REM Calculate MFB for 1977 Amendments special-minimum
  214. 3785 C9=1.5*D(1,5): G3=28: GOSUB 6700: D(8,5)=C9: D(4,5)=D(8,5)
  215. 3790 IF T(2,2)=1979 AND T(2,1)<6 THEN 3840
  216. 3795 A(2,5)=A(2,2)-4
  217. 3797 REM Apply benefit increases
  218. 3800 FOR K1=29 TO 28+A(2,5)
  219. 3805 C9=D(1,5)*(C(2,K1)/100!+1!): G3=K1: GOSUB 6700: D(1,5)=C9
  220. 3810 C9=D(8,5)*(C(2,K1)/100!+1!): G3=K1: GOSUB 6700: D(8,5)=C9
  221. 3812 C9=1.5*D(1,5): G3=K1: GOSUB 6700: IF D(8,5)<C9 THEN D(8,5)=C9
  222. 3815 C9=D(1,5): GOSUB 6900: D(1,5)=C9
  223. 3820 C9=D(8,5): GOSUB 6900: D(8,5)=C9
  224. 3825 C9=1.5*D(1,5): G3=K1: GOSUB 6700: IF D(8,5)<C9 THEN D(8,5)=C9
  225. 3835 NEXT K1
  226. 3840 REM Start PIA Table method
  227. 3842 A(1,2)=0: D(1,2)=0: FOR K1=1 TO N7: B(3,K1)=0!: L(2,K1)=0!: NEXT K1
  228. 3845 IF G9>27 OR T(2,2)<1953 THEN 3910
  229. 3850 IF A5=2 AND T(3,2)<1953 THEN 3910
  230. 3855 A(1,2)=1: PRINT "   Working on PIA Table calculation"
  231. 3860 I2=P6: IF I2>U4-1950 THEN I2=U4-1950
  232. 3865 FOR K3=P8 TO I2
  233. 3875 B(3,K3)=O(K3+14): L(2,K3)=B(3,K3): NEXT K3
  234. 3880 S3=2: S6=P8: S7=P6: S8=N1: GOSUB 5500
  235. 3885 IF T(2,2)<1974 OR (T(2,2)=1974 AND T(2,1)<=5) THEN 3900
  236. 3890 T1=24+A(2,2): T2=0: GOSUB 4900
  237. 3895 GOTO 3910
  238. 3900 M9=D(5,2): GOSUB 4600
  239. 3905 D(1,2)=X6: D(8,2)=X7
  240. 3910 REM Start transitional-guarantee method
  241. 3912 A(1,4)=0: D(1,4)=0: FOR K1=1 TO N7: B(3,K1)=0!: L(4,K1)=0!: NEXT K1
  242. 3915 IF G9<28 OR A7>32 OR A5=3 THEN 3970
  243. 3920 IF A5=2 AND T(3,2)<T(5,3)+62 THEN 3970
  244. 3925 IF T(3,2)=T(5,3)+62 AND T(3,1)<T(5,1) THEN 3970
  245. 3930 A(1,4)=1: PRINT "   Working on transitional guarantee PIA"
  246. 3935 I2=A7: IF I2>U4-1950 THEN I2=U4-1950
  247. 3940 FOR K3=P8 TO I2
  248. 3950 B(3,K3)=O(K3+14): L(4,K3)=B(3,K3): NEXT K3
  249. 3955 S3=4: S6=P8: S7=A7: S8=N1: GOSUB 5500: T1=28: T2=1: GOSUB 4900
  250. 3960 GOSUB 5300: U2=G9: C7=D(1,4): U8=G4: GOSUB 4800: D(1,4)=C7
  251. 3965 C7=D(8,4): U8=G4: GOSUB 4800: D(8,4)=C7
  252. 3970 REM Start wage-indexed method
  253. 3972 A(1,3)=0: D(1,3)=0: FOR K1=1 TO N7: B(3,K1)=0!: L(3,K1)=0!: NEXT K1
  254. 3975 IF G9<=27 THEN 4190
  255. 3980 A(1,3)=1: PRINT "   Working on wage-indexed PIA"
  256. 3985 P4=10: Q(2,1)=.9: Q(2,2)=.32: Q(2,3)=.15: IF G9-1<P8 THEN 4045
  257. 3990 REM Calculate AIME
  258. 3995 FOR K3=P8 TO G9-1
  259. 4005 C(3,K3)=B(5,G9+13)*O(K3+14)
  260. 4010 B(3,K3)=C(3,K3)/B(5,K3+14)
  261. 4015 B(3,K3)=FIX(B(3,K3)*100!+.5)/100!
  262. 4020 L(3,K3)=B(3,K3): NEXT K3
  263. 4045 FOR K3=G9 TO P6: B(3,K3)=O(K3+14): L(3,K3)=B(3,K3): NEXT K3
  264. 4050 S3=3: S6=P8: S7=P6: S8=N1: GOSUB 5500
  265. 4052 REM Calculate AIME PIA
  266. 4055 Q(8,2)=FIX(180!*B(5,G9+13)/B(5,41)+.5)
  267. 4060 Q(8,3)=FIX(1085!*B(5,G9+13)/B(5,41)+.5)
  268. 4065 H(1,3)=D(5,3): IF H(1,3)>Q(8,2) THEN H(1,3)=Q(8,2)
  269. 4070 H(2,3)=D(5,3)-Q(8,2)
  270. 4075 IF H(2,3)>Q(8,3)-Q(8,2) THEN H(2,3)=Q(8,3)-Q(8,2)
  271. 4080 IF H(2,3)<0 THEN H(2,3)=0
  272. 4085 H(3,3)=D(5,3)-Q(8,3): IF H(3,3)<0 THEN H(3,3)=0
  273. 4090 D(2,3)=0!: FOR K3=1 TO 3: D(2,3)=D(2,3)+Q(2,K3)*H(K3,3): NEXT K3
  274. 4095 C9=D(2,3): G3=G9: GOSUB 6700: D(2,3)=C9
  275. 4100 REM Apply windfall provision
  276. 4105 P1=0: IF F6<.001 OR G9<35 THEN 4170
  277. 4110 IF G6<30 THEN 4120
  278. 4115 P1=-1: GOTO 4170
  279. 4119 REM Round one-half of pension
  280. 4120 C9=.5*F6: G3=G9: GOSUB 6700
  281. 4125 Q(3,3)=D(2,3): P1=1: D(2,3)=D(2,3)-C9
  282. 4130 C9=D(2,3): G3=G9: GOSUB 6700
  283. 4135 D(2,3)=C9
  284. 4140 Q(4,1)=.9-.1*(G9-34): IF Q(4,1)<.4 THEN Q(4,1)=.4
  285. 4145 Q(4,2)=Q(2,2): Q(4,3)=Q(2,3)
  286. 4150 I2=30-G6: IF I2>5 THEN I2=5
  287. 4155 IF Q(4,1)<.9-.1*I2 THEN Q(4,1)=.9-.1*I2
  288. 4160 V5=0!: FOR K3=1 TO 3: V5=V5+Q(4,K3)*H(K3,3): NEXT K3
  289. 4165 C9=V5: G3=G9: GOSUB 6700: V5=C9: IF D(2,3)<V5 THEN P1=2: D(2,3)=V5
  290. 4167 REM Apply benefit increases
  291. 4170 D(1,3)=D(2,3): GOSUB 5300: U2=G9: GOSUB 6800
  292. 4174 U2=G9: C7=D(1,3): U8=G4: GOSUB 4800: D(1,3)=C7
  293. 4175 C7=D(8,3): U8=G4: GOSUB 4800: D(8,3)=C7
  294. 4180 IF G9>=31 THEN 4190
  295. 4185 IF D(1,3)<122! THEN D(1,3)=122!: D(8,3)=183!
  296. 4190 REM Start re-indexed widow guarantee
  297. 4192 A(1,6)=0: D(1,6)=0: FOR K1=1 TO N7: B(3,K1)=0!: L(6,K1)=0!: NEXT K1
  298. 4195 IF G9<=27 OR A5<>2 THEN 4380
  299. 4200 IF T(3,2)>T(5,3)+62 THEN 4380
  300. 4205 IF T(3,2)=T(5,3)+62 AND T(3,1)>=T(5,1) THEN 4380
  301. 4210 IF A4<=1 THEN 4380
  302. 4230 IF S5<=33 AND T(3,2)<1985 THEN 4380
  303. 4235 A(1,6)=1: PRINT "   Working on re-indexed widow guarantee"
  304. 4240 M7=S5: IF M7<G9 THEN M7=G9
  305. 4245 I2=T(5,3)+62-1951
  306. 4250 IF T(5,1)=1 AND T(5,2)=1 THEN I2=I2-1
  307. 4255 IF M7>I2 THEN M7=I2
  308. 4265 FOR K3=P8 TO M7-1
  309. 4275 C(4,K3)=B(5,M7+13)*O(K3+14)
  310. 4280 B(3,K3)=C(4,K3)/B(5,K3+14)
  311. 4285 B(3,K3)=FIX(B(3,K3)*100!+.5)/100!
  312. 4290 L(6,K3)=B(3,K3): NEXT K3
  313. 4315 FOR K3=M7 TO P6: B(3,K3)=O(K3+14): L(6,K3)=B(3,K3): NEXT K3
  314. 4320 S3=6: S6=P8: S7=P6: S8=N1: GOSUB 5500
  315. 4325 Q(5,2)=FIX(180!*B(5,M7+13)/B(5,41)+.5)
  316. 4330 Q(5,3)=FIX(1085!*B(5,M7+13)/B(5,41)+.5)
  317. 4335 H(1,6)=D(5,6): IF H(1,6)>Q(5,2) THEN H(1,6)=Q(5,2)
  318. 4340 H(2,6)=D(5,6)-Q(5,2)
  319. 4345 IF H(2,6)>Q(5,3)-Q(5,2) THEN H(2,6)=Q(5,3)-Q(5,2)
  320. 4350 IF H(2,6)<0 THEN H(2,6)=0
  321. 4355 H(3,6)=D(5,6)-Q(5,3): IF H(3,6)<0 THEN H(3,6)=0
  322. 4360 D(2,6)=0!: FOR K3=1 TO 3: D(2,6)=D(2,6)+Q(2,K3)*H(K3,6): NEXT K3
  323. 4365 C9=D(2,6): G3=M7: GOSUB 6700: D(2,6)=C9
  324. 4367 M2=M7-N4+1: IF M2<1 THEN M2=1
  325. 4368 IF M2>10 THEN M2=10
  326. 4370 D(1,6)=D(2,6): U2=M7: GOSUB 6800: D(4,6)=D(4,3)
  327. 4375 U2=M7: C7=D(1,6): U8=M2: GOSUB 4800: D(1,6)=C7: D(8,6)=D(8,3)
  328. 4380 REM Calculate highest PIA and DI family maximum
  329. 4385 V6=0!: M8=0: FOR K3=1 TO 6
  330. 4390 IF V6<D(1,K3) THEN V6=D(1,K3): M8=K3
  331. 4395 NEXT K3
  332. 4400 IF M8>0 THEN A(1,M8)=2
  333. 4405 V7=0!: P2=0: IF A5<>3 THEN RETURN
  334. 4410 IF T(2,2)<=1979 OR (T(2,2)=1980 AND T(2,1)<=6) THEN RETURN
  335. 4412 IF G9<28 THEN RETURN
  336. 4415 IF .85*D(5,3)<1.5*D(2,M8) THEN 4425
  337. 4420 V7=1.5: P2=1: D(4,M8)=V7*D(2,M8): GOTO 4440
  338. 4425 IF .85*D(5,3)>D(2,M8) THEN 4435
  339. 4430 V7=1!: P2=3: D(4,M8)=V7*D(2,M8): GOTO 4440
  340. 4435 V7=.85: P2=2: D(4,M8)=V7*D(5,3)
  341. 4440 G3=G9: C9=D(4,M8): GOSUB 6700: D(4,M8)=C9
  342. 4445 C7=D(4,M8): U2=G9: U8=G4: GOSUB 4800: D(8,M8)=C7: RETURN
  343. 4500 REM Subroutine to calculate total quarters of coverage
  344. 4505 S2=G(0,N6): IF G2<=1936+N6 THEN RETURN
  345. 4510 FOR K1=N6+1 TO N5: G(0,K1)=INT(O(K1)/L(0,K1))
  346. 4515 IF G(0,K1)>4 THEN G(0,K1)=4
  347. 4520 S2=S2+G(0,K1): NEXT K1: RETURN
  348. 4600 REM Subroutine to choose correct PIA table subroutine
  349. 4605 IF (T(2,2)=1952 AND T(2,1)>=9) OR T(2,2)=1953 THEN GOSUB 6500
  350. 4610 IF T(2,2)=1954 AND T(2,1)<9 THEN GOSUB 6500
  351. 4615 IF T(2,2)=1954 AND T(2,1)>=9 THEN GOSUB 6600
  352. 4620 IF T(2,2)>=1955 AND T(2,2)<=1958 THEN GOSUB 6600
  353. 4625 IF T(2,2)>=1959 AND T(2,2)<=1964 THEN GOSUB 6300
  354. 4630 IF T(2,2)>=1965 AND T(2,2)<=1967 THEN GOSUB 6200
  355. 4635 IF T(2,2)=1968 AND T(2,1)=1 THEN GOSUB 6200
  356. 4640 IF (T(2,2)=1968 AND T(2,1)>=2) OR T(2,2)=1969 THEN GOSUB 6000
  357. 4645 IF T(2,2)=1970 THEN GOSUB 5900
  358. 4650 IF T(2,2)=1971 OR (T(2,2)=1972 AND T(2,1)<=8) THEN GOSUB 5800
  359. 4655 IF (T(2,2)=1972 AND T(2,1)>=9) OR T(2,2)=1973 THEN GOSUB 5700
  360. 4660 IF T(2,2)=1974 AND T(2,1)<=5 THEN GOSUB 5700
  361. 4665 RETURN
  362. 4800 REM Subroutine to apply CPI increase to 1977 Amendments
  363. 4805 A(2,S3)=0: IF T(2,2)-1951<=U2 AND T(2,1)<P7 THEN RETURN
  364. 4810 U1=U2+1: IF U1<=28 THEN RETURN
  365. 4825 U9=T(2,2)-1951
  366. 4830 IF T(2,1)>=P7 THEN U9=U9+1
  367. 4835 FOR K1=U1 TO U9
  368. 4840 C9=C7*(C(2,K1)/100!+1!): G3=K1: GOSUB 6700: C7=C9
  369. 4845 C9=C7: GOSUB 6900: C7=C9
  370. 4860 A(2,S3)=A(2,S3)+1: NEXT K1
  371. 4865 RETURN
  372. 4900 REM Subroutine to apply CPI and wage base increase to 1973 Act
  373. 4905 T4=0: U8=G9-N4+1: IF U8<1 THEN U8=1
  374. 4910 IF U8>10 THEN U8=10
  375. 4915 IF D(5,S3)<=1100 THEN 5055
  376. 4920 FOR K1=25 TO T1
  377. 4925 IF D(5,S3)<=B(1,K1+14)/12! AND T4=0 THEN T4=K1
  378. 4930 NEXT K1
  379. 4935 M9=1100: GOSUB 5600
  380. 4940 D(1,S3)=X6: D(8,S3)=X7: IF T4=25 THEN 5045
  381. 4945 FOR K1=25 TO T4-1
  382. 4950 I7=B(1,K1+13)/12!: I8=B(1,K1+14)/12!
  383. 4955 IF (CINT(B(1,K1+13))/60)*60=CINT(B(1,K1+13)) THEN 4965
  384. 4960 I7=CSNG((CINT(B(1,K1+13))/60)*5)
  385. 4965 IF (CINT(B(1,K1+14))/60)*60=CINT(B(1,K1+14)) THEN 4975
  386. 4970 I8=CSNG((CINT(B(1,K1+14))/60)*5)
  387. 4975 D(1,S3)=D(1,S3)+.2*(I8-I7)
  388. 4980 C9=1.75*D(1,S3): G3=K1-1: GOSUB 6700: D(8,S3)=C9
  389. 4985 C9=D(1,S3)*(1!+C(2,K1)/100!): G3=K1: GOSUB 6700: D(1,S3)=C9
  390. 4990 C9=D(8,S3)*(1!+C(2,K1)/100!): G3=K1: GOSUB 6700: D(8,S3)=C9
  391. 4995 C9=1.5*D(1,S3): G3=K1: GOSUB 6700: C8=C9
  392. 5000 IF D(8,S3)<C8 THEN D(8,S3)=C8
  393. 5005 IF K1=28 AND T2>0 THEN D(2,S3)=D(1,S3)
  394. 5010 C9=D(1,S3): GOSUB 6900: D(1,S3)=C9
  395. 5015 C9=D(8,S3): GOSUB 6900: D(8,S3)=C9
  396. 5030 C9=1.5*D(1,S3): G3=K1: GOSUB 6700: C8=C9
  397. 5035 IF D(8,S3)<C8 THEN D(8,S3)=C8
  398. 5040 NEXT K1
  399. 5045 REM Apply extension in year AME is first included in table
  400. 5046 D(1,S3)=D(1,S3)+FIX((D(5,S3)-B(1,T4+13)/12!+4!)/5!)
  401. 5047 C9=1.75*D(1,S3): G3=T4: GOSUB 6700: D(8,S3)=C9
  402. 5050 U1=T4: GOTO 5100
  403. 5055 IF G9>29 AND T2>0 AND D(5,S3)<=75 THEN 5080
  404. 5060 M9=D(5,S3): X6=D(1,S3): X7=D(8,S3): GOSUB 5600
  405. 5065 D(1,S3)=X6: D(8,S3)=X7: D(2,S3)=D(1,S3): D(4,S3)=D(8,S3)
  406. 5070 U1=25: IF T1<U1 THEN RETURN
  407. 5075 GOTO 5100
  408. 5080 C9=D(5,S3)*121.8/76!: G3=28: GOSUB 6700
  409. 5085 D(1,S3)=C9: D(2,S3)=D(1,S3)
  410. 5090 C9=1.5*D(1,S3): G3=28: GOSUB 6700
  411. 5095 D(8,S3)=C9: D(4,S3)=D(8,S3): RETURN
  412. 5100 FOR K1=U1 TO T1
  413. 5105 C9=D(1,S3)*(1!+C(2,K1)/100!): G3=K1: GOSUB 6700: D(1,S3)=C9
  414. 5110 C9=D(8,S3)*(1!+C(2,K1)/100!): G3=K1: GOSUB 6700: D(8,S3)=C9
  415. 5115 C9=1.5*D(1,S3): G3=K1: GOSUB 6700: C8=C9
  416. 5120 IF D(8,S3)<C8 THEN D(8,S3)=C8
  417. 5125 IF K1=28 AND T2>0! THEN D(2,S3)=D(1,S3)
  418. 5130 C9=D(1,S3): GOSUB 6900: D(1,S3)=C9
  419. 5135 C9=D(8,S3): GOSUB 6900: D(8,S3)=C9
  420. 5150 C9=1.5*D(1,S3): G3=K1: GOSUB 6700: C8=C9
  421. 5155 IF D(8,S3)<C8 THEN D(8,S3)=C8
  422. 5160 NEXT K1
  423. 5165 RETURN
  424. 5300 REM Subroutine to calculate MFB at eligibility under 1977 law
  425. 5305 Q(1,1)=1.5: Q(1,2)=2.72: Q(1,3)=1.34: Q(1,4)=1.75
  426. 5310 Q(7,2)=FIX(230!*B(5,G9+13)/B(5,41)+.5)
  427. 5315 Q(7,3)=FIX(332!*B(5,G9+13)/B(5,41)+.5)
  428. 5320 Q(7,4)=FIX(433!*B(5,G9+13)/B(5,41)+.5)
  429. 5325 V(1,S3)=D(2,S3): IF V(1,S3)>Q(7,2) THEN V(1,S3)=Q(7,2)
  430. 5330 V(2,S3)=D(2,S3)-Q(7,2)
  431. 5335 IF V(2,S3)>Q(7,3)-Q(7,2) THEN V(2,S3)=Q(7,3)-Q(7,2)
  432. 5340 IF V(2,S3)<0 THEN V(2,S3)=0
  433. 5345 V(3,S3)=D(2,S3)-Q(7,3)
  434. 5350 IF V(3,S3)>Q(7,4)-Q(7,3) THEN V(3,S3)=Q(7,4)-Q(7,3)
  435. 5355 IF V(3,S3)<0 THEN V(3,S3)=0
  436. 5360 V(4,S3)=D(2,S3)-Q(7,4): IF V(4,S3)<0 THEN V(4,S3)=0
  437. 5365 C9=0!: FOR K1=1 TO 4: C9=C9+Q(1,K1)*V(K1,S3): NEXT K1
  438. 5370 G3=G9: GOSUB 6700: D(8,S3)=C9: D(4,S3)=D(8,S3): RETURN
  439. 5500 REM Subroutine to order earnings to compute an AIME or AME
  440. 5505 FOR K1=1 TO N5: I(K1)=K1: G(S3,K1)=0: NEXT K1
  441. 5506 IF S7=S6 THEN 5530
  442. 5510 FOR K1=S6 TO S7-1: FOR K2=K1+1 TO S7
  443. 5515 IF B(3,K1)<=B(3,K2) THEN 5525
  444. 5520 SWAP B(3,K1), B(3,K2): SWAP I(K1), I(K2)
  445. 5525 NEXT K2: NEXT K1
  446. 5530 D(9,S3)=0!: FOR K1=S7-S8+1 TO S7
  447. 5535 K2=I(K1): G(S3,K2)=1: D(9,S3)=D(9,S3)+B(3,K1): NEXT K1
  448. 5540 D(5,S3)=FIX(D(9,S3)/(S8*12)): RETURN
  449. 5600 REM Subroutine to calculate PIA under 1973 Act, effective 6/1974
  450. 5605 IF M9>1000! THEN 5630 ELSE GOSUB 5700: P4=9
  451. 5610 C9=1.11*X6: G3=24: GOSUB 6700: X6=C9
  452. 5615 C9=1.11*X7: G3=24: GOSUB 6700: X7=C9
  453. 5620 C9=1.5*X6: G3=24: GOSUB 6700: R1=C9: IF X7<R1 THEN X7=R1
  454. 5625 RETURN
  455. 5630 P4=9: X6=FIX((M9+4.01)/5!)+249!
  456. 5635 C9=1.75*X6: G3=24: GOSUB 6700: X7=C9: RETURN
  457. 5700 REM Subroutine to calculate PIAs under 1972 Act, effective 9/1972
  458. 5705 IF M9>750 THEN 5730 ELSE GOSUB 5800: P4=8
  459. 5710 C9=1.2*X6: G3=22: GOSUB 6700: X6=C9
  460. 5715 C9=1.2*X7: G3=22: GOSUB 6700: X7=C9
  461. 5720 C9=1.5*X6: G3=22: GOSUB 6700: Q5=C9: IF X7<Q5 THEN X7=Q5
  462. 5725 GOTO 5740
  463. 5730 P4=8: X6=FIX((M9+4.01)/5!)+204.5
  464. 5735 C9=1.75*X6: G3=22: GOSUB 6700: X7=C9
  465. 5740 IF T(2,2)<>1974 OR T(2,1)<3! OR T(2,1)>5 THEN RETURN
  466. 5745 C9=1.07*X6: G3=24: GOSUB 6700: X6=C9
  467. 5750 C9=1.07*X7: G3=24: GOSUB 6700: X7=C9: RETURN
  468. 5800 REM Subroutine to calculate PIAs under 1971 Act
  469. 5805 IF M9>651! THEN 5850 ELSE GOSUB 5900
  470. 5810 M3=M4: P4=7: C9=1.1*X6: G3=21: GOSUB 6700: X6=C9
  471. 5815 IF M9>627! THEN 5870
  472. 5820 IF M9<=436! THEN C9=.88*M3: GOTO 5830
  473. 5825 C9=383.68+.44*191!: IF M3-436<191 THEN C9=C9+.44*(M3-436-191)
  474. 5830 G3=21: GOSUB 6700: X7=C9
  475. 5835 C9=1.5*X6: G3=21: GOSUB 6700
  476. 5840 Q6=C9: IF M9<240! OR X7<Q6 THEN X7=Q6
  477. 5845 RETURN
  478. 5850 P4=7
  479. 5855 IF M9>656 THEN X6=FIX((M9+4.01)/5!)+145.4
  480. 5860 IF M9<=656 AND M9>=653 THEN X6=276.6
  481. 5865 IF M9=652 THEN X6=275.8
  482. 5870 C9=1.75*X6: G3=21: GOSUB 6700: X7=C9: RETURN
  483. 5900 REM Subroutine to calculate PIAs under 1969 Act
  484. 5905 GOSUB 6000: M4=M1: P4=6
  485. 5910 C9=1.15*X6: G3=20: GOSUB 6700: X6=C9: IF X6<64! THEN X6=64!
  486. 5915 IF M9>239 THEN RETURN
  487. 5920 C9=1.5*X6: G3=20: GOSUB 6700: X7=C9: RETURN
  488. 6000 REM Subroutine to calculate PIAs under 1967 Act
  489. 6005 IF M9>553 THEN 6020 ELSE GOSUB 6200: P4=5: M1=S1
  490. 6010 C9=X6*1.13: G3=18: GOSUB 6700: X6=C9: IF X6<55! THEN X6=55!
  491. 6015 GOTO 6065
  492. 6020 P4=5: X6=189.598+.2843*(M9-550)
  493. 6025 S9=0: IF X6-FIX(X6)>=.49999 THEN S9=1
  494. 6030 X6=S9+FIX(X6): M1=M9
  495. 6035 M1=M1+1
  496. 6040 Q4=189.598+.2843*(M1-550)
  497. 6045 S9=0: IF Q4-FIX(Q4)>.49999 THEN S9=1
  498. 6050 Q4=S9+FIX(Q4)
  499. 6055 IF (Q4-X6)<.1 AND Q4-X6>-.1 THEN 6035
  500. 6060 M1=M1-1: GOTO 6080
  501. 6065 IF M9>370 THEN 6080
  502. 6070 IF M9>=179 THEN RETURN
  503. 6075 C9=1.5*X6: G3=18: GOSUB 6700: X7=C9: RETURN
  504. 6080 IF M9<=436 THEN X7=.8*M1: RETURN
  505. 6085 X7=348.8+.4*(M1-436): IF X7>434.4 THEN X7=434.4
  506. 6090 RETURN
  507. 6200 REM Subroutine to calculate PIAs under 1965 Act
  508. 6205 GOSUB 6300: P4=4: S1=P9: IF M9>94 THEN 6220
  509. 6210 X6=X6+4!: IF X6<44! THEN X6=44!
  510. 6215 X7=1.5*X6: RETURN
  511. 6220 IF M9>403 THEN X6=X6+9!: GOTO 6230
  512. 6225 C9=X6*1.07: G3=15: GOSUB 6700: X6=C9
  513. 6230 IF M9>314 THEN 6245
  514. 6235 IF M9>=142 THEN RETURN
  515. 6240 C9=1.5*X6: G3=15: GOSUB 6700: X7=C9: RETURN
  516. 6245 IF M9<=370 THEN X7=.8*P9: RETURN
  517. 6250 X7=296!+4!*(P9-370): IF X7>368! THEN X7=368!
  518. 6255 RETURN
  519. 6300 REM Subroutine to calculate PIAs under 1958 Act
  520. 6305 P4=3: IF M9>84 THEN 6315
  521. 6310 X6=3.49+.55*M9: GOTO 6325
  522. 6315 X6=.5885*110: IF M9<110 THEN X6=.5885*M9
  523. 6320 IF M9>110 THEN X6=X6+.214*(M9-110)
  524. 6325 P3=0!: IF X6-FIX(X6)>=.49999 THEN P3=1!
  525. 6330 X6=P3+FIX(X6)
  526. 6335 IF X6<33 THEN X6=33
  527. 6340 IF M9=553 THEN X6=159
  528. 6345 IF T(2,2)>1961 AND X6<40! THEN X6=40!
  529. 6350 IF T(2,2)=1961 AND T(2,1)>=8 AND X6<40! THEN X6=40!
  530. 6355 IF M9<=127 THEN 6400 ELSE P9=M9
  531. 6360 P9=P9+1
  532. 6365 Q1=41.195+.214*P9
  533. 6370 P3=0!: IF Q1-FIX(Q1)>.49999 THEN P3=1
  534. 6375 Q1=P3+FIX(Q1)
  535. 6380 IF (Q1-X6)<1 AND (Q1-X6)>-1 THEN 6360
  536. 6385 IF P9<>553 THEN P9=P9-1
  537. 6390 X7=.8*P9: IF X7>254! THEN X7=254!
  538. 6395 RETURN
  539. 6400 X7=1.5*X6: IF X7<X6+20! THEN X7=X6+20!
  540. 6405 RETURN
  541. 6500 REM Subroutine to calculate PIAs under 1952 Act
  542. 6505 X6=.55*100: IF M9<100 THEN X6=.55*M9
  543. 6510 IF M9>100 THEN X6=X6+.15*(M9-100)
  544. 6515 C9=X6: G3=2: GOSUB 6700: X6=C9: IF X6<25! THEN X6=25!
  545. 6520 X7=.8*M9: IF X7<45 THEN X7=45
  546. 6525 IF X7>168.75 THEN X7=168.75
  547. 6530 P4=1: RETURN
  548. 6600 REM Subroutine to calculate PIAs under 1954 Act
  549. 6605 X6=.55*110: IF M9<110 THEN X6=.55*M9
  550. 6610 IF M9>110 THEN X6=X6+.2*(M9-110)
  551. 6615 C9=X6: G3=4: GOSUB 6700: X6=C9: IF X6<30! THEN X6=30!
  552. 6620 X7=.8*M9: IF X7<50! THEN X7=50!
  553. 6625 IF X7<1.5*X6 THEN X7=1.5*X6
  554. 6630 IF X7>200! THEN X7=200!
  555. 6635 P4=2: RETURN
  556. 6700 REM Subroutine to round a PIA or MFB to appropriate dime
  557. 6705 IF G3>31 THEN 6730
  558. 6710 IF G3>=23 THEN Q9=.01 ELSE Q9=.499
  559. 6715 X9=10!*(10!*C9-FIX(10!*C9))
  560. 6720 IF CSNG(1000*X9 MOD 10000)/1000!<Q9 THEN RETURN
  561. 6725 C9=C9+.1-CSNG(1000*X9 MOD 10000)/100000!: RETURN
  562. 6730 C9=FIX(10!*C9+.001)/10!: RETURN
  563. 6800 REM Subroutine to apply real-wage-gain adjustment
  564. 6805 IF U2<=N4 OR T3<>7 THEN RETURN
  565. 6810 C9=D(2,S3)*(1!+.01*(U2-N4)): G3=N4: GOSUB 6700: D(3,S3)=C9
  566. 6815 C9=D(4,S3)*(1!+.01*(U2-N4)): G3=N4: GOSUB 6700: D(6,S3)=C9
  567. 6820 D(1,S3)=D(3,S3): D(8,S3)=D(6,S3): RETURN
  568. 6900 REM Subroutine to apply catch-up benefit increase
  569. 6905 IF K1<N4+3 OR K1>N4+10 THEN RETURN
  570. 6910 IF F(U8,K1-N4-2)<.05 THEN RETURN
  571. 6915 C9=C9*(F(U8,K1-N4-2)/100!+1!): G3=K1: GOSUB 6700: RETURN
  572. 7000 REM Subroutine to convert response to one-letter uppercase
  573. 7005 I4=ASC(C$): IF I4>96 THEN C$=CHR$(I4-32) ELSE C$=CHR$(I4)
  574. 7010 RETURN
  575. 9813 REM For Macintosh, $INCLUDE "COLOR.MAC"
  576. 9814 REM $INCLUDE: 'COLOR.BAS'
  577. 9900 PRINT "   Do you wish to do another calculation? (y or n) > ";
  578. 9905 C$=FNGETSTRN$(1): GOSUB 9860
  579. 9906 IF LEN(C$)<=0 THEN BEEP: GOTO 9900
  580. 9907 GOSUB 7000: IF C$<>"Y" AND C$<>"N" THEN BEEP: GOTO 9900
  581. 9910 IF C$<>"Y" THEN 9935
  582. 9915 CLS: GOSUB 9850
  583. 9920 PRINT "   Loading PIA data-input program; please wait..."
  584. 9925 CHAIN "PIAIN"
  585. 9935 GOSUB 9860: CLS: END
  586. 9999 REM PIACAL.BAS - 05/04/88 - 09:30 AM
  587.