home *** CD-ROM | disk | FTP | other *** search
/ Oakland CPM Archive / oakcpm.iso / cpm / database / mail20.ark / MROOT1.INC < prev    next >
Encoding:
Text File  |  1986-09-25  |  9.0 KB  |  279 lines
  1. { File = MROOT1.INC -- Include file for Reliance Mailing List
  2.     Copyright (c) 1986 William Meacham, All Rights Reserved
  3.     Revised: 3/7/86 }
  4.  
  5. { ------------------------------------------------------------- }
  6.  
  7. procedure setbit (var dbyt : byte ; n : integer) ;
  8.   { sets bit n of a byte to 1 }
  9.  
  10. begin
  11.     dbyt := ((1 shl n) or dbyt)
  12. end ;
  13.  
  14. { ------------------------------------------------------------- }
  15.  
  16. procedure clrbit (var dbyt : byte ; n : integer ) ;
  17.   { sets bit n of a byte to 0 }
  18.  
  19. begin
  20.     dbyt := ((not(1 shl n)) and dbyt)
  21. end ;
  22.  
  23. { ------------------------------------------------------------- }
  24.  
  25. function tstbit (dbyt : byte ; n : integer) : boolean ;
  26.   { test bit n of a byte -- True if 1, False if 0 }
  27.  
  28. begin
  29.     tstbit := not(((1 shl n) and dbyt) = 0)
  30. end ;
  31.  
  32. { ------------------------------------------------------------- }
  33.  
  34. function center (st : str80 ; n : integer) : str80 ;
  35.   { Returns a string of length n.  The input string is centered
  36.     in a field of length n, framed by blanks. }
  37.  
  38.     var
  39.         i   : integer ;
  40.         out : str80 ;
  41.  
  42.     begin
  43.         if n <= length(st) then
  44.             out := st
  45.         else
  46.           begin
  47.             out := '' ;
  48.             for i := 1 to (n - length(st)) div 2 do
  49.                 out := concat (out, ' ') ;
  50.             out := concat (out, st) ;
  51.             for i := length(out)+1 to n do
  52.                 out := concat (out, ' ')
  53.           end ;
  54.         center := out
  55.     end ; { function center }
  56.  
  57. { ------------------------------------------------------------- }
  58.  
  59. procedure page (var f : text) ;
  60.     const
  61.         formfeed = ^L ;
  62.     begin
  63.         write (f,formfeed)
  64.     end ;
  65.  
  66. { ------------------------------------------------------------ }
  67.  
  68. procedure add_blanks (var st : str132 ; num_blanks : integer) ;
  69.   { appends the number of blanks indicated to the string }
  70.     var
  71.         i : integer ;
  72.     begin
  73.         for i := 1 to num_blanks do
  74.             st := concat (st,' ')
  75.     end ;  { proc add_blanks }
  76.  
  77. { ------------------------------------------------------------ }
  78.  
  79. PROCEDURE EDITNUM (RNUM : REAL ; MAXLEN, FRAC : INTEGER ;
  80.                    VAR RSTR : num_str_typ) ;
  81.   { Insert commas into string representation of real number -- 8/24/84 }
  82.     VAR
  83.         I    : INTEGER ;
  84.         NEG  : BOOLEAN ;
  85.     BEGIN
  86.         NEG := FALSE ;
  87.         IF RNUM < 0 THEN
  88.             BEGIN
  89.                 NEG := TRUE ;
  90.                 RNUM := -RNUM
  91.             END ;
  92.         STR (RNUM:MAXLEN:FRAC,RSTR) ;
  93.         RSTR := STRIPCH (RSTR, ' ') ;
  94.         IF NOT (POS('.',RSTR) = 0) THEN     { If there is a dec pt ... }
  95.                 I := POS('.',RSTR)          { mark where it is }
  96.         ELSE                                { If no dec pt ... }
  97.                 I := LENGTH(RSTR) + 1 ;     { mark where it would be }
  98.         WHILE I > 4 DO
  99.             BEGIN
  100.                 I := I-3 ;
  101.                 INSERT (',', RSTR, I)
  102.             END ;
  103.         IF NEG THEN
  104.                 INSERT ('-', RSTR, 1)
  105.     END ; {--- EDITNUM ---}
  106.  
  107. { ------------------------------------------------------------ }
  108.  
  109. procedure write_scr ;
  110.   begin
  111.     rewrite(scr_file) ;
  112.     write(scr_file,scr) ;
  113.     close(scr_file)
  114.   end ; { proc write_scr }
  115.  
  116. { ----------------------------------------------------------- }
  117.  
  118. procedure read_scr ;
  119.   begin
  120.     reset(scr_file) ;
  121.     read(scr_file,scr) ;
  122.     close(scr_file)
  123.   end ; { proc read_scr }
  124.  
  125. { ----------------------------------------------------------- }
  126.  
  127. procedure open_database ;
  128.   { Open master file and index files }
  129.  
  130.   procedure bomb (filename : str14) ;
  131.     begin
  132.       show_msg (concat('CANNOT OPEN ',filename,'!')) ;
  133.       halt
  134.     end ; { proc bomb }
  135.  
  136. begin
  137.     openfile (mf_file,mf_fname,sizeof(master)) ;
  138.     if not OK then bomb (mf_fname) ;
  139.     openindex (ix1_file,ix1_fname,sizeof(key1),dups_ok) ;
  140.     if not OK then bomb (ix1_fname) ;
  141.     openindex (ix2_file,ix2_fname,sizeof(key2),dups_ok) ;
  142.     if not OK then bomb (ix2_fname)
  143. end ; { proc open_database }
  144.  
  145. { ----------------------------------------------------------- }
  146.  
  147. procedure close_database ;
  148.   { Close master file and index files }
  149. begin
  150.     closefile (mf_file) ;
  151.     closeindex (ix1_file) ; 
  152.     closeindex (ix2_file)
  153. end ; { proc close_database }
  154.  
  155. { ----------------------------------------------------------- }
  156.  
  157. function build_key1 (name : str30) : key1_typ ;
  158.   { Construct key for index file 1, last name }
  159. var
  160.     work_area : key1_typ ;
  161.     i         : integer ;
  162. begin
  163.     work_area := purgech(name,' ') ;
  164.     for i := 1 to length(work_area) do
  165.         work_area[i] := upcase(work_area[i]) ;
  166.     build_key1 := work_area
  167. end ;  { function build_key1 }
  168.  
  169. { ----------------------------------------------------------- }
  170.  
  171. function build_key2 (name : str30 ; zip : str9) : key2_typ ;
  172.   { Construct key for index file 2, zip plus last name }
  173. begin
  174.     build_key2 := concat(purgech(zip,' '),build_key1(name))
  175. end ;  { function build_key2 }
  176.  
  177. { ----------------------------------------------------------- }
  178.  
  179. procedure get_prev_rec ;
  180.   { We have already established a value for key1.
  181.     This procedure returns the previous key and associated record. }
  182. var
  183.     entrykey1 : key1_typ ;
  184. begin
  185.     entrykey1 := key1 ;
  186.     prevkey (ix1_file,rec_num,key1) ;
  187.     if OK then                           { OK = found previous key }
  188.         getrec (mf_file,rec_num,master)
  189.     else                                 { not OK = at first key }
  190.       begin                              { re-establish pointer to key1 }
  191.         key1 := entrykey1 ;
  192.         findkey (ix1_file,rec_num,key1)
  193.       end
  194. end ; { proc get_prev_rec }
  195.  
  196. { ----------------------------------------------------------- }
  197.  
  198. procedure get_next_rec ;
  199.   { We have already established a value for key1.
  200.     This procedure returns the next key and associated record. }
  201. var
  202.     entrykey1 : key1_typ ;
  203. begin
  204.     entrykey1 := key1 ;
  205.     nextkey (ix1_file,rec_num,key1) ;
  206.     if OK then                           { OK = found next key }
  207.         getrec (mf_file,rec_num,master)
  208.     else                                 { not OK = at last key }
  209.       begin                              { re-establish pointer to key1 }
  210.         key1 := entrykey1 ;
  211.         findkey (ix1_file,rec_num,key1)
  212.       end
  213. end ; { proc get_prev_rec }
  214.  
  215. { ----------------------------------------------------------- }
  216.  
  217. procedure paint_screen (n:integer) ;
  218.   { Paints a screen on the CRT -- N tells which screen to paint }
  219.     begin
  220.         case n of
  221.           0:    { Main menu }
  222.             begin
  223.               clrscr ;
  224.               write_str ('RELIANCE MAILING LIST MAIN MENU', 25,1) ;
  225.               write_str (center(scr.ID,30), 26,2) ;
  226.               write_str ('Please select:', 26,4) ;
  227.               write_str ('1    Set-Up Menu', 26,6) ;
  228.               write_str ('2    Add a name', 26,8) ;
  229.               write_str ('3    Display or Change a name', 26,9) ;
  230.               write_str ('4    Delete a name', 26,10) ;
  231.               write_str ('5    Record contributions', 26,11) ;
  232.               write_str ('6    Print list of names', 26,13) ;
  233.               write_str ('7    Print labels', 26,14) ;
  234.               write_str ('8    Create MailMerge file', 26,15) ;
  235.               write_str ('9    Change data diskette', 26,17) ;
  236.               write_str ('ESC  Exit the program', 26,19) ;
  237.               write_str ('==>', 26,21)
  238.             end ; { 0 }
  239.           1:    { data entry screen }
  240.             begin
  241.               write_str ('First Name:',2,3) ;
  242.               write_str ('Contributions',47,3) ;
  243.               write_str ('Last Name:',3,4) ;
  244.               write_str ('Last amount:',49,4) ;
  245.               write_str ('Last date:',51,5) ;
  246.               write_str ('Title:',7,6) ;
  247.               write_str ('Total amount:',48,6) ;
  248.               write_str ('Salutation:',2,7) ;
  249.               write_str ('Selection categories',47,8) ;
  250.               write_str ('Address:',5,9) ;
  251.               write_str ('1 ',49,9) ;
  252.               write     (scr.cat_name[1]) ;
  253.               write_str ('2 ',49,10) ;
  254.               write     (scr.cat_name[2]) ;
  255.               write_str ('City:',8,11) ;
  256.               write_str ('3 ',49,11) ;
  257.               write     (scr.cat_name[3]) ;
  258.               write_str ('State:     Zip Code:',7,12) ;
  259.               write_str ('4 ',49,12) ;
  260.               write     (scr.cat_name[4]) ;
  261.               write_str ('5 ',49,13) ;
  262.               write     (scr.cat_name[5]) ;
  263.               write_str ('Home Phone:',2,14) ;
  264.               write_str ('Precinct:',31,14) ;
  265.               write_str ('6 ',49,14) ;
  266.               write     (scr.cat_name[6]) ;
  267.               write_str ('Work Phone:',2,15) ;
  268.               write_str ('7 ',49,15) ;
  269.               write     (scr.cat_name[7]) ;
  270.               write_str ('8 ',49,16) ;
  271.               write     (scr.cat_name[8])
  272.             end  { 1 }
  273.           else
  274.             beep ;
  275.         end { case }
  276.     end ; { --- Procedure Paint_screen --- }
  277.  
  278. { ---- EOF FILE MROOT1.INC ---------------------------------- }
  279.        write_s