home *** CD-ROM | disk | FTP | other *** search
/ RBBS in a Box Volume 1 #3.1 / RBBSIABOX31.cdr / zzap / zbbs.bas < prev    next >
Encoding:
BASIC Source File  |  1985-07-09  |  41.4 KB  |  788 lines
  1.  
  2. 10 '        *****************************************************************
  3. 20 '        ***                                                           ***
  4. 30 '        ***   Z100/PC-BBS      Original 1982 by C McCurry(PC) and     ***
  5. 40 '        ***   Bill Taylor (Z100) Rewritten extensively by Len Johnson ***
  6. 50 '        ***   of DCASR, CHICAGO and Phil Cleaves of DCASR, BOSTON.    ***
  7. 60 '        ***     -------------------------------------------------     ***
  8. 70 '        ***     THIS IS Z-120/SMODEM 1200 VERSION 2.0 of 08/28/84     ***
  9. 80 '        ***     -------------------------------------------------     ***
  10. 90 '        *****************************************************************
  11. 100 '
  12. 110 CLEAR:COLOR 7,0:CLS:CLOSE:KEY OFF
  13. 115 '---------- DEFINITIONS ----------
  14. 116 SOH$=CHR$(1):EOT$=CHR$(4):CAN$=CHR$(24):ACK$=CHR$(6):NAK$=CHR$(21)
  15. 120 BELL$=CHR$(7):CR$=CHR$(13):XON$=CHR$(17):XOFF$=CHR$(19):ETX$=CHR$(3)
  16. 124 '
  17. 130 CL=FRE(A$):F=FRE("")
  18. 140 DIM N$(50),S$(50),TI$(250),MSG(250),REC(250),L$(300),ST(25),ET(25)
  19. 150 DIM F$(250),CNS$(250),D$(250),T$(250),NF$(20),NL$(20)
  20. 160 VERSION$="Version 2.0":TIMEL$=TIME$:DATEL$=DATE$
  21. 170 LOCAL=0      ' Initial value is for remote access
  22. 180 MEM=2000     ' Insure space for buffers
  23. 190 '
  24. 200 GOSUB 50000                              ' WAIT FOR A CALL
  25. 210 '
  26. 220 ECHO=1    'Allow user to see his own input
  27. 230 CR=1      ' Initialize "Carriage return" as default for output messages
  28. 240 UC=0      ' Set to 1 for all upper case letters
  29. 250 IF LOCAL THEN ON ERROR GOTO 0:NF$="SYSOP":LOGTIME$=TIME$:CLS:GOTO 830
  30. 260 FOR I=1 TO 2000:NEXT I
  31. 270 O$="WELCOME":GOSUB 2680
  32. 275 A$=STRING$(80,"*"):GOSUB 2120
  33. 280 '
  34. 290 ' *** SIGN ON AND VERIFY ***
  35. 300 '
  36. 310 N=2:GOSUB 3990:UC=1
  37. 320 A$="What Is Your First Name->":CR=0:GOSUB 2120:GOSUB 2300:NF$=A$
  38. 330 IF LEN(NF$)<3 THEN 320
  39. 340 IF NF$="SYSOP" THEN A$="That's an unusual and RESERVED name....Try another....":GOSUB 2120:GOTO 320
  40. 350 GOSUB 3990:A$="What is Your Last Name->":CR=0:GOSUB 2120:GOSUB 2300:NL$=A$
  41. 360 IF LEN(NL$)<3 THEN 350
  42. 370 GOSUB 3990:A$="What phone or location are you calling from->":CR=0:GOSUB 2120:GOSUB 2300:CNS$=A$
  43. 380 IF LEN(CNS$)<3 THEN 370
  44. 390 N=4:GOSUB 3990:A$="If you're not "+NF$+" "+NL$:GOSUB 2120
  45. 400 A$="         From "+CNS$:GOSUB 2120:GOSUB 3990
  46. 410 A$="Hit R to reenter else hit RETURN ->":CR=0:GOSUB 2120:GOSUB 2300:A$=LEFT$(A$,1):IF A$="R" THEN 320
  47. 420 LOCATE 25,1:PRINT STRING$(80," ")
  48. 430 '
  49. 440 ' *** RECORD LOGON ***
  50. 450 '
  51. 460 LOCATE 25,1:PRINT "LOGON at ";TIME$;" -- ";NF$;" ";NL$;" from ";CNS$;
  52. 470 UC=0:A$="Adding Your Name To Our List of Callers.... * ":CR=0:GOSUB 2120
  53. 480 CLOSE #2:OPEN "R",#2,"CALLS",6:FIELD #2,6 AS CA$:GET #2,1:LSET CA$=STR$(VAL(CA$)+1):CS$=CA$:PUT#2,1:CLOSE#2:GOTO 510
  54. 490 '  OPEN "I",2,"CALLS":LINE INPUT#2,CS$:CLOSE#2:GOTO 510
  55. 500 PRINT ERR,ERL:IF (ERR=53 AND ERL=520) THEN RESUME 580:ELSE RESUME 590
  56. 510 CLOSE #3:OPEN "NULOG" FOR OUTPUT AS #3:WRITE #3,CS$,NF$,NL$,CNS$,TIME$,DATE$
  57. 520 ON ERROR GOTO 500:OPEN "I",#2,"USERLOG"
  58. 530 IF EOF(2) GOTO 570
  59. 540 INPUT #2,XCS$,XNF$,XNL$,XCNS$,XT$,XD$
  60. 550 WRITE #3,XCS$,XNF$,XNL$,XCNS$,XT$,XD$
  61. 560 GOTO 530
  62. 570 CLOSE #2:KILL "USERLOG"
  63. 580 CLOSE #3:NAME "NULOG" AS "USERLOG":A$=" *":GOSUB 2120
  64. 590 LPRINT: LPRINT "LOGON -> # "CS$;" - ";NF$;" "NL$;" FROM ";CNS$;" AT ";TIME$;" ON ";DATE$
  65. 600 LOGTIME$=TIME$
  66. 610 SM=INP(233):IF SM>100 THEN BR$=" 300 BAUD" ELSE BR$="1200 BAUD"
  67. 620 LPRINT BR$:LOCATE 25,70:PRINT BR$
  68. 630 N=2:GOSUB 3990:A$="You Are Logged On As of => "+LEFT$(DATE$,2)+"/"+MID$(DATE$,4,2)+"/"+RIGHT$(DATE$,2)+" at "+TIME$+" -- Line Speed is "+BR$:GOSUB 2120:N=2:GOSUB 3990
  69. 640 A$=STRING$(80,"*"):GOSUB 2120
  70. 650 REM ********** BYPASS PASSWORD CHECK **********
  71. 660 GOTO 750
  72. 670 REM *******************************************
  73. 680 '
  74. 690 '*** PASSWORD CHECK ***
  75. 700 '
  76. 710 PASS1$="DCRBUG":PASS2$="dcrbug":GOSUB 3910:IF NP=1 THEN A$="PASSWORD FAILED -- Call Terminated....":GOSUB 2120:A$="T":GOTO 930
  77. 720 '
  78. 730 '*** GENERAL MESSAGE OPTION ***
  79. 740 '
  80. 750 N=2:GOSUB 3990:A$="Do you wish to read the General Message Files ?(y/n)->":CR=0:GOSUB 2120:GOSUB 2300:GM$=LEFT$(A$,1):N=3:GOSUB 3990:IF GM$="N" OR GM$="n" THEN 765
  81. 760 A$=STRING$(80,"*"):GOSUB 2120:O$="GENMESS":GOSUB 2680
  82. 765 A$=STRING$(80,"*"):GOSUB 2120:GOSUB 3990
  83. 770 REM ******************************************
  84. 780 REM **                                      **
  85. 790 REM **         MAIN MENU HANDLER            **
  86. 800 REM **                                      **
  87. 810 REM ******************************************
  88. 820 GOSUB 4140
  89. 830 CLOSE 2:ON ERROR GOTO 3630:GOSUB 3990:A$="Input the MENU Command ( ?-If Not Known)->"+BELL$:CR=0:GOSUB 2120:GOSUB 2300:N=2:GOSUB 3990
  90. 840 IF A$="CHAT" OR A$="chat" THEN GOSUB 3310:GOTO 820
  91. 850 A$=LEFT$(A$,1):IF A$>="a" AND A$<="z" THEN A$=CHR$(ASC(A$)-32)
  92. 860 '  IF OP THEN PRINT #3,LEFT$(A$,4);",";
  93. 870 IF A$="?" THEN O$="MENU":GOSUB 2680:GOTO 820
  94. 880 IF A$="U" THEN GOSUB 20000:GOTO 820
  95. 885 IF A$="X" THEN GOSUB 20000:GOTO 820
  96. 890 IF A$="F" THEN GOSUB 3190:GOTO 820
  97. 900 IF A$="B" THEN GOSUB 1030:GOTO 820
  98. 910 IF A$="O" THEN GOSUB 2810:GOTO 820
  99. 920 IF A$="D" THEN GOSUB 20000:GOTO 820
  100. 930 IF A$="T" THEN GOSUB 3530:RUN 110
  101. 940 IF A$="C" THEN GOSUB 3050:GOTO 820
  102. 950 IF A$="E" THEN GOSUB 3440:GOTO 820
  103. 960 IF A$="P" THEN GOSUB 2920:GOTO 820
  104. 970 GOSUB 3990:A$=">> NOT IMPLEMENTED <<":GOSUB 2120:GOTO 820
  105. 980 REM ******************************************
  106. 990 REM **                                      **
  107. 1000 REM **      ACCESS BULLETIN BOARDS          **
  108. 1010 REM **                                      **
  109. 1020 REM ******************************************
  110. 1030 A$="                        Scan/Read/Post Bulletin Board ":GOSUB 2120:GOSUB 3990
  111. 1040 A$="          *********   Current Message Boards Available  *********":GOSUB 2120:GOSUB 3990
  112. 1050 A$="          A   -   Messages Requesting Technical Assistance":GOSUB 2120
  113. 1060 A$="          C   -   Messages Specific to the Contracts Directorate":GOSUB  2120
  114. 1070 A$="          E   -   Executive Message File (Protected)":GOSUB  2120
  115. 1080 A$="          G   -   General Messages For All Callers":GOSUB 2120
  116. 1090 A$="          Q   -   Messages Specific to the Quality Directorate":GOSUB 2120
  117. 1100 A$="          Z   -   Messages for Zenith Model 100 Users":GOSUB 2120:GOSUB 3990
  118. 1101 A$="                     RETURN Only For Master Menu":GOSUB 2120:GOSUB 3990
  119. 1108 A$="          *******************************************************":GOSUB 2120:GOSUB 3990
  120. 1110 A$="                Which Board Do You Wish To Access ?->":CR=0:GOSUB 2120:GOSUB 2300:A$=LEFT$(A$,1)
  121. 1120 IF A$="" THEN GOTO 1270
  122. 1130 IF INSTR("AaCcEeGgQqSsUuZz",A$)=0 THEN GOSUB 2110:GOTO 1030
  123. 1140 BOARD$=A$
  124. 1150 IF INSTR("EeSsUu",A$)=0 THEN GOTO 1205
  125. 1160 IF A$="E" OR A$="e" THEN PASS1$="EXEC":PASS2$="exec":GOSUB 3910:IF NP<>1 THEN GOTO 1210
  126. 1170 IF A$="U" OR A$="u" THEN PASS1$="USER":PASS2$="user":GOSUB 3910:IF NP<>1 THEN GOTO 1210
  127. 1180 IF A$="S" OR A$="s" THEN PASS1$="STEER":PASS2$="steer":GOSUB 3910:IF NP<>1 GOTO 1210
  128. 1190 A$="PASSWORD FAILED -- Access Denied...."+BELL$:GOSUB 2120:GOTO 1030
  129. 1205 N=2:GOSUB 3990
  130. 1210 A$="Scan (S) ??, Post (P) ?? or Return (R) For A Different Board ->":CR=0:GOSUB 2120:GOSUB 2300
  131. 1230 IF A$="R" OR A$="r" OR A$="" THEN N=2:GOSUB 3990:GOTO 1030
  132. 1240 IF INSTR("SsPp",A$)=0 THEN GOSUB 2110: GOTO 1210
  133. 1250 IF INSTR("SsPp",A$)<3 THEN GOSUB 1330:N=2:GOSUB 3990:GOTO 1210
  134. 1260 GOSUB 1840:GOTO 1210
  135. 1270 RETURN
  136. 1280 REM ******************************************************
  137. 1290 REM **                                                  **
  138. 1300 REM **             SCAN MESSAGES ROUTINE                **
  139. 1310 REM **                                                  **
  140. 1320 REM ******************************************************
  141. 1330 CLOSE #2:ON ERROR GOTO 1340:OPEN "I",2,BOARD$+"_NEXT":INPUT #2,M,NREC:CLOSE #2:GOTO 1350
  142. 1340 IF ERR=53 AND ERL=1330 THEN A$="There are no messages currently posted on this Bulletin Board ....":GOSUB 2120:RESUME 1510:ELSE PRINT ERR,ERL:RESUME 1510
  143. 1350 GOSUB 3990:A$="There are Message Numbers 1 -"+STR$(M-1):GOSUB 2120:GOSUB 3990
  144. 1360 A$="Start The Scan With Which Number? ('Q' to quit) ->":CR=0:GOSUB 2120:GOSUB 2300
  145. 1370 IF A$="Q" OR A$="q" THEN 1510
  146. 1380 IF VAL(A$)<1 OR VAL(A$)>M-1 OR VAL(A$)<>INT(VAL(A$)) THEN GOSUB 2110:GOTO 1350
  147. 1390 BS=VAL(A$)
  148. 1400 CLOSE #2:OPEN "R",2,BOARD$+"_TITLES",45
  149. 1410 FIELD #2,4 AS MSG$,4 AS REC$,35 AS TITLE$
  150. 1420 GOSUB 3990:C=1
  151. 1430 FOR X=BS TO M-1
  152. 1440 GET #2,X:MSG(X)=CVS(MSG$):REC(X)=CVS(REC$):TI$(X)=TITLE$
  153. 1450 A$=STR$(MSG(X))+SPACE$(6-LEN(STR$(MSG(X))))+TI$(X):GOSUB 2120:C=C+1
  154. 1460 IF C>20 THEN GOSUB 2100
  155. 1470 NEXT X
  156. 1480 GOSUB 3990:A$="Read (R) ?? or Quit (Q) ?? ->":CR=0:GOSUB 2120:GOSUB 2300
  157. 1490 GOSUB 3990:IF A$="Q" OR A$="q" THEN 1510
  158. 1500 IF A$="R" OR A$="r" THEN GOSUB 1570:GOTO 1400
  159. 1510 RETURN
  160. 1520 REM ******************************************************
  161. 1530 REM **                                                  **
  162. 1540 REM **             READ MESSAGES ROUTINE                **
  163. 1550 REM **                                                  **
  164. 1560 REM ******************************************************
  165. 1570 A$="Which Message Do You Want To Read? ('Q' to quit) ->":CR=0:GOSUB 2120:GOSUB 2300:RM$=A$:RM=VAL(RM$)
  166. 1580 IF A$="Q" OR A$="q" THEN GOTO 1780
  167. 1590 IF RM>M-1 OR RM<1 THEN GOSUB 2110:GOTO 1570
  168. 1595 IF RM<BS THEN GOSUB 3990:A$=">> NOT IN REQUESTED SCAN RANGE <<":GOSUB 2120:GOTO 1780
  169. 1600 CLOSE #2:OPEN "R",2,+BOARD$+"_MSGS",79
  170. 1610 FIELD #2,15 AS FIN$,15 AS LN$,6 AS DA$,6 AS TI$,4 AS L$,20 AS AD$,13 AS FILLER$
  171. 1620 FIELD #2,79 AS ML$
  172. 1630 GET #2,REC(RM):L=CVS(L$):D=0
  173. 1640 N=2:GOSUB 3990:A$="MESSAGE #:"+STR$(RM):GOSUB 2120
  174. 1650 A$="TITLE    : "+TI$(RM):GOSUB 2120
  175. 1660 A$="From     : "+FIN$+" "+LN$:GOSUB 2120
  176. 1670 A$="To       : "+AD$:GOSUB 2120
  177. 1680 A$="Date     : "+LEFT$(DA$,2)+"/"+MID$(DA$,3,2)+"/"+RIGHT$(DA$,2):GOSUB 2120
  178. 1690 A$="Time     : "+LEFT$(TI$,2)+":"+MID$(TI$,3,2)+":"+RIGHT$(TI$,2):GOSUB 2120
  179. 1700 A$="Length   :"+STR$(L)+" Lines":GOSUB 2120
  180. 1710 N=2:GOSUB 3990:C=1
  181. 1720 FOR Y=1 TO L:GET #2,REC(RM)+Y:A$=ML$:GOSUB 2120:C=C+1
  182. 1730 IF C>20 THEN GOSUB 2100
  183. 1740 NEXT Y
  184. 1750 CLOSE 2:GOSUB 3990:A$=STRING$(80,"-"):GOSUB 2120
  185. 1780 RETURN
  186. 1790 REM ******************************************
  187. 1800 REM **                                      **
  188. 1810 REM **       POST MESSAGE HANDLER           **
  189. 1820 REM **                                      **
  190. 1830 REM ******************************************
  191. 1840 UC=1:N=2:GOSUB 3990:A$="Title ->":CR=0:GOSUB 2120:GOSUB 2300:TITLE$=A$
  192. 1850 N=2:GOSUB 3990:A$="Enter the Name of Person to Receive Message or Enter ALL ->":CR=0:GOSUB 2120:GOSUB 2300:ADDRESSEE$=A$
  193. 1860 UC=0:GOSUB 2490:LINES=LINES-1
  194. 1870 IF LINES<=0 THEN GOTO 2080
  195. 1880 GOSUB 3990:A$="Saving message... *":CR=0:GOSUB 2120
  196. 1890 LPRINT "   **** Posted message to board : ";BOARD$
  197. 1900 CLOSE #2:ON ERROR GOTO 2090:OPEN "I",#2,BOARD$+"_NEXT":INPUT #2,R,NREC:CLOSE #2
  198. 1910 OPEN "R",#2,BOARD$+"_MSGS",79
  199. 1920 A$=" *":GOSUB 2120
  200. 1930 FIELD #2,15 AS FIN$,15 AS LN$,6 AS DA$,6 AS TI$,4 AS L$,20 AS AD$,13 AS FILLER$
  201. 1940 FIELD #2,79 AS ML$
  202. 1950 LSET FIN$=NF$
  203. 1960 LSET LN$=NL$
  204. 1970 LSET DA$=LEFT$(DATE$,2)+MID$(DATE$,4,2)+RIGHT$(DATE$,2)
  205. 1980 LSET TI$=LEFT$(TIME$,2)+MID$(TIME$,4,2)+RIGHT$(TIME$,2)
  206. 1990 LSET AD$=ADDRESSEE$
  207. 2000 LSET L$=MKS$(LINES)
  208. 2010 PUT #2,NREC
  209. 2020 FOR X=1 TO LINES:LSET ML$=L$(X):PUT #2,NREC+X:NEXT X
  210. 2030 CLOSE 2:OPEN "O",2,BOARD$+"_NEXT":PRINT #2,R+1;",";NREC+LINES+1
  211. 2040 CLOSE 2:OPEN "R",2,BOARD$+"_TITLES",45
  212. 2050 FIELD #2,4 AS MSG$,4 AS REC$,35 AS OTITLE$
  213. 2060 LSET MSG$=MKS$(R):LSET REC$=MKS$(NREC):LSET OTITLE$=TITLE$:PUT #2,R
  214. 2070 CLOSE 2:N=2:GOSUB 3990
  215. 2080 RETURN
  216. 2090 IF ERR=53 AND ERL=1900 THEN:CLOSE #2:OPEN "O",#2,BOARD$+"_NEXT":PRINT #2,1,1:CLOSE #2:RESUME 1900:ELSE A$="Can not post message....Try another Board....":GOSUB 2120:RESUME 2080
  217. 2100 GOSUB 3990:A$="        .... Hit RETURN to continue ....":CR=0:GOSUB 2120:GOSUB 2300:C=1:GOSUB 3990:RETURN  'Suspend print after 20 lines / continue
  218. 2110 GOSUB 3990:A$=">> INVALID REQUEST <<":GOSUB 2120:N=2:GOSUB 3990:RETURN  'Invalid Bulletin Board usage
  219. 2120 REM ******************************************
  220. 2130 REM **                                      **
  221. 2140 REM **         PRINT TEXT ROUTINE           **
  222. 2150 REM **                                      **
  223. 2160 REM ******************************************
  224. 2170 FOR XX=LEN(A$) TO 1 STEP -1:IF MID$(A$,XX,1)=" " THEN NEXT XX        'Strip trailing spaces
  225. 2180 A$=LEFT$(A$,XX)   'New length for A$ less trailing spaces
  226. 2190 FOR XX=LEN(A$) TO 1 STEP -1:IF MID$(A$,XX,1)=CHR$(10) THEN NEXT XX   'Strip line feed/s
  227. 2200 A$=LEFT$(A$,XX)   'New length for A$ less line feed/s
  228. 2210 FOR XX=LEN(A$) TO 1 STEP -1:IF MID$(A$,XX,1)=CHR$(13) THEN NEXT XX   'Strip CR
  229. 2220 A$=LEFT$(A$,XX)   'New length for A$ less CR
  230. 2230 IF LOCAL=1 THEN 2270
  231. 2240 GOSUB 3830
  232. 2250 PRINT #1,A$;
  233. 2260 IF CR=1 THEN PRINT #1,CHR$(13);
  234. 2270 PRINT A$;
  235. 2280 IF CR=1 THEN PRINT
  236. 2290 CR=1:RETURN
  237. 2300 REM ******************************************
  238. 2310 REM **                                      **
  239. 2320 REM **         INPUT TEXT ROUTINE           **
  240. 2330 REM **                                      **
  241. 2340 REM ******************************************
  242. 2350 IF LOCAL=1 THEN 2480
  243. 2370 C$="":A$="":WHILE C$<>CR$
  244. 2380 IF LOC(1)>0 THEN C$=INPUT$(1,#1) ELSE C$="":GOSUB 3830
  245. 2390 B$=INKEY$:IF C$="" THEN C$=B$
  246. 2400 IF C$>="a" AND C$<="z" AND UC=1 THEN C$=CHR$(ASC(C$)-32)
  247. 2410 IF C$=CHR$(8) AND POS(0)>1 AND LEN(A$)>0 THEN LOCATE ,POS(1)-1:PRINT #1,C$;" ";C$;
  248. 2420 IF C$=CHR$(8) AND LEN(A$)>0 THEN A$=LEFT$(A$,LEN(A$)-1):GOTO 2460
  249. 2430 IF C$<CHR$(30) AND C$<>CR$ THEN 2460
  250. 2440 IF C$<>CR$ THEN A$=A$+C$
  251. 2450 PRINT C$;:IF ECHO THEN PRINT #1,C$;
  252. 2460 WEND
  253. 2470 RETURN
  254. 2480 LINE INPUT A$:RETURN
  255. 2490 REM ******************************************
  256. 2500 REM **                                      **
  257. 2510 REM **      BLOCK TEXT INPUT ROUTINE        **
  258. 2520 REM **                                      **
  259. 2530 REM ******************************************
  260. 2540 GOSUB 3990:LINES=0
  261. 2550 A$="Enter the text of your message now:":GOSUB 2120:GOSUB 3990
  262. 2560 A$=" Enter  /EX  on a line when done...":GOSUB 2120:N=2:GOSUB 3990
  263. 2570 LINES=LINES+1
  264. 2580 A$=RIGHT$("  "+STR$(LINES),2)+">":CR=0:GOSUB 2120:GOSUB 2300:L$(LINES)=A$:IF A$<>"/ex" AND A$<>"/EX" AND A$<>"/Ex" AND A$<>"/eX" THEN 2570
  265. 2590 N=2:GOSUB 3990:A$="S)ave, C)ontinue, L)ist, F)ix, A)bort->":CR=0:GOSUB 2120:GOSUB 2300
  266. 2600 IF A$="s" OR A$="S" THEN RETURN
  267. 2610 IF A$="a" OR A$="A" THEN LINES=0:RETURN
  268. 2620 IF A$="C" OR A$="c" THEN 2580
  269. 2630 IF A$="L" OR A$="l" THEN GOSUB 3990:FOR QX=1 TO LINES-1:A$=RIGHT$("  "+STR$(QX),2)+">"+L$(QX):GOSUB 2120:NEXT QX:GOTO 2590
  270. 2640 IF A$<>"F" AND A$<>"f" THEN A$=BELL$:CR=0:GOSUB 2120:GOTO 2590
  271. 2650 GOSUB 3990:A$="Line # to Fix ->":CR=0:GOSUB 2120:GOSUB 2300:L=VAL(A$):IF L<1 OR L<>INT(L) OR L>LINES-1 THEN 2590
  272. 2660 A$=RIGHT$("  "+STR$(L),2)+">"+L$(L):GOSUB 2120
  273. 2670 A$=RIGHT$("  "+STR$(L),2)+">":CR=0:GOSUB 2120:GOSUB 2300:L$(L)=A$:GOTO 2590
  274. 2680 REM ******************************************
  275. 2690 REM **                                      **
  276. 2700 REM **      BLOCK TEXT OUTPUT ROUTINE       **
  277. 2710 REM **                                      **
  278. 2720 REM ******************************************
  279. 2730 CLOSE #2:OPEN "I",#2,O$
  280. 2740 WHILE NOT EOF(2)
  281. 2750 LINE INPUT #2,A$
  282. 2755 GOSUB 2170
  283. 2790 WEND
  284. 2800 CLOSE #2:RETURN
  285. 2810 '  ******************************************
  286. 2820 '  **                                      **
  287. 2830 '  **    DISPLAY OTHER BULLETIN BOARDS     **
  288. 2840 '  **                                      **
  289. 2850 '  ******************************************
  290. 2860 A$="Current DLA/DOD Bulletin Boards in Operation Are:":GOSUB 2120:GOSUB 3990
  291. 2870 A$="BBS   Organ         Autovon     Commercial         Systems Operator ":GOSUB 2120
  292. 2880 GOSUB 3990:A$=STRING$(80,"-"):GOSUB 2120:GOSUB 3990
  293. 2890 CLOSE 2:OPEN "I",2,"BBSDATA":D=0:WHILE NOT(EOF(2)):D=D+1:INPUT #2, **                                      **
  294. 2940 '  **         PAGE SYSTEM OPERATOR         **
  295. 2950 '  **                                      **
  296. 2960 '  ******************************************
  297. 2970 IF LOCAL=1 THEN GOSUB 4330:GOTO 3040
  298. 2980 N=2:GOSUB 3990
  299. 2990 IF PAGE THEN A$="Page has been turned back off...":PAGE=0:GOSUB 2120:GOSUB 3990:GOTO 3040
  300. 3000 IF VAL(LEFT$(TIME$,2))>22 THEN A$="It's past the SYSOP's normal bedtime, but I'll try anyway...":GOSUB 2120:GOTO 3030
  301. 3010 IF VAL(LEFT$(TIME$,2))<7 THEN A$="The SYSOP's probably not out of bed yet, but I'll try anyway...":GOSUB 2120:GOTO 3030
  302. 3020 N=2:GOSUB 3990:A$="The Page has been turned on,  if the SYSOP's around, he will answer it.         Meanwhile, you can continue to use the system.":GOSUB 2120
  303. 3030 PAGE=1:GOSUB 3990
  304. 3040 RETURN
  305. 3050 '  ******************************************
  306. 3060 '  **                                      **
  307. 3070 '  **      ACCESS LIST OF CALLERS          **
  308. 3080 '  **                                      **
  309. 3090 '  ******************************************
  310. 3100 A$="The 15 Most Recent Callers were....":GOSUB 2120
  311. 3110 A$="-----------------------------------":GOSUB 2120:GOSUB 3990
  312. 3120 OPEN "USERLOG" FOR INPUT AS #2:X=1
  313. 3130 IF EOF(2) GOTO 3180
  314. 3140 IF X>15   GOTO 3180
  315. 3150 X=X+1:INPUT #2,XCS$,XNF$,XNL$,XCNS$,XT$,XD$
  316. 3160 A$=" # "+XCS$+" -- "+XNF$+" "+XNL$+" FROM "+XCNS$+" @ "+XT$+" ON "+XD$:GOSUB 2120
  317. 3170 GOTO 3130
  318. 3180 CLOSE #2:GOSUB 3990:RETURN
  319. 3190 '  ******************************************
  320. 3200 '  **                                      **
  321. 3210 '  **         FEED BACK HANDLER            **
  322. 3220 '  **                                      **
  323. 3230 '  ******************************************
  324. 3240 IF LOCAL=1 THEN GOSUB 4330:GOTO 3300
  325. 3250 GOSUB 3990:A$="Feedback to SYSOP...":GOSUB 2120:GOSUB 3990:GOSUB 2490
  326. 3260 LINES=LINES-1:IF LINES<=0 THEN GOTO 3300
  327. 3270 N=2:GOSUB 3990:A$="Writing feedback...":CR=0:GOSUB 2120
  328. 3280 LPRINT "FEEDBACK...."
  329. 3290 CLOSE #2:OPEN "FEEDBACK" FOR APPEND AS #2:PRINT #2,FIRSTNAME$;",";LASTNAME$:PRINT#2,"":PRINT#2,STRING$(80,"-"):FOR QX=1 TO LINES:PRINT#2,L$(QX):NEXT QX:PRINT#2,"":PRINT#2,STRING$(80,"-"):CLOSE 2:A$="Written...":GOSUB 2120:GOSUB 3990
  330. 3300 RETURN
  331. 3310 '  ******************************************
  332. 3320 '  **                                      **
  333. 3330 '  **         CHAT MODE HANDLER            **
  334. 3340 '  **                                      **
  335. 3350 '  ******************************************
  336. 3360 IF LOCAL=1 THEN GOSUB 4330:GOTO 3430
  337. 3370 PB$="":B$=""
  338. 3380 A$="Type a CTRL-E (CHR$(5)) then a CTRL-X (CHR$(24)) to end chat mode...":GOSUB 2120:N=2:GOSUB 3990
  339. 3390 A$=INKEY$:IF A$<>"" THEN B$=A$:PRINT B$;:PRINT #1,B$;
  340. 3400 IF LOC(1)>0 THEN B$=INPUT$(1,1):PRINT B$;:PRINT #1,B$;
  341. 3410 IF PB$=CHR$(5) AND B$=CHR$(24) THEN GOTO 3430
  342. 3420 PB$=B$:GOTO 3390
  343. 3430 RETURN
  344. 3440 '  ******************************************
  345. 3450 '  **                                      **
  346. 3460 '  **         DISPLAY DATE AND TIME        **
  347. 3470 '  **                                      **
  348. 3480 '  ******************************************
  349. 3490 A$="Date & Time in Boston, Mass....":GOSUB 2120
  350. 3500 A$="-------------------------------":GOSUB 2120:GOSUB 3990
  351. 3510 A$="Date  - "+LEFT$(DATE$,2)+"/"+MID$(DATE$,4,2)+"/"+RIGHT$(DATE$,2):GOSUB 2120:A$="Time  - "+TIME$:GOSUB 2120:GOSUB 3990:RETURN
  352. 3530 REM ******************************************
  353. 3540 REM **                                      **
  354. 3550 REM **         TERMINATE HANDLER            **
  355. 3560 REM **                                      **
  356. 3570 REM ******************************************
  357. 3580 IF LOCAL=1 THEN GOTO 3620
  358. 3590 N=2:GOSUB 3990:A$="LOGOFF AT => "+LEFT$(DATE$,2)+"/"+MID$(DATE$,4,2)+"/"+RIGHT$(DATE$,2)+"      "+TIME$:GOSUB 2120:GOSUB 3990
  359. 3600 O$="GOODBYE":GOSUB 2680:GOSUB 3990
  360. 3610 LPRINT"LOGOFF -> "NF$;" "NL$;" : "CNS$,TIME$,DATE$:LPRINT
  361. 3620 GOSUB 4230:RETURN
  362. 3630 REM ******************************************
  363. 3640 REM **                                      **
  364. 3650 REM **         ERROR HANDLER                **
  365. 3660 REM **                                      **
  366. 3670 REM ******************************************
  367. 3680 PRINT ERR,ERL
  368. 3690 IF LOCAL GOTO 3820
  369. 3700 IF ERR=10 THEN GOTO 3820
  370. 3710 IF ERR=57 THEN GOTO 3820
  371. 3720 IF ERR=3  THEN GOTO 3820
  372. 3730 IF ERR=7  THEN GOTO 3820
  373. 3740 IF ERR=62 THEN GOTO 3820
  374. 3750 IF ERR=69 THEN GOTO 3820
  375. 3760 IF ERR=53 THEN A$="Sorry, The SYOPS Put This File On List of Programs, But The Dummy Forgot to Put It On The Disk":GOSUB 2120:GOTO 3820
  376. 3770 '  IF ERR=61 THEN PRINT#1,"NO DISK SPACE-TRY LATER":PRINT#1,"":GOTO 6190
  377. 3780 IF ERR=55 THEN GOTO 3820
  378. 3790 IF ERR=PERR AND ERL=PERL AND PTIME$=LEFT$(TIME$,5) THEN GOTO 3820
  379. 3800 PERR=ERR:PERL=ERL:PTIME$=LEFT$(TIME$,5)
  380. 3810 CLOSE 2:OPEN "ERRORS" FOR APPEND AS #2:PRINT #2,ERR;",";ERL;",";DATE$;",";TIME$:CLOSE 2
  381. 3820 GOTO 970
  382. 3830 REM *********************************************************
  383. 3840 REM ****  CARRIER  CHECK ROUTINE                         ****
  384. 3850 REM *********************************************************
  385. 3860 IF FRE(0)<MEM THEN CL=FRE(A$)
  386. 3870 IF LOCAL=1 GOTO 3900
  387. 3880 CD=INP(237)
  388. 3890 IF CD<=100 THEN LPRINT "** LOST CARRIER -> "NF$;" ";NL$;" : "CNS$,TIME$,DATE$:LPRINT:RUN 110
  389. 3900 RETURN
  390. 3910 REM **********************************************************
  391. 3920 REM ****  SUBROUTINE TO ENTER PASSWORD FOR ENTRY          ****
  392. 3930 REM **********************************************************
  393. 3940 X=0:NP=0
  394. 3950 A$="Enter the Password for Access.....  ":CR=0:GOSUB 2120:GOSUB 2300
  395. 3960 IF A$=PASS1$ OR A$=PASS2$ THEN 3980
  396. 3970 X=X+1:IF X<4 THEN 3950 ELSE NP=1
  397. 3980 RETURN
  398. 3990 REM *********************************************************
  399. 4000 REM ****  SUBROUTINE TO SKIP A GIVEN NUMBER OF LINES (N)  ***
  400. 4010 REM *********************************************************
  401. 4020 IF N<=1 THEN N=1
  402. 4030 I=0:WHILE I<N
  403. 4040 IF LOCAL=1 THEN GOTO 4060
  404. 4050 PRINT #1,CHR$(13);
  405. 4060 PRINT
  406. 4070 I=I+1
  407. 4080 WEND
  408. 4090 N=1:RETURN
  409. 4100 REM *********************************************************
  410. 4110 REM ****  SUBROUTINE TO MONITOR TIME ON SYSTEM         ******
  411. 4120 REM ****  AND DISCONNECT AFTER 20 MINUTES              ******
  412. 4130 REM *********************************************************
  413. 4140 LOGTIME=(VAL(LEFT$(LOGTIME$,2))*60)+(VAL(MID$(LOGTIME$,4,2)))
  414. 4150 CURRTIME=(VAL(LEFT$(TIME$,2))*60)+(VAL(MID$(TIME$,4,2)))
  415. 4160 SYSTIME=CURRTIME-LOGTIME:SYSTIME$=STR$(SYSTIME)
  416. 4170 IF SYSTIME>20 THEN GOTO 4210
  417. 4180 IF SYSTIME<=15 THEN GOTO 4200
  418. 4190 N=2:GOSUB 3990:A$="You Have Been On The System "+SYSTIME$+" Minutes. (20 Minute Max)":GOSUB 2120:N=3:GOSUB 3990
  419. 4200 RETURN
  420. 4210 GOSUB 3990:A$="You Have Reached the 20 Minute Maximum...You Will be Terminated":GOSUB 2120:GOSUB 3990
  421. 4220 A$="T":GOTO 930
  422. 4230 REM *********************************************************
  423. 4240 REM ****  BREAK IN COMM LINKAGE -- TERMINATE             ****
  424. 4250 REM *********************************************************
  425. 4260 IF LOCAL=1 GOTO 4300 ELSE GOSUB 4310
  426. 4270 GOSUB 3860
  427. 4280 A$="%%%":PRINT #1,A$;:GOSUB 4312:IF A$="OK" GOTO 4290 ELSE GOTO 4270
  428. 4290 A$="ATH":PRINT #1,A$;
  429. 4300 RETURN
  430. 4310 FOR I=1 TO 2000:NEXT I:RETURN         ' TIMER FOR BREAK IN COMM LINKAGE
  431. 4312 GOSUB 4310:A$="":X$="":Y$=""          ' LOOK FOR RESPONSE IN COMMAND MODE
  432. 4313 IF LOC(1)>0 THEN Y$=INPUT$(1,#1) ELSE RETURN
  433. 4314 IF X$="O" AND Y$="K" THEN A$="OK":RETURN
  434. 4315 X$=Y$:GOTO 4313
  435. 4320 REM *********************************************************
  436. 4330 REM *********************************************************
  437. 4340 REM ****  LOCAL ERROR SUBROUTINE                         ****
  438. 4350 REM *********************************************************
  439. 4360 GOSUB 3990:A$="  >> NOT FOR LOCAL USE <<":GOSUB 2120:GOSUB 3990:RETURN
  440. 4370 REM *********************************************************
  441. 20000 REM ******************************************
  442. 20010 REM **                                      **
  443. 20020 REM **      FILE TRANSFER MENU              **
  444. 20030 REM **                                      **
  445. 20040 REM ******************************************
  446. 20050 N=2:GOSUB 3990
  447. 20055 A$="                         File Transfer Menu":GOSUB  2120:GOSUB 3990
  448. 20060 A$="          ********   Options Currently Available  ********":GOSUB 2120:GOSUB 3990
  449. 20070 A$="          A   -   ASCII File Upload   (RAW Data - No Error Checking)":GOSUB 2120
  450. 20075 A$="          D   -   ASCII File Download (RAW Data - No Error Checking)":GOSUB 2120
  451. 20080 A$="          B   -   CHRISTIENSEN Protocol Upload   (Error Checking)":GOSUB  2120
  452. 20090 A$="          X   -   CHRISTIENSEN Protocol Download (Error Checking)":GOSUB 2120:GOSUB 3990
  453. 20095 A$="          Q   -   Quit to Main Menu":GOSUB 2120:GOSUB 3990
  454. 20100 A$="          ************************************************":GOSUB 2120:GOSUB 3990
  455. 20110 A$="          NOTES:  USE ASCII FOR SOURCE CODE AND TEXT FILES":GOSUB 2120
  456. 20120 GOSUB 3990:A$="                  CHRISTIENSEN PROTOCOL TRANSFERS WILL WORK":GOSUB 2120
  457. 20125 A$="                  WITH ANY FILES BUT NON-ASCII FILES ARE FOR":GOSUB 2120
  458. 20127 A$="                  Z-100 USERS ONLY":GOSUB 2120
  459. 20130 N=2:GOSUB 3990:A$="                Which Function Do You Wish ?? ->":CR=0:GOSUB 2120:GOSUB 2300:A$=LEFT$(A$,1)
  460. 20140 IF A$="" OR A$="Q" OR A$="q" THEN GOTO 20290
  461. 20150 IF INSTR("AaBbDdXx",A$)=0 THEN GOSUB 2110:GOTO 20050
  462. 20160 FUNC$=A$
  463. 20169 '
  464. 20170 '  IF FUNC$="B" OR FUNC$="b" OR FUNC$="X" OR FUNC$="x" THEN A$=">> OPTION NOT AVAILABLE AT PRESENT <<":GOSUB 2120:GOTO 20050
  465. 20171 '
  466. 20180 IF A$="A" OR A$="a" OR A$="B" OR A$="b" THEN GOSUB 21350:RETURN
  467. 20185 IF A$="D" OR A$="d" OR A$="X" OR A$="x" THEN GOSUB 21000:RETURN
  468. 20290 RETURN
  469. 21000 REM ******************************************
  470. 21010 REM **                                      **
  471. 21020 REM **      DOWNLOAD PROGRAMS & FILES       **
  472. 21030 REM **                                      **
  473. 21040 REM ******************************************
  474. 21050 N=2:GOSUB 3990:A$="**** Files are Downloaded by Number -- Available Files are Listed Below ****":GOSUB 2120:GOSUB 3990
  475. 21060 A$="                                                                    Transfer":GOSUB 2120
  476. 21070 A$="File                                                                  Time  ":GOSUB 2120
  477. 21080 A$=" #   Program       Description                             System   300/1200":GOSUB 2120
  478. 21090 A$=STRING$(80,"-"):GOSUB 2120:GOSUB 3990
  479. 21130 CLOSE #2:OPEN "I",#2,FUNC$+"_DOWN":D=0:C=1
  480. 21140 WHILE NOT(EOF(2)):D=D+1:C=C+1:INPUT #2,P$(D),D$(D),S$(D),T$(D)
  481. 21150 A$=RIGHT$("  "+STR$(D)+" - ",5)+P$(D)+SPACE$(14-LEN(P$(D)))+D$(D)+SPACE$(40-LEN(D$(D)))+S$(D)+SPACE$(10-LEN(S$(D)))+T$(D)+SPACE$(8-LEN(T$(D))):GOSUB 2120
  482. 21160 IF C>18 THEN GOSUB 2100
  483. 21170 WEND
  484. 21180 CLOSE #2
  485. 21190 GOSUB 3990:A$=STRING$(80,"-"):GOSUB 2120
  486. 21200 GOSUB 3990:CR=0:A$="Which file number to download ('Q'=QUIT, 'F'=FILELIST)->":GOSUB 2120:GOSUB 2300
  487. 21210 IF A$="F" OR A$="f" THEN GOTO 21050
  488. 21215 IF A$="Q" OR A$="q" THEN RETURN
  489. 21220 DL=VAL(A$):IF DL<1 OR DL<>INT(DL) OR DL>D THEN GOTO 21316
  490. 21230 O$=P$(DL)
  491. 21235 CLOSE #2:OPEN "I",#2,O$
  492. 21237 LPRINT "Downloading - ";O$;" @ ";TIME$;" ..."
  493. 21240 GOSUB 21317:A$="Open YOUR File To RECEIVE "+O$+" ... I'll Take it from there ...":GOSUB 2120:A$="":GOSUB 22580
  494. 21245 WHILE LOC(1)=0:GOSUB 3860:GOTO 21245:WEND:ECHO=0:A$=INPUT$(1,#1):ECHO=1
  495. 21265 IF FUNC$="X" OR FUNC$="x" THEN GOTO 22700
  496. 21267 IF LEFT$(A$,1)<>XON$ AND LEFT$(A$,1)<>CR$ THEN GOTO 21313
  497. 21280 IF EOF(2) THEN GOTO 21305
  498. 21290 X$=INPUT$(1,#2)
  499. 21292 WHILE HOLDING=1 GOSUB 21320:WEND
  500. 21295 PRINT #1,X$;
  501. 21297 GOSUB 21325
  502. 21300 GOTO 21280
  503. 21305 CLOSE #2:A$="":GOSUB 22580
  504. 21308 WHILE LOC(1)=0:GOSUB 3860:GOTO 21308:WEND:ECHO=0:A$=INPUT$(1,#1):ECHO=1
  505. 21310 IF LEFT$(A$,1)<>EOT$ AND LEFT$(A$,1)<>ETX$ AND LEFT$(A$,1)<>CR$ THEN GOTO 21314
  506. 21312 GOSUB 21317:A$="Download Complete ...":GOSUB 2120:GOTO 21190
  507. 21313 GOSUB 21317:A$="Transfer Not Begun ...":GOSUB 2120:GOTO 21190
  508. 21314 GOSUB 21317:A$="Transfer Aborted ...":GOSUB 2120:GOTO 21190
  509. 21316 GOSUB 21317:A$="Invalid Selection ...":GOSUB 2120:GOTO 21050
  510. 21317 N=2:GOSUB 3990:RETURN
  511. 21320 IF LOC(1)<=0 THEN RETURN
  512. 21321 Y$=INPUT$(1,#1):IF Y$=XON$ THEN HOLDING=0:RETURN ELSE RETURN
  513. 21325 IF LOC(1)<=0 THEN RETURN
  514. 21326 Y$=INPUT$(1,#1):IF Y$=XOFF$ THEN HOLDING=1:RETURN ELSE RETURN
  515. 21350 REM ******************************************
  516. 21360 REM **                                      **
  517. 21370 REM **      UPLOAD PROGRAMS & FILES         **
  518. 21380 REM **                                      **
  519. 21390 REM ******************************************
  520. 21410 N=2:GOSUB 3990:A$=STRING$(71,"*"):GOSUB 2120
  521. 21420 N=2:GOSUB 21890:A$="***                       NOTES ON UPLOADING                        ***":GOSUB 2120
  522. 21430 GOSUB 21890:A$="***  (1) Uploaded Files are not immediately available for Download  ***":GOSUB 2120
  523. 21440 A$="***       They are placed in a Holding Area until they are reviewed ***":GOSUB 2120
  524. 21450 GOSUB 21890:A$="***  (2) Programs that do not step the User through the entire I/O  ***":GOSUB 2120
  525. 21460 A$="***       process should have an identically named file with a .DOC ***":GOSUB 2120
  526. 21470 A$="***       extension to explain the programs usefulness              ***":GOSUB 2120
  527. 21480 GOSUB 21890:A$="***  (3) BASIC source code MUST be Uploaded from a file saved as an ***":GOSUB 2120
  528. 21490 A$="***       ASCII file and should have a .BAS extension               ***":GOSUB 2120
  529. 21500 GOSUB 21890:A$="***  (4) Other file extensions should follow the 'SOURCE' Program   ***":GOSUB 2120
  530. 21510 A$="***       conventions (i.e. LOTUS Worksheets use .WKS etc)          ***":GOSUB 2120
  531. 21520 GOSUB 21890:A$=STRING$(71,"*"):GOSUB 2120:N=2:GOSUB 2100:GOSUB 3990
  532. 21530 A$="*****    The Current files in The Holding Area are:    *****":GOSUB 2120:N=3:GOSUB 3990
  533. 21540 A$=" #   Program       Description                             System           ":GOSUB 2120
  534. 21550 A$=STRING$(80,"-"):GOSUB 2120:GOSUB 3990
  535. 21590 CLOSE #2:ON ERROR GOTO 21910:OPEN "I",#2,"A:"+FUNC$+"_UPLD":D=0:C=1
  536. 21600 WHILE NOT(EOF(2)):D=D+1:C=C+1:INPUT #2,P$(D),D$(D),S$(D)
  537. 21610 A$=RIGHT$("  "+STR$(D)+" - ",5)+P$(D)+SPACE$(14-LEN(P$(D)))+D$(D)+SPACE$(40-LEN(D$(D)))+S$(D)+SPACE$(10-LEN(S$(D))):GOSUB 2120
  538. 21620 IF C>18 THEN GOSUB 2100
  539. 21630 WEND
  540. 21640 CLOSE #2
  541. 21650 GOSUB 3990:A$=STRING$(80,"-"):GOSUB 2120:UC=1
  542. 21660 N=2:GOSUB 3990:A$="Enter the Name, Including Extension (i.e. .BAS ) To Save Under.  ":GOSUB 2120
  543. 21670 A$="DO NOT Duplicate a Name Already Used Above...... ->":CR=0:GOSUB 2120:GOSUB 2300
  544. 21680 IF A$="" THEN 21880:ELSE P$=LEFT$(A$,14)
  545. 21690 N=2:GOSUB 3990:A$="Enter the System if Limited Use (i.e. Z-100 or ALL) - (10 char max)....->":CR=0:GOSUB 2120:GOSUB 2300
  546. 21700 IF A$="" THEN 21690 ELSE S$=LEFT$(A$,10)
  547. 21710 N=2:GOSUB 3990:A$="Enter a Brief Discription of Application (40 char max)....":GOSUB 2120:GOSUB 2300
  548. 21720 IF A$="" THEN 21710 ELSE D$=LEFT$(A$,40)
  549. 21730 CLOSE #2:UC=0:ON ERROR GOTO 21900:OPEN "O",#2,"A:"+P$
  550. 21740 N=2:GOSUB 3990:A$="Open the File to be sent and Hit RETURN....I'll take it from there.....":GOSUB 2120:GOSUB 2300:HOLDING=0:C$=""
  551. 21745 GOSUB 22560        '  Purge COMM Buffer
  552. 21747 IF FUNC$="B" OR FUNC$="b" THEN GOTO 22270
  553. 21750 WHILE LOC(1)>0
  554. 21760 A$=INPUT$(LOC(1),#1)
  555. 21765 PRINT #2,A$;
  556. 21770 WEND
  557. 21775 GOSUB 3860
  558. 21780 FOR I=1 TO 1000
  559. 21790 IF LOC(1)>0 THEN I=9999
  560. 21800 NEXT I
  561. 21810 IF I=>9999 THEN GOTO 21750
  562. 21820 CLOSE #2
  563. 21830 OPEN "A:"+FUNC$+"_UPLD" FOR APPEND AS #2
  564. 21840 WRITE #2,P$,D$,S$
  565. 21850 CLOSE #2
  566. 21860 N=2:GOSUB 3990:A$="Upload Complete ...":GOSUB 2120
  567. 21870 LPRINT "    UPLOAD -- ";P$
  568. 21875 N=2:GOSUB 3990
  569. 21880 RETURN
  570. 21890 B$=STRING$(65," "):FOR I=1 TO N:A$="***"+B$+"***":GOSUB 2120:NEXT I:N=1:RETURN
  571. 21900 PRINT ERR,ERL:RESUME 21820
  572. 21910 IF ERR=53 AND ERL=21590 THEN A$="NO PROGRAMS IN HOLD AREA":GOSUB 2120:RESUME 21640:ELSE PRINT ERR,ERL:A$=">> OPTION NOT AVAILABLE AT PRESENT <<":GOSUB 2120:RESUME 21880
  573. 21920 REM ************010 '---------- GET Input from COMM ----------
  574. 22020 Y$=""
  575. 22030 FOR A=1 TO 420
  576. 22040 IF LOC(1)>0 THEN Y$=INPUT$(LOC(1),#1):RETURN
  577. 22050 NEXT A:Y$="":RETURN
  578. 22070 '---------- WAIT (Timeout) ----------
  579. 22090 FOR B=1 TO 10
  580. 22100 GOSUB 22020
  581. 22110 IF MID$(Y$,1,1)=SOH$ THEN RETURN
  582. 22120 IF MID$(Y$,1,1)=EOT$ THEN 22530
  583. 22130 IF MID$(Y$,1,1)=CAN$ THEN 22540
  584. 22140 IF Y$<>"" THEN GOSUB 22560:GOTO 22090
  585. 22150 NEXT B
  586. 22160 IF Y$="" THEN PRINT #1,NAK$;
  587. 22170 GOTO 22090
  588. 22180 '
  589. 22190 '---------- CHRISTIENSEN RECEIVE ----------
  590. 22200 '
  591. 22270 X$="":SEC=1
  592. 22280 PRINT #1,NAK$;
  593. 22290 GOSUB 22070                  ' Timeout
  594. 22300 GOSUB 22020                  ' Get Char
  595. 22310 IF Y$="" THEN PRINT "Timeout":GOTO 22340
  596. 22320 X$=X$+Y$
  597. 22330 IF LEN(X$)<=131 THEN 22300
  598. 22340 IF LEN(X$)= 132 THEN Z$=MID$(X$,4,128):N=132:GOTO 22420
  599. 22350 IF LEN(X$)= 131 THEN Z$=MID$(X$,3,128):N=131:GOTO 22420
  600. 22360 IF LEN(X$)> 132 THEN 22490
  601. 22370 IF X$=EOT$      THEN 22530
  602. 22380 IF X$=CAN$      THEN 22540
  603. 22390 GOTO 22480
  604. 22400 IF SEC<> VAL(MID$(X$,2,1) THEN 22510
  605. 22410 IF (SEC XOR 255) <> VAL(MID$(X$,3,1) THEN 22520
  606. 22420 FOR Q=1 TO 128:CK=CK+ASC(MID$(Z$,Q,1)):NEXT
  607. 22430 IF (CK AND 255) <> (ASC(MID$(X$,N,1))) THEN 22500
  608. 22440 PRINT "Received #";SEC:SEC=255 AND (SEC+1)
  609. 22450 PRINT #2,Z$;
  610. 22460 PRINT #1,ACK$;
  611. 22470 X$="":CK=0:GOTO 22300
  612. 22480 PRINT "Short Block in #"   ;SEC:PRINT #1,NAK$;:GOTO 22470
  613. 22490 PRINT "Long  Block in #"   ;SEC:PRINT #1,NAK$;:GOTO 22470
  614. 22500 PRINT "Checksum Error in #";SEC:PRINT #1,NAK$;:GOTO 22470
  615. 22510 PRINT "Block #  Error in #";SEC:PRINT #1,NAK$;:GOTO 22470
  616. 22520 PRINT "Complement Error in #";SEC:PRINT #1,NAK$;:GOTO 22470
  617. 22530 PRINT #1,ACK$;GOTO 21820
  618. 22540 N=2:GOSUB 3990:A$="Transfer Aborted ..."GOSUB 2120:GOTO 21875
  619. 22550 '
  620. 22560 '---------- PURGE COMM BUFFER OF DATA -----------
  621. 22570 '
  622. 22580 WHILE LOC(1)>0:DUMMY$=INPUT$(LOC(1),#1):WEND:RETURN
  623. 22590 '
  624. 22600 '---------- CHRISTIENSEN SEND -----------
  625. 22610 '
  626. 22700 EOT=0:Y$="":X=0:SEC=0
  627. 22710 WHILE LOC(1)>0              'Wait for NAK
  628. 22720    Y$=INPUT$(1,#1)
  629. 22730    IF Y$=CAN$ THEN 23050
  630. 22740    IF Y$=NAK$ THEN PRINT "Request to Send Acknowledged ...":FOR I=1 TO 2000:NEXT I:GOTO 22850
  631. 22750 WEND:GOTO 22710
  632. 22760 '
  633. 22770 PRINT "Waiting for ACK ...":GOSUB 4310:WHILE LOC(1)>0              ' Wait for ACK
  634. 22780    Y$=INPUT$(1,#1)
  635. 22790    IF Y$=ACK$ THEN CK=0:Y$="":GOTO 22890
  636. 22800    IF Y$=NAK$ THEN 23000
  637. 22810    IF Y$=CAN$ THEN 23050
  638. 22820 WEND:GOTO 22770
  639. 22830 '
  640. 22840 '                             Build and Send Block
  641. 22850 CK=0:Y$=""
  642. 22860 IF EOF(2) THEN 23030
  643. 22870 LINE INPUT #2,Z$
  644. 22879 PRINT "Reading Disk ...":GOSUB 4310
  645. 22880 Z$=Z$+CR$
  646. 22890 IF EOT THEN 23040
  647. 22900 FOR X=1 TO LEN(Z$)
  648. 22910   Y$=Y$+MID$(Z$,X,1)
  649. 22920   CK=CK+ASC(MID$(Z$,X,1))
  650. 22930   IF LEN(Y$)=128 THEN 22950
  651. 22940 NEXT:GOTO 22860
  652. 22950 Z$=MID$(Z$,X+1)
  653. 22959 PRINT "Length Adjusted -- Adding Controls ...":GOSUB 4310
  654. 22970 IF CK>256 THEN CK=CK-256:GOTO 22970
  655. 22975 CK=(CK AND 255)
  656. 22980 SEC=255 AND (SEC+1)
  657. 22990 A$=SOH$+CHR$(SEC)+CHR$(SEC XOR 255)+Y$+CHR$(CK)
  658. 23000 PRINT "Send #";SEC
  659. 23009 PRINT "Sending Block ...":GOSUB 4310
  660. 23010 PRINT #1,A$;
  661. 23020 GOTO 22770
  662. 23030 Z$=Z$+SPACE$(128-LEN(Z$)):EOT=-1:GOTO 22900
  663. 23040 PRINT #1,EOT$;:A$=EOT$:GOTO 21310
  664. 23050 GOTO 21314
  665. 50000 REM *********************************************************
  666. 50010 REM ****  SET UP LINK TO SMARTMODEM 1200                 ****
  667. 50020 REM *********************************************************
  668. 50030 OPEN "COM1:1200,N,8,1,CS,DS,CD100,LF" AS #1:PRINT #1,"ATZ":FOR I=1 TO 1000:NEXT I
  669. 50040 PRINT #1,"AT T S2=37 S9=08 S11=50":FOR I=1 TO 1000:NEXT I:PRINT #1,"":CLOSE #1
  670. 50050 '  PRINT CHR$(27)+"z":PRINT CHR$(27)+"x"+"1":PRINT CHR$(27)+"x"+"5"
  671. 50060 REM **                                      **
  672. 50070 REM **         WAIT FOR RING                **
  673. 50080 REM **                                      **
  674. 50090 '
  675. 50100 ' SET UP HOLDING SCREEN
  676. 50110 '
  677. 50120 LOCATE 22,29:COLOR 0,3:PRINT "WAITING FOR CALL ...."
  678. 50130 LOCATE 25,23:COLOR 6,0:PRINT"Last LOGOFF at ";TIMEL$;" on "; DATEL$
  679. 50140 LOCATE 3,25:COLOR 0,3:PRINT "DCASR, BOSTON BULLETIN BOARD"
  680. 50150 LOCATE 5,33:COLOR 0,3:PRINT VERSION$
  681. 50160 GOSUB 51080                                  ' set-up block numbers
  682. 50170 COLOR 7,0
  683. 50180 CLR=7:CCLR= CLR XOR 4:FILL=CLR XOR 3       ' Set colors for borders/fill
  684. 50190 M=120:Y=100                                ' set initial positions
  685. 50200 N1=10:N2=10:N3=10:N4=10:N5=10:N6=10        ' so ALL numbers will print
  686. 50210 PSET(M+100,Y),0:DRAW"S28C"+STR$(CCLR)+COLON$ ' print first colon
  687. 50220 PSET(M+240,Y),0:DRAW"S28C"+STR$(CCLR)+COLON$ ' print second colon
  688. 50230 GOSUB 50250
  689. 50240 RETURN
  690. 50250 '
  691. 50260 '*** REFRESH DATE AND TIME ***
  692. 50270 '
  693. 50280 C$=DATE$:LOCATE 20,34:COLOR 0,3:PRINT C$   ' get the date
  694. 50290 GOSUB 50460                                'perform time subroutine
  695. 50300 '
  696. 50310 ' *** ESCAPE TO LOCAL MONITOR OR SYSTEM ***
  697. 50320 '
  698. 50330 B$=INKEY$
  699. 50340 IF B$="~" THEN COLOR 7,0:CLS:SYSTEM
  700. 50350 IF B$="S" OR B$="s" THEN LOCAL=1:GOTO 50450
  701. 50360 '
  702. 50370 ' *** ESCAPE ON SIGNAL FROM SERIAL PORT ***
  703. 50380 '
  704. 50390 CD=INP(237)
  705. 50400 IF CD<=100 THEN GOTO 50250
  706. 50410 SM=INP(233)
  707. 50420 IF SM>63 THEN OPEN"COM1:1200,N,8,1,CS,DS,CD100,LF"AS #1 :PRINT "COM1 OPENED AT 1200 BAUD":LOCATE 22,29:COLOR 7,0:PRINT "                     ":GOTO 50450
  708. 50430 OPEN "COM1:300,N,8,1,CS,DS,CD100,LF" AS #1:PRINT "COM1 OPENED AT 300 BAUD":LOCATE 22,29:COLOR 7,0:PRINT "                     ":GOTO 50450
  709. 50440 PRINT "SPEED NOT 300/1200 BAUD -- IGNORED !!":GOTO 50280
  710. 50450 N=2:GOSUB 4020:RETURN
  711. 50460 '
  712. 50470 '   *** SUBROUTINE TO REFRESH TIME AND DATE ***
  713. 50480 '      Clock Routine written by David A. Hurd
  714. 50490 A$=TIME$                                     'BPBC - get the time
  715. 50500 N=ASC(MID$(A$,1,1))-48                     ' get first TIME number
  716. 50510 IF N=N1 GOTO 50550                           ' SAME as last pass?
  717. 50520 X=M:PSET(X,Y),0                            ' set the position
  718. 50530 Q=N1:GOSUB 50940:DRAW "s28c0"+NUM$(N1):N1=N  ' erase old one
  719. 50540 DRAW "s28c"+STR$(CLR)+NUM$(N):GOSUB 50840    ' draw the new one
  720. 50550 N=ASC(MID$(A$,2,1))-48                     ' get second TIME number
  721. 50560 IF N=N2 GOTO 50600                           ' SAME as last pass?
  722. 50570 X=M+50:PSET(X,Y),0                         ' set the position
  723. 50580 Q=N2:GOSUB 50940:DRAW "s28c0"+NUM$(N2):N2=N  ' erase old one
  724. 50590 DRAW "s28c"+STR$(CLR)+NUM$(N):GOSUB 50840    ' draw the new one
  725. 50600 N=ASC(MID$(A$,4,1))-48                     ' get third TIME number
  726. 50610 IF N=N3 GOTO 50650                           ' SAME as last pass?
  727. 50620 X=M+140:PSET(X,Y),0                        ' set the position
  728. 50630 Q=N3:GOSUB 50940:DRAW "s28c0"+NUM$(N3):N3=N  ' erase old one
  729. 50640 DRAW "s28c"+STR$(CLR)+NUM$(N):GOSUB 50840    ' draw the new one
  730. 50650 N=ASC(MID$(A$,5,1))-48                     ' get the fourth TIME number
  731. 50660 IF N=N4 GOTO 50700                           ' SAME as last pass?
  732. 50670 X=M+190:PSET(X,Y),0                        ' set the position
  733. 50680 Q=N4:GOSUB 50940:DRAW "s28c0"+NUM$(N4):N4=N  ' erase old one
  734. 50690 DRAW "s28c"+STR$(CLR)+NUM$(N):GOSUB 50840    ' draw the new one
  735. 50700 N=ASC(MID$(A$,7,1))-48                     ' get the fifth TIME number
  736. 50710 IF N=N5 GOTO 50750                           ' SAME as last pass?
  737. 50720 X=M+280:PSET (X,Y),0                         ' position for fifth TIME number
  738. 50730 Q=N5:GOSUB 50940:DRAW "s28c0"+NUM$(N5):N5=N ' erase the old one
  739. 50740 DRAW "s28c"+STR$(CLR)+NUM$(N):GOSUB 50840   ' draw the new one
  740. 50750 N=ASC(MID$(A$,8,1))-48                     ' get the sixth TIME number
  741. 50760 IF N=N6 GOTO 50800                           ' SAME as last pass?
  742. 50770 X=M+330:PSET (X,Y),0                         ' position for sixth number
  743. 50780 Q=N6:GOSUB 50940:DRAW "s28c0"+NUM$(N6):N6=N ' erase the old one
  744. 50790 DRAW "s28c"+STR$(CLR)+NUM$(N):GOSUB 50840         ' draw the new one
  745. 50800 RETURN                                       ' make another pass---------
  746. 50810 '
  747. 50820 REM   ROUTINE TO PAINT THE BLOCK NUMBERS A SOLID COLOR
  748. 50830 '
  749. 50840 Y1=Y:X1=X
  750. 50850 IF N=2 OR N=4 OR N=6 THEN Y1=Y+1           ' Find a point INSIDE the number
  751. 50860 IF N=3 OR N=5 OR N=9 THEN Y1=Y-1
  752. 50870 IF N=0 THEN Y1=Y-30
  753. 50880 IF N=7 THEN X1=X+2
  754. 50890 PAINT(X1,Y1),FILL,CLR                      ' Paint it a solid color
  755. 50900 RETURN
  756. 50910 '
  757. 50920 REM     ROUTINE TO ERASE THE SOLID COLOR FROM BLOCK NUMBERS
  758. 50930 '
  759. 50940 Y1=Y:X1=X
  760. 50950 IF Q=2 OR Q=4 OR Q=6 THEN Y1=Y+1           ' Find a point INSIDE the number
  761. 50960 IF Q=3 OR Q=5 OR Q=9 THEN Y1=Y-1
  762. 50970 IF Q=0 THEN Y1=Y-30
  763. 50980 IF Q=7 THEN X1=X+2
  764. 50990 PAINT(X1,Y1),0,CLR                         ' Paint it black
  765. 51000 PSET(X,Y),0                                ' reset position for draw
  766. 51010 RETURN
  767. 51020 '
  768. 51030 REM     ROUTINE TO ESTABLISH THE BLOCK NUMBERS
  769. 51040 REM  These are SMALL numers in size and get printed in the program above as
  770. 51050 REM  28 times their drawn size.  The ZBASIC DRAW command sequences were used
  771. 51060 REM  to trace out the numbers and the colon.
  772. 51070 '
  773. 51080 DIM NUM$(10)                               ' to save the strings for draw
  774. 51090 NUM$(1)="BM-1,-5R1F1D8R2D1L6U1R2U7L2E2BM+1,+5
  775. 51100 NUM$(2)="R1E1U2H1L2G1D1L1U2E1R4F1D4G1L3G1D2R5D1L6U4E1R2"
  776. 51110 NUM$(3)="BU1R1E1U1H1L2G1D1L1U2E1R4F1D2G1D1F1D3G1L4H1U2R1D1F1R2E1U2H1L3U1R2BD1"
  777. 51120 NUM$(4)="L1M+2,-3D3L1BD1L3M+4,-6R1D10L1U4L1BU1"
  778. 51130 NUM$(5)="L3U5R6D1L5D3R4F1D4G1L4H1U2R1D1F1R2E1U2H1L1"
  779. 51140 NUM$(6)="BD1L2D2F1R2E1U1H1L1BU1R2F1D3G1L4H1U8E1R4F1D1L1H1L2G1D3R2"
  780. 51150 NUM$(7)="M+2,-4L3G1L1U1E1R5D1M-4,+9L1M+2,-5"
  781. 51160 X$="L1H1U1E1R2F1D1G1L1"
  782. 51170 NUM$(8)="BU1"+X$+"BD5"+X$+"BD1L2H1U3E1H1U3E1R4F1D3G1F1D3G1L2BU5"
  783. 51180 NUM$(9)="L2H1U3E1R4F1D8G1L4H1U2R1D1F1R2E1U3L2BU1L1H1U1E1R2F1D2L2BD1"
  784. 51190 NUM$(0)="BU4L1G1D6F1R2E1U6H1L1BU1L2G1D8F1R4E1U8H1L2BD5"
  785. 51200 COLON$="BU1L1U2R2D2L1BD2L1D2R2U2L1BU1"
  786. 51210 RETURN
  787. 65399 '** DONE - PRESS ENTER TO RETURN TO MENU **
  788. 800 RETURN