10 DEFINT A-Z:H$="######":H1$="##":LCK$="ABCDEF"
20 ON ERROR GOTO 900
30 DIM M$(16):CLS$=CHR$(26):SEP$="============================================="
40 PRINT CLS$
50 PRINT"   [XBBS] v2.3 Utility Program    Written by Robert Crump":PRINT
60 PRINT SEP$:PRINT"Whice drive do you wish to store your archived files on: ";:PRINT CHR$(7);:LINE INPUT A$:CY$=A$:GOSUB 840:A$=CY$
70 IF A$="" THEN 60 ELSE FF=INSTR("ABCD",A$):IF FF=0 THEN 60 ELSE A1$=A$+":"
80 PRINT SEP$:PRINT"Which drive are your files to be purged: ";:PRINT CHR$(7);:LINE INPUT B$:CY$=B$:GOSUB 840:B$=CY$
90 IF B$="" THEN 80 ELSE FF=INSTR("ABCD",B$):IF FF=0 THEN 80 ELSE A2$=B$+":"
100 IF A1$=A2$ THEN PRINT"Both source and destination files cannot reside on the same drive...re-select":GOTO 60
110 PRINT CLS$;:PRINT SEP$:T9=0
120 PRINT"[XBBS] v2.3 Utility Commands:":PRINT
130 PRINT"P ==> purge the message file."
140 PRINT"U ==> purge the users file."
150 PRINT"B ==> build a summary from msg. file."
160 PRINT"R ==> reset counters."
170 PRINT"E ==> return to cp/m."
180 PRINT SEP$
190 PRINT:PRINT"Command: ";:LINE INPUT C$:CY$=C$:GOSUB 840:C$=CY$
200 IF C$="" THEN 190 ELSE FF=INSTR("PUBRE",C$):IF FF=0 THEN 190
210 ON FF GOTO 220,1060,1420,1690,970
220 '***** PURGE MESSAGE FILE SECTION *****
230 PRINT CLS$;:PRINT"(MM/DD/YY)":PRINT"Enter todays date: ";:LINE INPUT D$
240 IF D$="" THEN 110 ELSE D1$=D$
250 PRINT:PRINT"Purging summary file..."
260 NAME A2$+"SUMMARY. " AS A2$+"SUMMARY.BAK"
270 OPEN"R",1,A2$+"SUMMARY.BAK",92
280 FIELD #1,24 AS SUN$,6 AS SUM$,2 AS SPR$,6 AS SUP$,21 AS SUB$,24 AS SFR$,9 AS SDT$
290 OPEN"R",2,A2$+"SUMMARY.$$$",92
300 FIELD #2,24 AS PUN$,6 AS PUM$,2 AS PPR$,6 AS PUP$,21 AS PUB$,24 AS PFR$,9 AS PDT$
310 SR=2
320 GET #1,SR:SN$=SUN$:SM$=SUM$:PV$=SPR$:PWD$=SUP$:SB$=SUB$:SFN$=SFR$:ZDT$=SDT$
330 IF EOF(1) THEN CLOSE #1,#2:GOTO 440
340 SM=VAL(SUM$):IF SM<>0 THEN 350 ELSE 430
350 PRINT SEP$:PRINT"Msg.#";SM;"  Date: ";ZDT$
360 PRINT"To: ";SN$
370 PRINT"From: ";SFN$
380 PRINT"Subject: ";SB$
390 GET #2,1:RS=VAL(PUN$):IF RS<2 THEN RS=2
400 LSET PUN$=STR$(RS+1):PUT #2,1
410 LSET PUN$=SN$:LSET PUM$=SM$:LSET PPR$=PV$:LSET PUP$=PWD$:LSET PUB$=SB$:LSET PFR$=SFN$:LSET PDT$=ZDT$
420 PUT #2,RS:SR=SR+1:GOTO 320
430 PRINT SEP$:PRINT"Deletion...":SR=SR+1:GOTO 320
440 PRINT SEP$:PRINT:PRINT"Purging Message File...":PRINT
450 NAME A2$+"MESSAGES. " AS A2$+"MESSAGES.BAK"
460 OPEN"R",1,A2$+"MESSAGES.BAK",64:FIELD #1,64 AS RR$
470 OPEN"R",2,A2$+"MESSAGES.$$$",64:FIELD #2,64 AS RA$
480 OPEN"R",3,A1$+D1$+".ARC",64:FIELD #3,64 AS RB$
490 RN=2
500 GET #1,RN:I=INSTR(RR$,"~"):LE=VAL(LEFT$(RR$,I-1))
510 J=INSTR(I+1,RR$,"~"):PA$=MID$(RR$,I+1,J-I-1)
520 J1=INSTR(J+1,RR$,"~"):PA1$=MID$(RR$,J+1,J1-J-1)
530 J2=INSTR(J1+1,RR$,"~"):PA2$=MID$(RR$,J1+1,J2-J1-1)
540 J3=INSTR(J2+1,RR$," "):PA3$=MID$(RR$,J2+1,J3-J2-1)
550 RN=RN+1:GET #1,RN:I=INSTR(RR$,"~"):EM=VAL(LEFT$(RR$,I-1))
560 J=INSTR(I+1,RR$,"~"):PA4$=MID$(RR$,I+1,J-I-1)
570 J1=INSTR(J+1,RR$,"~"):PA5$=MID$(RR$,J+1,J1-J-1)
580 IF EM<>0 THEN 590 ELSE EM$=LEFT$(RR$,I-1):GOTO 730
590 GET #2,1:MR=VAL(RA$):IF MR<2 THEN MR=2
600 RR2$=STR$(MR+2+LE):GOSUB 1000:PUT #2,1
610 RR2$=STR$(LE)+"~"+PA$+"~"+PA1$+"~"+PA2$+"~"+PA3$:GOSUB 1000:PUT #2,MR:MR=MR+1
620 RR2$=STR$(EM)+"~"+PA4$+"~"+PA5$+"~":GOSUB 1000:PUT #2,MR:MR=MR+1
630 PRINT SEP$:PRINT
640 PRINT"Msg.#";EM;  "Date: ";PA3$
650 PRINT"To: ";PA4$
660 PRINT"From: ";PA5$
670 PRINT"Subject: ";PA2$:PRINT
680 RN=RN+1
690 GET #1,RN:M1=M1+1
700 RR4$=LEFT$(RR$,62):PRINT RR4$:RR2$=RR4$:GOSUB 1000:PUT #2,MR
710 IF M1=LE THEN 720 ELSE RN=RN+1:MR=MR+1:GOTO 690
720 RN=RN+1:M1=0:GOTO 500
730 PRINT SEP$:GET #3,1:NR=VAL(RB$):IF NR<2 THEN NR=2
740 RR3$=STR$(NR+2+LE):GOSUB 1030:PUT #3,1
750 PRINT"Archiving message..."
760 RR3$=STR$(LE)+"~"+PA$+"~"+PA1$+"~"+PA2$+"~"+PA3$:GOSUB 1030:PUT #3,NR:NR=NR+1
770 RR3$=EM$+"~"+PA4$+"~"+PA5$+"~":GOSUB 1030:PUT #3,NR:NR=NR+1
780 RN=RN+1
790 GET #1,RN:M1=M1+1
800 RR3$=RR$:GOSUB 1030:PUT #3,NR
810 PUT #3,NR
820 IF M1=LE THEN 830 ELSE RN=RN+1:NR=NR+1:GOTO 790
830 RN=RN+1:M1=0:GOTO 500
840 '***** LOWER TO UPPER CONVERSION *****
850 FOR ZZ=1 TO LEN(CY$)
860 ZA=ASC(MID$(CY$,ZZ,1)):IF ZA<&H61 OR ZA>&H7A THEN 880
870 MID$(CY$,ZZ,1)=CHR$(ZA-&H20)
880 NEXT ZZ
890 RETURN
900 '***** ON ERROR TRAPPING ****
910 IF ERL=450 THEN PRINT"Drive error on archive select. Re-select.":RESUME 60
920 IF ERL=1230 THEN CLOSE #1,2:PRINT"User file defect. Modify with WS.":STOP
930 IF ERL=500 AND T9=1 THEN RESUME 1450 ELSE CLOSE #1,2,3:GOTO 110
940 IF ERL=1180 THEN RESUME 1340
950 IF ERL=1450 THEN RESUME 1460
960 IF ERL=1520 THEN CLOSE #1,2:GOTO 110
970 '**** RETURN TO CPM ****
980 SYSTEM
990 '***** MESSAGE FILE LSET *****
1000 RL=64
1010 LSET RA$=LEFT$(RR2$+SPACE$(RL-2),RL-2)+CHR$(13)+CHR$(10)
1020 RETURN
1030 RL=64
1040 LSET RB$=LEFT$(RR3$+SPACE$(RL-2),RL-2)+CHR$(13)+CHR$(10)
1050 RETURN
1060 '***** USER PURGE SECTION *****
1070 PRINT CLS$;:PRINT SEP$
1080 PRINT"Users with password of ";LCK$;" will be purged."
1090 PRINT"Users below entered date will be purged.":PRINT SEP$
1100 PRINT:PRINT"(DD-MMM-YY)":PRINT"Enter deletion date: ";:LINE INPUT D$:MN=1
1110 READ MO$
1120 IF MO$<>MID$(D$,4,3) THEN MN=MN+1:GOTO 1110
1130 MN1=MN:RESTORE
1140 NAME A2$+"USERS. " AS A2$+"USERS.BAK"
1150 OPEN"R",1,A2$+"USERS.BAK",64:FIELD #1,64 AS UR$:UR=2
1160 OPEN"R",2,A2$+"USERS.$$$",64:FIELD #2,64 AS UR1$
1170 GET #1,UR
1180 I=INSTR(UR$,"~"):UN=VAL(LEFT$(UR$,I-1))
1190 I1=INSTR(I+1,UR$,"~"):NM$=MID$(UR$,I+1,I1-I-1)
1200 I2=INSTR(I1+1,UR$,"~"):PWD$=MID$(UR$,I1+1,I2-I1-1)
1210 I3=INSTR(I2+1,UR$,"~"):DTE$=MID$(UR$,I2+1,I3-I2-1)
1220 I4=INSTR(I3+1,UR$,"~"):MH=VAL(MID$(UR$,I3+1,I4-I3-1))
1230 I5=INSTR(I4+1,UR$,"~"):CT$=MID$(UR$,I4+1,I5-I4-1)
1240 MO=1
1250 READ MO1$
1260 IF MO1$<>MID$(DTE$,4,3) THEN MO=MO+1:GOTO 1250
1270 C=(MN-MO):IF C<0 THEN MN=MN+12:GOTO 1270:ELSE D=VAL(LEFT$(DTE$,2)):E=VAL(LEFT$(D$,2))
1280 DAY=30:IF C=>1 THEN DAY=DAY*C:MAX=DAY+E:ELSE MAX=E:C=0
1290 IF (MAX-D)=>30 OR PWD$=LCK$ THEN UR=UR+1:MN=MN1:RESTORE:GOTO 1170
1300 GET #2,1:UR1=VAL(UR1$):IF UR1<2 THEN UR1=2
1310 RL=63:UR2$=STR$(UR1+1):GOSUB 1380:PUT #2,1
1320 PRINT SEP$:PRINT"Issuing new user #";UR1;"to ";NM$
1330 GOSUB 1350:PUT #2,UR1:UR=UR+1:RESTORE:MN=MN1:GOTO 1170
1340 CLOSE #1,#2:GOTO 110
1350 '***** USER FILE LSET *****
1360 RL=63
1370 UR2$=STR$(UR1)+"~"+NM$+"~"+PWD$+"~"+DTE$+"~"+STR$(MH)+"~"+CT$+"~"
1380 LSET UR1$=LEFT$(UR2$+SPACE$(RL-2),RL-2)+CHR$(13)+CHR$(10)
1390 RETURN
1400 '***** DATA SET *****
1410 DATA JAN,FEB,MAR,APR,MAY,JUN,JUL,AUG,SEP,OCT,NOV,DEC
1420 '***** BUILD A SUMMARY FROM MSG. FILE *****
1430 T9=1:PRINT CLS$;:PRINT"(MM/DD/YY)":PRINT"Enter todays date: ";:LINE INPUT D$
1440 IF D$="" THEN 110 ELSE D1$=D$:GOTO 440
1450 CLOSE #1,2,3:KILL A2$+"SUMMARY. "
1460 PRINT:PRINT"Creating new summary file..."
1470 OPEN"R",1,A2$+"SUMMARY.$$$",92
1480 FIELD #1,24 AS SUN$,6 AS SUM$,2 AS SPR$,6 AS SUP$,21 AS SUB$,24 AS SFR$,9 AS SDT$
1490 OPEN"R",2,A2$+"MESSAGES.$$$",64
1500 FIELD #2,64 AS RA$
1510 RN=2
1520 GET #2,RN:I=INSTR(RA$,"~"):LE=VAL(LEFT$(RA$,I-1))
1530 J=INSTR(I+1,RA$,"~"):PA$=MID$(RA$,I+1,J-I-1)
1540 J1=INSTR(J+1,RA$,"~"):PA1$=MID$(RA$,J+1,J1-J-1)
1550 J2=INSTR(J1+1,RA$,"~"):PA2$=MID$(RA$,J1+1,J2-J1-1)
1560 J3=INSTR(J2+1,RA$," "):PA3$=MID$(RA$,J2+1,J3-J2-1)
1570 RN=RN+1:GET #2,RN:I=INSTR(RA$,"~"):EM=VAL(LEFT$(RA$,I-1))
1580 J=INSTR(I+1,RA$,"~"):PA4$=MID$(RA$,I+1,J-I-1)
1590 J1=INSTR(J+1,RA$,"~"):PA5$=MID$(RA$,J+1,J1-J-1)
1600 PRINT SEP$
1610 PRINT"Message #";EM;"  Date:";PA3$
1620 PRINT"To: ";PA4$
1630 PRINT"From: ";PA5$
1640 PRINT"Subject: ";PA2$
1650 GET #1,1:SR=VAL(SUN$):IF SR<2 THEN SR=2
1660 LSET SUN$=STR$(SR+1):PUT #1,1
1670 LSET SUN$=PA4$+"~":LSET SUM$=STR$(EM):LSET SPR$=PA$:LSET SUP$=PA1$:LSET SUB$=PA2$+"~":LSET SFR$=PA5$+"~":LSET SDT$=PA3$
1680 PUT #1,SR:RN=RN+LE+1:GOTO 1520
1690 '***** COUNTER RESET *****
1700 PRINT CLS$;:
1710 INPUT"Caller count? ",A
1720 INPUT"Active Msg. count? ",B
1730 INPUT"High Msg. count? ",C
1740 OPEN"R",1,A2$+"COUNTERS. "+CHR$(160)+" ",12
1750 FIELD #1,4 AS CAL$,4 AS MSG$,4 AS MNU$
1760 LSET CAL$=MKI$(A):LSET MSG$=MKI$(B):LSET MNU$=MKI$(C)
1770 PUT #1,1
1780 CLOSE #1:GOTO 110