1 'standard skeleton
5 'g03b gestab
'$INCLUDE: 'qb4\incl\routB.bas'
'$INCLUDE: 'qb4\incl\routIX.bas'
'$INCLUDE: 'qb4\incl\writext.bas'
DECLARE SUB buildset (ow%, mm%, delanom%)
DECLARE FUNCTION amg$ (x$)
'$INCLUDE: 'qb4\incl\print.bas'
ON ERROR GOTO 25100
qx$(0) = "001": maxr% = 72: tcl% = 7: sms% = 7
proc$ = "xxxx": iniproc proc$
tit$ = "Argument"
df1% = 1'mayn record type
250 GOSUB opn
DIM mff$(5), ff$(7), msk$(3), psel(2), tt$(24), r$(50), kalt(100), dnrf(2)
DATA"mask1","mask2","mask3": FOR i% = 1 TO 3: READ msk$(i%): NEXT
DATA "Insert","Change","View","Print","Rebuild Index"
DATA "Delete": FOR i% = 1 TO 6: READ ff$(i%): NEXT
opn: openfl 1: 'openfl ...
IF dberr% > 0 THEN 40100
openix 1: 'openix ...
RETURN
clo: closix 1: closfl 0: RETURN
1000 f1% = df1%: tr% = f1%: dtr% = tr%: tm% = tr%: dtm% = tr%
swhlp% = 0: GOSUB 38000
x$ = "Managing " + nametrk$(tr%, 2) + "\" + STR$(nrec(f1%)) + "\" + STR$(ndel(f1%))
swfld% = 1: menu x$, ff$(), 6, 2, "", fz%, cf%: IF cf% < 4 THEN GOSUB clo: END
swfld% = 2: t0$ = ff$(fz%) + " " + nametrk$(tr%, 1)
swalf% = 0: ON fz% GOTO 2000, 3000, 4000, 4000, 8910, 3000
'insertion on indexed file
2000 IF nrec(f1%) >= dnrf(f1%) THEN dnrf(f1%) = nrec(f1%) ELSE STOP
inibuf tr%: oldk$ = "": swshw% = 0
tx$ = t0$ + " ": w.invr = 1: GOTO 3050
2010 IF cf% < 4 THEN 1000 ELSE 2000
'identification of position on indexed file
3000 CLS : rg% = 1: cl% = 10: f1% = df1%
x$ = t0$ + " n.": in$ = "": w.invr = 2: ff% = df1%
GOSUB 20050: IF cf% < 4 THEN 1000
swshw% = 1: k$ = curkey$(df1%): oldk$ = k$
3050 IF swshw% = 0 THEN swshw% = 1: GOSUB 18200: GOSUB 35000
3090 IF fz% = 6 THEN 3500
'update on indexed file
3100 param$ = "": GOSUB 15400: IF cf% = 1 THEN 3260
IF ok% = 0 THEN 1000
updarc fz%, f1%, oldk$, 0
IF dberr% > 0 THEN 1000
3250 GOSUB 18600
3260 IF fz% = 1 THEN 2010
GOTO 3000
'delete on indexed file
3500 GOSUB 20190: IF x% = 0 THEN 3000
delix f1%: IF dberr% = 20 THEN 8900
IF dberr% > 0 THEN x$ = msg$("Operation NOT executed"): GOTO 1000
GOTO 3000
'view/print list
4000 f1% = df1%: tr% = dtr%: w.vs = fz% - 2: vs% = w.vs
titolo ff$(fz%)
4002 bounds df1%, 5, swkey%, k1$, k2$, psel(), nmax%, nk%, cf%: IF cf% < 4 THEN 1000
4030 x$ = nametrk$(dtr%, 2): l% = LEN(x$): l1% = LEN(k1$): l2% = LEN(k2$): tt% = l% + l1% + l2% + 25
k01$ = k1$: k02$ = k2$: lm% = 84 - w.vs * 5
IF tt% > lm% THEN
d% = tt% - lm%: d2% = l2% - d%
IF d2% > 2 THEN
k02$ = LEFT$(k2$, d2%)
ELSE
k02$ = LEFT$(k2$, 2)
d% = tt% - l2% + 2 - lm%: d1% = l1% - d%
IF d1% > 1 THEN k01$ = LEFT$(k1$, d1%) ELSE STOP'caso molto improbabile
END IF
END IF
tst$ = "List " + x$ + " from " + k01$ + " to " + k02$
tm% = dtm% + 10: GOSUB 38000
4040 w.vs = vs%
w.nr = 99: w.np = 0: ww$ = "": recpos% = 0: ntrov% = nk%: selez% = 0
4100 multiread df1%, swkey%, psel(), recpos%, ntrov%: IF recpos% = 9 THEN 4210
GOSUB 22050: IF ww$ <> "*" THEN 4100
4210 msn$ = "Read" + STR$(ntrov%) + " positions"
w.swtop = 0: w.swend = 1: GOSUB 22901: IF ww$ = "c" THEN 4000
GOTO 1000
8900 BEEP: IF msg$("You MUST reorder the file") = "*" THEN 1000
8910 closix f1%: creind proc$, f1%
openix f1%: GOTO 1000
'reading and updating a chain
10000 rets% = 0
IF fo% = 1 THEN x$ = "ns" ELSE x$ = "sn"
param$ = "@" + x$ + "\"
10100 fm% = 3: mf$ = "o": tm% = 3: dtr% = 3: df1% = 3
updset fo%, fm%, mf$, rets%, cf%: IF rets% = 9 THEN RETURN
ON rets% GOTO 10110, 10120, 10130, 10140
10110 f1% = fm%: GOSUB 18200: invr% = 2: GOSUB 35000: GOTO 10100
10120 w.invr = 2: GOTO 10132
10130 w.invr = 1: GOSUB 18000: invr% = 1: GOSUB 35000
10132 GOSUB 15400: IF ok% = 0 OR cf% < 4 OR cf% = 6 AND w.invr = 1 THEN RETURN ELSE 10100
10140 GOSUB 18500: GOTO 10100
'form managing
15400 ret% = 0: IF param$ = "" THEN param$ = "00"
w.swcic = 1: w.swcf6 = 0
15418 mskgen 4, param$, r$(), w, 0, ret%, in$, tr%, i%, j%: IF ret% < 10 THEN 16100
cf% = ret% - 10: IF cf% = 1 THEN ok% = 0: RETURN
GOSUB 17100: IF ok% = 1 OR sw$ = "*" THEN RETURN ELSE 15400
15428 ret% = 2: GOTO 15418
16000 x$ = "sn"
16001 IF INSTR(x$, in$) = 0 THEN 15418 ELSE 15428
'controls on fields
16100 ON tr% GOTO 16110, 16120'...
'record type 1
16110 'se ok, 15428 / ko, 15418
'record type 2
16120 '...
'final controls for various TRK
17100 ok% = 1'IF ... THEN RETURN
17900 ok% = 0: BEEP: sw$ = msg$(x$): RETURN
'integrate data after inibuf
18000 IF w.invr = 1 THEN x% = 3 - fo%: inibuf x%
RETURN
'integrate data before showing input form
18200 RETURN
'any connect not executed by updset
18500 RETURN
'complete update
18600 RETURN
'search of location to manage
20050 IF swalf% <> 0 THEN 20052
swkey% = 0
findpos rg%, cl%, ff%, x$, in$, swkey%, swalf%, dlk%, cf%: IF dberr% > 0 THEN 40100
IF cf% < 4 THEN RETURN
20052 k = currec(ff%): tx$ = t0$ + STR$(k)
GOSUB 18200: GOSUB 35000
SELECT CASE swalf%
CASE 0
sw% = 3
CASE 1
nexprix ff%, dlk%, sw%
END SELECT: ON sw% GOTO 20054, 20052, 20056
20054 swalf% = 0: cf% = 1
20056 RETURN
20190 insn 25, 50, "Confirm DELETION", "n", x$, x%, cf%: pulrig 25, 25: RETURN
22050 x% = f1%: ret% = 0: vs$ = ""
22060 textgen x%, w, ret%, vs$, r$()
IF ret% = 1 THEN GOSUB 37400: x% = sws%: ret% = 2: GOTO 22060
22901 w.rfog = maxr%: w.rutl = maxr% - 6
ww$ = writext$(r$(), tt$(), tst$, sel$, msn$, w): RETURN
25100 IF ERR = 24 OR ERR = 25 OR ERR = 27 THEN IF msg$("Turn on printer, please...") = "*" THEN RESUME 900 ELSE RESUME
IF ERR = 70 THEN RESUME
25110 PRINT "Error "; ERR; " at line "; ERL: STOP
35000 GOSUB 38000: ret% = 0: x$ = tx$
35010 mskshow x$, w, ret%: IF ret% = 9 THEN RETURN
GOSUB 37400: x$ = vs$: ret% = 2: GOTO 35010
37400 IF w.tb = 1 THEN vs$ = tx$ + SPACE$(60): RETURN
STOP
'form definition
'external definitions
37900 msk2def proc$, msk$(tm%): GOTO 38810
38000 IF tm% = curtm% THEN RETURN ELSE curtm% = tm%
IF tm% < 10 THEN 37900
ON tm% - 10 GOTO 38110',38120,...: STOP
'internal definitions
'load: swcls%,sp%,swdop%,swcmp%,nrs%,ric$,rt%,rd%,nds%,tr%,i%,lus%,...
38110 RESTORE 38110: DATA 1,6,1,0,1,"nn",5,7,2,1,1,9,1,2,32: GOTO 38800
38800 ret% = 1: WHILE ret% < 99: READ x$: msk1def x$, ret%: WEND
38810 mskparm tt$(), w, x1$, x2$: RETURN
40100 x$ = msg$("Error dberr=" + STR$(dberr%) + " not foreseen"): closfl 0: END
