home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
ftp.barnyard.co.uk
/
2015.02.ftp.barnyard.co.uk.tar
/
ftp.barnyard.co.uk
/
cpm
/
walnut-creek-CDROM
/
CPM
/
DATABASE
/
MAIL20.ARK
/
MADDETC.INC
< prev
next >
Wrap
Text File
|
1986-09-25
|
15KB
|
500 lines
{ File = MADDETC.INC -- Include file for Reliance Mailing List
Copyright (c) 1986 William Meacham, All Rights Reserved
Revised : 3/2/86 }
{ ----------------------------------------------------------- }
overlay procedure do_name (opt : option) ;
{ Add, display/change, delete and record contribution for a name }
{ ==================== }
procedure add_name ;
{ add a name and address record -- get input from screen and
insert into database }
label 99 ;
const
full_msg : string[30] = 'CANNOT ADD -- THE FILE IS FULL' ;
var
save_it,
some_added,
do_another : boolean ;
begin
clrscr ;
write_str ('ADD A NAME',34,1) ;
paint_screen(1) ;
if scr.num_recs >= scr.max_rec then
begin
show_msg(full_msg) ;
goto 99
end ;
open_database ;
some_added := false ;
repeat
clear_display ;
clear_master ;
input_master ;
if fld = maxint then
save_it := false
else
begin
write_str ('Do you wish to save this information? (Y/N)',16,23) ;
read_yn (save_it,60,23) ;
clrline(16,23)
end ;
if save_it then
begin
key1 := build_key1 (master.last_name) ;
key2 := build_key2 (master.last_name,master.zip) ;
addrec (mf_file,rec_num,master) ;
addkey (ix1_file,rec_num,key1) ;
addkey (ix2_file,rec_num,key2) ;
write_str ('SAVED',16,23) ;
some_added := true
end { if save_it }
else
write_str ('NOT SAVED',16,23) ;
write_str ('Do you wish to add another name? (Y/N)',16,24) ;
read_yn (do_another,55,24) ;
if do_another
and (usedrecs(mf_file) >= scr.max_rec) then
begin
show_msg (full_msg) ;
do_another := false
end
until not do_another ;
if some_added then
begin
scr.num_recs := usedrecs (mf_file) ;
write_scr
end ;
close_database ;
99:
fld := 1
end ; { proc add_name }
{ ==================== }
procedure get_index (code : char) ;
{ Input name to display/change or delete, construct key,
search index, return global variables Key1 and Rec_num }
label 99 ;
var
name : str30 ;
get_closest : boolean ;
begin
clrscr ;
if code = 'C' then
write_str ('DISPLAY OR CHANGE A NAME',28,2)
else if code = 'D' then
write_str ('DELETE A NAME',33,2)
else { code = 'R' }
write_str ('RECORD A CONTRIBUTION',30,2) ;
write_str ('Press ESC to cancel',31,3) ;
if scr.num_recs = 0 then
begin
show_msg ('THE FILE IS EMPTY') ;
fld := maxint ;
goto 99
end ;
write_str ('Last name:',19,6) ;
name := '' ;
fld := 1 ;
repeat
case fld of
1: begin
read_str (name,30,30,6) ;
if (name = '') and not (fld = maxint) then
begin
beep ;
fld := 1
end
else if (fld > 1) and (fld < maxint) then
fld := 2
end ; { 1 }
2: begin
key1 := build_key1(name) ;
findkey (ix1_file,rec_num,key1) ;
if OK then
fld := 3
else
begin
write_str ('NAME NOT FOUND',19,10) ;
write_str ('Do you wish to view the closest one found?',19,12) ;
write_str ('(Y/N)',33,14) ;
get_closest := true ;
read_bool (get_closest,39,14) ;
if fld < 2 then
begin
clrline (19,10) ;
clrline (19,12) ;
clrline (33,14)
end
else if (fld > 2) and (fld < maxint) then
begin
if get_closest then
begin
prevkey (ix1_file,rec_num,key1) ;
if not OK then
searchkey (ix1_file,rec_num,key1)
end
else { not get_closest }
begin
clrline (19,10) ;
clrline (19,12) ;
clrline (33,14) ;
fld := 1
end
end { if (fld > 2) ... }
end { else, not OK }
end { 2 }
end ; { case }
if fld < 1 then fld := 1
until fld > 2 ;
99:
{ the calling proc must check for fld = maxint }
end ; { function get_index }
{ ==================== }
procedure prev_next_menu (code : char) ;
begin
write_str('SELECT: 1 Display previous name',20,18) ;
write_str('2 Display next name',29,19) ;
write_str('3 ',29,20) ;
if code = 'C' then
write ('CHANGE')
else if code = 'D' then
write ('DELETE')
else
write ('RECORD CONTRIBUTION for') ;
write (' this name') ;
write_str('ESC Cancel ==>',29,21) ;
end ; { proc prev_next_menu }
{ ==================== }
procedure choose_name (var code : char) ;
{ Select record to update, delete or record a contribution for.
Returns: valid rec_num and key1 if a name is selected;
fld = maxint if user cancelled while displaying names;
ch = 'Q' if user cancelled while entering name to search for. }
begin
get_index (code) ; { this updates globals rec_num and key1 }
if fld = maxint then
code := 'Q'
else
begin
clrscr ;
if code = 'C' then
write_str ('DISPLAY OR CHANGE A NAME',28,1)
else if code = 'D' then
write_str ('DELETE A NAME',33,1)
else { code = 'R' }
write_str ('RECORD A CONTRIBUTION',30,1) ;
paint_screen(1) ;
prev_next_menu (code) ;
getrec (mf_file,rec_num,master) ;
repeat
clear_display ;
display_master ;
(* write_str ('record ',2,18) ; write (rec_num,' ') ; *)
(* write_str ('key ',2,19) ; write (key1,' ') ; *)
choice := 0 ;
repeat
fld := 1 ;
read_int(choice,1,56,21)
until ((choice in [1..3]) and (fld > 1)) or (fld = maxint) ;
case choice of
1: get_prev_rec ;
2: get_next_rec
end ; { case }
until (choice = 3) or (fld = maxint)
end { else }
{ the calling proc must check for fld = maxint and code = 'Q' }
end ; { proc choose_name }
{ ==================== }
procedure change_name ;
{ display / change name & address information }
label 99 ;
var
save_it,
do_another : boolean ;
i : integer ;
entryname : str30 ;
entryzip : str9 ;
code : char ;
begin
open_database ;
repeat
code := 'C' ;
choose_name (code) ;
if code = 'Q' then
begin
do_another := false ;
goto 99
end ;
for i := 18 to 21 do
clrline (1,i) ;
if not (fld = maxint) then
begin
entryname := master.last_name ;
entryzip := master.zip ;
input_master
end ;
if fld = maxint then
save_it := false
else
begin
write_str ('Do you wish to save this information? (Y/N)',16,23) ;
read_yn (save_it,60,23) ;
clrline (16,23)
end ;
if save_it then { save the record }
begin { change the keys if needed }
if not (entryzip = master.zip)
or not (entryname = master.last_name) then
begin
key2 := build_key2 (entryname,entryzip) ;
deletekey (ix2_file,rec_num,key2) ;
key2 := build_key2 (master.last_name,master.zip) ;
addkey (ix2_file,rec_num,key2) ;
end ;
if not (entryname = master.last_name) then
begin
key1 := build_key1 (entryname) ;
deletekey (ix1_file,rec_num,key1) ;
key1 := build_key1 (master.last_name) ;
addkey (ix1_file,rec_num,key1) ;
end ;
putrec (mf_file,rec_num,master) ;
write_str ('SAVED',16,23)
end { if save_it }
else
write_str ('NOT SAVED',16,23) ;
write_str ('Do you wish to change another name? (Y/N)',16,24) ;
read_yn (do_another,58,24) ;
99:
until not do_another ;
close_database ;
fld := 1
end ; { proc change_name }
{ ==================== }
procedure delete_name ;
{ delete a name and address record }
label 99 ;
var
i : integer ;
some_deleted,
do_another : boolean ;
code : char ;
procedure bad_delete ;
begin
show_msg ('ERROR DELETING -- REBUILD DATABASE') ;
scr.num_recs := usedrecs(mf_file) ;
write_scr ;
close_database ;
halt
end ;
begin
open_database ;
some_deleted := false ;
repeat
code := 'D' ;
choose_name (code) ;
if code = 'Q' then
begin
do_another := false ;
goto 99
end ;
for i := 18 to 21 do
clrline (1,i) ;
if fld = maxint then
write_str ('NOT DELETED',16,23)
else { delete the record }
begin
deletekey (ix1_file,rec_num,key1) ;
if OK then
begin
key2 := build_key2 (master.last_name,master.zip) ;
deletekey (ix2_file,rec_num,key2) ;
if OK then
begin
deleterec (mf_file,rec_num) ;
if OK then
begin
write_str ('DELETED',16,23) ;
some_deleted := true
end
else
bad_delete
end
else
bad_delete
end
else
bad_delete
end ; { else, delete the record }
write_str ('Do you wish to delete another name? (Y/N)',16,24) ;
read_yn (do_another,58,24) ;
99:
until not do_another ;
if some_deleted then
begin
scr.num_recs := usedrecs(mf_file) ;
write_scr
end ;
close_database ;
fld := 1
end ; { proc delete_name }
{ ------------------------------ }
procedure record_contribution ;
label 99 ;
var
save_it,
do_another : boolean ;
i : integer ;
new_amt,
new_tot : real ;
new_date : date ;
code : char ;
begin
open_database ;
repeat
code := 'R' ;
choose_name (code) ;
if code = 'Q' then
begin
do_another := false ;
goto 99
end ;
for i := 18 to 21 do
clrline (1,i) ;
if not (fld = maxint) then
begin
new_amt := 0.0 ;
new_tot := master.tot_amt ;
new_date := null_date ;
write_str ('Previous total: $',24,18) ;
write_real (master.tot_amt,wid,frac,42,18) ;
write_str ('Contribution:',26,19) ;
write_str ('New total:',29,20) ;
write_real (master.tot_amt,wid,frac,42,20) ;
write_str ('Date:',34,21) ;
write_date (new_date,44,21) ;
fld := 1 ;
repeat
case fld of
1 : begin
read_real (new_amt,wid,frac,42,19) ;
if (fld > 1) and (fld < maxint) then
begin
if not(greater(new_amt,0.0)) then
begin
beep ;
fld := 1
end
else
begin
new_tot := master.tot_amt + new_amt ;
write_real (new_tot,wid,frac,42,20)
end
end
end ; { 1 }
2 : read_date (new_date,44,21) ;
3 : pause
end ; { case }
if fld < 1 then
fld := 1
else if (fld > 2) and (fld < maxint) then
begin
if (not (valid_date(new_date)))
or (equal_date(new_date,null_date))
or (greater_date(master.last_date,new_date) = 1) then
begin
show_msg ('NEW DATE MAY NOT BE EARLIER THAN CURRENT LAST DATE') ;
fld := 2
end
end ;
if (fld > 99) and (fld < maxint) then
fld := 3
until (fld > 3)
end ; { if not fld = maxint }
if fld = maxint then
save_it := false
else
begin
write_str ('Do you wish to save this information? (Y/N)',16,23) ;
read_yn (save_it,60,23) ;
clrline (16,23)
end ;
if save_it then { save the record }
with master do
begin
last_amt := new_amt ;
last_date := new_date ;
tot_amt := tot_amt + new_amt ;
write_real (last_amt,wid,frac,65,4) ;
write_date (last_date,67,5) ;
write_real (tot_amt,wid,frac,65,6) ;
putrec (mf_file,rec_num,master)
end { with }
else
write_str ('NOT SAVED',16,23) ;
write_str ('Do you wish to record another contribution? (Y/N)',16,24) ;
read_yn (do_another,66,24) ;
99:
until not do_another ;
close_database ;
fld := 1
end ; { record_contribution }
{ ------------------------------ }
begin { proc do_name }
case opt of
add : add_name ;
change : change_name ;
del_rec : delete_name ;
contribution : record_contribution
end
end ; { proc do_name }
{ ---------- EOF MADDETC.INC -------------------------------- }