home *** CD-ROM | disk | FTP | other *** search
/ ftp.update.uu.se / ftp.update.uu.se.2014.03.zip / ftp.update.uu.se / pub / rainbow / msdos / decus / RB139 / mail20r.lzh / MPRINT.INC < prev    next >
Text File  |  1988-10-09  |  15KB  |  470 lines
  1.   { File = MPRINT.INC -- Include file for Reliance Mailing List
  2.     Copyright (c) 1986 William Meacham, All Rights Reserved
  3.     Revised: 3/7/86 }
  4.  
  5. {Modified for the DEC Rainbow by David P. Maroun on  9-Oct-1988.}
  6.  
  7. overlay procedure print (opt : option) ;
  8.   { print list or labels }
  9.  
  10. var
  11.     which_ones  : prt_criterion ;
  12.     how_to_sort : sort_criterion ;
  13.     stop        : boolean ;        { whether to stop before done }
  14.     prt_num     : num_str_typ ;    { for printing dollar amounts }
  15.     prt_date    : datestring ;
  16.     num_out     : integer ;
  17.  
  18. { ==================== }
  19.  
  20. procedure get_a_rec ;
  21.   { get the next record to print }
  22.   begin
  23.     if how_to_sort = name then
  24.       begin
  25.         nextkey (ix1_file,rec_num,key1) ;
  26.         if OK then
  27.             getrec (mf_file,rec_num,master)
  28.       end
  29.     else { how_to_sort := szip }
  30.       begin
  31.         nextkey (ix2_file,rec_num,key2) ;
  32.         if OK then
  33.             getrec (mf_file,rec_num,master)
  34.       end
  35.   end ; { proc get_a_rec }
  36.  
  37. { ==================== }
  38.  
  39. function is_blank (st:str132) : boolean ;
  40. var
  41.     i : integer ;
  42. begin
  43.     is_blank := true ;
  44.     if not (st = '') then
  45.         for i := 1 to length(st) do
  46.             if not(st[i] = ' ') then
  47.                 is_blank := false
  48. end ; { function is_blank }
  49.  
  50. { ==================== }
  51.  
  52. procedure print_list ;
  53.  
  54. var
  55.     i,
  56.     page_num,
  57.     line_cnt   : integer ;                { counters }
  58.     header1,
  59.     header2    : str132 ;                 { page headers }
  60.     line       : array[1..4] of str132 ;  { detail lines }
  61.     ch         : char ;
  62.  
  63.     { - - - - - - - - - - - - - - - - }
  64.  
  65.     procedure print_page_header ;
  66.     { prints header line at top of each page }
  67.       begin
  68.         page_num := succ(page_num) ;
  69.         if page_num > 1 then
  70.             page (lst) ;
  71.         writeln (lst) ;
  72.         writeln (lst) ;
  73.         write   (lst,header1) ;
  74.         writeln (lst,page_num:5) ;
  75.         writeln (lst,header2) ;
  76.         writeln (lst) ;
  77.         line_cnt := 5
  78.       end ;  { --- proc print_page_header --- }
  79.  
  80.     { - - - - - - - - - - - - - - - - }
  81.  
  82.     procedure print (line:str132 ; num_newlines : integer) ;
  83.     { prints a line and the number of newlines indicated }
  84.       var
  85.         i : integer ;
  86.       begin
  87.         if line_cnt > max_lines then
  88.             print_page_header ;
  89.         write (lst,line) ;
  90.         for i := 1 to num_newlines do
  91.             writeln (lst) ;
  92.         line_cnt := line_cnt + num_newlines
  93.       end ;  { --- proc print --- }
  94.  
  95.     { - - - - - - - - - - - - - - - - }
  96.  
  97.     procedure print_a_name ;
  98.       label  99 ;
  99.       var
  100.           i  : integer ;
  101.       begin
  102.         if keypressed then
  103.           begin
  104.             keyin (ch) ;
  105.             if ch = #$1B then
  106.               begin
  107.                 write_str ('STOP NOW? (Y/N)',9,7) ;
  108.                 beep ;
  109.                 read_yn (stop,25,7) ;
  110.                 OK := not stop ;
  111.                 if OK then clrline(9,7) ;
  112.               end
  113.           end ;
  114.         if not OK then goto 99 ;
  115.  
  116.         for i := 1 to 4 do
  117.             line[i] := '' ;
  118.         with master do
  119.           begin
  120.             line[1] := concat(title,' ',frst_name,' ',last_name) ;
  121.             line[1] := stripch (line[1],' ') ;
  122.             add_blanks (line[1],65 - length(line[1])) ;
  123.             line[1] := concat(line[1],'Salut: ',salutation) ;
  124.             add_blanks (line[1],86 - length(line[1])) ;
  125.             line[1] := concat(line[1],'Hm ph: ',home_phon) ;
  126.             add_blanks (line[1],110 - length(line[1])) ;
  127.             line[1] := concat(line[1],'Wk ph: ',work_phon) ;
  128.  
  129.             line[2] := concat('  ',addr1) ;
  130.             add_blanks (line[2],42 - length(line[2])) ;
  131.             line[2] := concat(line[2],'Precinct ',precinct) ;
  132.             add_blanks (line[2],65 - length(line[2])) ;
  133.             editnum (last_amt,wid,frac,prt_num) ;
  134.             prt_date := mk_dt_st (last_date) ;
  135.             line[2] := concat(line[2],'Last amt: $',prt_num,', ',prt_date) ;
  136.             add_blanks (line[2],110 - length(line[2])) ;
  137.             editnum (tot_amt,wid,frac,prt_num) ;
  138.             line[2] := concat(line[2],'Total: $',prt_num) ;
  139.  
  140.             line[3] := concat ('  ',addr2) ;
  141.  
  142.             line[4] := concat('  ',city,', ',state,'  ',zip );
  143. (*          if length(zip) > 5 then
  144.                 line[4] := concat(line[4],'-',copy(zip,6,4)) ;
  145. *)
  146.           end ;
  147.         for i := 1 to 4 do
  148.             if not (is_blank(line[i])) then
  149.                 print (line[i],1) ;
  150.         print ('',1) ;
  151.         num_out := succ(num_out) ;
  152. 99:
  153.       end ; { proc print_a_name }
  154.  
  155.     { - - - - - - - - - - - - - - - - }
  156.  
  157.   begin  { --- procedure print_list --- }
  158.     header1 := 'RELIANCE MAILING LIST' ;         { build header1 line }
  159.     add_blanks (header1,23) ;
  160.     prt_date := mk_dt_st (cur_proc_dt) ;
  161.     header1 := concat(header1,center(concat(scr.ID,'  ',prt_date),43)) ;
  162.     add_blanks (header1,36) ;
  163.     header1 := concat (header1,'PAGE') ;
  164.  
  165.     case which_ones of                           { build header2 line }
  166.       all  :   header2 := 'All the names' ;
  167.       pcat : begin
  168.                header2 := 'Categories: ' ;
  169.                for i := 0 to 7 do
  170.                    if tstbit(mask,i) then
  171.                        header2 := concat(header2,scr.cat_name[i+1],', ') ;
  172.                delete (header2,length(header2)-1,2)
  173.              end ; { pcat }
  174.       pct  :   header2 := concat('Precinct ',pcinct) ;
  175.       pzip :   header2 := concat('Zip code ',copy(zipcode,1,5)) ;
  176.       dt   :   header2 := concat('Contributions since ',mk_dt_st(lastdt)) ;
  177.       amt  : begin
  178.                str (contrib:wid:frac,prt_num) ;
  179.                prt_num := stripch(prt_num,' ') ;
  180.                header2 := concat('Contributions of at least ',prt_num)
  181.              end ;
  182.     end ; { case }
  183.  
  184.     clrscr ;
  185.     write_str ('Printing list of names . . .',9,3) ;
  186.     write_str ('Press ESC to stop ',9,5) ;
  187.  
  188.     open_database ;
  189.     if how_to_sort = name then
  190.         clearkey (ix1_file)
  191.     else  { how_to_sort = szip }
  192.         clearkey (ix2_file) ;
  193.     page_num := 0 ; 
  194.     line_cnt := 99 ; { force header on first page }
  195.     num_out := 0 ;
  196.  
  197.     write (lst,scr.prt_init) ;
  198.     repeat
  199.         get_a_rec ;
  200.         if OK then
  201.             case which_ones of
  202.               all  : print_a_name ;
  203.               pcat : if (master.flags and mask) > 0 then
  204.                         print_a_name ;
  205.               pct  : if master.precinct = pcinct then
  206.                         print_a_name ;
  207.               pzip : if copy(master.zip,1,5) = copy(zipcode,1,5) then
  208.                         print_a_name ;
  209.               dt   : if not (greater_date(lastdt,master.last_date) = 1) then
  210.                         print_a_name ;
  211.               amt  : if not (greater(contrib,master.tot_amt)) then
  212.                         print_a_name ;
  213.             end { case }
  214.     until not OK ;
  215.  
  216.     close_database ;
  217.     if page_num > 0 then
  218.       begin
  219.         print ('',1) ;
  220.         write (lst,num_out) ;
  221.         print (' NAMES PRINTED',1) ;
  222.         page (lst)
  223.       end ;
  224.     write (lst,scr.prt_rset) ;
  225.     gotoxy(9,9) ;
  226.     write(num_out,' names printed') ;
  227.     beep ;
  228.     hard_pause
  229.   end ; { proc print_list }
  230.  
  231. { ==================== }
  232.  
  233. procedure print_labels ;
  234.  
  235. label 99 ;
  236.  
  237. type
  238.     label_buffer  = array [1..4] of string[60] ;  { two-up labels }
  239.  
  240. var
  241.     left, right   : label_buffer ;
  242.     line          : array [1..4] of str132 ;       { print lines }
  243.     ch            : char ;
  244.     left_is_empty : boolean ;
  245.  
  246.     { - - - - - - - - - - - - - - - - }
  247.  
  248.   procedure print_label_array ;    { print two labels, then clear the arrays }
  249.     var
  250.       i : integer ;
  251.     begin
  252.       for i := 1 to 4 do
  253.         begin
  254.           line[i] := left[i] ;
  255.           add_blanks (line[i],71 - length(line[i])) ;
  256.           line[i] := concat(line[i],right[i]) ;
  257.           writeln (lst,line[i]) ;
  258.           left[i] := '' ;
  259.           right[i] := ''
  260.         end ;
  261.       writeln (lst) ;
  262.       writeln (lst) ;
  263.     end ; { proc print_label_array }
  264.  
  265.     { - - - - - - - - - - - - - - - - }
  266.  
  267.   procedure print_test_pattern ;
  268.     var
  269.       savefld,choice : integer ;
  270.  
  271.     procedure print_pattern ;       { fill with Xs and print }
  272.       var
  273.         i,j : integer ;
  274.       begin
  275.         write (lst,scr.prt_init) ;
  276.  
  277.         prt_date := mk_dt_st(cur_proc_dt) ;          { build left[1] line }
  278.         left[1] := concat(' ',scr.ID,' ',prt_date,' ') ;
  279.         for i := length(left[1])+1 to 60 do
  280.             left[1] := concat(left[1],'X') ;
  281.  
  282.         case which_ones of                           { build left[2] line }
  283.           all  :   left[2] := ' All the names' ;
  284.           pcat : begin
  285.                    left[2] := ' Categories:' ;
  286.                    for i := 0 to 7 do
  287.                        if tstbit(mask,i) then
  288.                          begin
  289.                            str (i+1:2,prt_num) ;
  290.                            left[2] := concat(left[2],prt_num)
  291.                          end
  292.                  end ; { pcat }
  293.           pct  :   left[2] := concat(' Precinct ',pcinct) ;
  294.           pzip :   left[2] := concat(' Zip code ',copy(zipcode,1,5)) ;
  295.           dt   :   left[2] := concat(' Contributions since ',mk_dt_st(lastdt)) ;
  296.           amt  : begin
  297.                    str (contrib:wid:frac,prt_num) ;
  298.                    prt_num := stripch(prt_num,' ') ;
  299.                    left[2] := concat(' Contributions of at least ',prt_num)
  300.                  end ;
  301.         end ; { case }
  302.         left[2] := concat(left[2],' ') ;
  303.         for i := length(left[2])+1 to 60 do
  304.             left[2] := concat(left[2],'X') ;
  305.  
  306.         for j := 3 to 4 do                           { build left 3 and 4 }
  307.           begin
  308.             left[j] := ' ' ;
  309.             for i := 2 to 60 do
  310.                 left[j] := concat(left[j],'X')
  311.           end ;
  312.  
  313.         for j := 1 to 4 do                           { build right array }
  314.           begin
  315.             right[j] := ' ' ;
  316.             for i := 2 to 60 do
  317.                 right[j] := concat(right[j],'X')
  318.           end ;
  319.  
  320.         print_label_array ;
  321.         write (lst,scr.prt_rset)
  322.       end ;
  323.  
  324.     begin
  325.       clrscr ;
  326.       write_str ('PRINTING TEST PATTERN',30,2) ;
  327.       write_str ('Use the test pattern to align your printer',20,4) ;
  328.       write_str ('Please select:',26,6) ;
  329.       write_str ('1   Print test pattern again',26,8) ;
  330.       write_str ('2   Print the labels',26,9) ;
  331.       write_str ('ESC Cancel and return to menu',26,10) ;
  332.       write_str ('==> ',26,12) ;
  333.       print_pattern ;
  334.       repeat
  335.           fld := 1 ;
  336.           choice := 0 ;
  337.           read_int (choice,1,30,12) ;
  338.           if choice = 1 then
  339.               print_pattern ;
  340.       until (choice = 2) or (fld = maxint)
  341.     end ; { proc print_test_pattern }
  342.  
  343.     { - - - - - - - - - - - - - - - - }
  344.  
  345.   procedure print_a_label ;
  346.   { put name & address in output buffer, print if buffer full }
  347.  
  348.     procedure fill (var buf : label_buffer) ;
  349.       var
  350.         i,j : integer ;
  351.       begin
  352.         with master do
  353.           begin
  354.             buf[1] := concat(title,' ',frst_name,' ',last_name) ;
  355.             buf[1] := stripch (buf[1],' ') ;
  356.             buf[1] := concat(' ',buf[1]) ;
  357.             buf[2] := concat(' ',addr1) ;
  358.             buf[3] := concat(' ',addr2) ;
  359.             buf[4] := concat(' ',city,', ',state) ;
  360.             add_blanks (buf[4],34 - length(buf[4])) ;
  361.             buf[4] := concat(buf[4],zip) ;
  362. (*          if length(zip) > 5 then
  363.                 buf[4] := concat(buf[4],'-',copy(zip,6,4)) ;
  364. *)
  365.             for i := 1 to 4 do                   { get rid of blank lines }
  366.               begin
  367.                 if is_blank (buf[i]) then
  368.                   begin
  369.                     for j := i to 3 do
  370.                         buf[j] := buf[j+1] ;
  371.                     buf[4] := ''
  372.                   end  { if }
  373.               end { for i ... }
  374.           end { with }
  375.       end ; { proc fill }
  376.  
  377.     begin  { proc print_a_label }
  378.       if keypressed then
  379.         begin
  380.           keyin (ch) ;
  381.           if ch = #$1B then
  382.             begin
  383.               write_str ('STOP NOW? (Y/N)',9,7) ;
  384.               beep ;
  385.               read_yn (stop,25,7) ;
  386.               OK := not stop ;
  387.               if OK then clrline(9,7) ;
  388.             end
  389.         end ;
  390.       if OK then
  391.         begin
  392.           if left_is_empty then
  393.             begin
  394.               fill(left) ;
  395.               left_is_empty := false
  396.             end
  397.           else
  398.             begin
  399.               fill(right) ;
  400.               print_label_array ;
  401.               left_is_empty := true
  402.             end ; { else }
  403.           num_out := succ(num_out)
  404.         end { if OK }
  405.     end ;  { proc print_a_label }
  406.  
  407.     { - - - - - - - - - - - - - - - - }
  408.  
  409.   begin { --- procedure print_labels --- }
  410.     fld := 1 ;
  411.     print_test_pattern ;
  412.     if fld = maxint then goto 99 ;
  413.  
  414.     clrscr ;
  415.     write_str ('Printing labels . . .',9,3) ;
  416.     write_str ('Press ESC to stop ',9,5) ;
  417.     open_database ;
  418.     if how_to_sort = name then
  419.         clearkey (ix1_file)
  420.     else  { how_to_sort = szip }
  421.         clearkey (ix2_file) ;
  422.     left_is_empty := true ;
  423.     num_out := 0 ;
  424.  
  425.     write (lst,scr.prt_init) ;
  426.     repeat
  427.         get_a_rec ;
  428.         if OK then
  429.             case which_ones of
  430.               all : print_a_label ;
  431.               pcat : if (master.flags and mask) > 0 then
  432.                         print_a_label ;
  433.               pct : if master.precinct = pcinct then
  434.                         print_a_label ;
  435.               pzip : if copy(master.zip,1,5) = copy(zipcode,1,5) then
  436.                         print_a_label ;
  437.               dt  : if not (greater_date(lastdt,master.last_date) = 1) then
  438.                         print_a_label ;
  439.               amt : if not (greater(contrib,master.tot_amt)) then
  440.                         print_a_label ;
  441.             end { case }
  442.     until not OK ;
  443.     if not (left_is_empty) then
  444.         print_label_array ;
  445.     write (lst,scr.prt_rset) ;
  446.  
  447.     close_database ;
  448.     gotoxy(9,9) ;
  449.     write(num_out,' names printed') ;
  450.     beep ;
  451.     hard_pause ;
  452.     fld := 3 ;
  453. 99:
  454.   end ; { proc print_labels }
  455.  
  456. { ==================== }
  457.  
  458. begin { --- procedure print --- }
  459.     fld := 1 ;
  460.     select (which_ones, how_to_sort, opt) ;
  461.     if not (fld = maxint) then
  462.         case opt of
  463.             list   : print_list ;
  464.             labels : print_labels
  465.         end ; { case }
  466.     fld := 1
  467. end ; { procedure print }
  468.  
  469. { ---- EOF FILE MPRINT.INC ---------------------------------- }
  470.