CP/M/CPM_CDROM.iso/cpm/database/mail20.ark/MADDETC.INC

Text File | 1986-09-25 | 14.9 KB | 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 -------------------------------- }