Compucolor.org – Virtual Media

Listing of file='CREDDL.BAS;01' on disk='vmedia/personal_database-sector.ccvf'

100 REM  ** CREDDL - MAY 27,79 **
110 CLEAR 1000:DIM D$(50),M(50),C(50):FG= PEEK (33265)
120 ADR= 256* PEEK (32941)+ PEEK (32940):DD= PEEK (ADR+ 1):PP= PEEK (ADR+ 4)
130 IF PEEK (ADR+ 2)= 99THEN SAVE "1:CREDDL":LOAD "CRSEG":RUN
140 PLOT 6,0,12,14,6,11,3,17,0
150 PRINT " CREATE DATA DESCRIPTOR FILE "
160 PLOT 6,6,15,3,0,4
170 IF DD= 2THEN INPUT "   INSERT DATA DISK - HIT RETURN ";I$
180 PLOT 3,0,4
190 PRINT TAB( 10):INPUT "ENTER NAME OF DESCRIPTOR FILE: ";F$:REM 
200 IF F$= "EXIT"THEN 1050
210 D$= F$:F$= F$+ ".DDL":IF DD= 3THEN F$= "1:"+ F$
220 PRINT :PRINT TAB( 10)
230 FILE "T",240:FILE "R",1,F$,1:GOTO 660
240 FILE "E",F,E,L:IF E< > 14THEN PRINT "BAD FILE NAME":PRINT :GOTO 190
250 N= 0:P= 1
260 REM

    ** ENTER FIELD DESCRIPTORS **

270 PRINT TAB( 10):IF N= 0THEN PRINT "KEY FIELD";TAB( 22)
280 IF N> 0THEN PRINT "FIELD";N;TAB( 22)
290 PRINT "COL("P")"TAB( 34)
300 INPUT ": ";A$:IF A$= "0"OR LEN (A$)= 0THEN 470
310 FOR I= 1TO LEN (A$):IF MID$ (A$,I,1)= " "THEN 340
320 NEXT I
330 PLOT 11:PRINT TAB( 10);"ERROR":GOTO 270
340 D$(N)= MID$ (A$,1,I- 1):A$= MID$ (A$,I+ 1)
350 FOR I= 1TO LEN (A$):IF MID$ (A$,I,1)= " "THEN 370
360 NEXT I:M$= "1":GOTO 410
370 M$= MID$ (A$,I+ 1):J= I
380 IF J= 0THEN J= 1:GOTO 400
390 IF MID$ (A$,J,1)< > "A"OR MID$ (A$,J,1)< > "N"THEN J= J- 1:GOTO 380
400 A$= MID$ (A$,J,I)
410 IF N= 0AND LEFT$ (A$,1)< > "A"THEN 330
420 IF LEFT$ (A$,1)= "N"THEN C(N)= - 4:GOTO 450
430 IF LEFT$ (A$,1)< > "A"THEN 330
440 C(N)= INT (VAL (MID$ (A$,2))):IF C(N)< = 0OR C(N)> 255THEN 330
450 M(N)= INT (VAL (M$)):IF M(N)< 1THEN 330
460 P= P+ ABS (C(N))* M(N):N= N+ 1:GOTO 270
470 REM

    ** DISPLAY FIELDS ENTERED **

480 NR= N:GOSUB 910
490 PRINT :PRINT TAB( 10):INPUT "ANY CHANGES (Y/N) ";A$
500 IF A$< > "N"THEN 560
510 IF C(0)< = 0THEN 480
520 FILE "T",1090:FILE "N",F$,N,24,5:FILE "R",1,F$,1
530 FOR I= 0TO N- 1:PUT 1,I+ 1;D$(I)[16],C(I),M(I):NEXT I
540 FILE "C",1:PRINT :PRINT TAB( 10);"DESCRIPTOR ";D$;" IS STORED"
550 GOTO 1050
560 REM

    ** EDIT FIELDS **

570 PRINT :PRINT TAB( 10):INPUT "DELETE OR ADD FIELDS (D/A) ";A$
580 IF A$= "A"THEN 260
590 PRINT TAB( 10);
600 INPUT "ENTER NAME OF FIELD TO BE DELETED: ";A$
610 A$= A$+ " ":L= LEN (A$)
620 J= 0:FOR I= 0TO N- 1
630 IF LEFT$ (D$(I)+ " ",L)< > A$THEN D$(J)= D$(I):C(J)= C(I):M(J)= M(I):J= J+ 1
640 IF D$(I)= A$THEN P= P- ABS (C(I))* M(I)
650 NEXT I:N= J:GOTO 470
660 REM

     ** FILE ALREADY EXIST **

670 PRINT TAB( 10);"A DESCRIPTOR FILE CALLED ";D$;" ALREADY EXIST."
680 PRINT TAB( 10);"SELECT ONE OF THE FOLLOWING:":PRINT
690 PRINT TAB( 10);"1. CREATE A NEW FILE"
700 PRINT TAB( 10);"2. EDIT THE ABOVE DESCRIPTOR TO CREATE A NEW FILE"
710 PRINT TAB( 10);"3. PRINT DESCRIPTOR - RETURN TO MENU"
720 PRINT TAB( 10);"4. RETURN TO MENU DISPLAY":PRINT
730 PRINT TAB( 20);:INPUT "ENTER NUMBER DESIRED: ";I:REM 
740 IF I< 1OR I> 4THEN 730
750 IF  I= 1 THEN RUN
760 IF  I= 4 THEN 1050
770 FILE "A",1,C,NR,RS,BF:N= NR
780 FOR I1= 0TO NR- 1:GET 1;D$(I1)[16],C(I1),M(I1):NEXT I1:FILE "C",1
790 IF  I= 2 THEN 860
800 IF  PP= 0 THEN 830
810 PRINT :PRINT TAB( 10):INPUT "OUTPUT TO THE SCREEN OR A PRINTER? ";I$:REM 
820 IF  LEFT$ (I$,1)= "P"THEN PLOT  27,13
830 GOSUB 900
840 POKE  33265,FG:PRINT :PRINT TAB( 17):INPUT "HIT RETURN TO CONTINUE";I$
850 GOTO 1050
860 REM  ** EDIT OLD DESCRIPTOR **
870 PRINT :PRINT TAB( 10):INPUT "ENTER NEW NAME OF DESCRIPTOR FILE : ";F$:REM 
880 D$= F$:F$= F$+ ".DDL":IF DD= 3THEN F$= "1:"+ F$
890 GOSUB 900:GOTO 570
900 REM

    ** PRINT FILE CONTENTS **

910 FOR I= 4TO 30:PLOT 3,0,I,11:NEXT I
920 PLOT 3,0,4:CL= 1
930 PRINT TAB( 10);"DESCRIPTOR FILE - ";D$;""
940 PRINT :PRINT TAB( 6);"FIELD NAME";TAB( 26);
950 PRINT "TYPE";TAB( 36);"REPEAT";TAB( 46);"COLUMN"
960 FOR I= 0TO NR- 1:PRINT TAB( 6);D$(I);TAB( 26)
970 IF C(I)= - 4THEN PRINT "N";
980 IF C(I)> 0THEN PRINT "A";C(I);
990 PRINT TAB( 36);M(I);TAB( 46);CL:CL= CL+ ABS (C(I))* M(I):NEXT I
1000 P= CL:PRINT TAB( 33);"TOTAL LENGTH";TAB( 46);CL- 1
1010 IF C(0)> 0THEN RETURN
1020 PRINT :PRINT TAB( 10);"ERROR - FIRST FIELD MUST BE ALPHA"
1030 PRINT :RETURN
1040 REM

     ** EXIT PROGRAM - RETURN TO MENU **

1050 PRINT :PRINT TAB( 10)
1060 IF DD= 2THEN INPUT "INSERT PROGRAM DISK - HIT RETURN ";I$
1070 LOAD "MAIN":RUN
1080 REM

     ** PRINT FILE ERROR **

1090 PRINT :PRINT "FILE ERROR - CAN'T CREATE FILE":GOTO 1050