|
DataMuseum.dkPresents historical artifacts from the history of: CP/M |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about CP/M Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - metrics - download
Length: 36096 (0x8d00)
Types: TextFile
Names: »ENTRY.BAS«
└─⟦f51bd807e⟧ Bits:30005981/disk5.imd Turn Key Data Entry System/Datenerfassungspaket - Vers. 1.90
└─⟦this⟧ »ENTRY.BAS«
1 REM ************************************************** 2 REM * * 3 REM * MODULE : ENTRY .BAS (TKDES/RC700) * 4 REM * DATE : 01.02.82 * 5 REM * BY : ASE GMBH , 6472 ALTENSTADT * 6 REM * VERSION: 1.90 * 7 REM * * 8 REM ************************************************** 10 REM 11 REM ************************************************************************ 12 REM * SET ERROR-HANDLING-POINTER AND READ WORK-NO. * 13 REM ************************************************************************ 15 ON ERROR GOTO 10000 20 DEPFORM% = 0 : ARBSTATOPEN% = 0 : ARBSTATWRITE% = 0 : USRFORMFOPEN% = 0 : ENTRYSTATERR% = 0 30 ERRFLAG% = 0 : FILENAME$ = "CHAININF.DEP" 40 OPEN "R",#5,FILENAME$,26 60 FIELD #5,12 AS CHAININFO1$,12 AS CHAININFO2$,2 AS CHAININFO3$ 70 ERRFLAG% = 0 : GET #5,1 90 FORMNAME$ = CHAININFO1$ : DATANAME$ = CHAININFO2$ : ARBNR$ = CHAININFO3$ 92 ERRFLAG% = 0 : CLOSE 100 REM *********************************************************************** 102 REM * CHAIN TO SEL. PROGRAMM * 103 REM *********************************************************************** 110 IF VAL(ARBNR$) < 1 OR VAL(ARBNR$) > 11 GOTO 3900 120 IF VAL(ARBNR$) = 3 THEN GOTO 25020 130 IF VAL(ARBNR$) = 4 OR VAL(ARBNR$) = 5 THEN GOTO 23010 ELSE GOTO 3900 1000 REM ********************************************************************** 1002 REM * SUB.: (ESC) INPUT AFTER ERRMSG. * 1004 REM ********************************************************************** 1006 PRINT CHR$(7); : ESCINPUT$ = INPUT$(1) : IF ASC(ESCINPUT$) <> 27 GOTO 1002 1008 PRINT SPACE$(76); : RETURN 1980 REM ********************************************************************** 1985 REM * SUB.: POS. CURSOR * 1990 REM ********************************************************************** 1992 PRINT CHR$(13); 1994 PRINT CHR$(6);CHR$(XPOS%+31);CHR$(YPOS%+31); 1998 RETURN 3868 REM ********************************************************************** 3870 REM * PRINT ERRMSG. IN LINE 25 * 3872 REM ********************************************************************** 3874 ERRMSGNR% = 1 : GOSUB 20000 : GOSUB 1000 : GOTO 3900 3900 REM ********************************************************************** 3910 REM * CHAIN TO ENTRY-MENUE * 3920 REM ********************************************************************** 3930 CHAIN "B:CHAININF.COM" 3940 SYSTEM REM *** NO CHAIN-MODUL ! WARM BOOT ! 4760 REM ********************************************************************** 4762 REM * PRINT ERRMSG. IN LINE 25 * 4764 REM ********************************************************************** 4770 ERRMSGNR% = 7 : GOSUB 20000 4790 GOSUB 1000 : GOTO 3900 5285 REM ********************************************************************** 5290 REM * SUB.: WRITE FILENAME TO ARBSTAT-DIR * 5300 REM ********************************************************************** 5310 IF DIR2% = 1 GOTO 5380 5320 MID$(ARBSTATDIR1$,RELPOS1%,12) = MID$(FILENAME$,1,12) 5340 RELPOS1% = RELPOS1% +12 5350 MID$(ARBSTATDIR1$,RELPOS1%,4) = STR$(R1%) 5360 GOTO 5412 5380 MID$(ARBSTATDIR2$,RELPOS2%,12) = MID$(FILENAME$,1,12) 5400 RELPOS2% = RELPOS2% + 12 5410 MID$(ARBSTATDIR2$,RELPOS2%,4) = STR$(R1%) 5412 ARBSTATRECCOUNT$ = MID$(ARBSTATDIR1$,11,4) : ARBSTATRECCOUNT% = VAL(ARBSTATRECCOUNT$) 5414 ARBSTATRECCOUNT% = ARBSTATRECCOUNT% + 1 : ARBSTATRECCOUNT$ = STR$(ARBSTATRECCOUNT%) 5416 NARBSTATRECCOUNT$ = SPACE$(4) : RSET NARBSTATRECCOUNT$ = ARBSTATRECCOUNT$ 5418 MID$(ARBSTATDIR1$,11,4) = NARBSTATRECCOUNT$ 5419 RETURN 6600 REM ********************************************************************** 6610 REM * SUB.: DECREMENT RECORD-COUNTER * 6620 REM ********************************************************************** 6625 RECCOUNT$ = MID$(NONZ50$,39,6) : RECCOUNT% = VAL(RECCOUNT$) 6630 RECCOUNT% = RECCOUNT% - 1 : RECCOUNT$ = STR$(RECCOUNT%) 6635 NRECCOUNT$ = SPACE$(6) : RSET NRECCOUNT$ = RECCOUNT$ 6640 MID$(NONZ50$,39,6) = NRECCOUNT$ : RETURN 7000 REM ********************************************************************** 7002 REM * ENOUGH SPACE FOR MORE FILES IN ARBSTAT ? * 7004 REM ********************************************************************** 7010 R1% = 1 : DIR2% = 0 7020 FOR RELPOS1% = 15 TO 239 STEP 16 7030 R1% = R1% + 1 7040 IF MID$(ARBSTATDIR1$,RELPOS1%,1) = " " GOTO 7120 7050 NEXT RELPOS1% 7060 DIR2% = 1 7070 FOR RELPOS2% = 1 TO 225 STEP 16 7080 R1% = R1% + 1 7090 IF MID$(ARBSTATDIR2$,RELPOS2%,1) = " " GOTO 7120 7100 NEXT RELPOS2% 7110 NOSPACEFLAG% = 1 : RETURN 7120 NOSPACEFLAG% = 0 : RETURN 7210 REM ********************************************************************** 7212 REM * SUB.: CLEAR ADD/SUB/MUL REGISTER * 7214 REM ********************************************************************** 7220 MID$(MR$,1,15) = SPACE$(15) : MID$(ADDR$,1,225) = SPACE$(225) : MID$(SUBR$,1,135) = SPACE$(135) 7230 RETURN 7240 REM ********************************************************************** 7242 REM * SUB.: TEST GENERAL-STATUS (DEP) * 7244 REM ********************************************************************** 7250 GENERALST$ = MID$(ST$,1,2) : PRIMST$ = MID$(ST$,3,2) : SEKST$ = MID$(ST$,5,2) 7260 GENERALST% = VAL(GENERALST$) : PRIMST% = VAL(PRIMST$) : SEKST% = VAL(SEKST$) 7270 ON GENERALST% GOTO 7330,7320,7320,7320,7320,7320,7320 7272 REM ********************************************************************** 7274 REM * PRINT ERRMSG. IN LINE 25 * 7276 REM ********************************************************************** 7280 ERRMSGNR% = 8 : GOSUB 20000 7300 GOSUB 1000 : RETURN 7310 REM ********************************************************************** 7320 PRIMST% = 8 : RETURN 7330 RETURN 7400 REM ********************************************************************** 7402 REM * SUB.: FILE IN ARBSTAT-DIR * 7404 REM ********************************************************************** 7410 FILEINDIR% = 0 : DIR2% = 0 : NAME$ = SPACE$(16) 7412 FOR I% = 15 TO 239 STEP 16 7420 IF MID$(ARBSTATDIR1$,I%,12) = FILENAME$ GOTO 7480 7430 NEXT I% 7435 DIR2% = 1 7440 FOR I% = 1 TO 225 STEP 16 7450 IF MID$(ARBSTATDIR2$,I%,12) = FILENAME$ GOTO 7480 7460 NEXT I% 7470 FILEINDIR% = 0 : RETURN 7480 IF DIR2% = 1 THEN NAME$ = MID$(ARBSTATDIR2$,I%,16) ELSE NAME$ = MID$(ARBSTATDIR1$,I%,16) 7485 FILEINDIR% = 1 : RETURN 8000 REM ********************************************************************** 8002 REM * PRINT ERRMSG. IN LINE 25 * 8004 REM ********************************************************************** 8010 ERRMSGNR% = 4 : GOSUB 20000 8030 GOSUB 1000 : GOTO 26120 8050 REM ******************* FATAL SYSTEM ERROR ******************************* 8060 GOTO 8270 8100 REM ******************* DISC I/O ERROR *********************************** 8110 GOTO 8270 8120 REM ******************* DISC FULL **************************************** 8130 GOTO 26120 8140 REM ******************* CP/M DIR FULL ************************************ 8150 GOTO 8270 8160 REM ******************* CLOSE ARBSTAT ************************************ 8170 ERRFLAG% = 0 : CLOSE #1 8190 ARBSTATOPEN% = 0 : ARBSTATWRITE% = 0 : RETURN 8200 REM ******************* CLOSE FORMFILE *********************************** 8210 ERRFLAG% = 0 : USRFORMFOPEN% = 0 8220 CLOSE #2 : RETURN 8230 REM ******************* UPDATE ARBSTAT *********************************** 8240 MID$(NONZ50$,23,3) = "K.." : DRECCOUNT$ = SPACE$(6) : PRECCOUNT$ = SPACE$(6) : CRECCOUNT$ = SPACE$(6) 8241 RSET DRECCOUNT$ = STR$(DRECCOUNT%) 8242 MID$(SM$,1,3) = MID$(DRECCOUNT$,1,3) : MID$(WF$,1,3) = MID$(DRECCOUNT$,4,3) 8244 MID$(VA$,1,4) = MID$(PRECCOUNT$,1,4) : MID$(PC$,1,2) = MID$(PRECCOUNT$,5,2) 8246 MID$(PC$,3,2) = MID$(CRECCOUNT$,1,2) : MID$(FL$,1,4) = MID$(CRECCOUNT$,3,4) 8248 LSET NONZ$ = NONZ50$ : LSET SP$ = PSTATUS$ 8250 GOSUB 9550 : RETURN REM *** WRITE ARBSTAT 8260 REM ********************************************************************** 8262 REM * ERROR !!! WRITE ERROR-NO. TO ARBSTAT * 8264 REM ********************************************************************** 8270 IF ARBSTATOPEN% AND ARBSTATWRITE% THEN GOTO 8280 ELSE GOTO 8330 8280 MID$(PSTATUS$,1,2) = STR$(ERR) 8290 MID$(PSTATUS$,3,5) = STR$(ERL) 8295 LSET SP$ = PSTATUS$ 8300 MID$(NONZ50$,23,3) = "ERR" : LSET NONZ$ = NONZ50$ : GOSUB 9550 REM *** WRITE ARBSTAT 8330 GOTO 3900 9000 REM ******************* OPEN ARBSTAT ************************************* 9100 FILENAME$ = "ARBSTAT.DEP" 9120 ERRFLAG% = 0 : OPEN "R",#1,FILENAME$,512 9125 ARBSTATOPEN% = 1 9130 RETURN 9140 REM ******************* FIELD FOR ARBSTAT AND DEP ************************ 9150 FIELD #1,54 AS NONZ$,8 AS SP$,2 AS MO$,3 AS FLN$,3 AS SM$,6 AS ST$,3 AS WF$,4 AS VA$,4 AS FC$,4 AS PC$,4 AS FL$,6 AS EE$,6 AS VE$,6 AS KE$,6 AS KV$,6 AS EC$,6 AS FK$,6 AS VK$,15 AS MR$,225 AS ADDR$,135 AS SUBR$ 9160 RETURN 9170 REM ******************* READ ARBSTAT DIR ********************************* 9180 FIELD #1,255 AS ARBSTATDIR1$,255 AS ARBSTATDIR2$,2 AS NOTUSED$ 9200 ERRFLAG% = 0 : GET #1,1 9202 IF MID$(ARBSTATDIR1$,1,10) = "ARBSTATDIR" THEN RETURN 9210 ERRFLAG% = 8 : RETURN 9220 REM ********************************************************************** 9222 REM * PRINT ERRMSG. IN LINE 25 * 9224 REM ********************************************************************** 9230 ERRMSGNR% = 5 : GOSUB 20000 9250 GOSUB 1000 : RETURN 9270 REM ******************* OPEN FORM FILE ********************************* 9280 USRFORMFOPEN% = 1 9340 ERRFLAG% = 0 : OPEN "R",#2,FORMNAME$,1922 9350 RETURN 9360 REM ******************* WRITE ARBSTAT-DIR ******************************** 9370 ERRFLAG% = 0 : PUT #1,1 9420 RETURN 9430 REM ******************* INIT A NEW ARBSTAT ******************************* 9450 LSET NONZ$ = NONZ50$ 9460 LSET SP$ = PSTATUS$ 9470 LSET MO$ = MODE$ : LSET FLN$ = FIELDNO$ : LSET SM$ = SPECMOD$ 9530 RETURN 9540 REM ******************** WRITE ARBSTAT *********************************** 9550 ERRFLAG% = 0 : PUT #1,R1% 9555 ARBSTATWRITE% = 1 9560 RETURN 9562 REM ******************** READ ARBSTAT ************************************ 9564 ERRFLAG% = 0 9566 GET #1,R1% : RETURN 9570 REM ******************** INIT FORMBUFFER ********************************* 9580 FIELD #2,2 AS FORMBYTES$,255 AS FORMREC1$,255 AS FORMREC2$,255 AS FORMREC3$,255 AS FORMREC4$,255 AS FORMREC5$,255 AS FORMREC6$,255 AS FORMREC7$,135 AS FORMREC8$ 9585 RETURN 9640 REM ******************** WRITE FORMREC *********************************** 9650 ERRFLAG% = 0 9655 FORMBYTES1$ = "#&" : LSET FORMBYTES$ = FORMBYTES1$ 9660 PUT #2,FORMNR% 9670 RETURN 9672 REM ******************** READ FORMREC ************************************ 9674 ERRFLAG% = 0 9676 GET #2,FORMNR% 9678 RETURN 9680 REM ********************************************************************** 9682 REM * SUB.: INCREMENT RECORD-COUNTER * 9684 REM ********************************************************************** 9690 RECCOUNT$ = MID$(NONZ50$,39,6) : RECCOUNT% = VAL(RECCOUNT$) 9700 RECCOUNT% = RECCOUNT% + 1 : RECCOUNT$ = STR$(RECCOUNT%) 9705 NRECCOUNT$ = SPACE$(6) : RSET NRECCOUNT$ = RECCOUNT$ 9710 MID$(NONZ50$,39,6) = NRECCOUNT$ : RETURN 9900 REM ********************************************************************** 9910 REM * ERROR-HANDLING * 9920 REM ********************************************************************** 9930 ON ERRFLAG% GOTO 8060,8060,8060,8060,8110,8130,8150,8010 9940 GOTO 3900 10000 REM ***************************** E R R O R **************************** 10010 REM 10020 REM errflag% = 1 = "file not found" 10030 REM errflag% = 2 = "file already exists" 10040 REM errflag% = 3 = "bad filename" 10050 REM errflag% = 4 = "fatal error" 10060 REM errflag% = 5 = "disc i/o error" 10070 REM errflag% = 6 = "disc full" 10080 REM errflag% = 7 = "cp/m dir full" 10085 REM errflag% = 8 = "no arbstatdir" 10090 IF ERR < 50 OR ERR > 67 GOTO 10110 10100 ON ERR-49 GOTO 10110,10110,10110,10310,10110,10110,10110,10160,10310,10110,10110,10210,10110,10110,10310,10110,10110,10290 10102 REM ********************************************************************* 10104 REM * PRINT BASIC ERRMSG. IN LINE 25 * 10106 REM ********************************************************************* 10110 XPOS% = 1 : YPOS% = 25 : GOSUB 1990 10120 PRINT CHR$(144);"FEHLER #";ERR;"/";ERL;" DATEI: ";FILENAME$;" (0N ERR) !! (ESC)";CHR$(128);CHR$(13); 10140 GOSUB 1000 : ERRFLAG% = 4 : RESUME 9900 10150 REM ********************************************************************* 10152 REM * PRINT ERRMSG. IN LINE 25 * 10154 REM ********************************************************************* 10160 ERRMSGNR% = 9 : GOSUB 20000 10190 GOSUB 1000 : ERRFLAG% = 5 : RESUME 9900 10200 REM ********************************************************************* 10202 REM * PRINT ERRMSG. IN LINE 25 * 10204 REM ********************************************************************* 10210 ERRMSGNR% = 10 : GOSUB 20000 10240 GOSUB 1000 : ERRFLAG% = 6 : RESUME 9900 10250 REM ********************************************************************* 10290 ERRFLAG% = 7 : RESUME 9900 10310 ERRFLAG% = 1 : RESUME 9900 10320 ERRFLAG% = 2 : RESUME 9900 10330 ERRFLAG% = 3 : RESUME 9900 20000 REM ********************************************************************* 20001 REM * PRINT ERRMSG. ON CRT * 20002 REM ********************************************************************* 20070 XPOS% = 1 : YPOS% = 25 : GOSUB 1990 20080 PRINT CHR$(144);" *** "; 20090 ON ERRMSGNR% GOSUB 20120,20130,20140,20150,20160,20170,20180,20190,20200,20210,20220,20230,20240 20095 PRINT " !! (ESC) *** ";CHR$(128);CHR$(30);CHR$(13); 20115 RETURN 20120 PRINT "FORMAT-DATEI NICHT VORHANDEN"; : RETURN REM *** MSG. 01 20130 PRINT "SATZGRØSSE UNGLEICH FORMATGRØSSE"; : RETURN REM *** MSG. 02 20140 PRINT "ERFASSUNGSSTATUS DER ARBEITSDATEI ";MID$(DATANAME$,1,8);" = ";ENTRYSTAT$; : RETURN 20150 PRINT "ARBEITS-STATUS-DATEI NICHT VORHANDEN"; : RETURN REM *** MSG. 04 20160 PRINT "ARBEITS-STATUS-DATEI VOLL"; : RETURN REM *** MSG. 05 20170 PRINT "ERFASSUNGSSTATUS DER FORMAT-DATEI ";MID$(FORMNAME$,1,8);" = ";ENTRYSTAT$; : RETURN 20180 PRINT "KEINE SYSTEM-FORMATE"; : RETURN REM *** MSG. 07 20190 PRINT "DEP FEHLER-STATUS"; : RETURN REM *** MSG. 08 20200 PRINT "SCHREIB- ODER LESEFEHLER AUF DER DISKETTE"; : RETURN REM *** MSG. 09 20210 PRINT "DISKETTE VOLL"; : RETURN REM *** MSG. 10 20220 PRINT "KEIN FORMAT NR. ";CHAINFORMNR$; : RETURN REM *** MSG. 11 20230 PRINT "BEGINN DER DATEI"; : RETURN REM *** MSG. 12 20240 PRINT "ENDE DER DATEI"; : RETURN REM *** MSG. 13 20700 REM ********************************************************************* 20702 REM * DELETE A FILE * 20704 REM ********************************************************************* 20710 IF ARBSTATOPEN% GOTO 20730 ELSE GOSUB 9100 REM *** OPEN ARBSTAT 20730 XPOS% = 1 : YPOS% = 25 : GOSUB 1990 : PRINT CHR$(30); 20735 GOSUB 9180 REM *** READ ARBSTATDIR 20750 IF MID$(DATANAME$,1,1) = " " GOTO 20760 20755 FILENAME$ = DATANAME$ : GOTO 20770 20760 IF MID$(FORMNAME$,1,1) = " " GOTO 3900 20765 FILENAME$ = FORMNAME$ 20770 GOSUB 7410 REM *** SEARCH FILE IN FILEDIR 20780 IF FILEINDIR% THEN GOTO 20790 ELSE IF MID$(DATANAME$,1,1) = " " THEN GOTO 3900 ELSE GOTO 3900 20790 IF ENTRYSTATERR% THEN GOTO 20810 ELSE ERRFLAG% = 0 : KILL FILENAME$ REM *** KILL CP/M FILE 20810 IF DIR2% GOTO 20840 20820 MID$(ARBSTATDIR1$,I%,16) = SPACE$(16) 20830 GOTO 20841 20840 MID$(ARBSTATDIR2$,I%,16) = SPACE$(16) 20841 GOSUB 21020 REM *** DECREMENT ARBSTAT RECCOUNT 20842 GOSUB 9370 REM *** WRITE ARBSTATDIR 20846 IF ENTRYSTATERR% GOTO 3900 20850 XPOS% = 1 : YPOS% = 25 : GOSUB 1990 20860 PRINT CHR$(144);"*** ";MID$(FILENAME$,1,8);" GELØSCHT !!! "; 20870 IF VAL(ARBNR$) = 11 THEN PRINT "***";CHR$(128);CHR$(13);CHR$(7); : GOTO 3900 20880 PRINT "ANZAHL SÆTZE = 00 !! (ESC) ";CHR$(128);CHR$(13);CHR$(7); : GOSUB 1000 : GOTO 3900 21010 REM ********************************************************************* 21012 REM * SUB.: DECREMENT ARBSTAT-RECORD-COUNTER * 21014 REM ********************************************************************* 21020 ARBSTATRECCOUNT$ = MID$(ARBSTATDIR1$,11,4) : ARBSTATRECCOUNT% = VAL(ARBSTATRECCOUNT$) 21030 ARBSTATRECCOUNT% = ARBSTATRECCOUNT% - 1 : ARBSTATRECCOUNT$ = STR$(ARBSTATRECCOUNT%) 21040 NARBSTATRECCOUNT$ = SPACE$(4) : RSET NARBSTATRECCOUNT$ = ARBSTATRECCOUNT$ 21050 MID$(ARBSTATDIR1$,11,4) = NARBSTATRECCOUNT$ 21060 RETURN 23000 REM ********************************************************************* 23005 REM CONTINUE-ENTRY MODE 23010 REM ********************************************************************* 23020 GOSUB 9100 REM *** OPEN ARBSTAT 23030 GOSUB 9170 REM *** READ ARBSTATDIR 23040 FILENAME$ = DATANAME$ 23050 GOSUB 7410 REM *** SEARCH FILE IN ARBSTAT-DIR 23060 IF FILEINDIR% THEN SNAME$ = NAME$ : GOTO 23090 23070 GOSUB 8170 REM *** CLOSE ARBSTAT 23080 GOTO 3900 23090 IF MID$(FORMNAME$,1,1) <> " " THEN GOTO 23180 23100 R1$ = MID$(SNAME$,13,4) : R1% = VAL(R1$) 23110 GOSUB 9150 : GOSUB 9564 REM *** READ DATA ARBSTAT 23150 MID$(FORMNAME$,1,8) = MID$(NONZ$,11,8) : MID$(FORMNAME$,9,4) = ".FRM" 23160 GOSUB 9170 REM *** READ ARBSTATDIR 23180 FILENAME$ = FORMNAME$ 23190 GOSUB 7410 REM *** SEARCH FILE IN ARBSTAT-DIR 23200 IF FILEINDIR% GOTO 23240 23210 GOSUB 8170 REM *** CLOSE ARBSTAT 23230 GOTO 3874 23240 R1$ = MID$(NAME$,13,4) : R1% = VAL(R1$) 23246 CRECCOUNT$ = SPACE$(6) : MID$(CRECCOUNT$,1,2) = MID$(PC$,3,2) : MID$(CRECCOUNT$,3,4) = FL$ 23250 GOSUB 9150 : GOSUB 9564 REM *** READ FORMARBSTAT 23260 IF MID$(NONZ$,23,1) <> "K" THEN ENTRYSTAT$ = MID$(NONZ$,23,3) : GOSUB 27210 : GOTO 23070 23270 RECLENGTH$ = MID$(NONZ$,19,4) : RECLENGTH% = VAL(RECLENGTH$) 23290 FORMNRBUFFER$ = ADDR$ : FORMCHBUFFER$ = SUBR$ 23300 R1$ = MID$(SNAME$,13,4) : R1% = VAL(R1$) 23310 GOSUB 9564 REM *** READ DATA-ARBSTAT 23322 SRECLENGTH$ = MID$(NONZ$,19,4) : IF VAL(SRECLENGTH$) = RECLENGTH% THEN GOTO 23326 23324 GOSUB 27280 : GOTO 23070 23326 IF MID$(NONZ$,23,1) <> "K" THEN ENTRYSTAT$ = MID$(NONZ$,23,3) : GOSUB 27224 23330 NONZ50$ = NONZ$ : PSTATUS$ = SP$ : MID$(NONZ50$,23,3) = "S.." 23331 MID$(NONZ50$,11,8) = FORMNAME$ 23332 DRECCOUNT$ = SPACE$(6) : MID$(DRECCOUNT$,1,3) = SM$ : MID$(DRECCOUNT$,4,3) = WF$ 23340 WRECCOUNT$ = MID$(NONZ$,39,6) : WRECCOUNT% = VAL(WRECCOUNT$) : DRECCOUNT% = VAL(DRECCOUNT$) 23342 WRECCOUNT% = WRECCOUNT% + DRECCOUNT% 23343 IF VAL(ARBNR$) = 4 THEN RRECCOUNT% = WRECCOUNT% ELSE RRECCOUNT% = 0 23344 PRECCOUNT$ = SPACE$(6) : MID$(PRECCOUNT$,1,4) = VA$ : MID$(PRECCOUNT$,5,2) = MID$(PC$,1,2) 23346 CRECCOUNT$ = SPACE$(6) : MID$(CRECCOUNT$,1,2) = MID$(PC$,3,2) : MID$(CRECCOUNT$,3,4) = FL$ 23350 MODE$ = "02" : DATARECWRITE% = 1 23360 GOSUB 9450 REM *** WRITE ARBSTAT 23370 FILENAME$ = FORMNAME$ 23380 GOSUB 9280 REM *** OPEN FORMFILE 23387 GOSUB 9580 23390 FILENAME$ = DATANAME$ 23400 GOSUB 26820 REM *** OPEN DATAFILE 23410 GOSUB 26990 : GOSUB 27020 REM *** SET DATABUFFER-FIELD / CLEAR DATABUFFER 23420 FIRSTTIMEFLAG% = 1 23422 IF VAL(ARBNR$) = 4 THEN GOTO 26410 ELSE GOTO 26260 25000 REM ********************************************************************* 25005 REM ENTRY - MODE 25010 REM ********************************************************************* 25020 FIRSTTIMEFLAG% = 1 : GOSUB 9100 REM *** OPEN ARBSTAT 25030 GOSUB 9170 REM *** READ ARBSTAT DIR 25040 FILENAME$ = FORMNAME$ 25050 GOSUB 7410 REM *** FORMFILE IN ARBSTAT DIR ? 25060 IF FILEINDIR% GOTO 25090 25070 GOSUB 8170 REM *** CLOSE ARBSTAT 25080 GOTO 3874 25090 SNAME$ = NAME$ 25100 FILENAME$ = DATANAME$ 25105 GOSUB 7410 REM *** DATAFILE IN ARBSTAT DIR ? 25110 IF FILEINDIR% = 0 GOTO 25140 25120 GOSUB 8170 REM *** CLOSE ARBSTAT 25130 GOTO 3900 REM *** DATAFILE IN USE MSG 25140 GOSUB 7010 REM *** SPACE IN ARBSTAT DIR ? 25150 IF NOSPACEFLAG% = 0 GOTO 25190 25160 GOSUB 8170 REM *** CLOSE ARBSTAT 25170 GOSUB 9230 REM *** NO SPACE IN ARBSTAT MSG 25180 GOTO 3900 25190 SR1% = R1% : GOSUB 5310 REM ** SAVE R1% FOR NEW DATA-ARBSTAT/WRITE DATANAME 25192 GOSUB 9370 REM *** WRITE ARBSTAT-DIR 25200 R1$ = MID$(SNAME$,13,4) : R1% = VAL(R1$) 25210 GOSUB 9150 : GOSUB 9564 REM *** INIT AND READ FORMAT-ARBSTAT 25222 IF MID$(NONZ$,23,1) <> "K" THEN ENTRYSTAT$ = MID$(NONZ$,23,3) : ENTRYSTATERR% = 1 : GOSUB 27210 : GOTO 20700 25230 CHAINFORMNR$ = MID$(NONZ$,52,3) 25240 RECLENGTH$ = MID$(NONZ$,19,4) : RECLENGTH% = VAL(RECLENGTH$) 25245 FORMNRBUFFER$ = ADDR$ : FORMCHBUFFER$ = SUBR$ 25250 NONZ50$ = SPACE$(54) : PSTATUS$ = SPACE$(8) 25255 MID$(NONZ50$,3,8) = MID$(DATANAME$,1,8) : MID$(NONZ50$,11,8) = MID$(FORMNAME$,1,8) 25260 MID$(NONZ50$,19,4) = RECLENGTH$ : MID$(NONZ50$,23,3) = "S.." : MID$(NONZ50$,26,3) = "..." 25265 MID$(NONZ50$,29,1) = "N" : MID$(NONZ50$,30,6) = "......" : MID$(NONZ50$,39,6) = "000000" 25270 MID$(NONZ50$,45,6) = "000000" : MID$(NONZ50$,51,4) = CHAINFORMNR$ 25280 SPECMOD$ = "011" : MODE$ = "00" : FIELDNO$ = "000" 25290 R1% = SR1% : GOSUB 9450 : GOSUB 7220 : GOSUB 9550 REM *** WRITE ARBSTAT 25300 FILENAME$ = FORMNAME$ 25310 GOSUB 9280 REM *** OPEN FORMFILE 25320 GOSUB 9580 REM *** INIT FORMAT-BUFFER 25330 GOSUB 26730 REM *** GET RANDOM FORMNR 25335 IF FORMNRUSE% = 0 GOTO 27180 REM *** FORMNR NOT FOUND 25340 FIRSTTIMEFLAG% = 0 : GOSUB 9674 REM *** READ FORMAT-RECORD 25350 GOSUB 26810 REM *** CALC DATA-BUFFER AND OPEN DATA-FILE 25355 GOSUB 26990 : GOSUB 27020 25358 REM ********************************************************************* 25360 REM * INIT AND CALL THE DEP * 25361 REM ********************************************************************* 25362 FIELDNO$ = "000" : LSET FLN$ = FIELDNO$ 25365 F% = VARPTR(#2) : Z% = VARPTR(#1) : D% = VARPTR(#3) : CALL INIT(F%,Z%,D%) 25370 GOSUB 7240 REM *** GENERAL DEP-STATUS 25375 IF GENERALST% <> 1 THEN GOSUB 7280 ELSE GOTO 25390 25380 GOTO 26120 REM *** GENERAL STAT ERROR - USER EXIT 25390 FIELDNO$ = "001" : SPECMOD$ = "001" : LSET SM$ = SPECMOD$ : LSET FLN$ = FIELDNO$ 25400 F% = VARPTR(#2) : Z% = VARPTR(#1) : D% = VARPTR(#3) : CALL ENT(F%,Z%,D%) 25410 REM ********************************************************************* 25420 GOSUB 7240 REM *** GENERAL DEP-STATUS 25430 ON PRIMST% GOTO 25440,25470,25590,25610,25630,25650,25720,25740,25760,25780,25800,25830,25860,25890 25440 REM --- FIELD END --- 25450 FIELDNO$ = WF$ : LSET FLN$ = FIELDNO$ 25460 GOTO 25400 25470 REM --- FORMAT END / WRITE DATA --- 25480 IF VAL(MODE$) = 0 THEN GOSUB 9690 : WRECCOUNT% = WRECCOUNT% + 1 : RRECCOUNT% = RRECCOUNT% + 1 25482 IF INSERTREC% THEN NRINSERT% = NRINSERT% - 1 : DRECCOUNT% = DRECCOUNT% - 1 25490 IF VAL(MODE$) = 2 THEN SWRECCOUNT% = WRECCOUNT% : WRECCOUNT% = RRECCOUNT% : GOSUB 27080 ELSE GOTO 25520 25510 WRECCOUNT% = SWRECCOUNT% :GOTO 26260 25520 GOSUB 27080 25522 IF INSERTREC% THEN IF NRINSERT% <> 0 THEN GOTO 25530 ELSE GOTO 25524 ELSE GOTO 25530 25524 INSERTREC% = 0 : WRECCOUNT% = SIWRECCOUNT% : RRECCOUNT% = IWRECCOUNT% : MODE$ = "02" : LSET MO$ = MODE$ : GOTO 26260 25530 SFORMNR% = FORMNR% : CHAINFORMNR$ = FC$ : GOSUB 26720 25540 IF FORMNRUSE% = 0 GOTO 27170 REM *** FORMNR NOT FOUND 25550 IF FORMNR% = SFORMNR% GOTO 25390 REM *** NO FORMAT-NO. CHANGE 25560 IF MODE$ = "00" THEN GOSUB 27020 25565 GOSUB 9674 25580 GOTO 25360 25590 REM --- SEND KEY --- 25600 GOTO 25480 25610 REM --- FORWARD RECORD --- 25620 GOTO 26250 25630 REM --- BACKWARD RECORD --- 25640 GOTO 26360 25650 REM --- DELETE RECORD --- 25670 SRECCOUNT% = WRECCOUNT% : WRECCOUNT% = RRECCOUNT% : CHAINFORMNR$ = "000" : GOSUB 27090 25680 WRECCOUNT% = SRECCOUNT% 25690 GOSUB 6620 25700 IF WRECCOUNT% = RRECCOUNT% THEN WRECCOUNT% = WRECCOUNT% - 1 : RRECCOUNT% = RRECCOUNT% - 1 ELSE DRECCOUNT% = DRECCOUNT% + 1 25710 GOTO 26260 25720 REM --- INSERT RECORD --- 25730 GOTO 26480 25740 REM --- USER EXIT --- 25750 GOTO 26120 25760 REM --- CHANGE FORMAT CHAIN KEY --- 25770 SCHAINFORMNR$ = CHAINFORMNR$ : GOTO 25530 25780 REM --- SEARCH --- 25790 GOTO 25360 25800 REM --- FIELD FORWARD --- 25810 FIELDNO$ = WF$ : LSET FLN$ = FIELDNO$ 25820 GOTO 25400 25830 REM --- BACKWARD FIELD --- 25840 FIELDNO$ = WF$ : LSET FLN$ = FIELDNO$ 25850 GOTO 25400 25860 REM --- HOME KEY --- 25870 FIELDNO$ = WF$ : LSET FLN$ = FIELDNO$ 25880 GOTO 25400 25890 REM --- CHECK SECONDARY STATUS --- 25900 ON SEKST% GOTO 25910,25940,25970,26000,26020,26040,26070,26100 25910 REM --- FORM-MOD KEY --- 25920 FIELDNO$ = WF$ : LSET FLN$ = FIELDNO$ 25930 GOTO 25400 25940 REM --- FIELD KORR KEY --- 25950 FIELDNO$ = WF$ : LSET FLN$ = FIELDNO$ 25960 GOTO 25400 25970 REM --- FIELD KORR IN MUL REG --- 25980 FIELDNO$ = WF$ : LSET FLN$ = FIELDNO$ 25990 GOTO 25400 26000 REM --- ERROR FLAG COMPLETE --- 26010 GOTO 26120 26020 REM --- NO ERROR FLAG --- 26030 GOTO 26120 26040 REM --- FILL CHAR. UNCORRECTED --- 26050 FIELDNO$ = WF$ : LSET FLN$ = FIELDNO$ 26060 GOTO 25400 26070 REM --- SEQ. ERROR ON AUTO-INC. FIELD --- 26080 FIELDNO$ = WF$ : LSET FLN$ = FIELDNO$ 26090 GOTO 25400 26100 REM --- DISPLAY SUCCESSFULL --- 26110 GOTO 25400 26120 REM ********************************************************************* 26122 REM * USER EXIT * 26124 REM ********************************************************************* 26130 IF ARBSTATOPEN% = 0 GOTO 26220 26140 RECCOUNT$ = MID$(NONZ50$,39,6) : IF VAL(RECCOUNT$) <= 0 THEN RECCOUNT% = 0 : ELSE RECCOUNT% = 1 26150 GOSUB 8210 REM *** CLOSE FORMFILE 26170 IF RECCOUNT% = 0 THEN DATANAME$ = FILENAME$ : GOTO 20710 26180 GOSUB 8240 REM *** WRITE ARBSTAT 26200 GOSUB 8170 REM *** CLOSE ARBSTAT 26220 GOSUB 27160 REM *** CLOSE DATA-FILE 26240 GOTO 3900 26250 REM ********************************************************************* 26252 REM * FORWARD RECORD * 26254 REM ********************************************************************* 26260 IF VAL(ARBNR$) = 3 OR VAL(ARBNR$) = 4 THEN IF RRECCOUNT% = WRECCOUNT% THEN MODE$ = "00" : LSET MO$ = MODE$ : GOTO 25530 26262 IF VAL(ARBNR$) = 5 THEN IF RRECCOUNT% = WRECCOUNT% AND INSERTREC% THEN MODE$ = "00" : LSET MO$ = MODE$ : GOTO 25530 26264 IF VAL(ARBNR$) = 5 THEN IF RRECCOUNT% = WRECCOUNT% THEN GOSUB 27282 : GOTO 25390 26270 RRECCOUNT% = RRECCOUNT% + 1 26280 GOSUB 27130 REM *** READ DATA-RECORD 26300 IF VAL(FCK$) = 0 GOTO 26260 26310 IF VAL(CHAINFORMNR$) = VAL(FCK$) GOTO 25390 26320 CHAINFORMNR$ = FCK$ : GOSUB 26730 : IF FORMNRUSE% = 0 GOTO 27180 26330 GOSUB 9674 REM *** READ FORMAT-RECORD 26350 MODE$ = "02" : LSET MO$ = MODE$ : GOTO 25360 26360 REM ********************************************************************* 26362 REM * BACKWARD RECORD * 26364 REM ********************************************************************* 26370 IF VAL(MODE$) = 0 AND DATARECWRITE% = 0 THEN GOSUB 27240 : GOTO 25390 26380 IF VAL(MODE$) = 0 AND RRECCOUNT% <= 0 THEN GOSUB 27240 : GOTO 25390 ELSE IF VAL(MODE$) = 0 THEN MODE$ = "02" : LSET MO$ = MODE$ : GOTO 26410 26390 IF RRECCOUNT% <= 1 THEN GOSUB 27240 : IF DELETEREC% = 1 THEN GOTO 26250 ELSE GOTO 25400 26400 RRECCOUNT% = RRECCOUNT% - 1 26410 GOSUB 27140 REM *** READ DATA-RECORD 26420 IF VAL(FCK$) = 0 THEN DELETEREC% = 1 : GOTO 26370 ELSE DELETEREC% = 0 26430 IF VAL(CHAINFORMNR$) = VAL(FCK$) THEN GOTO 25390 26440 CHAINFORMNR$ = FCK$ : GOSUB 26730 : IF FORMNRUSE% = 0 GOTO 27180 26450 FIRSTTIMEFLAG% = 0 : GOSUB 9674 REM *** READ FORMAT-RECORD 26460 GOTO 25360 26470 REM ********************************************************************* 26472 REM * INSERT RECORD * 26474 REM ********************************************************************* 26480 XPOS% = 1 : YPOS% = 25 : GOSUB 1990 : NRINSERT$ = SPACE$(2) 26482 PRINT SPACE$(60);CHR$(13); 26490 PRINT CHR$(144);" WIEVIELE SÆTZE EINFÅGEN ?? .. ";CHR$(128);CHR$(8);CHR$(8);CHR$(8);CHR$(8);CHR$(8); 26500 FOR I% = 1 TO 2 26510 KEYINPUT$ = INPUT$(1) : IF ASC(KEYINPUT$) = 13 THEN GOTO 26570 26520 IF ASC(KEYINPUT$) = 8 AND I% = 2 THEN PRINT KEYINPUT$; : GOTO 26500 26530 IF ASC(KEYINPUT$) < 48 OR ASC(KEYINPUT$) > 57 THEN GOTO 26510 26540 PRINT KEYINPUT$; : MID$(NRINSERT$,I%,1) = KEYINPUT$ 26550 NEXT I% 26560 PRINT CHR$(8);CHR$(8); : KEYINPUT$ = SPACE$(1) : GOTO 26500 26570 NRINSERT% = VAL(NRINSERT$) 26580 IF NRINSERT% = 0 THEN XPOS% = 1 : YPOS% = 25 : GOSUB 1990 : PRINT SPACE$(33); : GOTO 25400 26590 SRRECCOUNT% = RRECCOUNT% : CHAINFORMNR$ = FC$ : INSERTREC% = 1 26600 IWRECCOUNT% = WRECCOUNT% + NRINSERT% : SIWRECCOUNT% = IWRECCOUNT% 26610 LOOPINSERT% = WRECCOUNT% - RRECCOUNT% + 1 26620 RRECCOUNT% = WRECCOUNT% 26630 FOR I% = 1 TO LOOPINSERT% 26640 GOSUB 27140 REM *** READ DATA-RECORD 26650 WRECCOUNT% = IWRECCOUNT% 26660 GOSUB 27100 REM *** WRITE DATA-RECORD 26670 IWRECCOUNT% = IWRECCOUNT% - 1 : RRECCOUNT% = RRECCOUNT% - 1 26672 NEXT I% 26673 LSET FC$ = CHAINFORMNR$ 26674 WRECCOUNT% = SRRECCOUNT% : CHAINFORMNR$ = "000" : GOSUB 27030 26676 FOR I% = 1 TO NRINSERT% 26678 GOSUB 27090 REM *** WRITE DATA-RECORD 26679 WRECCOUNT% = WRECCOUNT% + 1 26680 NEXT I% 26690 WRECCOUNT% = SRRECCOUNT% - 1 : DRECCOUNT% = DRECCOUNT% + NRINSERT% 26700 MODE$ = "00" : LSET MO$ = MODE$ 26710 XPOS% = 1 : YPOS% = 25 : GOSUB 1990 : PRINT SPACE$(33); : GOTO 25530 26720 REM ********************************************************************* 26722 REM * SUB.: GET RANDOM FORMAT-NO. * 26724 REM ********************************************************************* 26730 F% = 1 : F1% = 1 : FORMNRUSE% = 0 : CHAINFORMNR% = VAL(CHAINFORMNR$) 26740 FOR FP% = 1 TO 45 26750 OFORMNR$ = MID$(FORMNRBUFFER$,F%,4) : IF VAL(OFORMNR$) = CHAINFORMNR% GOTO 26790 26760 F% = F% + 4 : F1% = F1% + 3 26770 NEXT FP% 26780 RETURN 26790 FORMNRUSE% = 1 : FORMNR% = FP% : FORMCHKEY$ = MID$(FORMCHBUFFER$,F1%,3) 26800 RETURN 26810 REM ********************************************************************* 26812 REM * SUB.: CALC. DATABUFFER-SIZE AND OPEN DATA-FILE * 26814 REM ********************************************************************* 26820 DB1% = 0 : DB2% = 0 : DB3% = 0 : DB4% = 0 : DB5% = 0 : DB6% = 0 : DB7% = 0 : DB8% = 0 26830 FILENAME$ = DATANAME$ : IF RECLENGTH% =< 255 THEN DB1% = RECLENGTH% : GOTO 26870 26840 FOR I% = 1 TO 7 26850 IF RECLENGTH% > 255 THEN GOSUB 26910 26860 NEXT I% 26870 ERRFLAG% = 0 26880 DB% = DB% + DB1%+DB2%+DB3%+DB4%+DB5%+DB6%+DB7%+DB8%+3 26890 OPEN "R",#3,FILENAME$,DB% + 2 26900 RETURN 26910 ON I% GOTO 26920,26930,26940,26950,26960,26970,26980 26920 DB1% = 255 : RECLENGTH% = RECLENGTH% - 255 : DB2% = RECLENGTH% : RETURN 26930 DB2% = 255 : RECLENGTH% = RECLENGTH% - 255 : DB3% = RECLENGTH% : RETURN 26940 DB3% = 255 : RECLENGTH% = RECLENGTH% - 255 : DB4% = RECLENGTH% : RETURN 26950 DB4% = 255 : RECLENGTH% = RECLENGTH% - 255 : DB5% = RECLENGTH% : RETURN 26960 DB5% = 255 : RECLENGTH% = RECLENGTH% - 255 : DB6% = RECLENGTH% : RETURN 26970 DB6% = 255 : RECLENGTH% = RECLENGTH% - 255 : DB7% = RECLENGTH% : RETURN 26980 DB7% = 255 : RECLENGTH% = RECLENGTH% - 255 : DB8% = RECLENGTH% : RETURN 26990 REM ****************** SET DATA-BUFFER FIELD **************************** 27000 FIELD #3,DB1% AS DATA1$,DB2% AS DATA2$,DB3% AS DATA3$,DB4% AS DATA4$,DB5% AS DATA5$,DB6% AS DATA6$,DB7% AS DATA7$,DB8% AS DATA8$,3 AS FCK$,2 AS CRLF$ 27010 RETURN 27020 REM ****************** CLEAR DATABUFFER ********************************* 27030 LSET DATA1$ = SPACE$(DB1%) : LSET DATA2$ = SPACE$(DB2%) 27040 LSET DATA3$ = SPACE$(DB3%) : LSET DATA4$ = SPACE$(DB4%) 27050 LSET DATA5$ = SPACE$(DB5%) : LSET DATA6$ = SPACE$(DB6%) 27060 LSET DATA7$ = SPACE$(DB7%) : LSET DATA8$ = SPACE$(DB8%) 27070 RETURN 27080 REM ******************* WRITE DATA REC ********************************** 27090 MID$(FCK$,1,3) = CHAINFORMNR$ 27100 ERRFLAG% = 0 : MID$(CRLF$,1,1) = CHR$(13) : MID$(CRLF$,2,1) = CHR$(10) 27110 PUT #3,WRECCOUNT% 27120 DATARECWRITE% = 1 : RETURN 27130 REM ********************** READ DATA RECORD ***************************** 27140 ERRFLAG% = 0 : GET #3,RRECCOUNT% : RETURN 27150 REM ********************** CLOSE DATAFILE ******************************* 27160 ERRFLAG% = 0 : CLOSE #3 : RETURN 27170 REM ********************************************************************* 27172 REM * PRINT ERRMSG. IN LINE 25 * 27174 REM ********************************************************************* 27180 ERRMSGNR% = 11 : GOSUB 20000 27192 GOSUB 1000 27200 IF FIRSTTIMEFLAG% THEN GOTO 26130 ELSE IF PRIMST% = 9 THEN CHAINFORMNR$ = SCHAINFORMNR$ : GOTO 25400 ELSE GOTO 25400 27210 REM ********************************************************************* 27212 REM * SUB.: PRINT ERRMSG. IN LINE 25 * 27214 REM ********************************************************************* 27220 ERRMSGNR% = 6 : GOSUB 20000 : GOSUB 1000 : RETURN 27221 REM ********************************************************************* 27222 REM * SUB.: PRINT ERRMSG. IN LINE 25 * 27223 REM ********************************************************************* 27224 ERRMSGNR% = 3 : GOSUB 20000 : GOSUB 1000 : RETURN 27230 REM ********************************************************************* 27232 REM * SUB.: PRINT ERRMSG. IN LINE 25 * 27234 REM ********************************************************************* 27240 ERRMSGNR% = 12 : GOSUB 20000 27260 GOSUB 1000 : RETURN 27270 REM ********************************************************************* 27272 REM * SUB.: PRINT ERRMSG. IN LINE 25 * 27274 REM ********************************************************************* 27280 ERRMSGNR% = 2 : GOSUB 20000 : GOSUB 1000 : RETURN 27282 REM ********************************************************************* 27284 REM * SUB.: PRINT ERRMSG. IN LINE 25 * 27286 REM ********************************************************************* 27288 ERRMSGNR% = 13 : GOSUB 20000 27290 GOSUB 1000 : RETURN «eof»