Oakland CPM Archive/oakcpm.iso/cpm/database/mail20.ark/MPRINT.INC

Text File | 1986-09-25 | 14.5 KB | 468 lines

  { File = MPRINT.INC -- Include file for Reliance Mailing List
    Copyright (c) 1986 William Meacham, All Rights Reserved
    Revised: 3/7/86 }

overlay procedure print (opt : option) ;
  { print list or labels }

var
    which_ones  : prt_criterion ;
    how_to_sort : sort_criterion ;
    stop        : boolean ;        { whether to stop before done }
    prt_num     : num_str_typ ;    { for printing dollar amounts }
    prt_date    : datestring ;
    num_out     : integer ;

{ ==================== }

procedure get_a_rec ;
  { get the next record to print }
  begin
    if how_to_sort = name then
      begin
        nextkey (ix1_file,rec_num,key1) ;
        if OK then
            getrec (mf_file,rec_num,master)
      end
    else { how_to_sort := szip }
      begin
        nextkey (ix2_file,rec_num,key2) ;
        if OK then
            getrec (mf_file,rec_num,master)
      end
  end ; { proc get_a_rec }

{ ==================== }

function is_blank (st:str132) : boolean ;
var
    i : integer ;
begin
    is_blank := true ;
    if not (st = '') then
        for i := 1 to length(st) do
            if not(st[i] = ' ') then
                is_blank := false
end ; { function is_blank }

{ ==================== }

procedure print_list ;

var
    i,
    page_num,
    line_cnt   : integer ;                { counters }
    header1,
    header2    : str132 ;                 { page headers }
    line       : array[1..4] of str132 ;  { detail lines }
    ch         : char ;

    { - - - - - - - - - - - - - - - - }

    procedure print_page_header ;
    { prints header line at top of each page }
      begin
        page_num := succ(page_num) ;
        if page_num > 1 then
            page (lst) ;
        writeln (lst) ;
        writeln (lst) ;
        write   (lst,header1) ;
        writeln (lst,page_num:5) ;
        writeln (lst,header2) ;
        writeln (lst) ;
        line_cnt := 5
      end ;  { --- proc print_page_header --- }

    { - - - - - - - - - - - - - - - - }

    procedure print (line:str132 ; num_newlines : integer) ;
    { prints a line and the number of newlines indicated }
      var
        i : integer ;
      begin
        if line_cnt > max_lines then
            print_page_header ;
        write (lst,line) ;
        for i := 1 to num_newlines do
            writeln (lst) ;
        line_cnt := line_cnt + num_newlines
      end ;  { --- proc print --- }

    { - - - - - - - - - - - - - - - - }

    procedure print_a_name ;
      label  99 ;
      var
          i  : integer ;
      begin
        if keypressed then
          begin
            keyin (ch) ;
            if ch = #$1B then
              begin
                write_str ('STOP NOW? (Y/N)',9,7) ;
                beep ;
                read_yn (stop,25,7) ;
                OK := not stop ;
                if OK then clrline(9,7) ;
              end
          end ;
        if not OK then goto 99 ;

        for i := 1 to 4 do
            line[i] := '' ;
        with master do
          begin
            line[1] := concat(title,' ',frst_name,' ',last_name) ;
            line[1] := stripch (line[1],' ') ;
            add_blanks (line[1],65 - length(line[1])) ;
            line[1] := concat(line[1],'Salut: ',salutation) ;
            add_blanks (line[1],86 - length(line[1])) ;
            line[1] := concat(line[1],'Hm ph: ',home_phon) ;
            add_blanks (line[1],110 - length(line[1])) ;
            line[1] := concat(line[1],'Wk ph: ',work_phon) ;

            line[2] := concat('  ',addr1) ;
            add_blanks (line[2],42 - length(line[2])) ;
            line[2] := concat(line[2],'Precinct ',precinct) ;
            add_blanks (line[2],65 - length(line[2])) ;
            editnum (last_amt,wid,frac,prt_num) ;
            prt_date := mk_dt_st (last_date) ;
            line[2] := concat(line[2],'Last amt: $',prt_num,', ',prt_date) ;
            add_blanks (line[2],110 - length(line[2])) ;
            editnum (tot_amt,wid,frac,prt_num) ;
            line[2] := concat(line[2],'Total: $',prt_num) ;

            line[3] := concat ('  ',addr2) ;

            line[4] := concat('  ',city,', ',state,'  ',copy(zip,1,5)) ;
            if length(zip) > 5 then
                line[4] := concat(line[4],'-',copy(zip,6,4)) ;
          end ;
        for i := 1 to 4 do
            if not (is_blank(line[i])) then
                print (line[i],1) ;
        print ('',1) ;
        num_out := succ(num_out) ;
99:
      end ; { proc print_a_name }

    { - - - - - - - - - - - - - - - - }

  begin  { --- procedure print_list --- }
    header1 := 'RELIANCE MAILING LIST' ;         { build header1 line }
    add_blanks (header1,23) ;
    prt_date := mk_dt_st (cur_proc_dt) ;
    header1 := concat(header1,center(concat(scr.ID,'  ',prt_date),43)) ;
    add_blanks (header1,36) ;
    header1 := concat (header1,'PAGE') ;

    case which_ones of                           { build header2 line }
      all  :   header2 := 'All the names' ;
      pcat : begin
               header2 := 'Categories: ' ;
               for i := 0 to 7 do
                   if tstbit(mask,i) then
                       header2 := concat(header2,scr.cat_name[i+1],', ') ;
               delete (header2,length(header2)-1,2)
             end ; { pcat }
      pct  :   header2 := concat('Precinct ',pcinct) ;
      pzip :   header2 := concat('Zip code ',copy(zipcode,1,5)) ;
      dt   :   header2 := concat('Contributions since ',mk_dt_st(lastdt)) ;
      amt  : begin
               str (contrib:wid:frac,prt_num) ;
               prt_num := stripch(prt_num,' ') ;
               header2 := concat('Contributions of at least ',prt_num)
             end ;
    end ; { case }

    clrscr ;
    write_str ('Printing list of names . . .',9,3) ;
    write_str ('Press ESC to stop ',9,5) ;

    open_database ;
    if how_to_sort = name then
        clearkey (ix1_file)
    else  { how_to_sort = szip }
        clearkey (ix2_file) ;
    page_num := 0 ;
    line_cnt := 99 ; { force header on first page }
    num_out := 0 ;

    write (lst,scr.prt_init) ;
    repeat
        get_a_rec ;
        if OK then
            case which_ones of
              all  : print_a_name ;
              pcat : if (master.flags and mask) > 0 then
                        print_a_name ;
              pct  : if master.precinct = pcinct then
                        print_a_name ;
              pzip : if copy(master.zip,1,5) = copy(zipcode,1,5) then
                        print_a_name ;
              dt   : if not (greater_date(lastdt,master.last_date) = 1) then
                        print_a_name ;
              amt  : if not (greater(contrib,master.tot_amt)) then
                        print_a_name ;
            end { case }
    until not OK ;

    close_database ;
    if page_num > 0 then
      begin
        print ('',1) ;
        write (lst,num_out) ;
        print (' NAMES PRINTED',1) ;
        page (lst)
      end ;
    write (lst,scr.prt_rset) ;
    gotoxy(9,9) ;
    write(num_out,' names printed') ;
    beep ;
    hard_pause
  end ; { proc print_list }

{ ==================== }

procedure print_labels ;

label 99 ;

type
    label_buffer  = array [1..4] of string[60] ;  { two-up labels }

var
    left, right   : label_buffer ;
    line          : array [1..4] of str132 ;       { print lines }
    ch            : char ;
    left_is_empty : boolean ;

    { - - - - - - - - - - - - - - - - }

  procedure print_label_array ;    { print two labels, then clear the arrays }
    var
      i : integer ;
    begin
      for i := 1 to 4 do
        begin
          line[i] := left[i] ;
          add_blanks (line[i],71 - length(line[i])) ;
          line[i] := concat(line[i],right[i]) ;
          writeln (lst,line[i]) ;
          left[i] := '' ;
          right[i] := ''
        end ;
      writeln (lst) ;
      writeln (lst) ;
    end ; { proc print_label_array }

    { - - - - - - - - - - - - - - - - }

  procedure print_test_pattern ;
    var
      savefld,choice : integer ;

    procedure print_pattern ;       { fill with Xs and print }
      var
        i,j : integer ;
      begin
        write (lst,scr.prt_init) ;

        prt_date := mk_dt_st(cur_proc_dt) ;          { build left[1] line }
        left[1] := concat(' ',scr.ID,' ',prt_date,' ') ;
        for i := length(left[1])+1 to 60 do
            left[1] := concat(left[1],'X') ;

        case which_ones of                           { build left[2] line }
          all  :   left[2] := ' All the names' ;
          pcat : begin
                   left[2] := ' Categories:' ;
                   for i := 0 to 7 do
                       if tstbit(mask,i) then
                         begin
                           str (i+1:2,prt_num) ;
                           left[2] := concat(left[2],prt_num)
                         end
                 end ; { pcat }
          pct  :   left[2] := concat(' Precinct ',pcinct) ;
          pzip :   left[2] := concat(' Zip code ',copy(zipcode,1,5)) ;
          dt   :   left[2] := concat(' Contributions since ',mk_dt_st(lastdt)) ;
          amt  : begin
                   str (contrib:wid:frac,prt_num) ;
                   prt_num := stripch(prt_num,' ') ;
                   left[2] := concat(' Contributions of at least ',prt_num)
                 end ;
        end ; { case }
        left[2] := concat(left[2],' ') ;
        for i := length(left[2])+1 to 60 do
            left[2] := concat(left[2],'X') ;

        for j := 3 to 4 do                           { build left 3 and 4 }
          begin
            left[j] := ' ' ;
            for i := 2 to 60 do
                left[j] := concat(left[j],'X')
          end ;

        for j := 1 to 4 do                           { build right array }
          begin
            right[j] := ' ' ;
            for i := 2 to 60 do
                right[j] := concat(right[j],'X')
          end ;

        print_label_array ;
        write (lst,scr.prt_rset)
      end ;

    begin
      clrscr ;
      write_str ('PRINTING TEST PATTERN',30,2) ;
      write_str ('Use the test pattern to align your printer',20,4) ;
      write_str ('Please select:',26,6) ;
      write_str ('1   Print test pattern again',26,8) ;
      write_str ('2   Print the labels',26,9) ;
      write_str ('ESC Cancel and return to menu',26,10) ;
      write_str ('==> ',26,12) ;
      print_pattern ;
      repeat
          fld := 1 ;
          choice := 0 ;
          read_int (choice,1,30,12) ;
          if choice = 1 then
              print_pattern ;
      until (choice = 2) or (fld = maxint)
    end ; { proc print_test_pattern }

    { - - - - - - - - - - - - - - - - }

  procedure print_a_label ;
  { put name & address in output buffer, print if buffer full }

    procedure fill (var buf : label_buffer) ;
      var
        i,j : integer ;
      begin
        with master do
          begin
            buf[1] := concat(title,' ',frst_name,' ',last_name) ;
            buf[1] := stripch (buf[1],' ') ;
            buf[1] := concat(' ',buf[1]) ;
            buf[2] := concat(' ',addr1) ;
            buf[3] := concat(' ',addr2) ;
            buf[4] := concat(' ',city,', ',state) ;
            add_blanks (buf[4],34 - length(buf[4])) ;
            buf[4] := concat(buf[4],copy(zip,1,5)) ;
            if length(zip) > 5 then
                buf[4] := concat(buf[4],'-',copy(zip,6,4)) ;
            for i := 1 to 4 do                   { get rid of blank lines }
              begin
                if is_blank (buf[i]) then
                  begin
                    for j := i to 3 do
                        buf[j] := buf[j+1] ;
                    buf[4] := ''
                  end  { if }
              end { for i ... }
          end { with }
      end ; { proc fill }

    begin  { proc print_a_label }
      if keypressed then
        begin
          keyin (ch) ;
          if ch = #$1B then
            begin
              write_str ('STOP NOW? (Y/N)',9,7) ;
              beep ;
              read_yn (stop,25,7) ;
              OK := not stop ;
              if OK then clrline(9,7) ;
            end
        end ;
      if OK then
        begin
          if left_is_empty then
            begin
              fill(left) ;
              left_is_empty := false
            end
          else
            begin
              fill(right) ;
              print_label_array ;
              left_is_empty := true
            end ; { else }
          num_out := succ(num_out)
        end { if OK }
    end ;  { proc print_a_label }

    { - - - - - - - - - - - - - - - - }

  begin { --- procedure print_labels --- }
    fld := 1 ;
    print_test_pattern ;
    if fld = maxint then goto 99 ;

    clrscr ;
    write_str ('Printing labels . . .',9,3) ;
    write_str ('Press ESC to stop ',9,5) ;
    open_database ;
    if how_to_sort = name then
        clearkey (ix1_file)
    else  { how_to_sort = szip }
        clearkey (ix2_file) ;
    left_is_empty := true ;
    num_out := 0 ;

    write (lst,scr.prt_init) ;
    repeat
        get_a_rec ;
        if OK then
            case which_ones of
              all : print_a_label ;
              pcat : if (master.flags and mask) > 0 then
                        print_a_label ;
              pct : if master.precinct = pcinct then
                        print_a_label ;
              pzip : if copy(master.zip,1,5) = copy(zipcode,1,5) then
                        print_a_label ;
              dt  : if not (greater_date(lastdt,master.last_date) = 1) then
                        print_a_label ;
              amt : if not (greater(contrib,master.tot_amt)) then
                        print_a_label ;
            end { case }
    until not OK ;
    if not (left_is_empty) then
        print_label_array ;
    write (lst,scr.prt_rset) ;

    close_database ;
    gotoxy(9,9) ;
    write(num_out,' names printed') ;
    beep ;
    hard_pause ;
    fld := 3 ;
99:
  end ; { proc print_labels }

{ ==================== }

begin { --- procedure print --- }
    fld := 1 ;
    select (which_ones, how_to_sort, opt) ;
    if not (fld = maxint) then
        case opt of
            list   : print_list ;
            labels : print_labels
        end ; { case }
    fld := 1
end ; { procedure print }

{ ---- EOF FILE MPRINT.INC ---------------------------------- }
              pzip : if copy(master.zip,1,5) = copy(zipcode,1,5) then
                        print_a_label ;