'===========================================================================
' Subject: Random Database for Persons        Date: 03-16-03 (  :  )       
'  Author: Mikerinos Altermann                Code: QB, PDS                
'  Origin: mikerinos@excite.com             Packet: DATABASE.ABC
'===========================================================================
'Random database for persons
'Created by Qware comp. 1997
'Completly free software - do anything you want
'No documentation available
'Records have this format:
' first name     
' middle name    
' last name
' birth date    *only 8 chars ex. 08/14/1975 - 08141975
' adress
' telephone
' othes info




DECLARE FUNCTION inpstr$ (edit$, eline%)
DECLARE SUB crspoz (cry%, crx%)
TYPE dates
fname AS STRING * 10
mname AS STRING * 10
lname AS STRING * 15
bdate AS STRING * 8
adress AS STRING * 80
tel AS STRING * 10
sdates AS STRING * 255
END TYPE
TYPE cache
rec1 AS STRING * 10
rec2 AS STRING * 10
rec3 AS STRING * 15
rec4 AS STRING * 8
rec5 AS STRING * 80
rec6 AS STRING * 10
rec7 AS STRING * 255
END TYPE
DIM ind AS dates
DIM cr AS cache
ON ERROR GOTO errorl:
init:
errorsw% = 0
OPEN "records.dat" FOR RANDOM AS #1 LEN = LEN(ind)
IF errsw% = 1 THEN
PRINT "Error trying open dat file or this not exist"
SYSTEM
END IF
CLS
PRINT "*********INFOBLOCK RANDOM DATABASE SYSTEM************"
PRINT "version 1.10"
start:
i% = 0
empty% = 0
valid% = 0
find% = 0
sys$ = "ACTIVE"
sta$ = "WAIT"
answ$ = "NONE"
GOSUB status:
INPUT "COMMANDS:", com$
com$ = LTRIM$(RTRIM$(LCASE$(com$)))
SELECT CASE com$
CASE "find name"
CLS
sta$ = "WORK"
GOSUB status:
INPUT "INPUT FIRST NAME OF INDIVIDUAL:", cr.rec1
INPUT "INPUT MIDDLE NAME OF INDIVIDUAL:", cr.rec2
INPUT "INPUT LAST NAME OF INDIVIDUAL:", cr.rec3
GOSUB filtren:
DO
i% = i% + 1
GET 1, i%, ind
IF cr.rec1 = ind.fname AND cr.rec2 = ind.mname AND cr.rec3 = ind.lname 
THEN
CLS
find% = 1
answ$ = "FOUND"
GOSUB status:
PRINT "FIRST NAME:"; ind.fname
PRINT "MIDDLE NAME:"; ind.mname
PRINT "LAST NAME:"; ind.lname
PRINT "BIRTH DATE:"; ind.bdate
PRINT "ADRESS:"; ind.adress
PRINT "TELEPHONE:"; ind.tel
PRINT "SUPLAY DATES:"; ind.sdates
PRINT "RECORD NR."; i%
EXIT DO
END IF
LOOP UNTIL EOF(1)
IF find% = 0 THEN
answ$ = "NOT FOUND"
GOSUB status:
END IF
GOSUB delay:
CASE "input"
sta$ = "ADDING DATA"
answ$ = "WAIT"
GOSUB status:
INPUT "FIRST NAME:"; cr.rec1
INPUT "MIDDLE NAME:"; cr.rec2
INPUT "LAST NAME:"; cr.rec3
INPUT "BIRTH DATE:"; cr.rec4
INPUT "ADRESS:"; cr.rec5
INPUT "TELEPHONE:"; cr.rec6
INPUT "SUPLAY DATES:"; cr.rec7
GOSUB filtren:
GOSUB filtrenr:
DO
i% = i% + 1
GET 1, i%, ind
IF ASC(MID$(ind.fname, 1, 1)) = 32 OR ASC(MID$(ind.fname, 1, 1)) = 0 
THEN
PUT 1, i%, cr
EXIT DO
END IF
LOOP UNTIL EOF(1)
PRINT "WRITTEN RECORD NR."; i%
sta$ = "FINISH"
answ$ = "DATA ADDED"
GOSUB status:
GOSUB delay:
CASE "status"
CLS
sta$ = "EXAMINE"
answ$ = "REPORT"
GOSUB status:
IF LOF(1) = 0 THEN
PRINT "DATAFILE IS EMPTY"
ELSE
DO
i% = i% + 1
GET 1, i%, cr
IF ASC(MID$(cr.rec1, 1, 1)) = 32 OR ASC(MID$(cr.rec1, 1, 1)) = 0 THEN
empty% = empty% + 1
ELSE
valid% = valid% + 1
END IF
LOOP UNTIL EOF(1)
PRINT "DATA FILE SIZE:"; LOF(1)
PRINT "NUMBER OF RECORDS:"; i% - 1
PRINT "TOTAL VALID DATA"; valid%
PRINT "TOTAL EMPTY RECORDS"; empty% - 1
END IF
GOSUB delay:
CASE "erase last"
IF LOC(1) = 0 THEN
PRINT "NO RECORD ACCESED"
ELSE
cr.rec1 = ""
cr.rec2 = ""
cr.rec3 = ""
cr.rec4 = ""
cr.rec5 = ""
cr.rec6 = ""
cr.rec7 = ""
PUT 1, LOC(1), cr
sta$ = "DELETING"
answ$ = "LAST RECORD ERASED"
GOSUB status:
END IF
GOSUB delay:
CASE "erase all"
CLOSE
KILL "records.dat"
sta$ = "DELETING DATABASE"
IF errsw% = 1 THEN
answ$ = "CANNOT ERASE FILE RECORDS"
ELSE
answ$ = "ALL RECORDS HAVE BEEN ERASED"
END IF
GOSUB status:
GOSUB delay:
GOTO init:
CASE "erase rec"
sta$ = "DELETING"
answ$ = "WAIT"
GOSUB status:
INPUT "INTRODUCE NUMBER OF RECORD:", i%
IF i% > LOF(1) / LEN(ind) THEN
PRINT "WRONG RECORD NUMBER"
ELSE
cr.rec1 = ""
cr.rec2 = ""
cr.rec3 = ""
cr.rec4 = ""
cr.rec5 = ""
cr.rec6 = ""
cr.rec7 = ""
PUT 1, i%, cr
sta$ = "FINISH"
answ$ = "THIS RECORD HAS BEEN ERASED"
GOSUB status:
END IF
GOSUB delay:
CASE "locate"
CLS
sta$ = "SEARCHING"
answ$ = "WAIT"
GOSUB status:
DO
INPUT "INTRODUCE STRING TO LOCATE (max.20 characters):", txt$
IF LEN(txt$) > 20 THEN PRINT "STRING IS TOO LONG"
LOOP UNTIL LEN(txt$) <= 20
txt$ = LCASE$(LTRIM$(RTRIM$(txt$)))
DO
i% = i% + 1
GET 1, i%, cr
IF LEN(txt$) < 10 AND INSTR(1, LCASE$(cr.rec1), txt$) > 0 OR LEN(txt$) 
< 10 AND INSTR(1, LCASE$(cr.rec2), txt$) > 0 OR LEN(txt$) < 15 AND 
INSTR(1, LCASE$(cr.rec3), txt$) > 0 OR LEN(txt$) < 8 AND INSTR(1, 
LCASE$(cr.rec4), txt$) > 0 OR INSTR(1, LCASE$ _
(cr.rec5), txt$) > 0 OR LEN(txt$) < 10 AND INSTR(1, LCASE$(cr.rec6), 
txt$) > 0 OR INSTR(1, LCASE$(cr.rec7), txt$) > 0 THEN
CLS
answ$ = "STRING FOUND"
find% = 1
GOSUB status:
PRINT "STRING DETECTED TO RECORD:"; i%; ".PRESS ANY KEY TO CONTINUE"
PRINT "FIRST NAME:"; cr.rec1
PRINT "MIDDLE NAME:"; cr.rec2
PRINT "LAST NAME:"; cr.rec3
PRINT "BIRTH DATE:"; cr.rec4
PRINT "ADRESS:"; cr.rec5
PRINT "TELEPHONE:"; cr.rec6
PRINT "SUPLAY DATES:"; cr.rec7
GOSUB delay:
END IF
LOOP UNTIL EOF(1)
IF find% = 0 THEN
sta$ = "FINISH"
answ$ = "CANNOT FIND STRING"
GOSUB status:
GOSUB delay:
END IF
CASE "replace last"
IF LOC(1) = 0 THEN
PRINT "NO RECORD ACCESED"
ELSE
CLS
sta$ = "CHANGE"
answ$ = "WAITING"
GOSUB status:
PRINT "LAST RECORD ACCESED HAS BEEN NR."; LOC(1)
GET 1, LOC(1), ind
PRINT "FIRST NAME:"
ind.fname = UCASE$(inpstr$(ind.fname, CSRLIN))
PRINT "MIDDLE NAME:"
ind.mname = UCASE$(inpstr$(ind.mname, CSRLIN))
PRINT "LAST NAME:"
ind.lname = UCASE$(inpstr$(ind.lname, CSRLIN))
PRINT "ADRESS:"
ind.adress = inpstr$(ind.adress, CSRLIN)
PRINT "TELEPHONE:"
ind.tel = inpstr$(ind.tel, CSRLIN)
PRINT "SUPLAY DATES:"
ind.sdates = inpstr$(ind.sdates, CSRLIN)
PUT 1, LOC(1), ind
sta$ = "FINISH"
answ$ = "RECORD WAS REPLACED"
END IF
GOSUB status:
CASE "replace rec"
sta$ = "CHANGE"
answ$ = "WAIT"
GOSUB status:
INPUT "INTRODUCE NUMBER OF RECORD:", i%
IF i% > LOF(1) / LEN(ind) THEN
PRINT "WRONG RECORD NUMBER"
ELSE
CLS
GET 1, i%, ind
PRINT "FIRST NAME:"
ind.fname = UCASE$(inpstr$(ind.fname, CSRLIN))
PRINT "MIDDLE NAME:"
ind.mname = UCASE$(inpstr$(ind.mname, CSRLIN))
PRINT "LAST NAME:"
ind.lname = UCASE$(inpstr$(ind.lname, CSRLIN))
PRINT "BIRTH DATE"
ind.bdate = inpstr$(ind.bdate, CSRLIN)
PRINT "ADRESS:"
ind.adress = inpstr$(ind.adress, CSRLIN)
PRINT "TELEPHONE:"
ind.tel = inpstr$(ind.tel, CSRLIN)
PRINT "SUPLAY DATES:"
ind.sdates = inpstr$(ind.sdates, CSRLIN)
PUT 1, i%, ind
sta$ = "FINISH"
answ$ = "RECORD WAS REPLACED"
GOSUB status:
END IF
CASE "print last"
IF LOC(1) = 0 THEN
PRINT "NO RECORD ACCESED"
ELSE
CLS
sta$ = "PRINT"
answ$ = "WAITING"
GOSUB status:
PRINT "LAST RECORD ACCESED HAS BEEN NR."; LOC(1)
GET 1, LOC(1), ind
LPRINT "*********INFOBLOCK RANDOM DATABASE SYSTEM************"
LPRINT "version 1.10"
LPRINT "Printed person report"
LPRINT "FIRST NAME:"; ind.fname
LPRINT "MIDDLE NAME:"; ind.mname
LPRINT "LAST NAME:"; ind.lname
LPRINT "BIRTH DATE:"; ind.bdate
LPRINT "ADRESS:"; ind.adress
LPRINT "TELEPHONE:"; ind.tel
LPRINT "SUPLAY DATES:"; ind.sdates
LPRINT "RECORD NR."; i%
END IF
CASE "compact"
IF LOF(1) = 0 THEN
PRINT "DATAFILE IS EMPTY"
ELSE
OPEN "compact.dat" FOR RANDOM AS #2 LEN = LEN(ind)
DO
i% = i% + 1
GET 1, i%, cr
IF ASC(MID$(cr.rec1, 1, 1)) = 32 OR ASC(MID$(cr.rec1, 1, 1)) = 0 THEN
empty% = empty% + 1
ELSE
valid% = valid% + 1
PUT 2, valid%, cr
END IF
LOOP UNTIL EOF(1)
CLOSE
KILL "records.dat"
NAME "compact.dat" AS "records.dat"
answ$ = "DATAFILE HAS BEEN COMPACTED"
sta$ = "DEFLATING"
GOSUB status:
PRINT "ELIMINATED EMPTY RECORDS:"; empty%
GOSUB delay:
GOTO init:
END IF
CASE "help"
CLS
FOR i% = 1 TO 19
READ txt$
PRINT txt$
NEXT
GOSUB delay:
CASE "exit"
sys$ = "CLOSED"
sta$ = "QUITTING"
answ$ = "EXIT TO OPERATING SYSTEM"
GOSUB status:
SYSTEM
CASE ELSE
answ$ = "WRONG COMMAND"
GOSUB status:
END SELECT
GOTO start:
CLOSE
END
status:
PRINT "SYSTEM:"; sys$
PRINT "STATUS:"; sta$
PRINT "ANSWER:"; answ$
RETURN
filtren:
cr.rec1 = UCASE$(LTRIM$(RTRIM$(cr.rec1)))
cr.rec2 = UCASE$(LTRIM$(RTRIM$(cr.rec2)))
cr.rec3 = UCASE$(LTRIM$(RTRIM$(cr.rec3)))
RETURN
filtrenr:
cr.rec4 = LTRIM$(RTRIM$(cr.rec4))
cr.rec6 = LTRIM$(RTRIM$(cr.rec6))
RETURN
delay:
a$ = INPUT$(1)
RETURN
errorl:
errsw% = 1
PRINT "ERROR DURING THIS OPERATION"
RESUME NEXT
DATA "*****************       INFOBLOCK RANDOM DATABASE   version 1.10 
*************","         created by Qware comp. 1997            
FREEWARE EDITION","This program is a simple database of persons with 32,767 
possible records; it"
DATA "needn't use EMS or XMS memory; it also works with a slow CPU 
80286 or 80386."
DATA "There are no restrictios to distribute this program. If you have 
a problem,","write a letter to e-mail adress qwarecomp@go.com </ym/Compose?To=qwarecomp@go.com&YY=23186&order=down&sort=date&pos=0&view=a&head=b>. Thank 
you!","COMMANDS:"
DATA "find name    -find a person in database by using complete 
name","input        -introduce a new record to datafile","replace last 
-replace dates of last record accesed"
DATA "replace rec  -replace dates of a specific record","erase last   
-erase last record accesed","erase rec    -erase a specific 
record","erase all    -delete content of datafile"
DATA "print last   -print last record accesed","locate       -seek a 
specific string in all records","compact      -deflate datafile cleaning 
all empty records"
DATA "status       -display informations about database","help         
-display help information about program","exit         -exit of 
program"

SUB crspoz (cry%, crx%)
STATIC x AS INTEGER
STATIC y AS INTEGER
IF x <> 0 AND y <> 0 AND x <> crx% AND y <> cry% THEN
COLOR 7, 0
LOCATE y, x
PRINT CHR$(SCREEN(y, x))
END IF
IF crx% <> 0 AND cry% <> 0 THEN
COLOR 0, 7
LOCATE cry%, crx%
PRINT CHR$(SCREEN(cry%, crx%))
COLOR 7, 0
x = crx%
y = cry%
END IF
END SUB

FUNCTION inpstr$ (edit$, eline%)
lmax% = LEN(edit$) + 1
IF LEN(edit$) < 80 THEN
length% = LEN(edit$)
ELSE
length% = 80
END IF
x% = 1
crx% = 1
chstr$ = edit$ + SPACE$(lmax% - LEN(edit$))
DO
LOCATE eline%, 1
PRINT MID$(chstr$, x%, length%)
CALL crspoz(eline%, crx%)
DO
x$ = INKEY$
LOOP UNTIL x$ <> ""
SELECT CASE x$
CASE CHR$(0) + "M"
IF crx% < length% THEN
crx% = crx% + 1
ELSE
IF x% >= lmax% - length% THEN
BEEP
ELSE
x% = x% + 1
END IF
END IF
CASE CHR$(0) + "K"
IF crx% = 1 THEN
IF x% > 1 THEN x% = x% - 1
ELSE
crx% = crx% - 1
END IF
CASE CHR$(32) TO CHR$(126)
IF LEN(LTRIM$(chstr$)) < lmax% + 1 THEN
chstr$ = MID$(chstr$, 1, x% + crx% - 2) + x$ + MID$(chstr$, x% + crx% - 
1, lmax% - x% - crx%)
IF crx% = length% THEN
x% = x% + 1
IF x% > lmax% - length% THEN
BEEP
x% = x% - 1
END IF
ELSE
crx% = crx% + 1
END IF
END IF
CASE CHR$(0) + "S"'delete
chstr$ = MID$(chstr$, 1, x% + crx% - 2) + MID$(chstr$, x% + crx%, lmax% 
- x% - crx% + 1) + " "
CASE CHR$(8)
IF x% > 1 OR crx% > 1 THEN
chstr$ = MID$(chstr$, 1, x% + crx% - 3) + MID$(chstr$, x% + crx% - 1, 
lmax% - x% - crx% + 2) + " "
IF crx% > 1 THEN
crx% = crx% - 1
ELSE
x% = x% - 1
END IF
END IF
CASE CHR$(13)
EXIT DO
END SELECT
LOOP
inpstr$ = LTRIM$(RTRIM$(chstr$))
CALL crspoz(0, 0)
END FUNCTION