PCjs Machines
Home of the original IBM PC emulator for browsers.
PC-SIG Diskette Library (Disk #150)
[PCjs Machine "ibm5150"]
Waiting for machine "ibm5150" to load....
Information about “IBM BBS”
A simple, straight-forward BBS written especially for the IBM PC. The
code is compiled BASIC. Both the source and executable versions are
provided so you can run it as is or modify it.
It is a reasonably powerful system with a lot of thought and experience
behind its design. However, it has been around for awhile and many of
the newer BBS offerings surpass its capabilities by quite a bit. This
system, for example, handles only one line at a time.
System Requirements: Two drives, one serial port, modem, BASIC
How to Start: Documentation is spread out in files marked .DOC (for
DOCument) and .HLP and plenty of simple text files. To run IBBS.EXE,
type IBBS and hit <ENTER>.
File Descriptions:
BBSCOMP BAT BAT startup file
BBSLOGO BAS Logo displayed upon BBS startup
CALLERS List of each logon, excepting SYSOP
COUNTERS Workfile containing next message #, next caller, etc.
FLASH File displayed after WELCOME file
IBBS BAS Compiler BASIC source code
HARDWARE Information file on hardware prices
HELP BBS Help file
IBBS DOC Limited documentation
IBBS EXE Compiler object code for IBBS
NEWCOM Message file for first-time callers
MESSAGES Main messages file
RBBSUTIL BAS Source code for file cleanup utility
SOFTWARE Information file on software prices
RBBSUTIL EXE Compiled object code for file cleanup utility
USERS List of logon IDs
SUMMARY Messages summary file
XFER HLP Help file for file transfer function
WELCOME First file displayed after logon
XFERLIST List of files that can be transferred
BBSLOGO.BAS
██████ ████▌ ██ ██ █████ ██████
██ █ █ ██ ██ █ █ █
██ ████ █ █ █ █ █████ █
██ █ █ █ ██ █ █ █
██████ ████▌ █ █ █ ██████
████▌ █ █ ██ ██ █████ ██████ ██ ██ █
█ █ █ █ ██ ██ █ ██ ██ ██ █
████ █ █ ██ ██ ████ ██ ██ █ █▌ █
█ █ █ █ ██ ██ █ ██ ██ █ █ █
████▌ ████ █████ █████ █████ ██ ██ █ ██
████▌ █████ ███ █████ ████
█ █ █ █ ▄█ █▄ █ █ █ █
████ █ █ █ █ █████ █ █
█ █ █ █ █████ █ ▐▄ █ █
████▌ █████ █ █ █ ▐ ████
System Software Services (1983)
CRC.TXT
PC-SIG Disk No. #150, version v1
The following is a list of the file checksums which should be produced by
the CRCK4 program on disk #9 (and others). If the CRC numbers do not match
you may have a bad file. To use type: CRCK4 <filespec>
CRCK4 output for this disk:
CRCK ver 4.2B (MS DOS VERSION )
CTL-S pauses, CTL-C aborts
--> FILE: BBSCOMP .BAT CRC = 00 00
--> FILE: BBSLOGO .BAS CRC = A9 7F
--> FILE: CALLERS . CRC = F0 09
--> FILE: COUNTERS. CRC = 84 56
--> FILE: FLASH . CRC = 00 00
--> FILE: HARDWARE. CRC = 00 00
--> FILE: HELP .BBS CRC = 87 F8
--> FILE: IBBS .BAS CRC = 09 45
--> FILE: IBBS .DOC CRC = F7 1E
--> FILE: IBBS .EXE CRC = C5 BE
--> FILE: MESSAGES. CRC = A9 05
--> FILE: NEWCOM . CRC = 85 22
--> FILE: RBBSUTIL.BAS CRC = 12 59
--> FILE: RBBSUTIL.EXE CRC = 9D C4
--> FILE: SOFTWARE. CRC = 00 00
--> FILE: SUMMARY . CRC = 6C C7
--> FILE: USERS . CRC = 64 73
--> FILE: WELCOME . CRC = 54 CA
--> FILE: XFER .HLP CRC = 1C A4
--> FILE: XFERLIST. CRC = A9 1C
--> FILE: XXX . CRC = E1 D5
---------------------> SUM OF CRCS = 17 D4
DONE
These and other Public Domain and user-supported programs from:
PC Software Interest Group
1125 Stewart Ct Suite G
Sunnyvale, CA 94086
(408) 730-9291
IBBS.BAS
400 CLEAR ,,5000 ' IMPORTANT NOTE- IF SMARTMODEM IS USED, SWITCH 1 :
500 COLOR 7,0,0 ' AND SWITCH 6 MUST BE UP. CARRIER DETECT AND DTR. :
550 DEFINT A-Z
650 KEY OFF:CLS:GOSUB 20150
700 KEY(1) ON:KEY(2) ON:KEY(9) ON:KEY(8) ON:KEY(5) ON:KEY(4) ON
750 ON KEY(1) GOSUB 20950:ON KEY(2) GOSUB 20850:ON KEY(9) GOSUB 47850:ON KEY(8) GOSUB 48900:ON KEY(5) GOSUB 49150:ON KEY(4) GOSUB 55500
1150 ON ERROR GOTO 38650
1210 IVERS$="1.57":IDATE$="03/06/83"
1220 BOSS$="XXXX":P1$="YYYY":P2$="ZZZZ":ME$="GENE"
1250 FALSE=0:TRUE=NOT FALSE
1300 SOH$=CHR$(1):EOT$=CHR$(4):ACK$=CHR$(6):NAK$=CHR$(21):CAN$=CHR$(24)
1350 SEMI=TRUE:TCHECK=FALSE:SAVCOUNT$="0":ERRCOUNT=0:BULLCOUNT=0:PRTSW=TRUE:FDUP=TRUE
1400 OPEN "COM1:300,N,8,1,CS,DS" AS 1
1450 PRINT #1,"ATE0"+CHR$(13);
1500 IF PRTSW THEN LPRINT:LPRINT "***** SYSTEM ONLINE AT ";TIME$;" ";DATE$;" *****":LPRINT
1550 SOUND 32767,60:SOUND 32767,1
1600 GOSUB 17000
1650 LOCBELL=TRUE
1700 DIM A$(40),M(300,2)
1750 GOTO 19050
1800 GOSUB 20150:FDUP=TRUE:SEMI=TRUE:MSCAN=FALSE:BK=FALSE:INC=1
1850 IF LOCBELL THEN SOUND 550,12:SOUND 750,7:SOUND 550,8
1870 CR=FALSE:SPEED=3
1960 GOSUB 55700:GOSUB 17000:SOUND 32767,45:SOUND 32767,1
1968 GOSUB 18200
2100 IF CR THEN GOTO 2350 ELSE CR=FALSE:IF SPEED=3 THEN SPEED=1:GOTO 1960 ELSE SPEED=3:GOTO 1960
2350 CARRIER=TRUE:BK=FALSE
2500 INC=1
2550 XX=0:YY=0
2555 gosub 17000
2600 '
2700 '
2750 ONTIME$=TIME$
2800 ' Signon Functions...
2850 GOSUB 55100
2900 M$="IBMPC-RBBS Version "+IVERS$+" "+IDATE$:GOSUB 17200
2950 M$=TIME$+" Local Time ":GOSUB 17650:M$=DATE$:GOSUB 17200
2960 M$="by System Software Services (1982)":GOSUB 17200:GOSUB 17199
3000 M$="[Use CONTROL-K To Bypass The BULLETIN Stuff]":GOSUB 17200:GOSUB 17199
3050 MSGS=1:KALLS=MSGS+1:MNUM=KALLS+1
3150 GOSUB 8130
3350 BEL=TRUE:XPR=FALSE
3400 GOSUB 17199
3450 SAV$=""
3550 GOSUB 8130
3600 GOSUB 8900:GOSUB 9300 ' Print WELCOME File
4000 PRINT #1,CHR$(7);
4050 GOSUB 8130
4100 FIL$="FLASH":GOSUB 13500
4150 A$=" ":GOSUB 9300
4200 BK=0:A$="(Prompting bell means system is ready for input).":GOSUB 9300:GOSUB 9300:XX=0
4250 GOSUB 17000:BK=FALSE:CLOSE#3:GOSUB 17199:A$="What is your FIRST name ?":GOSUB 9300:C=1:GOSUB 9850:C=0:N$=B$:IF N$="" THEN 4250
4300 IF N$<"A" OR LEN(N$)=1 THEN 4250
4350 A1$="What is your LAST name ?":GOSUB 9300:C=1:GOSUB 9850:C=0:O$=B$:IF O$="" THEN 4250
4400 IF O$<"A" OR LEN(O$)=1 THEN 4250
4450 '
4600 IF N$<>BOSS$ THEN 4750
4650 IF N$=BOSS$ AND O$<>P1$ THEN XX=XX+1:IF XX=3 THEN 13850 ELSE 4250
4700 IF N$=BOSS$ AND O$=P1$ THEN O$="":XDUP=FDUP:FDUP=FALSE:A1$="2nd codeword?":GOSUB 9300:C=1:GOSUB 9850:C=0:FDUP=XDUP:X$=B$:IF X$=P2$ THEN 6300 ELSE 4250
4750 IF N$="SYSOP" OR N$+O$="SYSOP" THEN GOSUB 17199:M$="You know you're not the SYSOP!!!":GOSUB 17200:M$=" ":GOSUB 17200:SOUND 32767,50:SOUND 32767,1:GOTO 13850
4800 '
4850 M$="Checking user file...":GOSUB 17200:V=0:CLOSE#3:OPEN "R",3,"USERS",70:FIELD#3,58 AS RZ$,10 AS NC$:GET#3,1:NU=VAL(RZ$)
4900 FIELD #3,70 AS RR$
4950 FOR I=2 TO NU+1:GET#3,I:IF INSTR(RZ$,N$)>0 AND INSTR(RZ$,O$)>0 THEN MF$=LEFT$(RZ$,1):GOSUB 39940:PUT#3,I:CLOSE#3:GOSUB 9300:XX=1:GOTO 5600
5000 NEXT I ' If recognized, caller is passed to CALLER-logging routine
5050 ' But a caller not in the USER file gets quizzed further...
5100 V=1:A1$="Where (City,State) are you calling from ?":GOSUB 9300:C=1:GOSUB 9800:C=0:ST$=B$:IF ST$="" THEN 4350
5150 N=1:GOSUB 9300:M$="Hello "+N$+" "+O$+" from "+ST$:GOSUB 17200
5200 GOSUB 17199
5250 A1$="Is this Correct ?":GOSUB 9300:C=1:GOSUB 9850:C=0
5300 IF LEFT$(B$,1)="N" THEN CLOSE#3:GOTO 4250
5350 IF LEFT$(B$,1)<>"Y" THEN 5250
5400 GOSUB 17199
5450 N=1:M$="This checking is only done the first time you call.":GOSUB 17200:LSET NC$=MKI$(0)
5500 LSET RZ$=" "+N$+" "+O$+" "+ST$+" "+TIME$+" "+DATE$:S$=RZ$:GOSUB 39940:NU=NU+1:PUT#3,NU+1:S$=STR$(NU):GOSUB 39950:PUT#3,1:CLOSE#3
5550 FIL$="NEWCOM":GOSUB 13500:MF$=" ":SOUND 32767,120:SOUND 32760,1 '...and made to read the NEWCOMer file
5600 ' Now everybody gets logged to CALLERS
5650 GOSUB 17199
5700 M$="Logging "+N$+" "+O$+" to disk...":GOSUB 17200:OPEN "R",3,"CALLERS",60:FIELD#3,60 AS RR$:GET#3,1
5750 RE=VAL(RR$)+1:S$=STR$(RE):RL=60:GOSUB 39950:PUT#3,1:RE=RE+1
5800 S$=N$+" "+O$+" "+ST$+" "+TIME$+" "+DATE$:GOSUB 39950:PUT#3,RE:CLOSE#3
5850 ' Then twits (with *'s before their names in USERS) get logged off...
5900 IF MF$="*" THEN A$="Goodbye. Thanks for calling, "+N$+" "+O$:GOSUB 9300:GOSUB 9300:SOUND 32767,35:SOUND 32767,1:GOTO 13850
6050 '
6100 ' User privilege level (from USERS)
6150 IF MF$="+" THEN F$="SP"
6250 IF MF$=" " THEN F$="RG"
6300 IF N$=BOSS$ THEN MF$="+":F$="SP":GOTO 7250
6450 CLOSE#3:BK=0:GOSUB 9300:OPEN "R",3,"COUNTERS",5:FIELD#3,5 AS RR$
6550 GET#3,KALLS
6600 CN=VAL(RR$)+INC:A$=STR$(CN):LSET RR$=A$:PUT#3,KALLS:A$=""
6650 CLOSE#3
6700 CC=POS(0):LL=CSRLIN:SAVCOUNT$=STR$(CN)
6750 LOCATE 25,60:PRINT STRING$(19," ");
6800 LOCATE 25,60:PRINT STR$(CN);" ";LEFT$(N$,7);" ";LEFT$(O$,8);:LOCATE LL,CC
6850 IF PRTSW THEN LPRINT speed;DATE$;" ";ONTIME$;" ";N$;" "O$;" Caller # ";STR$(CN);" LOGON"
7000 GOSUB 17199:GOSUB 17199
7050 GOSUB 9200 ' Print DATA file for everyone, including SP & RG callers
7100 CLOSE#3 ' (just in case any files are still open)
7250 GOSUB 17000:BK=FALSE:GOSUB 55100
7260 A1$="Checking Message File...........":GOSUB 9300:GOSUB 9300
7300 KAT=TRUE:GOSUB 22650
7350 A1$="IBMPC R B B S MENU":GOSUB 9300
7450 GOSUB 9300
7500 IF XPR THEN A1$="COMMAND? (M,F,G,X,D) ":N=1:GOSUB 9300:C=1:N=0:GOSUB 9850:C=0:GOTO 7950 ELSE A1$="Choose ONE of the following functions:":GOSUB 9300
7550 GOSUB 9300
7600 A1$="MESSAGE SYSTEM ------> M":GOSUB 9300
7650 A1$="FILE TRANSFER ------> F":GOSUB 9300
7700 A1$="LOGOFF ------> G":GOSUB 9300
7710 A1$="EXPERT MODE ------> X (Short Menus)":GOSUB 9300
7750 A1$="TOGGLE ECHO ------> D ":IF FDUP THEN A1$=A1$+" (Currently ECHO From BBS)" ELSE A1$=A1$+" (Currently NO ECHO From BBS)"
7800 GOSUB 9300:GOSUB 9300
7850 A1$="Enter Your Choice ----> ":GOSUB 17000:N=1:GOSUB 9300:N=0:C=1:GOSUB 9850:C=0
7900 GOSUB 9300
7950 IF LEFT$(B$,1)<>"M" AND LEFT$(B$,1)<>"F" AND LEFT$(B$,1)<>"X" AND LEFT$(B$,1)<>"D" AND LEFT$(B$,1)<>"G" THEN GOSUB 9300:if xpr then goto 7500 else GOTO 7850
8000 IF B$="G" THEN GOTO 25550
8050 IF B$="M" THEN GOTO 21400
8060 IF B$="X" THEN XPR=NOT XPR:BEL=NOT BEL:GOTO 7350
8100 IF B$="D" THEN GOSUB 25300:SOUND 32760,30:SOUND 32760,1:GOTO 7350
8125 GOTO 8600
8130 GOSUB 18200:IF BK THEN BK=FALSE:RETURN 4250 ELSE RETURN
8150 GOSUB 55100
8250 A1$="--> FILE TRANSFER LIST (Newest First) <--":GOSUB 9300:GOSUB 9300:GOSUB 38500
8300 GOSUB 9300
8350 GOSUB 38290:GOSUB 38255:BK=FALSE
8400 GOSUB 9300
8450 M$="** END OF LIST - PRESS ENTER TO CONTINUE **":GOSUB 17650:GOSUB 9850
8500 IF N$=BOSS$ THEN M$="Hi There, BOSS! Do You Want To XFER a NEW BBS?":GOSUB 17650:C=1:GOSUB 9850:C=0:GOSUB 9300 ELSE GOSUB 9300:GOTO 8600
8550 IF LEFT$(B$,1)="Y" THEN FIL$="NEWIBBS.EXE":GOSUB 50100:M$="** XFER COMPLETE **":GOSUB 17200
8600 GOSUB 55100:A1$=" F I L E T R A N S F E R F U N C T I O N S":GOSUB 9300:GOSUB 9300
8610 GOSUB 9300 :GOSUB 25110
8615 IF XPR THEN A1$="XFER COMMAND? (U,D,L,H,Q) ":N=1:GOSUB 9300:N=0:C=1:GOSUB 9850:C=0:GOTO 8640 ELSE A1$=" Please Choose One Of The Following Options:":GOSUB 9300:GOSUB 9300
8620 A1$="Transfer A file TO This System (UPLOAD) ----> U":GOSUB 9300
8622 A1$="Transfer A File FROM This System (DOWNLOAD) ----> D":GOSUB 9300
8623 A1$="Directory Of Files To Transfer (LIST) ----> L":GOSUB 9300
8624 A1$="Information on These Features (HELP) ----> H":GOSUB 9300
8625 A1$="Quit This Section - Return to MENU (QUIT) ----> Q":GOSUB 9300
8635 GOSUB 9300 : A1$="ENTER YOUR FILE TRANSFER CHOICE ----> ":GOSUB 17000:N=1:GOSUB 9300:N=0:C=1:GOSUB 9850:C=0
8640 UPDOWN$=B$:IF LEFT$(B$,1)<>"U" AND LEFT$(B$,1)<>"D" AND LEFT$(B$,1)<>"Q" AND LEFT$(B$,1)<>"L" AND LEFT$(B$,1)<>"H" THEN GOSUB 9300:GOTO 8610
8650 IF LEFT$(B$,1)="Q" THEN GOSUB 55100:GOTO 7350
8652 IF LEFT$(B$,1)="H" THEN GOSUB 55100:PAGE=TRUE:SCNT=0:FIL$="XFER.HLP":GOSUB 13500:PAGE=FALSE:GOTO 8450
8654 IF LEFT$(B$,1)="L" THEN GOTO 8150
8660 GOSUB 18110
8661 IF F$="SP" THEN GOTO 8665
8662 IF LEFT$(B$,1)="D" AND (TC>719 AND TC<1259) THEN GOSUB 17199:GOSUB 17199:M$="Sorry, "+N$+", DOWNLOAD is only available from 9:00PM to NOON CST":GOSUB 17200:SOUND 32767,200:SOUND 32767,1:GOTO 8600
8665 GOSUB 9300: A1$="ENTER *FULL* NAME OF FILE TO BE TRANSFERRED ----> ":N=1:GOSUB 9300:N=0:C=1:GOSUB 9850:C=0
8670 IF LEN(B$)=0 THEN GOTO 8600 ELSE FIL$=B$:GOSUB 9300
8671 J=INSTR(FIL$,":"):IF J<>0 THEN FIL$=MID$(FIL$,J+1)
8672 if speed=1 then factor=6372 else factor=1593
8673 FOUND=FALSE:CLOSE#3:OPEN FIL$ FOR INPUT AS #3:SIZE#=LOF(3):XSECT=SIZE#/128:XTIME=SIZE#/factor:CLOSE#3:FOUND=TRUE:IF SIZE#>factor THEN M1$=STR$(XTIME) ELSE M1$=" 1 "
8674 M$="Xfer Time "+M1$+" minute(s) "+STR$(XSECT)+" sectors":GOSUB 17200:SOUND 32767,75:SOUND 32767,1
8675 IF FOUND AND LEFT$(UPDOWN$,1)="U" AND N$<>BOSS$ THEN M$="** That File Already Exists **":GOSUB 17200:GOTO 8660
8676 IF NOT FOUND AND LEFT$(UPDOWN$,1)="D" THEN M$="** That File Was Not Found **":GOSUB 17200:GOTO 8660
8678 IF LEFT$(UPDOWN$,1)="U" THEN A1$="Please enter a short (30 character max) Description for this file":GOSUB 9300:A1$="--> ":N=1:GOSUB 9300:N=0:C=1:GOSUB 9850:C=0:DESC$=B$
8680 GOSUB 55100:A1$="--> F I L E T R A N S F E R M O D E <--":GOSUB 9300:GOSUB 9300
8690 IF XPR THEN A1$="XFER MODE? (A,X,Q) ":N=1:GOSUB 9300:N=0:C=1:GOSUB 9850:C=0:GOTO 8730 ELSE A1$="Choose the transmission method for the file transfer:":GOSUB 9300:GOSUB 9300
8700 A1$="STRAIGHT ASCII Transfer ---> A":GOSUB 9300
8710 A1$="XMODEM Protocol Transfer ---> X":GOSUB 9300
8715 A1$="QUIT (Exit File Transfer) ---> Q":GOSUB 9300:GOSUB 9300
8720 A1$="Please Specify Method ---> ":N=1:GOSUB 9300:N=0:C=1:GOSUB 9850:C=0
8730 XTYPE$=B$:IF LEFT$(B$,1)<>"Q" AND LEFT$(B$,1)<>"X" AND LEFT$(B$,1)<>"A" THEN GOSUB 9300:GOTO 8720
8740 IF LEFT$(B$,1)="Q" THEN GOSUB 9300:GOTO 8600
8744 IF PRTSW THEN LPRINT "@@@@@ FILE ";FIL$;" method ";LEFT$(B$,1);" ";DATE$;" ";TIME$
8753 EXE=INSTR(FIL$,".EXE"):KOM=INSTR(FIL$,".COM")
8760 IF LEFT$(UPDOWN$,1)="D" AND LEFT$(B$,1)="X" THEN GOSUB 55100:GOSUB 51900:GOTO 8770
8763 IF (EXE<>0 OR KOM<>0) AND LEFT$(UPDOWN$,1)="D" AND LEFT$(B$,1)="A" THEN GOSUB 17199:M$="That won't work very well, "+N$+"- you must use X for EXE or COM files.":GOSUB 17200:GOTO 8690
8764 IF LEFT$(UPDOWN$,1)="D" AND LEFT$(B$,1)="A" THEN GOSUB 55100:M$="** PRESS YOUR ENTER KEY TO BEGIN **":GOSUB 17650:GOSUB 9850:GOSUB 13500:BK=FALSE:M$="65399 '** DONE - PRESS ENTER TO RETURN TO MENU **":GOSUB 17200:GOSUB 9850:GOTO 8600
8765 IF LEFT$(UPDOWN$,1)="U" AND LEFT$(B$,1)="X" THEN GOSUB 55100:GOSUB 50100:GOTO 8770
8768 IF LEFT$(UPDOWN$,1)="U" AND LEFT$(B$,1)="A" THEN OPEN FIL$ FOR OUTPUT AS #3:GOSUB 55100:M$="Ready To Receive Your ASCII File - Press Your ESCAPE Key When Done":GOSUB 17200:GOSUB 18705:GOSUB 51651:GOSUB 17199:M$="FILE SAVED .. Thanks":GOSUB 17200
8770 SOUND 32767,75:SOUND 32760,1:GOTO 8600
8900 FIL$="WELCOME":GOSUB 13500:RETURN
9200 FIL$="DATA":GOSUB 13500:RETURN
9300 '
9350 ' Routine to print string from A$ on console
9400 '
9450 GOSUB 18110
9455 IF SAV$<>"" AND A1$<>"" THEN A1$="":RETURN
9500 IF A1$<>"" THEN A$=A1$:A1$=""
9550 IF RIGHT$(A$,1)="?" OR N=1 THEN M$=A$:GOSUB 17650:PP$=A$:GOTO 9700
9600 M$=A$:GOSUB 17200
9700 A$="":N=0
9750 RETURN
9800 '
9850 ' Routine to accept string into B$ from console
9900 GOSUB 18110
9950 IF BEL AND SAV$="" THEN PRINT #1,CHR$(7);:IF LOCBELL THEN PRINT CHR$(7);
10000 B$="":BK=0:G=0:Y$="":Z$="":ADD=FALSE:DING=FALSE:BKCNT=0:GOODCNT=0:IF SAV$<>"" THEN GOTO 11800
10050 WHILE (NOT CR) AND CARRIER
10100 WHILE NOT EOF(1) AND NOT CR
10150 Y$=INPUT$(LOC(1),#1)
10200 FOR I=1 TO LEN(Y$)
10250 R=ASC(MID$(Y$,I,1)):Y=R AND 127:MID$(Y$,I,1)=CHR$(Y) ' strip parity
10300 IF Y=10 THEN MID$(Y$,I,1)=" " 'remove LF
10350 IF Y<8 OR (Y>8 AND Y<13) OR (Y>14 AND Y<32) THEN GOTO 10550
10400 IF Y=13 THEN CR=TRUE:PRINT #1,CHR$(13)+CHR$(10);:PRINT " ":GOTO 10550
10450 IF Y=127 THEN MID$(Y$,I,1)=CHR$(8):Y=8
10500 IF Y=8 THEN GOSUB 18750:GOTO 10550 ELSE IN=TRUE:IF FDUP THEN M$=MID$(Y$,I,1):GOSUB 17650:IN=FALSE ELSE IN=FALSE:PRINT MID$(Y$,I,1);
10520 G#=FRE(D$) '*** important - do not remove -corrects compiler bug ***
10525 GOODCNT=GOODCNT+1
10550 ADD=TRUE
10600 NEXT I
10650 WEND
10700 IF ADD THEN Z$=Z$+Y$
10702 ADD=FALSE
10705 IF (GOODCNT-BKCNT<>54) THEN DING=FALSE
10710 IF NOT DING AND BEL AND (GOODCNT-BKCNT=54) THEN DING=TRUE:PRINT#1,CHR$(7);
10750 CD=INP(&H3FE):CD=CD AND 128:IF CD<>128 THEN CARRIER=FALSE
10800 GOSUB 53900
10810 G#=FRE(D$) '*** important - do not remove -corrects compiler bug ***
10850 WEND
10900 GOSUB 18702 ' carrier dropped
10950 Y$=""
11020 FOR ZZ=1 TO LEN(Z$)
11050 R=ASC(MID$(Z$,ZZ,1))
11100 IF R<7 OR (R>8 AND R<32) THEN GOTO 11150 ELSE Y$=Y$+MID$(Z$,ZZ,1)
11150 NEXT ZZ
11200 Z$=""
11205 XX=0
11250 FOR ZZ=1 TO LEN(Y$) ' resolve backspaces
11300 IF (ASC(MID$(Y$,ZZ,1))=8 AND LEN(Z$)>0) THEN XX=XX-1:Z$=LEFT$(Z$,XX) ELSE Z$=Z$+MID$(Y$,ZZ,1):XX=XX+1
11500 NEXT ZZ
11550 Y$=Z$:XX=0
11600 '
11700 CR=FALSE:DING=FALSE:BKCNT=0:GOODCNT=0
11750 SAV$=Y$
11800 SP=INSTR(SAV$,";"):IF SP=0 OR NOT SEMI THEN B$=SAV$:SAV$="":GOTO 11900
11850 B$=LEFT$(SAV$,SP-1):SAV$=MID$(SAV$,SP+1)
11900 IF LEN(B$)=0 THEN RETURN
11950 IF C=0 THEN 12050
12000 FOR ZZ=1 TO LEN(B$):MID$(B$,ZZ,1)=CHR$(ASC(MID$(B$,ZZ,1))+32*(ASC(MID$(B$,ZZ,1))>96)):NEXT ZZ
12050 IF LEN(B$)<63 THEN 12350
12100 M$="Input line too long - would be truncated to:":GOSUB 17200
12150 B$=LEFT$(B$,62):M$=B$:IF RECUR THEN GOSUB 17200 ELSE OLD$=B$:GOSUB 17200
12200 M$="Retype line (Y/N)?":GOSUB 17650:RECUR=TRUE:GOSUB 9850:QQ$=LEFT$(Y$,1)
12300 IF QQ$="Y" OR QQ$="y" THEN M$="":GOSUB 17200:SAV$="":GOTO 9850 ELSE B$=OLD$:OLD$=""
12350 D=D+LEN(B$):IF LEFT$(B$,1)=CHR$(13) THEN B$=""
12500 RECUR=FALSE:RETURN
13450 '
13500 '
13550 ' Subroutine to print a file
13600 '
13650 OPEN "I",3,FIL$:BK=0:SCNT=0
13700 IF EOF(3) OR BK THEN 13750 ELSE LINE INPUT #3,A$:GOSUB 9300:SCNT=SCNT+1
13710 IF PAGE AND SCNT>21 THEN M$="** PRESS ENTER TO CONTINUE LIST or ENTER+CONTROL-K TO STOP **":SCNT=0:GOSUB 17650:GOSUB 9850
13720 GOTO 13700
13750 CLOSE #3:RETURN
13800 '
13850 IF PRTSW THEN LPRINT DATE$;" ";TIME$;" ";N$;" "O$;" Caller # ";STR$(CN);" ABNORMAL LOGOFF "
13900 ' Subroutine to log off an unwanted caller (=twit)
13950 T=INP(&H3FC):R=T AND &HFE:OUT &H3FC,R:PRINT #1,X$;:SOUND 32767,250:SOUND 32767,1:OUT &H3FC,T:SOUND 32767,40:SOUND 32767,1:GOSUB 17000:GOTO 19100
14400 '
17000 WHILE NOT EOF(1):K$=INPUT$(LOC(1),#1):WEND:cr=false:RETURN
17199 M$=" "
17200 '***** print string m$ to screen and com
17250 DOLF=TRUE:GOTO 17800
17650 '***** same as above with no CR
17700 DOLF=FALSE:IF IN THEN GOTO 17850
17800 GOSUB 18200
17820 IF BK THEN RETURN
17850 IF DOLF THEN PRINT M$: ELSE PRINT M$;:
17900 IF DOLF THEN PRINT #1,M$;CHR$(13);CHR$(10);: ELSE PRINT #1,M$;:
17950 GOSUB 18110
18000 PP$=M$:DOLF=FALSE
18100 RETURN
18110 HC=VAL(MID$(TIME$,1,2))*60:MC=VAL(MID$(TIME$,4,2)):TC=HC+MC:RETURN
18150 '
18200 WHILE NOT EOF(1)
18250 Y$=INPUT$(LOC(1),#1)
18300 FOR I=1 TO LEN(Y$)
18350 R=ASC(MID$(Y$,I,1)):Y=R AND 127:MID$(Y$,I,1)=CHR$(Y) ' strip parity
18400 IF Y=11 OR Y=3 THEN BK=TRUE
18450 IF Y=19 THEN WHILE EOF(1):WEND
18453 IF Y=13 THEN CR=TRUE
18455 GOSUB 18702
18600 NEXT I
18650 WEND
18700 RETURN
18702 CD=INP(&H3FE):CD=CD AND 128:IF CD<>128 THEN return 13850 ELSE RETURN 'no carrier
18705 ' ASCII file save routine
18706 ESCFLG=FALSE
18707 WHILE NOT ESCFLG
18709 WHILE NOT EOF(1)
18710 GOSUB 18110
18711 Y$=INPUT$(LOC(1),#1)
18712 FOR I=1 TO LEN(Y$)
18715 R=ASC(MID$(Y$,I,1)):Y=R AND 127:MID$(Y$,I,1)=CHR$(Y) ' strip parity
18720 IF Y=27 THEN ESCFLG=TRUE ELSE PRINT #3,MID$(Y$,I,1);:PRINT ".";
18732 NEXT I
18736 WEND
18738 CD=INP(&H3FE):CD=CD AND 128:IF CD<>128 THEN CLOSE#3:RETURN 13850 ' carrier dropped
18739 GOSUB 53900
18740 WEND
18743 ESCFLG=FALSE:RETURN
18750 '***** backspace
18800 '
18805 IF GOODCNT=BKCNT THEN PRINT#1,CHR$(7);:RETURN ELSE BKCNT=BKCNT+1
18850 GOSUB 54600
18900 M$=CHR$(8)+" "+CHR$(8):PRINT #1,M$;:PP$=""
19000 RETURN
19050 PRINT #1,"ATM0S7=45S2=255S0=1"+CHR$(13);
19100 SOUND 32767,60:SOUND 32767,1
19150 GOSUB 17000
19300 CLS:LOCATE 2,1
19310 CLOSE#3:OPEN "I",3,"BBSLOGO.BAS":LOCATE 1,1
19320 IF EOF(3) THEN 19330 ELSE LINE INPUT #3,A$:PRINT A$:GOTO 19320
19330 CLOSE #3
20100 GOSUB 20150:GOTO 20300
20150 LOCATE 25,1,0:PRINT " F1-Shutdown F2-Logoff F4-Message F5-Print ";:IF PRTSW THEN PRINT "ON "; ELSE PRINT "OFF ";
20250 PRINT " F8-Clr Cnts";:LOCATE 25,61:PRINT SAVCOUNT$;" ";LEFT$(N$,6);" ";LEFT$(O$,7);:LOCATE 24,1,0:RETURN
20300 ST$="":TIMEON=0
20350 G#=FRE(D$)
20400 GOSUB 47850
20410 CD=0
20500 WHILE CD<>128
20510 CD=INP(&H3FE):CD=CD AND 128
20550 IF FRE(0)<5000 THEN G#=FRE(D$)
20700 LOCATE 1,71,0:PRINT TIME$;
20800 WEND
20810 GOTO 1800
20850 RETURN 20900
20900 GOTO 13900
20950 CLS:GOSUB 47850:PRINT #1,"ATZ"+CHR$(13):CLOSE:IF PRTSW THEN LPRINT "#### SYSTEM SHUTDOWN ";TIME$;" ";DATE$;" ####"
21000 END
21400 VERS$="MINIRBBS vers "+IVERS$+" IBMPC (Release Date "+IDATE$+")"
21450 INC=1: ERS$=CHR$(8)+" "+CHR$(8)
21500 IF MSCAN THEN GOTO 24000
21540 BEL=TRUE
21550 ' Signon functions...
21600 '
21650 MSGS=1:KALLS=MSGS+1:MNUM=KALLS+1
21700 GOSUB 55100
21750 BK=0:GOSUB 17199:M$="IBMPC Remote RBBS Message Subsystem":GOSUB 17200
21800 M$=VERS$:GOSUB 17200
21820 M$="By System Software Services (1982)":GOSUB 17200
21900 INC=0
21950 '
22150 BK=0:GOSUB 17199:M$="Active # of msg's: ":GOSUB 17650
22200 OPEN "R",3,"COUNTERS",5:FIELD#3,5 AS RR$:GET#3,MSGS:M=VAL(RR$)
22250 M$=STR$(M):GOSUB 17200
22300 M$="You are caller # : ":GOSUB 17650:GET#3,KALLS
22350 CN=VAL(RR$):M$=STR$(CN):GOSUB 17200
22400 M$="Next msg # will be:":GOSUB 17650:GET#3,MNUM:U=VAL(RR$)
22450 M$=STR$(U+1):GOSUB 17200:CLOSE#3:GOSUB 17199
22500 '
22550 ' Look for messages for this caller
22600 '
22650 FT=1:MX=0:MZ=0:IU=0:UF=0: 'FLAG FIRST TIME FOR PRINTING HEADING
22700 OPEN "R",3,"SUMMARY",30:RE=1:FIELD#3,28 AS RR$
22750 BK=0:GET#3,RE:IF EOF(3) THEN 23450
22800 G=VAL(RR$):MZ=MZ+1:M(MZ,1)=G:IF G=0 THEN 23400
22850 IF IU=0 THEN IU=G
22900 IF G>9998 THEN MZ=MZ-1:GOTO 23450
22950 GET#3,RE+3:GOSUB 40200:IF INSTR(S$,N$)>0 AND INSTR(S$,O$)>0 THEN 23150
23000 IF N$=BOSS$ THEN N$="SYSOP"
23050 IF N$<>"SYSOP" THEN 23400
23100 IF INSTR(S$,ME$)=0 THEN 23400
23150 IF KAT THEN GOTO 23350
23200 IF FT THEN M$="The following message(s) was/were left for you.":GOSUB 17200
23250 IF FT THEN M$="Please kill the ones that would not interest other callers.":FT=0:GOSUB 17200:GOSUB 17199
23300 M$=STR$(G):N=1:GOSUB 17200
23350 UF=UF+1
23400 GET#3,RE+5:M(MZ,2)=VAL(RR$):MX=MX+M(MZ,2)+6:RE=RE+6:GOTO 22750
23450 CLOSE#3
23500 IF KAT AND UF>0 THEN A1$="You have "+STR$(UF)+" message(s) waiting, "+N$:GOSUB 9300:GOSUB 9300
23550 IF KAT AND UF=0 THEN A1$="Sorry, "+N$+", You have NO messages waiting ":GOSUB 9300:GOSUB 9300
23600 IF N$="SYSOP" THEN N$=BOSS$
23650 IF KAT THEN KAT=FALSE:RETURN
23660 IF KAT2 THEN KAT2=FALSE:RETURN
23700 GOSUB 17199:GOSUB 17199
23750 '
23800 ' *** Main Command Acceptor/Dispatcher ***
23850 '
24000 MSCAN=TRUE:BK=FALSE
24050 GOSUB 17199 :GOSUB 25110
24055 A1$="Function":IF NOT XPR THEN A1$=A1$+" [B,C,E,F,G,H,K,M,O,P,Q,R,S,T,U,X,# (or '?' if not known)]":
24100 A1$=A1$+"?":GOSUB 9300:C=1:GOSUB 9850:C=0
24150 IF B$="" THEN 24500
24200 B$=LEFT$(B$,1)
24250 ZZ=INSTR("ER?SKCGPXQTBOUFHM#",B$):GOSUB 24300:GOTO 23750
24300 IF ZZ=0 THEN 24400
24350 ON ZZ GOTO 27100,31500,25950,41600,36350,35100,25500,41050,40750,41700,46100,43300,41800,37800,25300,25300,25470,25460
24400 '
24450 IF F$<>"SP" THEN 25150 ELSE 24750
24500 GOTO 23750
24750 '
24800 '
24850 IF B$="Z" THEN GOSUB 44850:GOTO 23750
24950 IF N$=BOSS$ THEN IF B$="9" THEN FIL$="COMMENTS":GOSUB 13600:BK=0:GOTO 23750
25000 IF N$=BOSS$ THEN IF B$="8" THEN GOSUB 43200:GOTO 23750
25050 IF N$=BOSS$ THEN IF B$="7" THEN GOSUB 55150
25100 GOTO 23750
25110 IF F$="SP" THEN RETURN
25112 TCHECK=TRUE:GOSUB 46300:IF TIMEON>90 THEN M$="90 mins-Time's up. Please give others a chance.":GOSUB 17200:SOUND 32767,75:SOUND 32767,1:IF PRTSW THEN LPRINT "^^^":RETURN 25500 ELSE RETURN 25500
25115 IF TIMEON>60 THEN M$="You have been on the system for more than one hour. Please consider others.":GOSUB 17200:RETURN ELSE RETURN
25150 M$="I don't understand '"+B$+"', "+N$+".":GOSUB 17200:GOSUB 17199
25200 SAV$="":RETURN
25250 GOTO 23750
25300 ' change duplex
25350 FDUP=NOT FDUP
25400 IF FDUP THEN M$="FULL DUPLEX SET" ELSE M$="HALF DUPLEX SET"
25450 GOSUB 17200:RETURN
25460 KAT2=TRUE:GOSUB 22150:KAT2=FALSE:GOTO 23750
25470 BK=FALSE:GOSUB 55100:GOTO 7350
25500 '
25550 ' Exit - logoff
25600 '
25700 GOSUB 17199:GOSUB 46100:XPR=FALSE:MSCAN=FALSE:F$=" "
25750 GOSUB 17199:M$="Good Bye "+N$+", please call again...":GOSUB 17200:SOUND 32767,90:SOUND 32767,1
25800 IF PRTSW THEN LPRINT DATE$;" ";TIME$;" ";N$;" "O$;" Caller #";STR$(CN);" NORMAL LOGOFF-Time On Sys ";TIMEON
25850 GOTO 13900
25950 '
26000 ' *** Display Menu of Functions ***
26050 '
26100 GOSUB 55100:FIL$="HELP.BBS":PAGE=TRUE:GOSUB 13600:PAGE=FALSE:RETURN
27050 '
27100 ' Enter a new message
27150 '
27200 F=0:GOSUB 17199:OPEN "R",3,"COUNTERS",5:M$="Msg # will be: ":GOSUB 17650:FIELD#3,5 AS RR$:GET#3,MNUM:V=VAL(RR$)
27250 M$=STR$(V+1):GOSUB 17200:CLOSE#3
27350 GOSUB 17199: M$="Today is "+DATE$:GOSUB 17200
27400 M$="Who to (C/R for ALL)?":GOSUB 17650:C=1:GOSUB 9850:C=0:IF B$="" THEN T$="ALL" ELSE T$=B$
27500 M$="Subject (26 chars. max.):":GOSUB 17650:C=1:GOSUB 9850:C=0:K$=B$
27550 IF LEN(K$)>30 THEN GOTO 27500
27600 M$="Password?":GOSUB 17650:C=1:GOSUB 9850:C=0:PW$=B$:GOSUB 17199
27650 IF PW$=CHR$(13) THEN PW$=""
27700 M$="Type in up to 30 lines. A bell sounds near the end of each.":GOSUB 17200
27800 M$="To edit or end, hit 2 C/Rs. Semi-colons are Allowed in the Msg":GOSUB 17200:GOSUB 17199:F=0
27850 M$=" |"+STRING$(62,45)+"|":GOSUB 17200
27900 IF F=30 THEN M$="Msg full.":GOSUB 17200:GOTO 28150
27950 F=F+1:M$=STR$(F)+" ":GOSUB 17650:SEMI=FALSE:GOSUB 9850:IF B$="" THEN F=F-1:GOTO 28150
28000 IF F=27 THEN M$="(3 lines left. . . .)":GOSUB 17200
28050 IF F=29 THEN M$="(Last line. . . .)":GOSUB 17200
28100 A$(F)=B$+" ":GOTO 27900
28150 OXPR=XPR
28155 SEMI=TRUE:GOSUB 17199:M$="Choose: (L)ist, (E)dit, (D)elete, (A)bort, (C)ontinue, or (S)ave -- ":IF XPR THEN M$="L,E,D,A,C,S,? ---> "
28200 XPR=OXPR:GOSUB 17650:C=1:GOSUB 9850:C=0
28300 B$=LEFT$(B$,1)
28310 IF B$="?" THEN XPR=FALSE:GOTO 28155
28350 IF B$<>"L" THEN 28600
28400 GOSUB 38450
28450 GOSUB 17200:FOR L=1 TO F:M$=STR$(L)+" "+A$(L)
28500 IF BK THEN 28150 ELSE GOSUB 17200:NEXT L
28550 GOSUB 17199:CLOSE#3:GOTO 28150 'this CLOSE is from HB's FIX file
28600 DELT=FALSE:IF B$="A" THEN M$="Abort? (Y/N) -->":GOSUB 17650:C=1:GOSUB 9850:C=0:IF LEFT$(B$,1)="Y" THEN RETURN ELSE GOTO 28150
28650 IF B$="C" AND FM=0 THEN 27900
28700 IF B$="E" THEN 28900 ' Note that EDIT only works after compiling
28720 IF B$="D" THEN DELT=TRUE:GOTO 28900
28750 IF B$="S" AND FM=0 THEN 29800
28800 IF B$="S" AND FM=1 THEN 45850
28850 GOTO 28150
28865 FOR J=L+1 TO F:A$(J-1)=A$(J):NEXT J:F=F-1:GOTO 28150
28900 GOSUB 17199:M$="Line #?":GOSUB 17650:GOSUB 9850:L=VAL(B$)
28950 IF L=0 OR L>F THEN 28150 ELSE IF DELT THEN DELT=FALSE:GOTO 28865 ELSE M$="Was:":GOSUB 17200:M$=A$(L):GOSUB 17200
29000 M$="Enter new line":IF NOT XPR THEN M$=M$+" (C/R for no change)"
29050 GOSUB 17200:M$="or /oldstring/newstring/ to substitute"
29100 M$=M$+":":GOSUB 17200:SEMI=FALSE:GOSUB 9850:SEMI=TRUE
29150 IF LEFT$(B$,1)="/" THEN 29250
29200 IF B$="" THEN 28150 ELSE A$(L)=B$+" ":GOTO 28950
29250 IF RIGHT$(B$,1)="/" THEN B$=LEFT$(B$,LEN(B$)-1)
29300 B$=MID$(B$,2,99)
29350 FOR Q=LEN(B$) TO 1 STEP -1
29400 IF MID$(B$,Q,1)="/" THEN FROM$=LEFT$(B$,Q-1):TO$=MID$(B$,Q+1,99)
29450 NEXT Q:TEMP$=A$(L)
29500 FOR Q=1 TO LEN(TEMP$)-LEN(FROM$)+1
29550 IF MID$(TEMP$,Q,LEN(FROM$))=FROM$ THEN 29650
29600 NEXT Q: M$="String not found!":GOSUB 17200:GOTO 28950
29650 A$(L)=""
29700 IF Q<>1 THEN A$(L)=LEFT$(TEMP$,Q-1)
29750 A$(L)=A$(L)+TO$+MID$(TEMP$,Q+LEN(FROM$),99): GOTO 28950
29800 '
29850 IF PW$<>"" THEN PW$=";"+PW$
29900 M$="Updating summary file, ":GOSUB 17650
29950 OPEN "R",3,"SUMMARY",30:RE=1:FIELD#3,30 AS RR$:RL=30
30000 RE=MZ*6+1:S$=STR$(V+1)+PW$:GOSUB 39950:PUT#3,RE
30050 RE=RE+1:S$=DATE$+" "+TIME$:GOSUB 39950:PUT#3,RE
30100 IF N$=BOSS$ THEN N$="SYSOP"
30150 RE=RE+1:S$=N$+" "+O$:GOSUB 39950:PUT#3,RE
30200 IF N$="SYSOP" THEN N$=BOSS$
30250 RE=RE+1:S$=T$:GOSUB 39950:PUT#3,RE
30300 RE=RE+1:S$=K$:GOSUB 39950:PUT#3,RE
30350 RE=RE+1:S$=STR$(F):GOSUB 39950:PUT#3,RE
30400 RE=RE+1:S$=" 9999":GOSUB 39950:PUT#3,RE
30450 CLOSE#3
30500 M$="next msg #, ":GOSUB 17650:OPEN "R",3,"COUNTERS",5:FIELD#3,5 AS RR$
30550 GET#3,MNUM:LSET RR$=STR$(VAL(RR$)+1):PUT#3,MNUM
30600 M$="active msg's, ":GOSUB 17650
30650 GET#3,MSGS:LSET RR$=STR$(VAL(RR$)+1):PUT#3,MSGS:CLOSE#3
30700 M$="and msg file.":GOSUB 17650:OPEN "R",3,"MESSAGES",65:RL=65
30750 FIELD#3,65 AS RR$
30800 RE=MX+1
30850 S$=STR$(V+1)+PW$:GOSUB 39950:PUT#3,RE
30900 RE=RE+1:S$=DATE$+" "+TIME$:GOSUB 39950:PUT#3,RE
30950 IF N$=BOSS$ THEN N$="SYSOP"
31000 RE=RE+1:S$=N$+" "+O$:GOSUB 39950:PUT#3,RE
31050 IF N$="SYSOP" THEN N$=BOSS$
31100 RE=RE+1:S$=T$:GOSUB 39950:PUT#3,RE
31150 RE=RE+1:S$=K$:GOSUB 39950:PUT#3,RE
31200 RE=RE+1:S$=STR$(F):GOSUB 39950:PUT#3,RE
31250 RE=RE+1
31300 FOR P=1 TO F:S$=A$(P):GOSUB 39950:PUT#3,RE:RE=RE+1:NEXT P
31350 S$=" 9999":GOSUB 39950:PUT#3,RE:CLOSE#3:MX=MX+F+6:MZ=MZ+1:M(MZ,1)=V+1:M(MZ,2)=F
31400 GOSUB 17199:GOSUB 17200:U=U+1:RETURN
31450 RETURN
31500 '
31550 ' Retrieve a message
31600 '
31650 GOSUB 17199:A1$="MSG # ("+STR$(IU)+" -"+STR$(U)+" )":IF NOT XPR THEN M$=M$+" to retrieve (C/R to end)"
31700 A1$=A1$+"?":GOSUB 9300:GOSUB 9850:GOSUB 17199
31750 IF LEN(B$)=0 THEN M=0 ELSE M=VAL(B$)
31800 IF M<1 THEN GOSUB 17199:RETURN
31850 IF M>U THEN M$="There aren't that many msg's, "+N$+".":GOSUB 17200:SAV$="":GOTO 31650
31900 GOSUB 38500:GOSUB 17199
31950 OPEN "R",3,"MESSAGES",65:RE=1:FIELD#3,64 AS RR$:MI=0
32000 MI=MI+1:IF (MI>MZ) OR BK THEN 32750 ELSE G=M(MI,1)
32050 IF G<M THEN RE=RE+M(MI,2)+6:GOTO 32000
32100 IF G>M THEN 32750
32150 GOSUB 42350:IF OK THEN 32200 ELSE RE=RE+M(MI,2):GOTO 32000
32200 P=4:GOSUB 39910
32450 RE=RE+1:GET#3,RE:J=VAL(RR$):GOSUB 17199
32500 M$="Msg # "+STR$(G)+" Date entered: "+D$+" From: "+NO$:GOSUB 17200
32550 M$="To: "+T$+" About: "+K$:GOSUB 17200:GOSUB 17199
32600 RE=RE+1:FOR P=1 TO J:GET#3,RE:GOSUB 40200:M$=S$:GOSUB 17200
32650 IF BK THEN 32900
32700 RE=RE+1:NEXT P ' :GOSUB 38500
32750 IF RIGHT$(B$,1)<>"+" AND RIGHT$(B$,1)<>"-" THEN CLOSE#3:GOTO 31550
32800 IF RIGHT$(B$,1)="+" THEN M=M+1:MI=0:RE=1 ELSE M=M-1:MI=0:RE=1
32810 IF M<1 THEN GOTO 32900
32850 IF M<=U AND NOT BK THEN 32000
32900 BK=FALSE:CLOSE#3:M$="** End of messages **":GOSUB 17200:GOSUB 17199:D$="":NO$="":RETURN
33000 '
33050 ' Summarize messages
33100 ' (common code for S and Q cs)
33150 '
33200 GOSUB 17199
33250 A1$="Msg # ("+STR$(IU)+" -"+STR$(U)+" ) to start (C/R to end)?"
33300 GOSUB 9300:C=1:GOSUB 9850:C=0:GOSUB 17199
33350 IF LEN(B$)=0 THEN M=0 ELSE M=VAL(B$):GOSUB 9700
33400 IP=INSTR(B$,","):IF IP>0 THEN B$=MID$(B$,IP+1) ELSE ST=0:GOTO 33650
33450 IF LEN(B$)<3 THEN RETURN
33500 IF MID$(B$,2,1)<>"=" THEN RETURN
33550 SV$=MID$(B$,3):B$=LEFT$(B$,1):ST=INSTR("FTS",B$)
33600 IF ST=0 THEN RETURN
33650 IF M<1 THEN RETURN
33700 IF M>U THEN M$="There ain't that many msg's, "+N$+".":GOSUB 17200:SAV$="":RETURN
33750 IF NOT QU THEN GOSUB 38450:GOSUB 17199
33800 OPEN "R",3,"SUMMARY",30:RE=1:FIELD #3,28 AS RR$
33850 GET #3,RE
33900 IF EOF(3) OR BK THEN 35050 ELSE G=VAL(RR$)
33950 IF G>9998 THEN 35050
34000 IF G<M THEN RE=RE+6:GOTO 33850
34050 GOSUB 42350:IF OK THEN 34100 ELSE RE=RE+6:GOTO 33850
34100 GET #3,RE+ST+1:IF ST=0 THEN 34150 ELSE GOSUB 40200:IF INSTR(S$,SV$)=0 THEN RE=RE+6:GOTO 33850
34150 IF NOT QU THEN 34450
34200 '
34250 ' Quick summary only
34300 '
34350 GET #3,RE+4:GOSUB 40200:GOSUB 42850:M$=SPACE$(5-LEN(STR$(G)))+STR$(G)+" "+S$:GOSUB 17200
34400 IF U=G OR BK THEN 35050
34430 RE=RE+6:GOTO 33850
34450 ' full summary
34550 '
34600 P=0:GOSUB 39910
34850 ZS$=SZ$
34900 M$="#"+STR$(G)+" ="+ZS$+" lines, dated "+D$+" From: "+NO$:GOSUB 17200
34950 M$="To: "+T$+" Re: "+K$:GOSUB 17200
35000 GOSUB 17199:IF U=G OR BK THEN 35050 ELSE RE=RE+1:GOTO 33850
35050 GOSUB 17199:M$="** End of summary **":GOSUB 17200:GOSUB 17199:GOSUB 17199:CLOSE#3:RETURN
35100 '
35150 ' The goodbye routine
35200 '
35250 LOCATE 1,1:GOSUB 55100
35300 GOSUB 17199:GOSUB 17199
35350 M$="'Comments' are readable only by the SYSOP...":GOSUB 17200
35400 M$=" Want to leave any?":GOSUB 17650:C=1:GOSUB 9850:C=0
35500 IF LEFT$(B$,1)<>"Y" THEN 36100
35550 OPEN "R",3,"COMMENTS",65:FIELD#3,65 AS RR$:GET#3,1:RE=VAL(RR$)+1:RL=65
35600 IF RE=1 THEN RE=2
35650 S$="From: "+N$+" "+O$+" "+DATE$+" "+TIME$:GOSUB 39950
35700 PUT#3,RE
35750 M$=" Enter comments, C/R to end: (16 lines max - 64 characters/line)":GOSUB 17200
35800 M$=" |-------------------------------------------------------------|":GOSUB 17200
35850 M$="-->":GOSUB 17650:SEMI=FALSE:GOSUB 9850:SEMI=TRUE
35900 IF B$="" THEN 35950 ELSE RE=RE+1:S$=B$:RL=65:GOSUB 39950:PUT#3,RE:GOTO 35850
35950 S$=STR$(RE):RL=65:GOSUB 39950:PUT#3,1:CLOSE#3
36000 GOSUB 17199
36050 M$="Many thanks for the comment, "+N$+".":GOSUB 17200:GOTO 36250
36100 GOSUB 17199:M$=" No comment, then.":GOSUB 17200:GOTO 36250
36250 GOSUB 17199:GOSUB 17200:GOTO 23750
36300 '
36350 '
36400 ' Routine to kill a message
36450 '
36500 GOSUB 17199:A1$="Message # to kill?":GOSUB 9300:GOSUB 9850
36550 IF LEN(B$)=0 THEN M=0 ELSE M=VAL(B$)
36600 IF M<1 THEN M$=" ":GOSUB 17200:RETURN
36650 IF M>U THEN M$="There aren't that many msg's, "+N$+".":GOSUB 17200:SAV$="":GOTO 36450
36700 M$="Scanning summary file....":GOSUB 17200:OPEN "R",3,"SUMMARY",30:RE=1:FIELD#3,30 AS RR$:RL=30
36750 PRE=RE:GET#3,RE
36800 IF EOF(3) THEN 37750 ELSE G=VAL(RR$)
36850 IF G>9998 THEN 37750
36900 IF G<M THEN RE=RE+6:GOTO 36750
36950 IF G>M THEN 37750
36960 P=0:GOSUB 39910
36992 RE=PRE
37000 GOSUB 42350:IF PERS AND OK THEN GOTO 37300
37050 GOSUB 40200:PW=INSTR(S$,";"):PW$=""
37150 GOSUB 42550:IF N$=BOSS$ OR (OK AND PW=0) THEN PERS=0:GOTO 37300
37200 PW$=MID$(S$,PW+1)
37250 M$="Password ?":GOSUB 17650:C=1:GOSUB 9850:C=0:IF B$<>PW$ THEN M$="Incorrect.":GOSUB 17200:GOSUB 17199:CLOSE#3:RETURN
37300 M$="From: "+NO$+" To: "+T$+" Subject: "+K$:GOSUB 17200
37305 M$="OK TO DELETE? (Y/N) --> ":GOSUB 17650:C=1:GOSUB 9850:C=0
37310 IF LEFT$(B$,1)="Y" THEN GOTO 37340 ELSE CLOSE#3:GOSUB 17199:RETURN
37340 S$=" 0"+":"+STR$(G):GOSUB 39950:PUT#3,RE:CLOSE#3
37350 M$="Updating message file....":GOSUB 17200
37400 OPEN "R",3,"MESSAGES",65:RE=1:FIELD#3,65 AS RR$:MI=0
37450 MI=MI+1:IF MI>MZ THEN 37750 ELSE G=M(MI,1)
37500 IF G<M THEN RE=RE+M(MI,2)+6:GOTO 37450
37550 IF G=M THEN S$="0"+":"+STR$(G)+":"+N$+","+O$:RL=65:GOSUB 39950:PUT#3,RE:M(MI,1)=0
37600 CLOSE#3:M$="Updating message count...":GOSUB 17200
37650 OPEN "R",3,"COUNTERS",5:FIELD#3,5 AS RR$:GET#3,MSGS:LSET RR$=STR$(VAL(RR$)-1):PUT#3,MSGS:CLOSE#3
37700 GOSUB 17199:M$="Message killed.":GOSUB 17200:GOSUB 17199:RETURN
37750 CLOSE#3:M$="Message not found.":GOSUB 17200:GOSUB 17199:RETURN
37800 '
37850 GOSUB 17199:M$="The (U)SERS File -- Control-K to Stop":GOSUB 17200
37950 OPEN "R",3,"USERS",70:FIELD#3,70 AS RR$:FIELD#3,10 AS NN$
38000 GET#3,1:NU=VAL(NN$)
38050 IF N$=BOSS$ THEN LOWER=2 ELSE LOWER=NU+1-75
38060 IF LOWER<0 THEN LOWER=2
38100 FOR I=NU+1 TO LOWER STEP -1: GET#3,I:GOSUB 40200:M$=S$:GOSUB 17200
38150 IF BK THEN 38250
38200 NEXT I
38250 CLOSE#3: GOSUB 17199: RETURN
38255 ' DISPLAY XFERLIST IN LIFO ORDER
38260 J=0:FOR E=NU+1 TO 2 STEP -1: GET#3,E:GOSUB 40200:M$=S$:GOSUB 17200:J=J+1
38265 IF J=22 THEN J=0:M$="** PRESS ENTER TO CONTINUE or ENTER then CTL-K TO END **":GOSUB 17650:GOSUB 9850:BK=FALSE
38270 IF NOT BK THEN NEXT E
38280 CLOSE#3: GOSUB 17199: RETURN
38290 OPEN "R",3,"XFERLIST",78:FIELD#3,78 AS RR$:FIELD#3,10 AS NN$
38295 GET#3,1:NU=VAL(NN$):RETURN
38300 '
38350 ' Print control-char info
38400 '
38450 '
38500 M$="Use Ctl-S to Pause, Ctl-K to Abort.":GOSUB 17200:M$=" ":RETURN
38550 '
38600 '
38650 ' ***ON ERROR HANDLER***
38700 IF ERR=57 THEN RESUME NEXT
38710 IF ERR=7 THEN 55400
38750 IF ERL=13700 THEN RESUME 13750
38800 IF ERL=13650 THEN RESUME 13750
38900 IF ERL=5600 THEN RE=0:RESUME 5750
39000 IF ERL=22150 THEN M=0:RESUME 22250
39050 IF ERL=22300 THEN C=0:RESUME 22350
39100 IF ERL=22400 THEN U=0:RESUME 22450
39150 IF ERL=27200 THEN V=0:RESUME 27250
39200 IF ERL=30500 THEN C=0:RESUME 30550
39250 IF ERL=30600 THEN C=0:RESUME 30650
39300 IF ERL=43600 THEN RESUME 43750
39500 IF ERL=43200 THEN RESUME 43250
39550 IF ERL=55170 THEN RESUME NEXT
39670 IF ERL=19310 THEN RESUME 19330
39675 IF ERL=8673 THEN FOUND=FALSE:RESUME 8675
39677 IF ERL=8768 THEN RESUME 8690
39680 IF ERL=55600 THEN RESUME NEXT
39690 IF ERL=55610 THEN RESUME NEXT
39700 IF ERR=24 OR ERR=25 OR ERR=27 THEN PRTSW=FALSE:GOSUB 49160:RESUME NEXT
39750 PRINT ERR;" ";ERL:ERRCOUNT=ERRCOUNT+1
39800 IF PRTSW THEN LPRINT DATE$;" ";TIME$;" ";N$;" "O$;" Error Number ";ERR;" At Line ";ERL
39900 RESUME NEXT
39910 RE=RE+1:GET#3,RE:GOSUB 40200:D$=S$
39920 RE=RE+1:GET#3,RE:GOSUB 40200:NO$=S$
39930 RE=RE+1:GET#3,RE:GOSUB 40200:T$=S$
39935 RE=RE+1:GET#3,RE:GOSUB 40200:GOSUB 42850:K$=S$:IF P=4 THEN RETURN
39938 RE=RE+1:GET#3,RE:GOSUB 40200:SZ$=S$:RETURN
39940 S$=LEFT$(RZ$,58)
39945 RL=70 ' (now fall thru...).
39950 '
40000 ' Fill and store disk record
40050 '
40100 LSET RR$=LEFT$(S$+SPACE$(RL-2),RL-2)+CHR$(13)+CHR$(10)
40150 RETURN
40200 '
40250 ' Unpack disk record
40300 '
40350 ZZ=LEN(RR$)-2
40400 WHILE MID$(RR$,ZZ,1)=" "
40450 ZZ=ZZ-1:IF ZZ=1 THEN 40550
40500 WEND
40550 S$=LEFT$(RR$,ZZ):IF MID$(S$,ZZ,1)="?" THEN S$=S$+" ":RETURN ELSE RETURN
40750 ' *** Toggle EXPERT USER mode
40850 XPR=NOT XPR
40900 IF XPR THEN M$="EXPERT MODE (Type X again to return to Full Prompt Mode)":GOSUB 17200 ELSE M$="FULL PROMPT MODE":GOSUB 17200
40950 RETURN
41050 ' *** Toggle BELL prompt
41150 BEL=NOT BEL
41200 IF BEL THEN M$="PROMPT BELL ON":GOSUB 17200 ELSE M$="PROMPT BELL OFF":GOSUB 17200
41250 RETURN
41600 ' FULL SUMMARY
41650 QU=0:GOSUB 33000:RETURN
41700 ' QUICK SUMMARY
41750 QU=-1:GOSUB 33000:RETURN
41800 GOSUB 17199:M$="The (O)THER CALLERS File --Use Control-K To End":GOSUB 17200
41850 GOSUB 17199
41950 OPEN "R",3,"CALLERS",60:FIELD #3,60 AS RR$:GET #3,1:SIZ=VAL(RR$)
42000 CA=CN
42050 IF N$=BOSS$ THEN LOWER=2 ELSE LOWER=SIZ+1-75
42060 IF LOWER<0 THEN LOWER=2
42100 FOR CNT=SIZ+1 TO LOWER STEP -1
42150 GET #3,CNT:GOSUB 40200:M$=SPACE$(5-LEN(STR$(CA)))+STR$(CA)+" "+S$:GOSUB 17200:IF BK THEN 42300
42200 CA=CA-1
42250 NEXT CNT
42300 CLOSE#3:M$= "END OF CALLERS.":GOSUB 17200:GOSUB 17199:RETURN
42350 ' TEST FOR PERSONAL MESSAGES
42400 OK=TRUE:PERS=0:GET #3,RE:IF INSTR(RR$,";*")=0 THEN 42650
42450 PERS=TRUE
42500 IF N$=BOSS$ THEN 42650
42550 GET #3,RE+3:GOSUB 42700:IF OK THEN 42650
42600 GET #3,RE+2:GOSUB 42700
42650 RETURN
42700 ' TEST 'FROM' OR 'TO' FIELD FOR USER'S NAME
42750 IF INSTR(RR$,N$)>0 AND INSTR(RR$,O$)>0 THEN OK=TRUE ELSE OK=FALSE
42800 RETURN
42850 IF PERS THEN S$="("+S$:S$=S$+")":PERS=0
42900 RETURN
43200 CLOSE#3:KILL "COMMENTS":M$="** COMMENTS File Deleted ****":GOSUB 17200
43250 RETURN
43300 ' Subroutine to print BULLETIN (new programs) file...
43400 GOSUB 55100:M$="Print HARDWARE or SOFTWARE Bulletin? (H, S or <CR> to cancel) ":GOSUB 17650:C=1:GOSUB 9850:C=0
43450 IF LEN(B$)=0 THEN RETURN ELSE BULLCOUNT=BULLCOUNT+1
43500 IF LEFT$(B$,1)="S" THEN FIL$="SOFTWARE" ELSE FIL$="HARDWARE"
43550 '
43600 BK=0:GOSUB 55100:LOCATE 1,1:PAGE=TRUE:GOSUB 13500
43750 PAGE=FALSE:M$="End of Bulletin":GOSUB 17200:GOSUB 17199:SCNT=0:RETURN
44800 '
44850 GOSUB 17199:M$="Old message-modifying function.":GOSUB 17200
44900 GOSUB 17199:A1$="MSG # TO MODIFY?":GOSUB 9300:GOSUB 9850:GOSUB 17199
44950 IF B$="" THEN 23750
45000 IF LEN(B$)=0 THEN M=0 ELSE M=VAL(B$)
45050 IF M<1 THEN GOSUB 17200:RETURN
45100 IF M>U THEN M$="There aren't that many msgs, "+N$+".":GOSUB 17200:SAV$="":GOTO 44850
45150 OPEN "R",3,"MESSAGES",65:RE=1:FIELD#3,64 AS RR$:MI=0
45200 MI=MI+1:IF (MI>MZ) OR BK THEN GOTO 45350 ELSE G=M(MI,1)
45250 IF G<M THEN RE=RE+M(MI,2)+6:GOTO 45200
45300 IF G=M THEN 45400
45350 CLOSE#3: RETURN
45400 GOSUB 42350:IF NOT OK THEN RE=RE+M(MI,2):GOTO 45200
45450 GOSUB 40200:PW=INSTR(S$,";"):PW$=""
45500 IF PW=0 OR N$=BOSS$ OR PERS THEN PERS=0:GOTO 45650
45550 PW$=MID$(S$,PW+1):M$="Password ?":GOSUB 17650:C=1:GOSUB 9850:C=0
45600 IF B$<>PW$ THEN M$="Incorrect.":GOSUB 17200:CLOSE#3:RETURN
45650 RE=RE+5:GET#3,RE:F=VAL(RR$):RE=RE+1:ORE=RE:LF=F
45700 FOR QP = 1 TO LF
45750 GET#3,RE:GOSUB 40200:A$(QP)=S$:RE=RE+1:NEXT QP
45800 FM=1: GOTO 28400
45850 OPEN "R",3,"MESSAGES",65:RL=65:FIELD#3,65 AS RR$:RE=ORE
45900 FOR QP = 1 TO LF
45950 S$=A$(QP):GOSUB 39950:PUT#3,RE:RE=RE+1:NEXT QP
46000 CLOSE#3:FM=0:RETURN
46100 ' Print present time first
46150 '
46200 GOSUB 17199:M$="The Current Time is ............... "+TIME$:GOSUB 17650:M$=" Local Time ":GOSUB 17200
46300 HH1=VAL(MID$(ONTIME$,1,2)):MM1=VAL(MID$(ONTIME$,4,2)):HH2=VAL(MID$(TIME$,1,2)):MM2=VAL(MID$(TIME$,4,2)):HH1=HH1*60+MM1:HH2=HH2*60+MM2
46600 '
46650 TIMEON=HH2-HH1:IF TIMEON<0 THEN TIMEON=TIMEON+1440
46655 IF TCHECK THEN TCHECK=FALSE:RETURN
46850 M$="You've been on the system for...... ":GOSUB 17650
46900 PRINT #1,TIMEON;" minutes "+CHR$(13)+CHR$(10)
46950 PRINT TIMEON," minutes"
47250 GOSUB 17199:RETURN
47850 '
47950 LOCATE 21,20
48000 PRINT "BULLETIN READS --> ";BULLCOUNT
48050 LOCATE 22,20
48100 PRINT "HIGHEST CALLER NUMBER IS ";SAVCOUNT$;" ERROR COUNT - ";ERRCOUNT
48150 IF N$="" THEN GOTO 48250 ELSE LOCATE 23,20
48200 PRINT "The Last Caller Was ";LEFT$(N$,12);" ";LEFT$(O$,12);" At ";ONTIME$;
48250 LOCATE 24,1,0:RETURN
48900 FOR I=21 TO 23:LOCATE I,20:PRINT STRING$(55," ");:NEXT I:RETURN
49150 PRTSW=NOT PRTSW
49160 LOCATE 25,44:IF PRTSW THEN PRINT "ON "; ELSE PRINT "OFF ";:RETURN
49300 ' Get Character -----------------------------------------
49350 Y$=""
49400 FOR A=1 TO 900
49450 IF NOT EOF(1) THEN Y$=INPUT$(LOC(1),#1) :RETURN
49500 NEXT A
49550 Y$="" :RETURN
49600 ' Timeout -----------------------------------------------
49650 FOR B = 1 TO 100
49700 GOSUB 49300
49750 IF MID$(Y$,1,1)=SOH$ THEN RETURN
49800 IF MID$(Y$,1,1)=EOT$ THEN RETURN 51650
49850 IF MID$(Y$,1,1)=CAN$ THEN RETURN 51700
49900 IF Y$<>"" THEN GOSUB 17000 : GOTO 49600
49950 NEXT B
49960 CD=INP(&H3FE):CD=CD AND 128:IF CD<>128 THEN RETURN 13850 ' carrier dropped
50000 IF Y$="" THEN PRINT #1,NAK$;:PRINT "NAK"
50050 GOTO 49600
50100 ' Receive With Xmodem Protocol ---------------------------
50150 GOSUB 55100:M$="Begin Your Send Procedure Now - CONTROL-X To Cancel" :GOSUB 17200:GOSUB 17199
50155 PRINT " Receiving File..... ",FIL$
50200 GOSUB 53850 ' Open File
50250 GOSUB 17000:Y$="" ' Purge Buffer
50300 X$="" : SEC=1
50350 PRINT #1,NAK$;:PRINT "NAK"
50450 GOSUB 49600 ' Timeout
50500 GOSUB 49300 ' Get Char
50550 CD=INP(&H3FE):CD=CD AND 128:IF CD<>128 THEN RETURN 13850 ' carrier dropped
50560 IF Y$="" THEN PRINT "Timeout" : GOTO 50700
50600 X$=X$+Y$
50650 IF LEN(X$)<=131 THEN 50500
50700 IF LEN(X$)= 132 THEN Z$=MID$(X$,4,128) : N=132 : GOTO 51100
50750 IF LEN(X$)= 131 THEN Z$=MID$(X$,3,128) : N=131 : GOTO 51100
50800 IF LEN(X$)> 132 THEN 51400
50850 IF X$=EOT$ THEN 51650
50900 IF X$=CAN$ THEN 51700
50950 GOTO 51400
51000 IF SEC<>VAL(MID$(X$,2,1)) THEN GOTO 51400
51050 IF (SEC XOR 255) <> VAL(MID$(X$,3,1)) THEN GOTO 51400
51100 FOR Q=1 TO 128 : CK=CK+ASC(MID$(Z$,Q,1)) : NEXT
51150 IF (CK AND 255) <> (ASC(MID$(X$,N,1))) THEN 51400
51160 CC=POS(0):LL=CSRLIN:LOCATE 23,12,0:PRINT "Received #";SEC;: SEC=255 AND (SEC+1):LOCATE CC,LL,0
51250 PRINT #3,Z$;
51300 PRINT #1,ACK$;
51350 X$="" : CK=0 : GOTO 50500
51400 PRINT #1,NAK$; : GOTO 51350
51650 PRINT #1,ACK$;
51651 CLOSE#3:OPEN FIL$ FOR INPUT AS #3:SIZE#=LOF(3):CLOSE #3 : GOSUB 55100:M$="** File Closed **":GOSUB 17200:IF LEFT$(FIL$,5)="NEWIB" THEN RETURN
51653 IF FOUND AND N$=BOSS$ THEN RETURN
51654 GOSUB 38290:S$=FIL$+SPACE$(12-LEN(FIL$))+" - "+LEFT$(DESC$,30)+" "+DATE$+" "+STR$(SIZE#)+" bytes ":RL=78:GOSUB 39950:NU=NU+1:PUT#3,NU+1:S$=STR$(NU):GOSUB 39950:PUT#3,1:CLOSE#3:RETURN
51700 GOSUB 55100:M$="Transfer Aborted at Receiver":GOSUB 17200 : CLOSE #3 : KILL FIL$:RETURN
51850 ' Send with Xmodem Protocol -----------------------------------
51900 M$="Begin Your Receive Procedure - CONTROL-X To Cancel" : GOSUB 17200
51920 PRINT "Sending File......... ";FIL$
51950 XX=-1 : GOSUB 53860 'Open File
52000 SEC=0 : GOSUB 17000 'Purge Buffer
52050 EOT=0 : Y$="" : X$="" : Z$=""
52100 WHILE NOT EOF(1) 'Wait for NAK
52120 CD=INP(&H3FE):CD=CD AND 128:IF CD<>128 THEN RETURN 13850 ' carrier dropped
52150 Y$=INPUT$(1,#1)
52200 IF Y$=CAN$ THEN 53800
52250 IF Y$=NAK$ THEN 52800
52300 WEND : GOTO 52100
52350 '
52400 WHILE NOT EOF (1) ' Wait for ACK
52420 CD=INP(&H3FE):CD=CD AND 128:IF CD<>128 THEN RETURN 13850 ' carrier dropped
52450 Y$=INPUT$(1,#1)
52500 IF Y$=ACK$ THEN CK=0 : Y$="" : IF LEN(Z$)<128 THEN GOTO 52750 ELSE GOTO 53000
52550 IF Y$=NAK$ THEN 53550
52600 IF Y$=CAN$ THEN 53800
52650 WEND : GOTO 52400
52700 '
52750 IF EOT THEN 53750 ' Build and Send Block
52800 CK=0 : Y$=""
52963 FCOUNT=0:LAST=FALSE
52965 WHILE SIZE#>0 AND FCOUNT<1024 '10 sectors
52970 GET#3
52975 Z$=Z$+XYZ$
52980 FCOUNT=FCOUNT+512:SIZE#=SIZE#-512
52990 WEND
53000 IF EOT THEN 53750
53050 IF SIZE#<=0 AND LEN(Z$)=0 THEN GOTO 53750
53060 FOR X=1 TO LEN(Z$)
53100 Y$=Y$+MID$(Z$,X,1)
53150 CK=CK+ASC(MID$(Z$,X,1))
53220 IF LEN(Y$)=128 THEN 53300
53250 NEXT
53260 IF SIZE#<=0 AND NOT LAST THEN GOTO 53700
53300 Z$=MID$(Z$,X+1):CK=(CK AND 255)
53400 IF CK>256 THEN CK=CK-256 : GOTO 53400
53450 SEC=255 AND (SEC+1):A$=SOH$+CHR$(SEC)+CHR$(SEC XOR 255)+Y$+CHR$(CK)
53510 CC=POS(0):LL=CSRLIN
53550 LOCATE 23,12,0:PRINT "Send #";SEC;:LOCATE CC,LL
53600 PRINT #1,A$;:GOTO 52400
53700 Z$=Y$+STRING$(128-LEN(Y$),CHR$(0)) : EOT=-1 : Y$="":LAST=TRUE:CK=0:GOTO 53050
53750 PRINT#1,EOT$;:SOUND 32767,150:SOUND 32767,1:CLOSE#3:GOSUB 55100:M$="Transmission Completed":GOSUB 17200:RETURN
53800 PRINT#1,EOT$;:SOUND 32767,150:SOUND 32767,1:CLOSE#3:GOSUB 55100:M$="Transmission Aborted by Request":GOSUB 17200:RETURN
53850 CLOSE#3:OPEN FIL$ FOR OUTPUT AS #3:RETURN
53860 CLOSE#3:OPEN FIL$ AS #3 LEN=512:FIELD#3,512 AS XYZ$:RETURN
53900 TI$=TIME$:HE=VAL(MID$(TI$,1,2))*60:ME=VAL(MID$(TI$,4,2)):TE=HE+ME
54050 IF TE<TC THEN TE=TE+1440
54100 IF TE-TC<8 THEN RETURN
54150 OTC=TC:M$=CHR$(13)+CHR$(10)+"The Inactivity Limit of 7 Minutes Has Been Exceeded":GOSUB 17200:SOUND 32767,30:SOUND 32767,1:PRINT #1,CHR$(7);:SOUND 32767,40:SOUND 32767,1:IF PRTSW THEN LPRINT DATE$;" ";TIME$;" ";N$;" ";O$;" TIMEOUT"
54550 CLOSE#3:GOTO 13900
54600 CC=POS(0) ' cursor pos in column
54650 LL=CSRLIN ' cursor pos in line
54700 IF CC=1 THEN GOTO 54900
54750 CC=CC-1
54800 LOCATE LL,CC:PRINT " ";:LOCATE LL,CC ' move cursor back one line
54850 RETURN
54900 IF LL=1 THEN RETURN ' if line and column are 1, don't do anything
54950 CC=80
55000 LL=LL-1
55050 GOTO 54800 ' re-position cursor and goback
55100 CLS:A1$=CHR$(12):GOSUB 9300:GOSUB 20150:LOCATE 1,1:RETURN
55150 M$="WANT TO DO IT NOW?":GOSUB 17650:C=1:GOSUB 9850:C=0:IF LEFT$(B$,1)<>"Y" THEN RETURN
55170 KILL "OLDIBBS.EXE":NAME "IBBS.EXE" AS "OLDIBBS.EXE":NAME "NEWIBBS.EXE" AS "IBBS.EXE"
55300 M$="** RE-LOADING the BBS **":GOSUB 17200
55350 SOUND 32767,40:SOUND 32767,1
55400 RUN "IBBS"
55500 GOSUB 17199:PRINT#1,CHR$(7);:M$="*** SYSTEM COMING DOWN FOR MAINTENANCE - PLEASE FINISH UP**":GOSUB 17200:RETURN
55700 ON ERROR GOTO 0
55705 R=INP(&H3FB):K=R OR 128:OUT &H3FB,K
55710 IF SPEED=1 THEN OUT &H3F9,&H0:OUT &H3F8,&H60 ELSE OUT &H3F9,&H1:OUT &H3F8,&H80
55720 OUT &H3FB,R:ON ERROR GOTO 38650
55730 RETURN
IBBS.DOC
IBBS - The IBMPC Bulletin Board System
This short document describes the installation and care of the
remote bulletin board system called IBBS. This system was
modified to it's current state by Gene Plantz of System Software
Services.
Requirements:
IBMPC with 192K of RAM (might squeak by with 128K)
2 disk drives (either single or double sided, but double or harddisk better)
One communications adapter addressed as COM1
One 300 (or 300/1200) baud modem (Bell 212A used by author, but any should
work)
BASIC COMPILER (needed if changes are to be made to system)
NICE THINGS TO HAVE:
Hard disk (allows larger message files and file transfer with
little increase in file access time)
CONTROL:
This system is controlled by a system operator who is responsible
for all maintenance and content of the messages on the system. The
system operator has a special logon. The first and last name will be
a sequence known to the IBBS system, and a third password will be
requested ("2ND CODEWORD?"). The 3 codewords for the disk you
received will be written on a piece of paper attached to the
diskette sent to you. Once you are on the system as the system
operator (hereafter known as the SYSOP), you have much greater
authority than any other user. The commands that the SYSOP can do
will be described a little later.
These passwords can be changed by locating the labels:
BOSS$, P1$, and P2$.
INSTALLATION:
The diskette you received is a double-sided disk containing all
the source and executable modules for the system. The source
files (.BAS) may be retained on the distribution disk, while
everything else should be copied to a working disk. The working
disk should have a DOS boot on it. All the executable modules are
compiled, so no BASICA module is required.
*****THIS CODE WILL NOT RUN WITH THE BASIC INTERPRETER******.
The files on the disk are:
IBBS.BAS - source code for the BBS
IBBS.EXE - compiled BBS module
RBBSUTIL.BAS - source for the file cleanup utility
RBBSUTIL.EXE - compiled file cleanup utility
USERS - List of logon IDs (name appears once only here)
CALLERS - This is the list of each logon (except for SYSOP)
COUNTERS - small file that has next msg #,next caller #,etc
BBSLOGO.BAS - the local logo that is displayed upon BBS startup
MESSAGES - this is the main messages file
SUMMARY - this is the message summary file
NEWCOM - this is an info file for first time callers
FLASH - this is an info file, displayed after WELCOME file
HELP.BBS - help file with info on commands, called by ?
WELCOME - another info file displayed first after LOGON
XFER.HLP - info file for the file transfer function
SOFTWARE - info file on software prices, called by B
HARDWARE - info file on hardware prices, called by B
XFERLIST - list of files that can be transferred (not supplied)
STARTING THE BBS:
To begin operations, place the disk containing the BBS files in
drive A, and type in IBBS. This system is set up for a hard disk
and will probably require some modifications to split the files
out to a couple of floppies. All files are currently placed on
the default drive.
STOPPING THE BBS:
To shutdown the BBS, just press the F1 key. If anyone is
currently logged on, they will be cut off during the shutdown
process.
LOGGING OFF TWITS:
If you wish to log off someone currently on the system, just
press the F2 key. This will force off the current caller and
cause the BBS to recycle for the next call.
MESSAGE TO GET OFF SYSTEM:
If you want to shutdown the system for maintenance, but someone
is currently on, you may ask them to finish up what they are
doing and logoff by pressing the F4 key. This does not log them
off.
TOGGLE PRINTER:
This system uses a printer to log info on logon, timeouts, files
transferred, logoffs, errors. If a printer is on and ready at
system startup, it will be used. If you wish to turn it off,
press F5. If the printer has a problem and fails to operate, the
BBS will automatically toggle it off (the status of the printer
is displayed on line 25).
CLEARING ERROR COUNT DISPLAY:
To clear the counters display on the local screen, below the
logo, press the F8 key.
DISPLAYING STATUS COUNTS:
To re-display the status counts on the local screen, just below
the logo, just press the F9 key.
PROGRAM FLOW:
When someone calls into the board, CARRIER DETECT is found active and
the BBS begins the process of waiting for the user to press his ENTER key.
This is the baud rate detection technique. Throughout the system, a
control-k (or control-c) can be used to kill the display data being
sent. Due to a quirk in the compiler, the data is in the outgoing
communications buffer (the data that has not yet made it out to the
modem), and cannot be purged (according to an IBM rep). Therefore,
control-K can seem to take a while to work. Watching at the BBS
machine and the modem will show you that this is the case. The
computer display will have stopped while the modem is still sending
data.
The WELCOME and FLASH files are sent to the caller, and then the
caller is prompted for his/her FIRST NAME. At this point, all
commands may be stacked if the caller knows what prompts are
next. Otherwise, he/she will then be prompted for LAST NAME. A
check is then done in the USERS file.
If a match is found, then he/she is logged in the CALLERS file with
the date and time. If he/she was not found in the USERS file, caller
will be asked for CITY,STATE info. This is then placed into the
USERS file. Then logged to CALLERS file.
After that is out of the way (does NOT occur for SYSOP), the main
system menu is displayed. The choices here are:
G- Logoff the system
M- Go to the message subsystem
F- Go to the File transfer system
D- change duplex (i.e. ECHO) from ECHO to NO ECHO
X- short menus (sets Expert mode)
FILE TRANSFER:
The options in the FILE TRANSFER menu are self-descriptive.
The list of files to xfer are in a file called XFERLIST. This is a
random file that is displayed LAST-FIRST. Currently, file DOWNLOAD
is restricted to the hours of 9:00PM until NOON machine time. This
was done to allow the users of electronic mail so access to the
system. File transferers are very selfish and will monopolize the
system for great gobs of time. After one hour on the system, the
caller starts to get messages that he/she has been on for over one
hour and should think about giving someone else a chance. After 90
minutes, the caller is logged off and a string of ^^^^ is printed on
the hardcopy log.
Line 8662 can be "commented out" to eliminate the download time period
restriction or the time values can be changed.
XMODEM file transfers use the standard CPM protocol and an ASCII
transfer is nothing more than a listing from this end. An ASCII
upload can be done, and is terminated by sending an ESCAPE (or just
pressing the escape key). Incomplete files are deleted most of the
time if it is clear that the xfer was aborted. (No data is echoed
during an ASCII upload).
When the SYSOP list the XFERLIST file, at the end (or following a
control-K) the SYSOP is asked if he wants to XFER a new BBS. This
feature allows the SYSOP to be remote to the system, build a new
IBBS.EXE module, and transfer it via the phone to the system. It is
saved as NEWIBBS.EXE. If the SYSOP wishes, the new code can be
executed after transfer by going to the Message system and typing in
a 7 at the FUNCTION? prompt. This will cause the current IBBS.EXE to
renamed to OLDIBBS.EXE, NEWIBBS.EXE renamed to IBBS.EXE and then a
RUN"IBBS" is done. This will cause the phone connection to drop. You
should call back in to ensure that everything is OK. I have done
this many times with no failures. The machine running the BBS is
located 15 miles from my home.
MESSAGE SYSTEM:
Callers are notified if they have messages waiting for them upon
entering the message system (also the first time the main menu is
displayed). The SYSOP has the additional commands (undocumented for
safety reasons):
9 - read the comments file
8 - delete the comments file
7 - cause the new copy of the BBS to be RUN
Z - modify an old message (cannot add more lines)
There is a designation known as SPECIAL user. If the USER file entry
for a given person has a + symbol in the first position, that person
is a special user. He/she may use the Z command on messages to or
from themselves, and are not limited by the time restrictions on
system usage. If, instead, the first position in that file entry
contains an *, the user is a twit and cannot log on in the future.
Special Note:
Most of the files used in this system are random files. They are
fixed length and, although they can be editted with an editor, you
****MUST**** be extremely careful not to change the length of any record. If
you do, the file will not be readable past the record changed.
CLEANUP:
Since the deleted messages in a random file are only logically
deleted, a file cleanup must be done periodically (depends on your
system activity). Run the program RBBSUTIL to do this. It has many
features, but the one needed to do the file cleanup is called with
the P (for PURGE) command. You will be asked if you wish to
resequence the messages (I recommend you do not). Just press the
enter key to see what the other options are before pressing the P
option. All deleted messages are archived to a disk (compressed to
save space). The drive that this will go on is specified via an
option in this program. The message file will be recreated and a
backup will be keep. Be warned that these files can get to be very
large and cause disk space problems during the cleanup process.
TIMEOUT:
There is a 7 minute timeout on this system. Any inactivity for a
consecutive 7 minutes will cause a forced logoff.
SERIOUS NOTE:
Due to a limitation in the BASIC COMPILER, this code cannot be
enlarged without causing a compiler error. This code will have to be
broken up into multiple modules for any more enhancements to be
done.
COMPILING:
The BBS system may be compiled using the COMPILED run time system
option or without it. It is distributed using the /O option so as to
not require the BASIC COMPILER.
With RUN-TIME library: BASCOM IBBS/C:3000/S/V/X;
Without Run-Time Lib: BASCOM IBBS/C:3000/S/O/V/X;
LINK With Run-time Lib: LINK IBBS;
LINK Without Run-time Lib: LINK IBBS IBMCOM;
PRIVATE MESSAGES:
Messages from one users to another can be made private by entering
an * when asked for a password. ONLY the sender, addressee, and
SYSOP can read it. If anything else is used in the PASSWORD prompt,
that value must be used to delete the message. It can still be read
by everybody. The SYSOP can read and delete anything.
CABLING:
Use a full 25-wire cable between the PC and the modem. While not all
these sugnals are needed, more a than normal communications pgm are
used. There have been too many people calling with problems that are
related to cheap (or low-pin count cables). Use a full 25-pin cable
to ensure proper functioning.
RBBSUTIL.BAS
10 CLS
100 DEFINT A-Z
120 ARCDRV$="A"
140 VERS$="vers 1.0 IBMPC"
160 REM RBBSUTIL.BAS ==> UTILITY PROGRAM FOR THE RBBS REMOTE BULLETIN BOARD SYS
180 REM BY RON FOWLER, WESTLAND, MICH RBBS (313)-729-1905 (RINGBACK)
200 REM Please report any problems, bugs, fixes, etc. to the above RBBS.
220 REM
240 LOCATE 3,10:COLOR 8,7:PRINT" RBBS Utility ";VERS$:COLOR 7,0
260 ON ERROR GOTO 3620
280 DIM M(200,2)
300 SEP$="============================================================"
320 CRLF$=CHR$(13)+CHR$(10)
340 PRINT SEP$
360 PURGED=0:BACKUP=0
380 GOSUB 3700 'REM BUILD MSG INDEX
400 N$="SYSOP":O$=""
420 MSGS=1:KALLS=MSGS+1:MNUM=KALLS+1
440 PRINT:INPUT "Command? ",PROMPT$
460 PRINT:PRINT:IF PROMPT$="" THEN gosub 540:goto 440
480 B$=MID$(PROMPT$,1,1):GOSUB 1920:SM$=B$:SM=INSTR ("TFDPEBS",SM$):GOSUB 500::GOTO 440
500 IF SM=0 THEN gosub 540:goto 440
520 ON SM GOTO 980,920,760,2040,700,3320,4000
540 PRINT:PRINT "Commands allowed are:"
560 PRINT "B ==> build summary file from message file."
580 PRINT "D ==> display an ascii file"
600 PRINT "E ==> end the utility program."
620 PRINT "F ==> prints the disk directory."
640 PRINT "P ==> purge the message files"
660 PRINT "T ==> transfers a disk file to the message file."
665 PRINT "S ==> set drive letter for ARCHIVE file (Default A)"
680 RETURN
700 REM END OF PROGRAM
720 PRINT:PRINT:SYSTEM
740 REM DISPLAY A FILE
760 FILN$=MID$(PROMPT$,2):PRINT:IF FILN$="" THEN INPUT "Filename? ",FILN$:PRINT
780 OPEN "I",1,FILN$
800 IF EOF(1) THEN 860
820 IF INKEY$<>"" THEN CLOSE:PRINT:PRINT "++ Aborted ++":PRINT:RETURN
840 LINE INPUT #1,LIN$:PRINT LIN$:GOTO 800
860 CLOSE:PRINT:PRINT:PRINT "++ END OF FILE ++":PRINT
880 RETURN
900 REM DISPLAY DIRECTORY
920 IF LEN(PROMPT$)>1 THEN SPEC$=MID$(PROMPT$,2) ELSE SPEC$="*.*"
940 FILES SPEC$:PRINT:RETURN
960 REM TRANSFER A DISK FILE
980 PRINT "Active # of msg's ";:OPEN "R",1,"COUNTERS",5:FIELD#1,5 AS RR$:GET#1,MSGS:M=VAL(RR$)
1000 PRINT STR$(M)+"."
1020 PRINT "Last caller was # ";:GET#1,KALLS:PRINT STR$(VAL(RR$))
1040 PRINT "This msg # will be ";:GET#1,MNUM:U=VAL(RR$):PRINT STR$(U+1):CLOSE
1060 REM
1080 REM ***ENTER A NEW MESSAGE***
1100 REM
1120 IF NOT PURGED THEN PRINT "Files must be purged before messages can be added":RETURN
1140 OPEN "R",1,"COUNTERS",5:PRINT "Msg # will be ";:FIELD#1,5 AS RR$:GET#1,MNUM:V=VAL(RR$)
1160 PRINT STR$(V+1):CLOSE
1180 INPUT "Message file name? ",B$:GOSUB 1920:FIL$=B$
1200 ' INPUT "Todays date (MM/DD/YY)?",B$:GOSUB 1920:D$=B$
1202 D$=DATE$+" "+time$:PRINT "Today is ";DATE$+" "+time$
1220 INPUT "Who to (C/R for ALL)?";B$:GOSUB 1920:IF B$="" THEN T$="ALL" ELSE T$=B$
1240 INPUT "Subject?",B$:GOSUB 1920:K$=B$:INPUT "Password?",B$:GOSUB 1920:PW$=B$
1260 F=0 'F IS MESSAGE LENGTH
1280 PRINT "Updating counters":OPEN "R",1,"COUNTERS",5:FIELD#1,5 AS RR$
1300 GET#1,MNUM:LSET RR$=STR$(VAL(RR$)+1):PUT#1,MNUM
1320 GET#1,MSGS:LSET RR$=STR$(VAL(RR$)+1):PUT#1,MSGS:CLOSE#1
1340 PRINT "Updating msg file":OPEN "R",1,"MESSAGES",65:RL=65
1360 FIELD#1,65 AS RR$
1380 RE=MX+7:F=0
1400 OPEN "I",2,FIL$:IF EOF(2) THEN PRINT "File empty.":CLOSE#1:CLOSE#2:END
1420 IF EOF(2) THEN S$="9999":GOSUB 1940:PUT #1,RE:CLOSE #2:GOTO 1500
1440 LINE INPUT #2,S$
1460 IF LEN(S$)>63 THEN S$=LEFT$(S$,63)
1480 PRINT S$:GOSUB 1940:PUT #1,RE:RE=RE+1:F=F+1:GOTO 1420
1500 RE=MX+1
1520 S$=STR$(V+1):GOSUB 1940:PUT#1,RE
1540 RE=RE+1:S$=D$:GOSUB 1940:PUT#1,RE
1560 RE=RE+1:S$=N$+" "+O$:GOSUB 1940:PUT#1,RE
1580 RE=RE+1:S$=T$:GOSUB 1940:PUT#1,RE
1600 RE=RE+1:S$=K$:GOSUB 1940:PUT#1,RE:RE=RE+1:S$=STR$(F):GOSUB 1940:PUT#1,RE
1620 CLOSE #1
1640 IF PW$<>"" THEN PW$=";"+PW$
1660 PRINT "Updating summary file."
1680 OPEN "R",1,"SUMMARY",30:RE=1:FIELD#1,30 AS RR$:RL=30
1700 RE=MZ*6+1:S$=STR$(V+1)+PW$:GOSUB 1940:PUT#1,RE
1720 RE=RE+1:S$=D$:GOSUB 1940:PUT#1,RE
1740 RE=RE+1:S$=N$+" "+O$:GOSUB 1940:PUT#1,RE
1760 RE=RE+1:S$=T$:GOSUB 1940:PUT#1,RE
1780 RE=RE+1:S$=K$:GOSUB 1940:PUT#1,RE
1800 RE=RE+1:S$=STR$(F):GOSUB 1940:PUT#1,RE
1820 RE=RE+1:S$=" 9999":GOSUB 1940:PUT#1,RE
1840 CLOSE#1
1860 MX=MX+F+6:MZ=MZ+1:M(MZ,1)=V+1:M(MZ,2)=F
1880 U=U+1
1900 RETURN
1920 FOR ZZ=1 TO LEN(B$):MID$(B$,ZZ,1)=CHR$(ASC(MID$(B$,ZZ,1))+32*(ASC(MID$(B$,ZZ,1))>96)):NEXT ZZ:RETURN
1940 REM
1960 REM FILL AND STORE DISK RECORD
1980 REM
2000 LSET RR$=LEFT$(S$+SPACE$(RL-2),RL-2)+CHR$(13)+CHR$(10)
2020 RETURN
2040 REM
2060 REM PURGE KILLED MESSAGES FROM FILES
2080 REM
2100 IF PURGED THEN PRINT "Files already purged.":RETURN
2120 ' INPUT "Today's date (MM/DD/YY) ?",DATE$
2140 ' IF LEN(DATE$)>8 THEN PRINT "Must be less then 8 characters.":GOTO 2120
2159 D1$=MID$(DATE$,1,2)+MID$(DATE$,4,2)+MID$(DATE$,9,2)
2160 OPEN "R",1,ARCDRV$+":"+D1$+".ARC"
2180 IF LOF(1)>0 THEN PRINT "Archive file: ";ARCDRV$+":"+D1$+".ARC";" exists.":CLOSE:RETURN
2200 CLOSE
2220 MSGN=1:INPUT "Renumber messages?",PK$:PK$=MID$(PK$,1,1)
2240 IF PK$="y" THEN PK$="Y"
2260 IF PK$<>"Y" THEN 2320
2280 INPUT "Message number to start (CR=1)?",MSG$:IF MSG$="" THEN MSG$="1"
2300 MSGN=VAL(MSG$):IF MSGN=0 THEN PRINT "Invalid msg #.":RETURN
2320 PRINT "Purging summary file...":OPEN "R",1,"SUMMARY",30
2340 FIELD#1,30 AS R1$
2360 R1=1
2380 OPEN "R",2,"$SUMMARY.$$$",30
2400 FIELD#2,30 AS R2$
2420 R2=1
2440 PRINT SEP$:GET#1,R1:IF EOF(1) THEN 2680
2460 IF VAL(R1$)=0 THEN R1=R1+6:PRINT "Deletion":GOTO 2440
2480 IF PK$="Y" AND VAL(R1$)<9999 THEN LSET R2$=LEFT$(STR$(MSGN)+SPACE$(28),28)+CHR$(13)+CHR$(10):MSGN=MSGN+1:GOTO 2520
2500 LSET R2$=R1$
2520 PUT #2,R2
2540 PRINT LEFT$(R2$,28)
2560 IF VAL(R1$)>9998 THEN 2680
2580 FOR I=1 TO 5
2600 R1=R1+1:R2=R2+1:GET#1,R1:LSET R2$=R1$:PUT#2,R2
2620 PRINT LEFT$(R2$,28)
2640 NEXT I
2660 R1=R1+1:R2=R2+1:GOTO 2440
2680 CLOSE:OPEN "O",1,"SUMMARY.BAK":CLOSE:KILL "SUMMARY.BAK":NAME "SUMMARY" AS "SUMMARY.BAK":NAME "$SUMMARY.$$$" AS "SUMMARY"
2700 PRINT "Purging message file...":MSGN=VAL(MSG$)
2720 OPEN "R",1,"MESSAGES",65:FIELD #1,65 AS R1$
2740 OPEN "R",2,"$MESSAGS.$$$",65:FIELD #2,65 AS R2$
2760 OPEN "O",3,ARCDRV$+":"+D1$+".ARC":R1=1:KIL=0
2780 R1=1:R2=1
2800 PRINT SEP$:GET #1,R1:IF EOF(1) THEN 3140
2820 IF VAL(R1$)=0 THEN KIL=-1:PRINT "Archiving message":GOTO 2900
2840 KIL=0:IF PK$="Y" AND VAL(R1$)<9999 THEN LSET R2$=LEFT$(STR$(MSGN)+SPACE$(63),63)+CHR$(13)+CHR$(10):MSGN=MSGN+1:PRINT LEFT$(R2$,63):GOTO 2880
2860 LSET R2$=R1$:PRINT LEFT$(R2$,6)
2880 PUT #2,R2
2900 IF KIL THEN GOSUB 3860:PRINT #3,KL$
2920 IF VAL(R1$)>9998 THEN 3140
2940 FOR I=1 TO 5
2960 R1=R1+1:IF NOT KIL THEN R2=R2+1
2980 GET #1,R1:IF KIL THEN GOSUB 3860:PRINT #3,KL$:GOTO 3020
3000 LSET R2$=R1$:PUT #2,R2:PRINT LEFT$(R2$,63)
3020 NEXT I
3040 FOR I=1 TO VAL(R1$):R1=R1+1:IF NOT KIL THEN R2=R2+1
3060 GET #1,R1:IF KIL THEN GOSUB 3860:PRINT #3,KL$:GOTO 3100
3080 LSET R2$=R1$:PUT #2,R2:PRINT LEFT$(R2$,63)
3100 NEXT I:R1=R1+1:IF NOT KIL THEN R2=R2+1
3120 GOTO 2800
3140 CLOSE:OPEN "O",1,"MESSAGES.BAK":CLOSE:KILL "MESSAGES.BAK":NAME "MESSAGES" AS "MESSAGES.BAK":NAME "$MESSAGS.$$$" AS "MESSAGES"
3160 PRINT "Updating counters..."
3180 OPEN "O",1,"COUNTERS.BAK":CLOSE:KILL "COUNTERS.BAK"
3200 OPEN "R",1,"COUNTERS",15:FIELD #1,10 AS C1$,5 AS C2$
3220 OPEN "R",2,"COUNTERS.BAK",15:FIELD #2,15 AS R2$
3240 GET #1,1:LSET R2$=C1$+C2$:PUT #2,1
3260 IF PK$="Y" THEN LSET C2$=STR$(MSGN-1):PUT #1,1
3280 CLOSE
3300 PURGED=-1:GOSUB 3700:RETURN
3320 REM BUILD SUMMARY FILE FROM MESSAGE FILE
3340 PRINT "Building summary file..."
3360 OPEN "O",1,"SUMMARY.BAK":CLOSE:KILL "SUMMARY.BAK"
3380 OPEN "R",1,"MESSAGES",65:FIELD #1,65 AS R1$:R1=1
3400 OPEN "R",2,"SUMMARY.$$$",30:FIELD #2,30 AS R2$:R2=1
3420 PRINT SEP$
3440 FOR I=1 TO 6
3460 GET #1,R1:IF EOF(1) THEN 3560
3480 LSET R2$=LEFT$(R1$,28)+CRLF$:PUT #2,R2
3500 R1=R1+1:R2=R2+1:PRINT LEFT$(R2$,28):IF EOF(1) THEN 3560
3520 IF I=1 THEN IF VAL(R1$)>9998 THEN 3560
3540 NEXT I:R1=R1+VAL(R1$):GOTO 3420
3560 CLOSE:NAME "SUMMARY" AS "SUMMARY.BAK":NAME "SUMMARY.$$$" AS "SUMMARY"
3580 PRINT "Summary file built.":RETURN
3600 PRINT "Error number: ";ERR;" occurred at line number:";ERL
3620 IF ERL=940 AND ERR=53 THEN PRINT "File not found.":RETURN
3640 IF ERL=780 AND ERR=53 THEN PRINT "File not found.":CLOSE:RESUME 880
3660 PRINT "Error number ";ERR;" in line number ";ERL
3680 RESUME 440
3700 REM build message index
3720 MX=0:MZ=0
3740 OPEN "R",1,"SUMMARY",30:RE=1:FIELD#1,28 AS RR$
3760 GET#1,RE:IF EOF(1) THEN 3840
3780 G=VAL(RR$):MZ=MZ+1:M(MZ,1)=G:IF G=0 THEN 3820
3800 IF G>9998 THEN MZ=MZ-1:GOTO 3840
3820 GET#1,RE+5:M(MZ,2)=VAL(RR$):MX=MX+M(MZ,2)+6:RE=RE+6:GOTO 3760
3840 CLOSE:RETURN
3860 REM unpack record
3880 ZZ=LEN(R1$)-2
3900 WHILE MID$(R1$,ZZ,1)=" "
3920 ZZ=ZZ-1:IF ZZ=1 THEN 3960
3940 WEND
3960 KL$=LEFT$(R1$,ZZ)
3980 RETURN
4000 CLS
4010 LOCATE 10,10
4020 PRINT "Which drive is to be used for the ARCHIVE file? (A,B,C,D) ";
4030 X$=INKEY$:IF LEN(X$)=0 THEN GOTO 4030
4040 IF X$<>"a" AND X$<>"A" AND X$<>"b" AND X$<>"B" AND X$<>"c" AND X$<>"C" AND X$<>"d" AND X$<>"D" THEN GOTO 4040 ELSE PRINT X$;
4050 IF X$="a" THEN X$="A"
4060 IF X$="b" THEN X$="B"
4070 IF X$="c" THEN X$="C"
4080 IF X$="d" THEN X$="D"
4090 ARCDRV$=X$
4100 GOTO 440
Directory of PC-SIG Library Disk #0150
Volume in drive A has no label
Directory of A:\
BBSCOMP BAT 118 12-04-82 8:24p
BBSLOGO BAS 755 2-19-83 7:04p
CALLERS 256 12-29-82 9:59p
COUNTERS 128 12-29-82 10:01p
CRC TXT 1546 11-14-84 8:59a
CRCK4 COM 1536 10-21-82 7:54p
FLASH 115 9-28-82 9:39p
HARDWARE 59 2-24-83 8:45p
HELP BBS 1095 10-27-82 10:26p
IBBS BAS 44628 3-30-83 9:49p
IBBS DOC 11813 1-01-80 10:01a
IBBS EXE 81408 3-30-83 9:54p
MESSAGES 896 12-29-82 10:01p
NEWCOM 1020 9-17-82 10:53p
RBBSUTIL BAS 9166 9-19-82 11:15p
RBBSUTIL EXE 33920 9-19-82 11:17p
SOFTWARE 44 2-24-83 8:44p
SUMMARY 256 12-29-82 10:01p
USERS 256 12-29-82 9:59p
WELCOME 308 9-17-82 9:55p
XFER HLP 2519 11-25-82 11:46p
XFERLIST 159 12-29-82 9:32p
XXX 1280 4-25-84 11:56p
23 file(s) 193281 bytes
114688 bytes free