home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
ftp.barnyard.co.uk
/
2015.02.ftp.barnyard.co.uk.tar
/
ftp.barnyard.co.uk
/
cpm
/
walnut-creek-CDROM
/
CPM
/
DATABASE
/
DIMS103.ARK
/
DNADIN.ASC
< prev
next >
Wrap
Text File
|
1986-12-07
|
3KB
|
140 lines
1000 GOSUB 1790 'cs
1010 PRINT:PRINT TAB(27);"NADIN 1.02 - October 9, 1983
1020 ' by Dan Dugan -- public domain
1030 PRINT:PRINT"Inputs from a NAD-like data file to a DIMS 'standard' format mailing list.
1040 PRINT
1050 DEFINT A-Z
1060 COMMON I,J,K,X,Y,T$,R$,S$,T1$,SKIPPARSE,FT,SEARCH,
C,N,NC,P6,P7,P8,P9,PI,S,T,T1,T2,C(),B$(),N$(),
SEARCHWORD$(),SEARCHFIELD(),SKIPWORD$(),LOOKFIELD(),DD$(),F$,FT$
1070 DIM V$(5)
1080 '
OPEN SOURCE FILE
1090 PRINT:INPUT"Name of source file";X$
1100 GOSUB 1820:F2$=Y$ 'ucv
1110 IF MID$(F2$,2,1)=":" THEN 1130
1120 F2$=DD$(5)+F2$
1130 '
TEST FOR EXISTENCE
1140 ON ERROR GOTO 1170
1150 OPEN"I",3,F2$
1160 ON ERROR GOTO 0:GOTO 1210 'ok
1170 CLOSE 3
1180 IF ERR=53 THEN CLOSE 3:PRINT"File not found":RESUME 1080
1190 IF ERR=64 THEN PRINT"Bad file name, try again.":RESUME 1080
1200 ON ERROR GOTO 0
1210 '
READ FILE, PARSE
1220 GOSUB 1740 'exit
1230 IF EOF(3) THEN 1690
1240 FOR I=1 TO NC:B$(I)="":NEXT:NR=NR+1
1250 LINE INPUT #3,L$
1260 PRINT L$
1270 L1$=MID$(L$,2,92):STATE$=MID$(L$,97,2):ZIP$=MID$(L$,102,5):NOTE$=MID$(L$,110,13):L$=""
1280 X=INSTR(L1$,"*")
1281 IF X<>0 THEN 1290
1282 X=INSTR(L1$,CHR$(34))
1283 X$=LEFT$(L1$,X-1):GOSUB 1940:V$(1)=X$:V$(2)="":L1$=MID$(L1$,X+3):GOTO 1320
1290 V$(1)=LEFT$(L1$,X-1):L1$=MID$(L1$,X+1)
1300 X=INSTR(L1$,CHR$(34))
1310 X$=LEFT$(L1$,X-1):GOSUB 1940:V$(2)=X$:L1$=MID$(L1$,X+3)
1320 X=INSTR(L1$,CHR$(34))
1330 V$(3)=LEFT$(L1$,X-1):L1$=MID$(L1$,X+3)
1340 X=INSTR(L1$,CHR$(34))
1350 V$(4)=LEFT$(L1$,X-1)
1360 V$(5)=MID$(L1$,X+3):L1$=""
1370 ' PUT INTO DIMS ARRAY
1380 B$(1)=V$(1)
1390 B$(2)=V$(2)
1400 IF V$(4)="" THEN 1410 ELSE 1430
1410 B$(3)="":B$(4)=V$(3):B$(5)=V$(5)+" "+STATE$:B$(6)=ZIP$
1420 X$=NOTE$:GOSUB 1910:B$(9)=X$:GOTO 1450
1430 B$(3)=V$(3):B$(4)=V$(4):B$(5)=V$(5)+" "+STATE$:B$(6)=ZIP$
1440 X$=NOTE$:GOSUB 1910:B$(9)=X$
1450 '
ADD RECORD TO DIMS FILE
1460 T$=""
1470 FOR J=1 TO NC
1480 IF LEN(T$)+LEN(B$(J))+1>FT*128
THEN PRINT"Record too long."
1490 T$=T$+B$(J)+CHR$(126)
1500 NEXT
1510 N=N+1:PRINT N;T$
1520 GOSUB 1550:PRINT"*";:GOSUB 1620:PRINT"!":C=1
1530 '
LOOP
1540 GOTO 1210
1550 '
(SUB) WRITE T$ AS RECORD # N
1560 ON FT GOTO 1590,1570
1570 LSET R$=MID$(T$,129) 'latter half
1580 PUT #1,FT*N+2
1590 LSET R$=LEFT$(T$,128) 'first half
1600 PUT #1,FT*N+1
1610 RETURN
1620 '
(SUB) WRITE T$ AS DUPE REC N
1630 ON FT GOTO 1660,1640
1640 LSET S$=MID$(T$,129)
1650 PUT #2,FT*N+2
1660 LSET S$=LEFT$(T$,128)
1670 PUT #2,FT*N+1
1680 RETURN
1690 '
FINISH
1700 CLOSE 3
1710 PRINT:PRINT NR"records added.
1720 PRINT:PRINT TAB(32)"Re-loading DEDIT.
1730 CHAIN DD$(1)+"DEDIT",1000
1740 '
EXIT TEST (TERM DEP)
1750 X$=INKEY$:X=0
1760 IF X$<>"" THEN X=ASC(X$)
1770 IF X=27 THEN CLOSE 3:GOTO 1690 'use ESC to escape listing
1780 RETURN
1790 '
CLEAR SCREEN (TERM DEP)
1800 PRINT CHR$(12);
1810 RETURN
1820 '
(SUB) UCV
1830 Y$=""
1840 FOR K=1 TO LEN(X$)
1850 Y$=Y$+CHR$(32)
1860 X=ASC(MID$(X$,K,1))
1870 IF 96<X AND X<123 THEN MID$(Y$,K,1)=CHR$(X-32):GOTO 1890
1880 MID$(Y$,K,1)=MID$(X$,K,1)
1890 NEXT
1900 RETURN
1910 ' (SUB) TRIM LEFT SPACES from X$
1920 IF LEFT$(X$,1)=" " THEN X$=RIGHT$(X$,LEN(X$)-1) ELSE RETURN
1930 GOTO 1920
1940 ' (SUB) TRIM RIGHT SPACES from X$
1950 IF RIGHT$(X$,1)=" " THEN X$=LEFT$(X$,LEN(X$)-1) ELSE RETURN
1960 GOTO 1950
1940 ' (SU