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
/
DLABELS.ASC
< prev
next >
Wrap
Text File
|
1986-12-07
|
6KB
|
219 lines
10 PRINT"This program must be entered from DEDIT.":STOP
1000 GOSUB 2060 'cs
1010 PRINT:PRINT TAB(25);"DLABELS 1.02 - October 17, 1982
1015 ' by Dan Dugan -- public domain
1020 PRINT
1030 DEFINT A-Z
1040 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$
1060 '
SET-UP LABELS
1070 PRINT:PRINT"Please indicate the form that this list is in:
1080 PRINT:PRINT" 1. Short form, (NAME, N2, ADDR, C-ST, ZIP)
1085 PRINT" 2. Standard form, (LNAM, FNAM, N2, ADDR, C-ST, ZIP)
1090 PRINT" 3. Long form, (LNAM, FNAM, TITL, ORG, ADDR etc.)
1100 PRINT:PRINT"Enter 1, 2 or 3: ";
1110 A$=INPUT$(1): IF A$=CHR$(13) THEN A$="1"
1120 PRINT A$: A=VAL(A$): IF A=0 THEN 1740
1125 IF A<1 OR A>3 THEN 1100
1130 PL=A-1
1140 GOSUB 1870 ' align labels
1150 '
RECORD WORK LOOP
1160 C2=0 ' first time
1170 LC=0 ' count
1180 '
1190 FOR I=T1 TO T2 ' <==== FOR
1200 GOSUB 2210 ' get rec
1205 IF ASC(T$)=0 THEN PRINT"0";:GOTO 1720
1210 PRINT"+";
1220 T1$=T$ ' save it
1230 IF SKIPPARSE=1 THEN 1250
1240 GOSUB 1780 ' parse record string
1250 IF SEARCH=0 THEN 1540
1260 '
SEARCH
1270 IF SEARCH<>2 THEN 1320
1275 '
FIND
1280 IF INSTR(T$,SEARCHWORD$(0))=0 THEN 1720
1300 GOSUB 1780 ' parse
1310 GOTO 1540
1320 '
FIELD SEARCH
1330 J=0 ' check for skips first
1340 IF SKIPWORD$(J)="" THEN 1420 ' try search then
1350 IF LOOKFIELD(J)<>0 THEN 1390 ' look in field
1360 IF INSTR(T1$,SKIPWORD$(J))<>0 THEN 1720 ' whole rec search - skip it
1370 J=J+1
1380 GOTO 1340
1390 IF INSTR(B$(LOOKFIELD(J)),SKIPWORD$(J))<>0 THEN 1720 ' field compare - skip
1395 IF B$(LOOKFIELD(J))="" AND SKIPWORD$(J)="_" THEN 1720 'blank
1400 J=J+1
1410 GOTO 1340
1420 IF SEARCHWORD$(0)="" THEN 1520 ' don't care so print it
1430 J=0: GOTO 1450 ' now search
1440 IF SEARCHWORD$(J)="" THEN 1720 ' hesitate no longer
1450 IF SEARCHFIELD(J)<>0 THEN 1490 ' field
1460 IF INSTR(T1$,SEARCHWORD$(J))<>0 THEN 1520 ' found it
1470 J=J+1
1480 GOTO 1440
1490 IF INSTR(B$(SEARCHFIELD(J)),SEARCHWORD$(J))<>0 THEN 1520
1495 IF B$(SEARCHFIELD(J))="" AND SEARCHWORD$(J)="_" THEN 1520
1500 J=J+1
1510 GOTO 1440
1520 '
GET READY TO DO IT
1530 IF SKIPPARSE=1 THEN GOSUB 1780 ' parse
1540 '
PAUSE CONTROLS (TERM DEP IF UPPERCASE ONLY)
1541 GOSUB 2030 ' exit returns A
1542 IF A=122 THEN 1560 ' z means go on
1543 PRINT I;B$(1);TAB(30);"Ready (SPACE/z/r/n/ESC) >";
1544 A$=INPUT$(1):A=ASC(A$):IF A=27 THEN CLOSE 3:GOTO 1740
1545 PRINT A$:IF A=13 OR A=32 OR A=122 THEN 1560
1546 IF A=114 THEN I=IPREV:GOTO 1200 ' r
1547 IF A=110 THEN 1548 ELSE 1540 ' n or loop
1548 INPUT"Enter number of desired record: ";I:GOTO 1200
1550 GOSUB 2030 ' exit
1560 '
PRINT LABEL
1562 LC=LC+1:IPREV=I
1570 IF PL=1 THEN GOSUB 2290 ' reformat medium to short form
1575 IF PL=2 THEN GOSUB 2090 ' reformat long to short form
1580 IF P9=0 THEN PRINT
1590 PRINT"("I")"
1600 T3=0 ' counts blank lines
1610 FOR J=1 TO 3
1620 IF B$(J)="" OR B$(J)=" " THEN T3=T3+1: GOTO 1640
1630 IF P9=1 THEN LPRINT B$(J) ELSE PRINT B$(J)
1640 NEXT J
1650 IF P9=1 THEN LPRINT B$(4); ELSE PRINT B$(4);
1660 IF P9=1 THEN IF LPOS(0)<15 THEN LPRINT TAB(15);
1670 IF P9=0 THEN IF POS(0)<15 THEN PRINT TAB(15);
1680 IF P9=1 THEN LPRINT" "B$(5) ELSE PRINT" "B$(5)
1690 FOR J=1 TO T3+2
1700 IF P9=1 THEN LPRINT ELSE PRINT
1710 NEXT J
1720 GOSUB 2030 ' check exit
1730 NEXT I ' END OF RECORD WORK LOOP
1740 '
FINISH
1750 IF P9 THEN LPRINT"count:"LC:FOR J=1 TO 5:LPRINT:NEXT
1760 PRINT:PRINT:PRINT TAB(32)"Re-loading DEDIT.
1770 CHAIN DD$(1)+"DEDIT",1000
1780 '
(SUB) PARSE STRING
1790 K=0
1800 M=INSTR(T$,CHR$(126)) ' delimiter
1810 IF M=0 THEN RETURN
1820 K=K+1
1830 B$(K)=""
1840 B$(K)=MID$(T$,1,M-1)
1850 T$=MID$(T$,M+1)
1860 GOTO 1800
1870 '
(SUB) ALIGN LABELS
1880 PRINT"Print test label? (y/n) ";
1890 A$=INPUT$(1): PRINT A$: IF A$=CHR$(13) THEN A$="y"
1900 IF A$="n" THEN RETURN
1910 IF A$<>"y" THEN 1880
1920 A$(1)="<------- Dan Dugan Sound Design ------>" ' 39 wide
1930 A$(2)="File: "+F$+" Date:"
1940 A$(3)="Selection:"
1950 IF P9 THEN LPRINT A$(1) ELSE PRINT A$(1)
1960 IF P9 THEN LPRINT A$(2) ELSE PRINT A$(2)
1970 IF P9 THEN LPRINT A$(3) ELSE PRINT A$(3)
1980 IF P9 THEN LPRINT A$(1) ELSE PRINT A$(1)
1990 FOR J=1 TO 2
2000 IF P9=1 THEN LPRINT ELSE PRINT
2010 NEXT J
2020 GOTO 1870
2030 '
(SUB) EXIT TEST (TERM DEP)
2040 X$=INKEY$
2042 IF X$<>"" THEN A=ASC(X$)
2045 IF A=27 THEN CLOSE 3:GOTO 1740 'use ESC to escape listing
2050 RETURN
2060 '
(SUB) CLEAR SCREEN (TERM DEP)
2070 PRINT CHR$(12);
2080 RETURN
2090 '
(SUB) LONG FORM LABEL RE-FORMAT
2100 IF B$(1)="" AND B$(2)="" OR B$(3)="" THEN 2190
2110 IF B$(2)="" THEN B$(1)=B$(1)+", "+B$(3): GOTO 2130
2120 B$(1)=B$(2)+" "+B$(1)+", "+B$(3)
2130 IF LEN(B$(1))>39 THEN B$(1)=LEFT$(B$(1),39)
2140 B$(2)=B$(4)
2150 B$(3)=B$(5)
2160 B$(4)=B$(6)
2170 B$(5)=B$(7)
2180 RETURN
2190 IF B$(2)+B$(1)="" THEN B$(1)=B$(3) ELSE
IF B$(2)="" THEN B$(1)=B$(1) ELSE
B$(1)=B$(2)+" "+B$(1)
2200 GOTO 2130
2210 '
(SUB) GET RECORD "I" IN T$
2220 T$="" ' necessary!
2230 ON FT GOTO 2260,2240
2240 GET#1,FT*I+2 ' latter half
2250 T$=LEFT$(R$,127)
2260 GET#1,FT*I+1 ' whole or first half
2270 T$=R$+T$
2280 RETURN
2290 '
(SUB) MEDIUM FORM RE-FORMAT
2300 B$(1)=B$(2)+" "+B$(1)
2310 B$(2)=B$(3)
2320 B$(3)=B$(4)
2330 B$(4)=B$(5)
2340 B$(5)=B$(6)
2350 RETURN
RE-FORMAT
23