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
/
MROOT1.INC
< prev
next >
Wrap
Text File
|
1986-09-25
|
9KB
|
279 lines
{ File = MROOT1.INC -- Include file for Reliance Mailing List
Copyright (c) 1986 William Meacham, All Rights Reserved
Revised: 3/7/86 }
{ ------------------------------------------------------------- }
procedure setbit (var dbyt : byte ; n : integer) ;
{ sets bit n of a byte to 1 }
begin
dbyt := ((1 shl n) or dbyt)
end ;
{ ------------------------------------------------------------- }
procedure clrbit (var dbyt : byte ; n : integer ) ;
{ sets bit n of a byte to 0 }
begin
dbyt := ((not(1 shl n)) and dbyt)
end ;
{ ------------------------------------------------------------- }
function tstbit (dbyt : byte ; n : integer) : boolean ;
{ test bit n of a byte -- True if 1, False if 0 }
begin
tstbit := not(((1 shl n) and dbyt) = 0)
end ;
{ ------------------------------------------------------------- }
function center (st : str80 ; n : integer) : str80 ;
{ Returns a string of length n. The input string is centered
in a field of length n, framed by blanks. }
var
i : integer ;
out : str80 ;
begin
if n <= length(st) then
out := st
else
begin
out := '' ;
for i := 1 to (n - length(st)) div 2 do
out := concat (out, ' ') ;
out := concat (out, st) ;
for i := length(out)+1 to n do
out := concat (out, ' ')
end ;
center := out
end ; { function center }
{ ------------------------------------------------------------- }
procedure page (var f : text) ;
const
formfeed = ^L ;
begin
write (f,formfeed)
end ;
{ ------------------------------------------------------------ }
procedure add_blanks (var st : str132 ; num_blanks : integer) ;
{ appends the number of blanks indicated to the string }
var
i : integer ;
begin
for i := 1 to num_blanks do
st := concat (st,' ')
end ; { proc add_blanks }
{ ------------------------------------------------------------ }
PROCEDURE EDITNUM (RNUM : REAL ; MAXLEN, FRAC : INTEGER ;
VAR RSTR : num_str_typ) ;
{ Insert commas into string representation of real number -- 8/24/84 }
VAR
I : INTEGER ;
NEG : BOOLEAN ;
BEGIN
NEG := FALSE ;
IF RNUM < 0 THEN
BEGIN
NEG := TRUE ;
RNUM := -RNUM
END ;
STR (RNUM:MAXLEN:FRAC,RSTR) ;
RSTR := STRIPCH (RSTR, ' ') ;
IF NOT (POS('.',RSTR) = 0) THEN { If there is a dec pt ... }
I := POS('.',RSTR) { mark where it is }
ELSE { If no dec pt ... }
I := LENGTH(RSTR) + 1 ; { mark where it would be }
WHILE I > 4 DO
BEGIN
I := I-3 ;
INSERT (',', RSTR, I)
END ;
IF NEG THEN
INSERT ('-', RSTR, 1)
END ; {--- EDITNUM ---}
{ ------------------------------------------------------------ }
procedure write_scr ;
begin
rewrite(scr_file) ;
write(scr_file,scr) ;
close(scr_file)
end ; { proc write_scr }
{ ----------------------------------------------------------- }
procedure read_scr ;
begin
reset(scr_file) ;
read(scr_file,scr) ;
close(scr_file)
end ; { proc read_scr }
{ ----------------------------------------------------------- }
procedure open_database ;
{ Open master file and index files }
procedure bomb (filename : str14) ;
begin
show_msg (concat('CANNOT OPEN ',filename,'!')) ;
halt
end ; { proc bomb }
begin
openfile (mf_file,mf_fname,sizeof(master)) ;
if not OK then bomb (mf_fname) ;
openindex (ix1_file,ix1_fname,sizeof(key1),dups_ok) ;
if not OK then bomb (ix1_fname) ;
openindex (ix2_file,ix2_fname,sizeof(key2),dups_ok) ;
if not OK then bomb (ix2_fname)
end ; { proc open_database }
{ ----------------------------------------------------------- }
procedure close_database ;
{ Close master file and index files }
begin
closefile (mf_file) ;
closeindex (ix1_file) ;
closeindex (ix2_file)
end ; { proc close_database }
{ ----------------------------------------------------------- }
function build_key1 (name : str30) : key1_typ ;
{ Construct key for index file 1, last name }
var
work_area : key1_typ ;
i : integer ;
begin
work_area := purgech(name,' ') ;
for i := 1 to length(work_area) do
work_area[i] := upcase(work_area[i]) ;
build_key1 := work_area
end ; { function build_key1 }
{ ----------------------------------------------------------- }
function build_key2 (name : str30 ; zip : str9) : key2_typ ;
{ Construct key for index file 2, zip plus last name }
begin
build_key2 := concat(purgech(zip,' '),build_key1(name))
end ; { function build_key2 }
{ ----------------------------------------------------------- }
procedure get_prev_rec ;
{ We have already established a value for key1.
This procedure returns the previous key and associated record. }
var
entrykey1 : key1_typ ;
begin
entrykey1 := key1 ;
prevkey (ix1_file,rec_num,key1) ;
if OK then { OK = found previous key }
getrec (mf_file,rec_num,master)
else { not OK = at first key }
begin { re-establish pointer to key1 }
key1 := entrykey1 ;
findkey (ix1_file,rec_num,key1)
end
end ; { proc get_prev_rec }
{ ----------------------------------------------------------- }
procedure get_next_rec ;
{ We have already established a value for key1.
This procedure returns the next key and associated record. }
var
entrykey1 : key1_typ ;
begin
entrykey1 := key1 ;
nextkey (ix1_file,rec_num,key1) ;
if OK then { OK = found next key }
getrec (mf_file,rec_num,master)
else { not OK = at last key }
begin { re-establish pointer to key1 }
key1 := entrykey1 ;
findkey (ix1_file,rec_num,key1)
end
end ; { proc get_prev_rec }
{ ----------------------------------------------------------- }
procedure paint_screen (n:integer) ;
{ Paints a screen on the CRT -- N tells which screen to paint }
begin
case n of
0: { Main menu }
begin
clrscr ;
write_str ('RELIANCE MAILING LIST MAIN MENU', 25,1) ;
write_str (center(scr.ID,30), 26,2) ;
write_str ('Please select:', 26,4) ;
write_str ('1 Set-Up Menu', 26,6) ;
write_str ('2 Add a name', 26,8) ;
write_str ('3 Display or Change a name', 26,9) ;
write_str ('4 Delete a name', 26,10) ;
write_str ('5 Record contributions', 26,11) ;
write_str ('6 Print list of names', 26,13) ;
write_str ('7 Print labels', 26,14) ;
write_str ('8 Create MailMerge file', 26,15) ;
write_str ('9 Change data diskette', 26,17) ;
write_str ('ESC Exit the program', 26,19) ;
write_str ('==>', 26,21)
end ; { 0 }
1: { data entry screen }
begin
write_str ('First Name:',2,3) ;
write_str ('Contributions',47,3) ;
write_str ('Last Name:',3,4) ;
write_str ('Last amount:',49,4) ;
write_str ('Last date:',51,5) ;
write_str ('Title:',7,6) ;
write_str ('Total amount:',48,6) ;
write_str ('Salutation:',2,7) ;
write_str ('Selection categories',47,8) ;
write_str ('Address:',5,9) ;
write_str ('1 ',49,9) ;
write (scr.cat_name[1]) ;
write_str ('2 ',49,10) ;
write (scr.cat_name[2]) ;
write_str ('City:',8,11) ;
write_str ('3 ',49,11) ;
write (scr.cat_name[3]) ;
write_str ('State: Zip Code:',7,12) ;
write_str ('4 ',49,12) ;
write (scr.cat_name[4]) ;
write_str ('5 ',49,13) ;
write (scr.cat_name[5]) ;
write_str ('Home Phone:',2,14) ;
write_str ('Precinct:',31,14) ;
write_str ('6 ',49,14) ;
write (scr.cat_name[6]) ;
write_str ('Work Phone:',2,15) ;
write_str ('7 ',49,15) ;
write (scr.cat_name[7]) ;
write_str ('8 ',49,16) ;
write (scr.cat_name[8])
end { 1 }
else
beep ;
end { case }
end ; { --- Procedure Paint_screen --- }
{ ---- EOF FILE MROOT1.INC ---------------------------------- }
write_s