Category : BASIC Source Code
Archive   : FONBOOK.ZIP
Filename : FONBOOK.BAS

'FONBOOK.BAS - A personal and business phone book
'Copyright (c) 1992 J&J Software Solutions
' 715 212th Street
' Pasadena, MD 21122
' (410)-360-3997
' Jack Dillard
'This a fairly simple program written to serve as an example of how to
'interface Btrieve into PowerBASIC, this program will demonstrate how to
'create a Btrieve file, open a file, close a file and perform
'several record operations, get first, get next, get greater than or equal,
'insert, update, delete and anything else I can throw in.
'All PB keywords are UPPERCASE, all PBTools routines are lower case
'All program variables are lower case, all program routines are MixedCase

'I have used a key prefix in this program to keep the personal and business
'phone numbers separate within the same file

'If anyone would like to contact me with any questions or comments about
'this program or Btrieve in general I can be reached at the above number
'after 7:00pm eastern time. I do not know all there is to know about Btrieve
'but I have used Btrieve in several commercial applications and may be able
'offer some assistance. Thanks to Lloyd Smith of Spectra Publishing for
'suggesting this demo and thanks to Dave Navarro for PBTools, which can be
'downloaded from the PB BBS as well as The Bards Lair, Dave's BBS.

'This app can be run with Btrieve started with default parameters (pagesize
'of 512 bytes) giving a pagesize usage of about 95%, 40 some unused
'bytes per page.

'-----------------------------------------------------------------------------

'Init routine

SHARED stuff$, stuff1%, ok$, text%, border%, redwht%, bluwht%, prompt$_
, numprompt$, bborder%, btext% 'These variables will be available
'to all routines

'******** PBTools Stuff *************
PUBLIC xpos%(), ypos%(), wattr%(), xlen%(), ylen%(), battr%(), scrsav$()_
, brdr%(), shad%(), pntr%(), curwin%, maxwin%
maxwin%=7
$LINK "windo.pbu"
$LINK "scrnio.pbu"
CALL initpbscreen
'***********************************************

border%=attr%(0,7):text%=attr%(0,7):redwht%=attr%(15,4):bluwht%=attr%(1,7)
prompt$=REPEAT$(30,"."):numprompt$=REPEAT$(15,"#"):hilite%=attr%(15,0)
background%=attr%(7,1):bborder%=attr%(15,1):btext%=attr%(15,1)
CLS
DIM menu1$(1:3)
menu1$(1)=" Personal phone book " 'The upper case letter in each line
menu1$(2)=" Business phone book " 'will become the hot key for that
menu1$(3)=" eXit the fone book " 'menu item
GOSUB OpenFile

'-----------------------------------------------------------------------------

'Draw main screen
CALL fill(1,1,25,80,177,background%)
COLOR 0,7:LOCATE 25,1:PRINT SPACE$(80);
LOCATE 25,17:PRINT "Copyright (c) 1992 J&J Software Solutions";
LOCATE 1,1:PRINT SPACE$(80);
LOCATE 1,34:PRINT "The Fone Book";
CALL openwin(10,25,5,30,3,text%,border%,3,1,0)

'-----------------------------------------------------------------------------

MainMenu:
choice1%=menu%(menu1$(),1,3,choice1%,hilite%,attr%(4,7))
IF choice1%<1 THEN choice1%=3:GOTO MainMenu 'escape key pressed in menu
IF choice1%=1 THEN GOTO Personal
IF choice1%=2 THEN GOTO Business
IF choice1%=3 THEN GOTO ByeBye
GOTO MainMenu

'-----------------------------------------------------------------------------

'Personal phone book file maintenance and inquiry
Personal:
GOSUB ClearVars1
isit%=0:edit%=0:comp$=SPACE$(30):bustitle$=SPACE$(30):keyprefix$="P"
CALL OpenPersonalForm
GetPerLastName:
CALL OpenNameWindow
COLOR 0,7
CALL EntryHere(4,28,15,lname$,"A")
CALL closewin
IF stuff$=CHR$(27) THEN 'Escape key pressed, entry cancelled
GOTO ExitPersonal
END IF
IF stuff1%<>60 AND stuff1%<>0 THEN 'If any other special key than F2
GOTO GetPerLastName 'pressed
END IF
lname$=stuff$
size=LEN(lname$)
IF stuff1%=60 THEN 'F2 key pressed, if data is input before
savename$=lname$ 'the F2 is pressed the lookup will start
saveprefix$=keyprefix$ 'with the entry in the file = or greater
GOSUB Namelookup 'than the data input
IF recnum%=0 THEN
lname$=savename$
keyprefix$=saveprefix$
GOTO GetPerLastName
ELSE
operation1%=5 'set btrieve op code to get equal
status1%=0 'init error status to 0
keybuffer1$=namekeys$(recnum%)
GOSUB Read1
IF status1%<>0 THEN 'Check to see if read was successful
CALL BtrError(status1%,1,operation1%)
GOTO ExitPersonal
END IF
GOTO DisplayPerEntry
END IF
END IF
IF size=0 THEN 'This is a required field, entry can not
GOTO GetPerLastName 'be skipped
END IF
lname$=lname$+SPACE$(15-size)
LOCATE 4,28
PRINT lname$

GetPerFirstName:
CALL EntryHere(4,56,15,fstname$,"A")
IF stuff$=CHR$(27) THEN
GOTO ExitPersonal
END IF
IF stuff1%<>72 AND stuff1%<>0 THEN
GOTO GetPerFirstName 'Check to see if any special keys were
END IF 'other than up arrow
fstname$=stuff$
size=LEN(fstname$)
IF stuff1%=72 THEN 'Up arrow key pressed, go to previous
lname$=RTRIM$(lname$) 'field
GOTO GetPerLastName
END IF
IF size=0 THEN
GOTO GetPerFirstName
END IF
fstname$=fstname$+SPACE$(15-size)
LOCATE 4,56
PRINT fstname$
IF edit%=1 THEN 'This value will be 1 if the data correct
GOTO GetPerAdd1 'question was answered no
END IF

GetPerEntry:
a1$=keyprefix$:b1$=lname$:c1$=fstname$
operation1%=5 'Get equal operation
status1%=0
keybuffer1$=keyprefix$+lname$+fstname$ 'set key to check for
GOSUB Read1
IF status1%<>0 AND status1%<>4 THEN
CALL BtrError(status1%,1,operation1%)
GOTO ExitPersonal
END IF
IF status1%=4 THEN 'status of 4 means record did not exist
isit%=0 'Entry does not exist in file
GOSUB ClearVars1
keyprefix$=a1$:lname$=b1$:fstname$=c1$
GOTO GetPerAdd1
END IF

DisplayPerEntry:
isit%=1 'Entry does exist in file
LOCATE 4,28:PRINT lname$;SPACE$(15-LEN(lname$))
LOCATE 4,56:PRINT fstname$
LOCATE 5,35:PRINT add1$
LOCATE 6,35:PRINT add2$
LOCATE 7,35:PRINT add3$
LOCATE 8,29:PRINT data1$
LOCATE 8,58:PRINT data2$
LOCATE 9,29:PRINT data3$
LOCATE 9,58:PRINT data4$
GOTO PerEntryCorrect

GetPerAdd1:
CALL EntryHere(5,35,30,add1$,"A")
IF stuff$=CHR$(27) THEN
GOTO ExitPersonal
END IF
IF stuff1%<>72 AND stuff1%<>0 THEN
GOTO GetPerAdd1
END IF
add1$=stuff$
size=LEN(add1$)
IF stuff1%=72 THEN
GOTO GetPerFirstName
END IF
LOCATE 5,35
PRINT add1$+SPACE$(30-size)

GetPerAdd2:
CALL EntryHere(6,35,30,add2$,"A")
IF stuff$=CHR$(27) THEN
GOTO ExitPersonal
END IF
IF stuff1%<>72 AND stuff1%<>0 THEN
GOTO GetPerAdd2
END IF
add2$=stuff$
size=LEN(add2$)
IF stuff1%=72 THEN
GOTO GetPerAdd1
END IF
LOCATE 6,35
PRINT add2$+SPACE$(30-size)

GetPerAdd3:
CALL EntryHere(7,35,30,add3$,"A")
IF stuff$=CHR$(27) THEN
GOTO ExitPersonal
END IF
IF stuff1%<>72 AND stuff1%<>0 THEN
GOTO GetPerAdd3
END IF
add3$=stuff$
size=LEN(add3$)
IF stuff1%=72 THEN
GOTO GetPerAdd2
END IF
LOCATE 7,35
PRINT add3$+SPACE$(30-size)

GetPerData1:
CALL EntryHere(8,29,15,data1$,"A")
IF stuff$=CHR$(27) THEN
GOTO ExitPersonal
END IF
IF stuff1%<>72 AND stuff1%<>0 THEN
GOTO GetPerData1
END IF
data1$=stuff$
size=LEN(data1$)
IF stuff1%=72 THEN
GOTO GetPerAdd3
END IF
LOCATE 8,29
PRINT data1$+SPACE$(15-size)

GetPerData2:
CALL EntryHere(8,58,15,data2$,"A")
IF stuff$=CHR$(27) THEN
GOTO ExitPersonal
END IF
IF stuff1%<>72 AND stuff1%<>0 THEN
GOTO GetPerData2
END IF
data2$=stuff$
size=LEN(data2$)
IF stuff1%=72 THEN
GOTO GetPerData1
END IF
LOCATE 8,58
PRINT data2$+SPACE$(15-size)

GetPerData3:
CALL EntryHere(9,29,15,data3$,"A")
IF stuff$=CHR$(27) THEN
GOTO ExitPersonal
END IF
IF stuff1%<>72 AND stuff1%<>0 THEN
GOTO GetPerData3
END IF
data3$=stuff$
size=LEN(data3$)
IF stuff1%=72 THEN
GOTO GetPerData2
END IF
LOCATE 9,29
PRINT data3$+SPACE$(15-size)

GetPerData4:
CALL EntryHere(9,58,15,data4$,"A")
IF stuff$=CHR$(27) THEN
GOTO ExitPersonal
END IF
IF stuff1%<>72 AND stuff1%<>0 THEN
GOTO GetPerData4
END IF
data4$=stuff$
size=LEN(data4$)
IF stuff1%=72 THEN
GOTO GetPerData3
END IF
LOCATE 9,58
PRINT data4$+SPACE$(15-size)

PerEntryCorrect:
CALL wprintc(7,"Data Correct? es/o/elete ",text%)
CALL EntryHere(10,65,1,"","A")
IF stuff$=CHR$(27) THEN
GOTO ExitPersonal
END IF
a$=UCASE$(stuff$)
IF a$="N" THEN
CALL wprintc(7,SPACE$(60),text%)
edit%=1 'The data has been entered and is being
GOTO GetPerLastName 'edited
END IF
IF a$="Y" THEN
IF edit%=1 AND isit%=1 THEN
operation1%=3 'Update operation, do not set the keybuffer
GOTO WritePerEntry ' to the new key, Btrieve will handle that
END IF
IF isit%=0 THEN
operation1%=2 'Insert operation
keybuffer1$=keyprefix$+lname$+fstname$ 'keybuffer must be set
GOTO WritePerEntry
END IF
IF edit%=0 AND isit%=1 THEN
CALL closewin 'Data is correct and has not been changed
GOTO Personal
END IF
END IF
IF a$="D" AND isit%=1 THEN 'Record does exist and is to be deleted
operation1%=4 'Set operation to delete
GOTO WritePerEntry 'Do not set keybuffer
END IF
GOTO PerEntryCorrect

WritePerEntry:
status1%=0 'Init error status
GOSUB Write1
IF status1%<>0 THEN 'Check for successful operation
CALL BtrError(status1%,1,operation1%)
GOTO ExitPersonal
END IF
CALL closewin
GOTO Personal

ExitPersonal:
GOSUB ClearVars1
GOSUB ExitToMain1
GOTO MainMenu

'-----------------------------------------------------------------------------

Business:
GOSUB ClearVars1
isit%=0:edit%=0:comp$=SPACE$(30):bustitle$=SPACE$(30):keyprefix$="B"
CALL OpenBusinessForm
GetBusLastName:
CALL OpenNameWindow
COLOR 0,7
CALL EntryHere(4,28,15,lname$,"A")
CALL closewin
IF stuff$=CHR$(27) THEN
GOTO ExitBusiness
END IF
IF stuff1%<>60 AND stuff1%<>0 THEN
GOTO GetBusLastName
END IF
lname$=stuff$
size=LEN(lname$)
IF stuff1%=60 THEN
savename$=lname$
saveprefix$=keyprefix$
GOSUB Namelookup
IF recnum%=0 THEN
lname$=savename$
keyprefix$=saveprefix$
GOTO GetBusLastName
ELSE
operation1%=5
status1%=0
keybuffer1$=namekeys$(recnum%)
GOSUB Read1
IF status1%<>0 THEN
CALL BtrError(status1%,1,operation1%)
GOTO ExitBusiness
END IF
GOTO DisplayBusEntry
END IF
END IF
IF size=0 THEN
GOTO GetBusLastName
END IF
lname$=lname$+SPACE$(15-size)
LOCATE 4,28
PRINT lname$

GetBusFirstName:
CALL EntryHere(4,56,15,fstname$,"A")
IF stuff$=CHR$(27) THEN
GOTO ExitBusiness
END IF
IF stuff1%<>72 AND stuff1%<>0 THEN
GOTO GetBusFirstName
END IF
fstname$=stuff$
size=LEN(fstname$)
IF stuff1%=72 THEN
lname$=RTRIM$(lname$)
GOTO GetBusLastName
END IF
IF size=0 THEN
GOTO GetBusFirstName
END IF
fstname$=fstname$+SPACE$(15-size)
LOCATE 4,56
PRINT fstname$
IF edit%=1 THEN
GOTO GetBusComp
END IF

GetBusEntry:
a1$=keyprefix$:b1$=lname$:c1$=fstname$
operation1%=5
status1%=0
keybuffer1$=keyprefix$+lname$+fstname$
GOSUB Read1
IF status1%<>0 AND status1%<>4 THEN
CALL BtrError(status1%,1,operation1%)
GOTO ExitBusiness
END IF
IF status1%=4 THEN
isit%=0
GOSUB ClearVars1
keyprefix$=a1$:lname$=b1$:fstname$=c1$
GOTO GetBusComp
END IF

DisplayBusEntry:
isit%=1
LOCATE 4,28:PRINT lname$;SPACE$(15-LEN(lname$))
LOCATE 4,56:PRINT fstname$
LOCATE 5,35:PRINT comp$
LOCATE 6,35:PRINT bustitle$
LOCATE 7,35:PRINT add1$
LOCATE 8,35:PRINT add2$
LOCATE 9,35:PRINT add3$
LOCATE 10,29:PRINT data1$
LOCATE 10,58:PRINT data2$
LOCATE 11,29:PRINT data3$
LOCATE 11,58:PRINT data4$
GOTO BusEntryCorrect

GetBusComp:
CALL EntryHere(5,35,30,comp$,"A")
IF stuff$=CHR$(27) THEN
GOTO ExitBusiness
END IF
IF stuff1%<>72 AND stuff1%<>0 THEN
GOTO GetBusComp
END IF
comp$=stuff$
size=LEN(comp$)
IF stuff1%=72 THEN
GOTO GetBusFirstName
END IF
LOCATE 5,35
PRINT comp$+SPACE$(30-size)

GetBusTitle:
CALL EntryHere(6,35,30,bustitle$,"A")
IF stuff$=CHR$(27) THEN
GOTO ExitBusiness
END IF
IF stuff1%<>72 AND stuff1%<>0 THEN
GOTO GetBusTitle
END IF
bustitle$=stuff$
size=LEN(bustitle$)
IF stuff1%=72 THEN
GOTO GetBusComp
END IF
LOCATE 6,35
PRINT bustitle$+SPACE$(30-size)

GetBusAdd1:
CALL EntryHere(7,35,30,add1$,"A")
IF stuff$=CHR$(27) THEN
GOTO ExitBusiness
END IF
IF stuff1%<>72 AND stuff1%<>0 THEN
GOTO GetBusAdd1
END IF
add1$=stuff$
size=LEN(add1$)
IF stuff1%=72 THEN
GOTO GetBusTitle
END IF
LOCATE 7,35
PRINT add1$+SPACE$(30-size)

GetBusAdd2:
CALL EntryHere(8,35,30,add2$,"A")
IF stuff$=CHR$(27) THEN
GOTO ExitBusiness
END IF
IF stuff1%<>72 AND stuff1%<>0 THEN
GOTO GetBusAdd2
END IF
add2$=stuff$
size=LEN(add2$)
IF stuff1%=72 THEN
GOTO GetBusAdd1
END IF
LOCATE 8,35
PRINT add2$+SPACE$(30-size)

GetBusAdd3:
CALL EntryHere(9,35,30,add3$,"A")
IF stuff$=CHR$(27) THEN
GOTO ExitBusiness
END IF
IF stuff1%<>72 AND stuff1%<>0 THEN
GOTO GetBusAdd3
END IF
add3$=stuff$
size=LEN(add3$)
IF stuff1%=72 THEN
GOTO GetBusAdd2
END IF
LOCATE 9,35
PRINT add3$+SPACE$(30-size)

GetBusData1:
CALL EntryHere(10,29,15,data1$,"A")
IF stuff$=CHR$(27) THEN
GOTO ExitBusiness
END IF
IF stuff1%<>72 AND stuff1%<>0 THEN
GOTO GetBusData1
END IF
data1$=stuff$
size=LEN(data1$)
IF stuff1%=72 THEN
GOTO GetBusAdd3
END IF
LOCATE 10,29
PRINT data1$+SPACE$(15-size)

GetBusData2:
CALL EntryHere(10,58,15,data2$,"A")
IF stuff$=CHR$(27) THEN
GOTO ExitBusiness
END IF
IF stuff1%<>72 AND stuff1%<>0 THEN
GOTO GetBusData2
END IF
data2$=stuff$
size=LEN(data2$)
IF stuff1%=72 THEN
GOTO GetBusData1
END IF
LOCATE 10,58
PRINT data2$+SPACE$(15-size)

GetBusData3:
CALL EntryHere(11,29,15,data3$,"A")
IF stuff$=CHR$(27) THEN
GOTO ExitBusiness
END IF
IF stuff1%<>72 AND stuff1%<>0 THEN
GOTO GetBusData3
END IF
data3$=stuff$
size=LEN(data3$)
IF stuff1%=72 THEN
GOTO GetBusData2
END IF
LOCATE 11,29
PRINT data3$+SPACE$(15-size)

GetBusData4:
CALL EntryHere(11,58,15,data4$,"A")
IF stuff$=CHR$(27) THEN
GOTO ExitBusiness
END IF
IF stuff1%<>72 AND stuff1%<>0 THEN
GOTO GetBusData4
END IF
data4$=stuff$
size=LEN(data4$)
IF stuff1%=72 THEN
GOTO GetBusData3
END IF
LOCATE 11,58
PRINT data4$+SPACE$(15-size)

BusEntryCorrect:
CALL wprintc(9,"Data Correct? es/o/elete ",text%)
CALL EntryHere(12,65,1,"","A")
IF stuff$=CHR$(27) THEN
GOTO ExitBusiness
END IF
a$=UCASE$(stuff$)
IF a$="N" THEN
CALL wprintc(9,SPACE$(60),text%)
edit%=1
GOTO GetBusLastName
END IF
IF a$="Y" THEN
IF edit%=1 AND isit%=1 THEN
operation1%=3
GOTO WriteBusEntry
END IF
IF isit%=0 THEN
operation1%=2
keybuffer1$=keyprefix$+lname$+fstname$
GOTO WriteBusEntry
END IF
IF edit%=0 AND isit%=1 THEN
CALL closewin
GOTO Business
END IF
END IF
IF a$="D" AND isit%=1 THEN
operation1%=4
GOTO WriteBusEntry
END IF
GOTO BusEntryCorrect

WriteBusEntry:
status1%=0
GOSUB Write1
IF status1%<>0 THEN
CALL BtrError(status1%,1,operation1%)
GOTO ExitBusiness
END IF
CALL closewin
GOTO Business

ExitBusiness:
GOSUB ExitToMain1
GOTO MainMenu

'-----------------------------------------------------------------------------

SUB EntryHere(ypos,xpos,maxsize,stuffin$,kind$)

'So I won't forget whats going on
'ypos = line for input
'xpos = col for input
'maxsize = maximum len of input
'stuffin$ = string sent to input routine
'kind$ = "A" - Non Masked Alphanumeric input
' "Nx" - Numeric Input, x = precision
' "D" - Date in MMDDYY format
' "X" - Fomatting and printing handled by calling routine
'
'Shared variables:
'stuff$ = Returned from routine to your program with users input
'stuff1% = Returned to your program with
' 72 if SHIFT-TAB or Up Arrow pressed
' 60 if F2 key pressed
' 61 if F3 key pressed
' 0 if none of the above keys pressed
' Any other special keys can be acted upon by checking
' for the appropriate scan code in this routine
'prompt$ = Prompt for string to be displayed for empty input
'numprompt$ = for number to be displayed

'Up arrow, down arrow, enter, tab and shift tab will exit this routine
'leaving the data input intact
'Escape will exit this routine causing all input to be lost
'Backspace, insert, right and left arrow keys are active in this
'routine

IF stuffin$="" THEN
stuff$=""
ELSE
stuff$=stuffin$
END IF
y=ypos:x=xpos:insertstat=1:ct=7:cb=7:stuff1%=0:ee%=0:n$=CHR$(0):x7$=""
LOCATE y,x,1,ct,cb
IF UCASE$(LEFT$(kind$,1))<>"X" THEN
IF stuff$="" OR stuff$=SPACE$(maxsize) THEN
IF UCASE$(LEFT$(kind$,1))="A" THEN
PRINT LEFT$(prompt$,maxsize)
END IF
IF UCASE$(LEFT$(kind$,1))="N" THEN
prec=VAL(MID$(kind$,2,LEN(kind$)))
PRINT LEFT$(numprompt$, maxsize-prec-1)+"."+LEFT$(numprompt$,prec)
END IF
IF UCASE$(LEFT$(kind$,1))="D" THEN
PRINT "MMDDYY"
END IF
ELSE
IF UCASE$(LEFT$(kind$,1))="A" THEN
PRINT stuff$
END IF
IF UCASE$(LEFT$(kind$,1))="D" THEN
PRINT LEFT$(stuff$,2);"/";MID$(stuff$,3,2);"/";RIGHT$(stuff$,2)
END IF
IF UCASE$(LEFT$(kind$,1))="N" THEN
prec=VAL(MID$(kind$,2,LEN(kind$)))
mask$=LEFT$(numprompt$, maxsize-prec-1)+"."+LEFT$(numprompt$,prec)
stuff%=VAL(stuff$)
PRINT USING mask$; stuff%
END IF
END IF
END IF
DO
LOCATE y,x,1,ct,cb
WHILE x7$=""
x7$=INKEY$
WEND
f%=0
IF x7$=CHR$(32) AND y=ypos AND x=xpos AND stuffin$<>"" THEN 'Space as
PRINT SPACE$(maxsize) 'first key
x7$="" 'deletes
stuff$="" 'current
END IF 'value
IF x7$=CHR$(13) OR x7$=CHR$(9) THEN 'CR or TAB exits routine
EXIT LOOP
END IF
IF x7$=CHR$(27) THEN 'ESC exits routine cancels
stuff$=x7$ 'all input
EXIT LOOP
END IF
WHILE LEN(x7$)=1
WHILE x7$=CHR$(8) 'Backspace key
IF stuff$<>"" THEN
curpos=x-xpos
IF curpos=0 THEN
x7$=""
f%=1
EXIT LOOP
END IF
IF LEN(stuff$)<>curpos THEN
stuff$=MID$(stuff$,1,curpos-1)+MID$(stuff$,curpos+1,_
LEN(stuff$)-curpos+1)
x=x-1
LOCATE y,x
PRINT MID$(stuff$,curpos,LEN(stuff$)-curpos+1);SPACE$(1)
x7$=""
f%=1
ELSE
stuff$=MID$(stuff$,1,LEN(stuff$)-1)
x=x-1
LOCATE y,x
PRINT SPACE$(1)
f%=1
x7$=""
END IF
END IF
x7$=""
f%=1
WEND
WHILE x7$<>""
WHILE stuff$=""
stuff$=x7$
PRINT x7$
x=x+1
x7$=""
f%=1
WEND
WHILE f%=0
IF insertstat=1 THEN 'Type over mode
curpos=x-xpos
stuff$=MID$(stuff$,1,curpos)+x7$+MID$(stuff$,curpos+2,_
LEN(stuff$)-curpos+2)
PRINT x7$
x=x+1
x7$=""
f%=1
ELSE
IF LEN(stuff$)<>maxsize THEN 'Insert Mode
curpos=x-xpos
stuff$=MID$(stuff$,1,curpos)+x7$+MID$(stuff$,curpos+1,_
LEN(stuff$)-curpos+1)
LOCATE y,xpos+curpos
PRINT MID$(stuff$,curpos+1,LEN(stuff$)-curpos+1)
x=x+1
x7$=""
f%=1
ELSE
BEEP
x7$=""
f%=1
END IF
END IF
IF LEN(stuff$)=maxsize+1 THEN 'Check to see if end of field
stuff$=MID$(stuff$,1,LEN(stuff$)-1)
x=x-1
LOCATE y,x
PRINT SPACE$(1)
BEEP
x7$=""
f%=1
END IF
x7$=""
f%=1
WEND
x7$=""
f%=1
WEND
x7$=""
f%=1
WEND
WHILE LEN(x7$)=2
IF x7$=n$+CHR$(82) AND insertstat=1 THEN 'Insert key pressed
ct=4:cb=7 'while in TYPE OVER mode
insertstat=-1
x7$=""
END IF
IF x7$=n$+CHR$(82) AND insertstat=-1 THEN 'Insert key pressed
ct=7:cb=7 'while in INSERT mode
insertstat=1
x7$=""
END IF
IF x7$=n$+CHR$(75) AND x<>xpos THEN 'Right arrow pressed
x=x-1
x7$=""
END IF
IF x7$=n$+CHR$(77) AND x<>xpos+maxsize-1 THEN 'Left arrow Pressed
IF x+1<=LEN(stuff$)+xpos THEN
x=x+1
END IF
x7$=""
END IF
IF x7$=n$+CHR$(83) THEN 'Delete key pressed
curpos=x-xpos
stuff$=MID$(stuff$,1,curpos)+MID$(stuff$,curpos+2,_
LEN(stuff$)-curpos+2)
LOCATE y,xpos+curpos
PRINT MID$(stuff$,curpos+1,LEN(stuff$)-curpos+1);_
SPACE$(maxsize-LEN(stuff$))
x7$=""
END IF
IF x7$=n$+CHR$(15) THEN 'Shift tab pressed
stuff1%=72
ee%=1
EXIT LOOP
END IF
IF x7$=n$+CHR$(60) THEN 'F2 key pressed
stuff1%=60
ee%=1
EXIT LOOP
END IF
IF x7$=n$+CHR$(72) THEN 'up arrow pressed
stuff1%=72
ee%=1
EXIT LOOP
END IF
IF x7$=n$+CHR$(61) THEN 'F3 key pressed
stuff1%=61
ee%=1
EXIT LOOP
END IF
IF x7$=n$+CHR$(80) THEN 'Down arrow pressed
ee%=1
EXIT LOOP
END IF
x7$=""
WEND
IF ee%=1 THEN 'If exit routine key pressed then ee%=1
EXIT LOOP
END IF
LOOP
END SUB

'-----------------------------------------------------------------------------

Write1:
LSET fleprefix$=keyprefix$ 'All data needed was set before
LSET flelname$=lname$ 'the GOSUB to read or write routines
LSET flefstname$=fstname$
LSET flecomp$=comp$
LSET flebustitle$=bustitle$
LSET fleadd1$=add1$
LSET fleadd2$=add2$
LSET fleadd3$=add3$
LSET fledata1$=data1$
LSET fledata2$=data2$
LSET fledata3$=data3$
LSET fledata4$=data4$
CALL btrv(operation1%,status1%,fcbblock1$,databuffer1$,databuffer1%_
,keybuffer1$,keynumber1%)
GOSUB ClearVars1
RETURN

'-----------------------------------------------------------------------------

Read1:
GOSUB ClearVars1
CALL btrv(operation1%,status1%,fcbblock1$,databuffer1$,databuffer1%_
,keybuffer1$,keynumber1%)
keyprefix$=RTRIM$(fleprefix$)
lname$=RTRIM$(flelname$)
fstname$=RTRIM$(flefstname$)
comp$=RTRIM$(flecomp$)
bustitle$=RTRIM$(flebustitle$)
add1$=RTRIM$(fleadd1$)
add2$=RTRIM$(fleadd2$)
add3$=RTRIM$(fleadd3$)
data1$=RTRIM$(fledata1$)
data2$=RTRIM$(fledata2$)
data3$=RTRIM$(fledata3$)
data4$=RTRIM$(fledata4$)
RETURN

'-----------------------------------------------------------------------------

ExitToMain1:
CALL closewin
GOSUB ClearVars1
RETURN

'-----------------------------------------------------------------------------

'This is the subroutine to open the file. Each Btrieve file should have 2
'field statements, 1 for the Btrieve data buffer and 1 for PB
'The file control block, fcbblock1$ in this case, must initially be set to
'128 spaces and never changed by your program, this tells btrieve where the
'file among other things
'When btrieve performs a read operation the data is returned in the btrieve
'databuffer as well as the PB data buffer, when a write is performed the
'data is assigned to the PB variables and need not be assigned to the btrieve
'databuffer, this is handled automatically by PB (I think, all I know is it
'works)

OpenFile:
OPEN "NUL" FOR RANDOM ACCESS READ WRITE SHARED AS #1 LEN=241
FIELD #1, 241 AS databuffer1$
FIELD #1, 1 AS fleprefix$, 15 AS flelname$, 15 AS flefstname$_
, 30 AS flecomp$, 30 AS flebustitle$, 30 AS fleadd1$, 30 AS fleadd2$_
, 30 AS fladd3$, 15 AS fledata1$, 15 AS fledata2$, 15 AS fledata3$_
, 15 AS fledata4$
databuffer1%=241 'record size
fcbblock1$=SPACE$(128) 'file control block
filename1$="fonbook.dat"+CHR$(0) 'file name to open
keynumber1%=0 'keynumber to use
operation1%=0 'set operation to open
Number1:
status1%=0 'init error status
CALL btrv(operation1%,status1%,fcbblock1$,databuffer1$,databuffer1%,filename1$_
,keynumber1%)
IF status1%=12 THEN '12 means the file did not
GOSUB Createfile 'exist and must be created
GOTO number1
END IF
IF status1%<>0 THEN
CALL BtrError(status1%,1,operation1%)
GOTO ByeBye
END IF
RETURN

'-----------------------------------------------------------------------------

SUB OpenPersonalForm
CALL openwin(3,15,9,65,2,border%,text%,0,1,0)
CALL wprint(1,2,"Last Name: First Name:",bluwht%)
CALL wprint(2,2," Address Line 1:",bluwht%)
CALL wprint(3,2," Address Line 2:",bluwht%)
CALL wprint(4,2,"City, State, Zip:",bluwht%)
CALL wprint(5,2,"Home Phone: Work Phone:",bluwht%)
CALL wprint(6,2," Birthday: Anniversary:",bluwht%)
COLOR 0,7
END SUB

'-----------------------------------------------------------------------------

SUB OpenBusinessForm
CALL openwin(3,15,11,65,2,border%,text%,0,1,0)
CALL wprint(1,2,"Last Name: First Name:",bluwht%)
CALL wprint(2,2," Company Name:",bluwht%)
CALL wprint(3,2," Title:",bluwht%)
CALL wprint(4,2," Address Line 1:",bluwht%)
CALL wprint(5,2," Address Line 2:",bluwht%)
CALL wprint(6,2,"City, State, Zip:",bluwht%)
CALL wprint(7,2,"Home Phone: Work Phone:",bluwht%)
CALL wprint(8,2," Fax Phone: Modem Phone:",bluwht%)
COLOR 0,7
END SUB

'-----------------------------------------------------------------------------

ClearVars1:
lname$="":fstname$="":comp$="":bustitle$="":add1$="":add2$="":add3$=""
data1$="":data2$="":data3$="":data4$=""
RETURN

'-----------------------------------------------------------------------------

SUB OpenNameWindow
CALL openwin(9,5,4,29,3,bborder%,btext%,3,1,0)
CALL wprintc(1,"Press F2 to search",btext%)
CALL wprintc(2,"for an entry.",btext%)
END SUB

'-----------------------------------------------------------------------------


NameLookup:
CALL openwin(6,2,19,50,3,redwht%,redwht%,0,1,0)
status1%=0
operation1%=9
keybuffer1$=keyprefix$+lname$+SPACE$(31-(LEN(lname$)+1))
recnum%=0:recnum$="
GetNameRecords:
REDIM namekeys$(1:13)
number%=2
selection=0
WHILE number%<15 AND status1%=0
GOSUB Read1
IF status1%<>0 AND status1%<>9 THEN
CALL BtrError(status1%,1,operation1%)
GOTO ExitNameLookup
END IF
operation1%=6
IF status1%=0 AND keyprefix$=saveprefix$ THEN
number$=LTRIM$(RTRIM$(STR$(number%-1)))
IF LEN(number$)<2 THEN
number$=SPACE$(1)+number$
END IF
disline$=number$+" "+lname$+", "+fstname$
CALL wprint(number%,2,disline$,frtext%)
namekeys$(number%-1)=keybuffer1$
INCR number%
END IF
WEND
GetRecNum:
CALL wprintc(16,"Enter record number or",rtext%)
CALL wprintc(17," to see more. ",rtext%)
CALL EntryHere(23,36,2,"","A")
IF stuff$=CHR$(27) THEN
GOTO ExitNameLookup
END IF
recnum$=UCASE$(stuff$)
size=LEN(recnum$)
recnum%=VAL(recnum$)
IF size=0 AND status1%=9 THEN 'status 9 means we have reached the end
CALL clearwin 'of the file
status1%=0
operation1%=12 'Get first operation
keybuffer1$=SPACE$(31)
REDIM namekeys$(1:13)
GOTO GetNameRecords
ELSE
IF size=0 AND status1%<>9 THEN
CALL clearwin
REDIM namekeys$(1:13)
GOTO GetNameRecords
END IF
END IF
IF recnum%<1 OR recnum%>(number%-2) THEN
GOTO GetRecNum
END IF

ExitNameLookup:
GOSUB ClearVars1
CALL closewin
COLOR 0,7
RETURN

'-----------------------------------------------------------------------------

ByeBye:
RESET 'Close PB file
operation1%=1 'Close Btrieve file
CALL btrv(operation1%,status1%,fcbblock1$,databuffer1$,databuffer1%_
,keybuffer1$,keynumber1%)
IF status1%<>0 THEN
CALL BtrError(status1%,1,operation1%)
END IF
COLOR 7,0
CLS
END

'-----------------------------------------------------------------------------

'This routine will create the file if it does not already exist

CreateFile:
CLOSE(1)
OPEN "NUL" FOR RANDOM ACCESS READ WRITE SHARED AS #1 LEN=241
'change LEN to correct record length

FIELD #1, 241 AS databuffer$ 'change number to match record
'length

'This field statement defines the file header record
FIELD #1, 2 AS reclen$, 2 AS pagesize$, 2 AS numkeys$, 4 AS notused1$_
, 2 AS fileflags$, 2 AS reserveword$, 2 AS preallocate$_
, 2 AS key1pos$, 2 AS key1len$, 2 AS key1flags$, 4 AS notused2$_
, 1 AS extkey1type$, 5 AS key1reserved$, 209 AS filler$
'change as needed for file being created
'first 16 bytes for file definition
'next 16 bytes for key definition
'if more than one key is needed
'repeat the 16 bytes for key definition
'changing the name of the fields to
'denote a different key

'This section assigns the values to the fields defined above
LSET reclen$=MKI$(241) 'record length
LSET pagesize$=MKI$(2048) 'page size
LSET numkeys$=MKI$(1) 'number of keys
LSET notused1$=MKI$(0) 'reserved
LSET fileflags$=MKI$(0) 'file flags normal
LSET reserveword$=MKI$(0) 'reserved
LSET preallocate$=MKI$(0) 'preallocate = no
LSET key1pos$=MKI$(1) 'start position key 1
LSET key1len$=MKI$(31) 'length key 1 = 31
LSET key1flags$=MKI$(2) 'key 1 type = modifiable
LSET notused2$=MKI$(0) 'reserved
LSET extkey1type$=MKI$(0) 'key type = string
LSET key1reserved$=MKI$(0) 'reserved

operation%=14 'create a file
status%=0 'init status
fcbblock$=SPACE$(128) 'init FCB Block
recordsize%=241 'set record size
filename$="fonbook.dat"+CHR$(0) 'define file name
keynumber%=-1 'abort if file exists

CALL btrv(operation%,status%,fcbblock$,databuffer$,recordsize%,filename$_
,keynumber%)

IF status%<>0 AND status%<>59 THEN
PRINT filename$;" not created, error";status%;" has occurred"
ELSE
IF status%<>59 THEN
PRINT filename$;" has been successfully created!"
END IF
END IF
RETURN

$SEGMENT

'-----------------------------------------------------------------------------

'Btrieve error routine

SUB BtrError(bterror%,file%,op%)

SELECT CASE file%
CASE 1
flnm$="Phone Book Master File"
CASE ELSE
flnm$="Unknown File"
END SELECT

SELECT CASE op%
CASE 0
op$="Open File"
CASE 1
op$="Close File"
CASE 2
op$="Add a Record"
CASE 3
op$="Change a Record"
CASE 4
op$="Delete a Record"
CASE 5
op$="Get Equal"
CASE 6
op$="Get Next"
CASE 7
op$="Get Previous"
CASE 8
op$="Get Greater Than"
CASE 9
op$="Get Greater Than or Equal"
CASE 10
op$="Get Less Than"
CASE 11
op$="Get Less Than or Equal"
CASE 12
op$="Get First"
CASE 13
op$="Get Last"
CASE 14
op$="Create a File"
CASE 15
op$="Status of File"
CASE 16
op$="Extend a File"
CASE 17
op$="Set Directory"
CASE 18
op$="Get Directory"
CASE 19
op$="Begin Transaction"
CASE 20
op$="End Transaction"
CASE 21
op$="Abort Transaction"
CASE 22
op$="Get Position"
CASE 23
op$="Get Direct"
CASE 24
op$="Step Direct"
CASE 25
op$="Stop"
CASE 26
op$="Version"
CASE 27
op$="Unlock"
CASE 28
op$="Reset"
CASE 29
op$="Set Owner"
CASE 30
op$="Clear Owner"
CASE 31
op$="Create Supplemental Index"
CASE 32
op$="Drop Supplemental Index"
CASE ELSE
op$="Unknown Operation Code"
END SELECT

SELECT CASE bterror%
CASE 1
bterror$="Unknown operation code"
CASE 2
bterror$="Disk read/write error"
CASE 3
bterror$="File is not open"
CASE 4
bterror$="Record does not exist in file"
CASE 5
bterror$="File does not accept duplicate keys"
CASE 6
bterror$="Invalid Key Number parameter"
CASE 7
bterror$="Key Number parameter can not be changed"
CASE 8
bterror$="Record must be read before it can be deleted or updated"
CASE 9
bterror$="End of file"
CASE 10
bterror$="The key to this file can not be modified"
CASE 11
bterror$="Invalid file name"
CASE 12
bterror$="File does not exist in directory or path"
CASE 13
bterror$="File extension does not exist in directory or path"
CASE 14
bterror$="Back up file for Transaction processing could not be created"
CASE 15
bterror$="Disk read/write error in back up file for Transaction"
CASE 16
bterror$="FIle could not be expanded"
CASE 17
bterror$="File can not be closed"
CASE 18
bterror$="Out of disk space"
CASE 19
bterror$="Unrecoverable error, file is corrupt"
CASE 20
bterror$="Btrieve is not installed in memory"
CASE 21
bterror$="Record key buffer is to small"
CASE 22
bterror$="Record data buffer is to small"
CASE 23
bterror$="The position block is not 128 characters"
CASE 24
bterror$="The page size is invalid"
CASE 25
bterror$="File could not be created"
CASE 26
bterror$="The number of key indexes is out of range"
CASE 27
bterror$="The key position is greater than the record length"
CASE 28
bterror$="Invalid record length"
CASE 29
bterror$="Invalid key length"
CASE 30
bterror$="File is not a Btrieve file"
CASE 31
bterror$="File is already extended"
CASE 32
bterror$="Disk read/write error during file extend"
CASE 34
bterror$="Invalid file name for extension"
CASE 35
bterror$="Invalid directory"
CASE 36
bterror$="Invalid transaction"
CASE 37
bterror$="Transaction error"
CASE 38
bterror$="Disk read/write error to transaction control file"
CASE 39
bterror$="Transaction end/abort error"
CASE 40
bterror$="Too many files included in transaction"
CASE 41
bterror$="Prohibited operation within transaction"
CASE 42
bterror$="Unable to open file in accelerated mode"
CASE 43
bterror$="Invalid data record address"
CASE 44
bterror$="Null key value"
CASE 45
bterror$="Inconsistent key flags for key segments"
CASE 46
bterror$="File is open in read only mode"
CASE 47
bterror$="Exceeded maximum allowed open accelerated files"
CASE 48
bterror$="Invalid alternate collating sequence definition"
CASE 50
bterror$="Owner is already set"
CASE 51
bterror$="Non matching owner in key buffer and data buffer"
CASE 52
bterror$="Error writing cache"
CASE 53
bterror$="Invalid language interface"
CASE 54
bterror$="All of variable length record could not be read"
CASE 56
bterror$="Damaged supplemental index"
CASE 80
bterror$="Record has been changed, can not delete/update the record"
CASE 81
bterror$="File or record lock error"
CASE 82
bterror$="File pointer position lost"
CASE 83
bterror$="Can not delete/update this record within transaction"
CASE 84
bterror$="Record is locked by another task"
CASE 85
bterror$="File is locked"
CASE 86
bterror$="Maximum number of files is open"
CASE 87
bterror$="Maximum number of file handles in use"
CASE 88
bterror$="File can not be opened in current mode"
CASE 90
bterror$="Redirection table is full"
CASE 91
bterror$="Requested server not active or does not have Btrieve installed"
CASE 92
bterror$="Maximum number of transactions has been reached"
CASE 93
bterror$="Invalid record locking had been attempted"
CASE 94
bterror$="No access rights to the requested directory"
CASE 97
bterror$="Data buffer too large"
CASE 98
bterror$="Internal transaction error"
CASE ELSE
bterror$="Unknown error code"
END SELECT

a%=LEN(flnm$):b%=LEN(op$):c%=LEN(bterror$)
IF a%>b% THEN
longest%=a%
ELSE
longest%=b%
END IF
IF c%>longest% THEN
longest%=c%
END IF
INCR longest%, 16
row%=INT(80-longest%)
IF row%<=0 THEN
row%=1
END IF
row%=INT(row%/2)
CALL openwin(6,row%,9,longest%,3,attr%(15,4),attr%(15,4),3,1,0)
CALL wprint(1,2,"File Name: "+flnm$,rtext%)
CALL wprint(2,2,"Operation: "+op$,rtext%)
btverr$=STR$(bterror%)
CALL wprint(3,2,"Error Code: "+btverr$,rtext%)
CALL wprintc(5,bterror$,rtext%)
CALL wprintc(7,"Press any key to continue",rtext%)
k$=getkey$
COLOR 0,7
CALL closewin

END SUB

'-----------------------------------------------------------------------------

'*****************************************************************************
'*****************************************************************************
'*** I did not write this SUB, it was downloaded from the PB BBS, the author
'*** is not known to me, but I am glad he released this into the public domain
'*****************************************************************************
'*****************************************************************************

' This SUBprocedure provides the interface between Spectra Publishing's
' PowerBASIC 2.00 compiler and Novell's BTRIEVE file system on PCDOS/MSDOS
' machines.

' In order to use the SUB, include its source code in your program with the
' $INCLUDE metastatement: $INCLUDE "POWERBBT.BAS"

' Each time you wish to perform a BTRIEVE operation, use the CALL statement
' to call the SUB with the following parameters:

' CALL BTRV(OPERATION%, RETSTATUS%, FCBPOSBLOCK$, DATABUFFER$, _
' DATABUFLEN%, KEYBUFFER$, KEYNUMBER%)

' where: OPERATION% is the BTRIEVE operation code for the desired function.
' RETSTATUS% is a BTRIEVE status code returned after the desired
' function is attempted.
' FCBPOSBLOCK$ is a 128-byte data area containing file control block
' (FCB) and position information which must not be changed by
' your program.
' DATABUFFER$ is a data buffer used to specify special information
' such as file specifications, key characteristics, etc. Its
' structure will be defined by your program with a FIELD
' statement.
' DATABUFLEN% is the length of the data buffer, DATABUFFER$.
' KEYBUFFER$ is the key buffer.
' KEYNUMBER% is the key number to be processed.

' Important note: The BTRV routine resets the currently-active PowerBASIC
' data segment to the default data segment (by executing a DEF SEG state-
' ment with no argument). If you set a different segment with DEF SEG in
' your main program and then call BTRV, you will need to execute your DEF
' SEG statement again (after the call), if you wish to continue using your
' segment as PowerBASIC's data segment; otherwise, the default data segment
' will be active when BTRV returns to your main program.


sub BTRV(Operation%, RetStatus%, FCBPosBlock$, DataBuffer$, DataBufLen%, _
KeyBuffer$, KeyNumber%)

static VersionDetermined%, BMULTIPresent%, BMULTIProcessID%
local CriticalErrorVec$ 'holds critical error handler vector

dim ParamBlock%(0:13) 'local array holds 14-word parameter block

%AX = 1 : %BX = 2 : %DX = 4 : %DS = 8 'register equates for use with REG

'parameter positions within ParamBlock% array
%DBOfst = 0 : %DBSeg = 1 : %DBLength = 2 : %PosOfst = 3 : %PosSeg = 4
%FCBOfst = 5 : %FCBSeg = 6 : %OpCode = 7 : %KBOfst = 8 : %KBSeg = 9
%KeyInfo = 10: %StatOfst = 11 : %StatSeg = 12 : %IfaceID = 13

%FCBPosSize = 128 '128 = correct size for FCB + position info
%FCBPosLenErr = 23 'status code returned if size exceeded
%NoBTRIEVEErr = 20 'status code returned if BTRIEVE not loaded


'First, swap critical error handler and check for presence of BTRIEVE

def seg = 0 'use segment zero (DOS INT vectors)
CriticalErrorVec$ = peek$(&h90,4) 'get critical error handler vector
poke$ &h90, peek$(&h51A,4) 'tell DOS to handle errors

'if INT 7B offset = 33 hex, BTRIEVE handler
if peeki(&h7B * 4) = &h33 then ' has been loaded
if VersionDetermined% = 0 then 'DOS version has yet to be determined
incr VersionDetermined% 'set flag since we're determining now
reg %AX, &h3000 'use DOS function 30 hex to get the
call interrupt &h21 ' DOS version number in register AX
if (reg(%AX) AND &h00FF) >= 3 then 'we have DOS 3.00 or above
reg %AX, &hAB00 'so check to see if BMULTI loaded
call interrupt &h2F
if (reg(%AX) AND &h00FF) = 77 then
BMULTIPresent% = 1 'it is loaded, so flag it
else
BMULTIPresent% = 0 'otherwise set flag to zero
end if
end if
end if
else 'BTRIEVE handler isn't loaded, so warn user
RetStatus% = %NoBTRIEVEErr
poke$ &h90, CriticalErrorVec$ 'restore critical error handler
def seg 'and PB default data segment
exit sub 'then quit
end if

if len(FCBPosBlock$) < %FCBPosSize then 'make sure the passed FCBPosBlock$
RetStatus% = %FCBPosLenErr ' is long enough to hold FCB and
' position info -- quit if not
poke$ &h90, CriticalErrorVec$ 'restore critical error handler
def seg 'and PB default data segment
exit sub
end if


'Now set up 14-word parameter block for the BTRIEVE interrupt

ParamBlock%(%DBOfst) = cvi(mkl$(strptr(DataBuffer$))) 'offset and segment
ParamBlock%(%DBSeg) = cvi(mkl$(strseg(DataBuffer$))) 'of data buffer

ParamBlock%(%DBLength) = DataBufLen% 'data buffer length

ParamBlock%(%FCBOfst) = cvi(mkl$(strptr(FCBPosBlock$))) 'offset and segment
ParamBlock%(%FCBSeg) = cvi(mkl$(strseg(FCBPosBlock$))) 'of FCB block

ParamBlock%(%PosOfst) = ParamBlock%(%FCBOfst) + 38 'offset and segment
ParamBlock%(%PosSeg) = ParamBlock%(%FCBSeg) 'of position block

ParamBlock%(%OpCode) = Operation% 'BTRIEVE operation code

ParamBlock%(%KBOfst) = cvi(mkl$(strptr(KeyBuffer$))) 'offset and segment
ParamBlock%(%KBSeg) = cvi(mkl$(strseg(KeyBuffer$))) 'of key buffer

ParamBlock%(%KeyInfo) = len(KeyBuffer$)+(KeyNumber%*256) 'key info word

ParamBlock%(%StatOfst) = cvi(mkl$(varptr(RetStatus%))) 'offset and segment
ParamBlock%(%StatSeg) = cvi(mkl$(varseg(RetStatus%))) 'of status variable

ParamBlock%(%IfaceID) = &h6176 'interface ID


'Now do the interrupt with DS:DX pointing to the parameter block

reg %DX, varptr(ParamBlock%(0))
reg %DS, varseg(ParamBlock%(0))

if BMULTIPresent% = 0 then 'BMULTI not present, so use INT 7B
call interrupt &h7B
else
do 'use BMULTI to do it
if BMULTIProcessID% = 0 then 'get process ID if haven't yet
reg %AX, &hAB01
else
reg %AX, &hAB02 'here if we have process ID -- need
reg %BX, BMULTIProcessID% ' to set it now
end if
call interrupt &h2F 'invoke BMULTI
if (reg(%AX) AND &h00FF) = 0 then exit loop 'go on if done processing
reg %AX, &h0200 'otherwise allow task
call interrupt &h7F ' switch and try request
loop ' again
if BMULTIProcessID% = 0 then BMULTIProcessID% = reg(%BX) 'assign proc ID
end if

DataBufLen% = ParamBlock%(%DBLength) 'pass new data buffer length back


'Now restore critical error handler vector and PB's default data segment

poke$ &h90, CriticalErrorVec$
def seg

end sub

'-----------------------------------------------------------------------------