`***********************************************************************
`**                                                                   **
`** This program is written in S-BASIC by Robert Pearce               **
`**                                                                   **
`***********************************************************************
`
`       This is a simple database program that makes use of the DISAM
`   Functions. First you fill out what is needed on the screen then
`   you enter a function key + a C/R. You can add, change, delete or
`   display the DISAM records.
`
`       To use this program, define a DISAM file using the following:
`           filename:   ADDRBOOK.DSF
`           Key length: 10
`           Key offset: 0
`           Use the index and data block size defaults
`           Share:      N
`
`       Subroutines: VERIFY.DFH3.LOADED and ACCESS.DFH3 are the one's
`   that actually go outside the BASIC's environment.
`
`       This program is written in S-BASIC, (Structured BASIC). This
`   is a product purchased from Sunflower Software, 13915 midland Dr.
`   Shawnee, KS. 65215 in 1986. This code is fed into S-BASIC which
`   is a pre-processor that converts this file into a GW-BASIC program
`   which is passed to the Microsoft BASIC compiler and out comes an
`   executable module.
`
GOSUB INITIALIZE.CONSTANTS
GOSUB VERIFY.DFH3.LOADED
GOSUB OPEN.FILE
GOSUB DISPLAY.SCREEN
GOSUB SET.SOFT.KEYS
WHILE Z<>1 DO
    GOSUB PROCESS
END WHILE
SYSTEM
END

SUB INITIALIZE.CONSTANTS        'initialization routine
    DIM FLD$(5)                 'five fields defined.
    FILE$="ADDRBOOK.DSF"        'file name.
    KEY.LEN=10                  'key length is 10 bytes
    KEY.OFF=0                   'starting at offset 0.
    MAX.REC.LEN=255             'BASIC record length constraint
    DELIMITER$=CHR$(01)         'delimiter is a CTRL-A
    X$=""                       'tempy string area
    Z=0                         'end of program indicator
    NAM.LEN=30                  'define field maximum lengths
    ADR1.LEN=40
    ADR2.LEN=40
    CSZ.LEN=40
    PHO.LEN=15
`   MAX RECORD LENGTH IS 165+5 = 170     (1 delimiter per field)
`   MIN RECORD LENGTH IS KEY.LEN+5 = 15  (5 delimiters)
    RETURN

SUB DISPLAY.SCREEN              'these are screen constants
    CLS
    LOCATE 3,27
    PRINT "Sample DISAM Program";
    LOCATE 4,12
    PRINT "When a Fn key is used, it must be followed by a C/R"
    LOCATE 7,19
    PRINT "Name:";
    LOCATE 9,16
    PRINT "Address:";
    LOCATE 11,16
    PRINT "Address:";
    LOCATE 13,10
    PRINT "City, St. Zip:";
    LOCATE 15,12
    PRINT "Telephone #:";
    RETURN

SUB SET.SOFT.KEYS               'function key setup
    DATA "AddRec","","ChgRec","","DelRec","","GetRec","","ClrScn","End"
    KEY OFF
    FOR N=1 TO 10 DO
        READ SOFTKEY$
        KEY N,SOFTKEY$
    NEXT N
    KEY ON
    ON KEY(1) GOSUB ADD.RECORD
    KEY(1) ON
    ON KEY(3) GOSUB CHANGE.RECORD
    KEY(3) ON
    ON KEY(5) GOSUB DELETE.RECORD
    KEY(5) ON
    ON KEY(7) GOSUB DISPLAY.RECORD
    KEY(7) ON
    ON KEY(9) GOSUB CLEAR.SCREEN
    KEY(9) ON
    ON KEY(10) GOSUB END.SESSION
    KEY(10) ON
    RETURN

SUB PROCESS                     'get input from screen
    LOCATE 7,25                 'position cursor
    LINE INPUT X$               'get input
    IF LEN(X$)<>0 THEN
        NAME$=X$                'if something was entered, use it
    END IF
    LOCATE 17,25                'clear the info line
    PRINT SPACE$(50)
    LOCATE 9,25                 'get input 4 more times
    LINE INPUT X$
    IF LEN(X$)<>0 THEN
        ADDR1$=X$
    END IF
    LOCATE 11,25
    LINE INPUT X$
    IF LEN(X$)<>0 THEN
        ADDR2$=X$
    END IF
    LOCATE 13,25
    LINE INPUT X$
    IF LEN(X$)<>0 THEN
        CSZ$=X$
    END IF
    LOCATE 15,25
    LINE INPUT X$
    IF LEN(X$)<>0 THEN
        PHONE$=X$
    END IF
    RETURN

SUB END.SESSION                 'close DISAM file and exit
    GOSUB CLOSE.FILE
    Z=1
    SYSTEM
    RETURN

SUB ADD.RECORD                  'add a record to the DISAM file
    GOSUB EDIT.KEY.LENGTH
    GOSUB BUILD.RECORD
    FUNC$="A"                   'add action
    REC$=TMP$                   'input record
    GOSUB ACCESS.DFH3
    IF REC$="2" THEN
        LOCATE 17,25            'display error
        PRINT "Record already exists                    ";
    ELSE
        GOSUB CLEAR.SCREEN
    END IF
    RETURN

SUB EDIT.KEY.LENGTH             'insure key is at least key.len long
    IF LEN(NAME$)<KEY.LEN THEN
        NAME$=NAME$+SPACE$(KEY.LEN-LEN(NAME$))
    END IF
    RETURN

SUB BUILD.RECORD                'concatinate fields
    TMP$=NAME$+DELIMITER$+ADDR1$+DELIMITER$+ADDR2$+DELIMITER$
    TMP$=TMP$+CSZ$+DELIMITER$+PHONE$+DELIMITER$
    RETURN

SUB CLEAR.SCREEN                'clear screen and field values
    LOCATE 07,25
    PRINT SPACE$(NAM.LEN)
    NAME$=""
    LOCATE 09,25
    PRINT SPACE$(ADR1.LEN)
    ADDR1$=""
    LOCATE 11,25
    PRINT SPACE$(ADR2.LEN)
    ADDR2$=""
    LOCATE 13,25
    PRINT SPACE$(CSZ.LEN)
    CSZ$=""
    LOCATE 15,25
    PRINT SPACE$(PHO.LEN)
    PHONE$=""
    LOCATE 17,25
    PRINT SPACE$(50)
    RETURN

SUB DISPLAY.RECORD              'get a DISAM record
    GOSUB EDIT.KEY.LENGTH
    FUNC$="G"
    REC$=NAME$+SPACE$(MAX.REC.LEN-LEN(NAME$)) 'send a 255 byte field
    GOSUB ACCESS.DFH3                         'to DISAM for record
    IF REC$="1" THEN
        LOCATE 17,25
        PRINT "Record not found                         ";
    ELSE IF REC$="3"
        GOSUB CLEAR.SCREEN
        LOCATE 17,25
        PRINT "You have reached the end of the file     ";
    ELSE
        GOSUB CLEAR.SCREEN
        GOSUB PARSE.RECORD
        GOSUB DISPLAY.FIELDS
    END IF
    RETURN

SUB PARSE.RECORD                'split the record into 5 fields
    FOR I=1 TO 5 DO
        J=INSTR(1,REC$,DELIMITER$)
        FLD$(I)=MID$(REC$,1,J-1)
        REC$=MID$(REC$,J+1)
    NEXT
    NAME$=FLD$(1)
    ADDR1$=FLD$(2)
    ADDR2$=FLD$(3)
    CSZ$=FLD$(4)
    PHONE$=FLD$(5)
    RETURN

SUB DISPLAY.FIELDS              'display the fields
    LOCATE 7,25
    PRINT NAME$;
    LOCATE 9,25
    PRINT ADDR1$;
    LOCATE 11,25
    PRINT ADDR2$;
    LOCATE 13,25
    PRINT CSZ$;
    LOCATE 15,25
    PRINT PHONE$;
    RETURN

SUB CHANGE.RECORD               'replace the DISAM record
    GOSUB EDIT.KEY.LENGTH
    GOSUB BUILD.RECORD
    FUNC$="P"
    REC$=TMP$
    GOSUB ACCESS.DFH3
    IF REC$="1" THEN
        LOCATE 17,25
        PRINT "Record not found                         ";
    ELSE
        GOSUB CLEAR.SCREEN
    END IF
    RETURN

SUB DELETE.RECORD               'delete the DISAM record
    GOSUB EDIT.KEY.LENGTH
    FUNC$="D"
    REC$=NAME$
    IF LEN(REC$)<>0 THEN
       GOSUB ACCESS.DFH3
       IF REC$="1" THEN
           LOCATE 17,25
           PRINT "Record not found                         ";
       ELSE
           GOSUB CLEAR.SCREEN
       END IF
    END IF
    RETURN

SUB VERIFY.DFH3.LOADED          'verify DISAM is loaded in the system
    DEF SEG=&H0012
    X=PEEK(&H0)
    DEF SEG
    IF X<>234 THEN
        PRINT "DISAM File Handler is not loaded."
        STOP
    END IF
    RETURN

SUB OPEN.FILE                   'open the DISAM file
    FUNC$="F"                   'insure that the buffer is available
    REC$="  "
    GOSUB ACCESS.DFH3
    FUNC$="O"                   'and then open the file
    REC$=FILE$+""
    GOSUB ACCESS.DFH3
    RETURN                      'assume a "0" return-code

SUB CLOSE.FILE                  'close the DISAM file
    FUNC$="C"
    REC$=" "
    GOSUB ACCESS.DFH3
    RETURN                      'assume a "0" return-code

SUB ACCESS.DFH3                 'this is the DISAM access routine
    ERR.F$=FUNC$                'Store stuff for possible error
    ERR.R$=REC$
    DEF SEG=&H0012              'point SEG addr to DISAM epa
    DFH3=&H0
    CALL ABSOLUTE (FUNC$,REC$,DFH3)
    DEF SEG
    IF ERR.F$="F"THEN RETURN    'do not edit the FREE function
    IF REC$="9" THEN
        PRINT "Unexpected response from DFH3"
                                    'process internal errors here
        PRINT "FUNC= ";ERR.F$       'also display what was sent
        PRINT "REC= ";ERR.R$        'to DISAM to help debug
        STOP
    END IF
    RETURN
END PROGRAM