Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/MADTRB36.ZIP/STARTER.PAS

Pascal/Delphi Source File | 1986-02-09 | 19.1 KB | 535 lines

(***************************************************************)
(*                                                             *)
(*        FILER A LA PASCAL DATA BASE SOURCE CODE FILE         *)
(*                                                             *)
(*        (C) 1985 by  John M. Harlan                          *)
(*                     24000 Telegraph                         *)
(*                     Southfield, MI. 48034                   *)
(*                                                             *)
(*     The FILER GROUP of programs is released on a "FREE      *)
(*     SOFTWARE" basis.  The recipient is free to examine      *)
(*     and use the software with the understanding that if     *)
(*     the FILER GROUP of programs prove to be of use and      *)
(*     value,  a contribution to the author is encouraged.     *)
(*                                                             *)
(*     While reasonable effort has been made to ensure the     *)
(*     reliability of the FILER GROUP of programs, no war-     *)
(*     ranty is given. The recipient uses the programs at      *)
(*     his own risk  and in no event shall the author be       *)
(*     liable for damages arising from their use.              *)
(*                                                             *)
(*                                                             *)
(***************************************************************)


program starter; { ONE OF THE FILER GROUP OF PROGRAMS }
{  A GENERALIZED FRAMEWORK FOR A CUSTOMIZED OUTPUT REPORT  }
{  STARTER.PAS  VERSION 2.0 }
{  INCLUDE FILES : STARTER1.PAS }
{  NOV 15, 1984 }

{ Formatted 2/7/86 by Doug Stevens using Pformat and the Turbo
  editors global search/replace. Original version was 100%
  upper case and very hard to read. }

label QUIT;

type
  Range          = array[1..256] of char;
  String60       = string[60];
  String20       = string[20];
  NameStr        = string[12];

var
  filerecchgd      : boolean;
  fileexists       : boolean;
  recaddedtofile   : boolean;
  exitflag         : boolean;

  ch               : char;

  filename       : string[6];
  filedate,
  currdate       : string[8];
  sourcename     : string[14];
  ans            : String60;
  message        : String60;
  prevcontents   : String60;

  w,x,z, code, len,
  maxnbrrec, nbrrecused, rcdlen,
  blockingfactor, fieldperrecord,
  datarecord, diskrecord, precbyte,
  diskrecnowinmem, nbrdiskrecused,
  lastrecused, first,
  ascii,page,line,pagefulllinecount          :    integer;

  numvalue                                   :    real;

  labellength, datalen, dataform,
  labelposn, dataposn, row,
  column, fieldnbr                  :    array[1..32] of integer;
  lbl                               :    array[1..384] of char;
  getdata                           :    Range;
  asciifield                        :    array[1..32] of String60;
  numfield                          :    array[1..32] of real;
  subtotal                          :    array[1..32] of real;
  grandtotal                        :    array[1..32] of real;

  source                            :    file;
{================================================================}
{        BINARY CODED DECIMAL TO INTEGER FUNCTION                }
{================================================================}
function BcdToInt (cha : char) : integer;
begin
  BcdToInt := ord(cha) - trunc(ord(cha)/16)*6;
end;
{================================================================}
{             CHARACTER TO INTEGER FUNCTION                      }
{================================================================}
function ChrToInt(var charray : Range; start, len : integer)  : integer;
var
  code, result : integer;
  workstring   : string[10];
begin
  workstring := '';
  for result := 0 to len-1  do
    begin
      if charray[start + result ] = ' ' then
        workstring := workstring + '0'
      else workstring := workstring + charray[start+result];
    end;
  val(workstring,result,code);
  ChrToInt := result;
end;
{================================================================}
{               GET DATA FROM ARRAY PROCEDURE                    }
{================================================================}
procedure GetDataFromArray(var message : String60; z : integer);
var w :  integer;
begin
  message := '';
  for w := precbyte+dataposn[z] to precbyte+dataposn[z+1]-1 do
    message := message + getdata[w];
end;
{================================================================}
{               TIDE (EDIT BACKWARDS) PROCEDURE                  }
{================================================================}
procedure Tide( var message : String60);
var w  :  integer;
begin
  for w := length(message) downto 1 do
    begin
      if message[w] in [',', '$', '+'] then
        begin
          delete(message,w,1);
          message := ' ' + message;
        end;
    end;
end;
{===============================================================}
{                      FUNCTION EDITNBR                         }
{===============================================================}
function EditNbr(x: real; y,z: integer; dollar: char ) : String20;

var
  numstring : string[24];

begin    { CONVERT THE REAL NUMBER TO A STRING VALUE }
  str(x:18:z,numstring);
  if z = 0 then z := 16  { FIRST POSSIBLE COMMA LOCATION  }
  else z := pos('.',numstring)-3;  {    DITTO             }

  while z > 1 do  {  INSERT COMMAS/SPACES IN THE NUMBER  }
    begin
      if numstring[z-1] in [' ','-'] then
        insert(' ',numstring,z)
      else insert(',',numstring,z);
      z := z -3 ;  {  COMMAS OCCUR EVERY THIRD CHARACTER  }
    end;

  {  FIND THE FIRST NON SPACE CHARACTER IN THE NUMBER }
  z := 0;
  repeat
    z := z + 1;
 until numstring[z] <> ' ';

  { DELETE ANY SPACE FOLLOWING A MINUS SIGN }
  if numstring[z] = '-' then
    begin
      if numstring[z+1] = ' ' then delete(numstring,z+1,1);
      if dollar = '$' then insert('$',numstring,z+1);
    end

  { ADD THE $/SPACE CHARACTER TO THE BEGINNING OF THE NUMBER }
  else numstring[z-1] := dollar;

  { REPLACE THE NUMBER WITH A FIELD OF '<' IF IT IS TOO BIG  }
  z := length(numstring)-y;
  if numstring[z-1] = '-' then
      for z := y downto 0 do numstring[z] := '<'
  else
    begin
      if numstring[z] in ['0'..'9',',','-','.'] then
          for z := y downto 0 do numstring[z] := '<';
    end;
  EditNbr := copy(numstring,z+1,y);

end;
{================================================================}
{               STRING TO REAL NUMBER PROCEDURE                  }
{================================================================}
procedure StringToReal(var source:String60;var numb:real;var code:integer);
var
  w  :  integer;
  condition  :  boolean;
begin
  w := 1;
  numb := 0;
  condition := true;
  Tide(source); { ELIMINATE PUNCTUATION }
  repeat  { UNTIL CONDITION = FALSE }
    if source[w] = ' ' then delete(source,1,1)
    else condition := false;
    if length(source) = 0 then
      begin
        source := '0';
        condition := false;
      end;
  until condition = false;
  if length(source) = 1 then condition := true;
  while condition = false do
    begin
      if source[w] = ' ' then
        begin
          condition := true;
          w := w-2;
        end;
      if length(source) = w then
        begin
          condition := true;
          w := w-1;
        end;
      w := w + 1;
    end;
  source := copy(source,1,w);
  val( source,numb,code );
end;
{================================================================}
{           CALCULATE DISKRECORD & PRECBYTE PROCEDURE            }
{================================================================}
procedure Calculate;
  begin
    diskrecord := trunc((datarecord-1)/blockingfactor)*2+7;
    precbyte := ((datarecord-1) mod blockingfactor)*rcdlen;
  end;
{================================================================}
{                   GET DATA RECORD PROCEDURE                    }
{================================================================}
procedure GetDataRec;
  begin
    Calculate;
    if diskrecord <> diskrecnowinmem then
      begin
        if filerecchgd = true then
          begin
            if diskrecnowinmem > nbrdiskrecused then
              begin                 { GET NEXT AVAILABLE RECORD }
                Seek(source,nbrdiskrecused+2);
                nbrdiskrecused := diskrecnowinmem;
              end
            else
              begin
                Seek(source,diskrecnowinmem);
              end;
            blockwrite(source,getdata,2);  {SAVE CHANGED DATA}
            filerecchgd := false;
          end;

        if diskrecord <= nbrdiskrecused then
          begin
            Seek(source,diskrecord);
            blockread(source,getdata,2);         {  RECORD DATA  }
         end
        else FillChar(getdata[1],256,' '); {SPACES FOR EMPTY REC }

       diskrecnowinmem := diskrecord;
      end;
  end;
{===============================================================}
{                       FUNCTION EXIST                          }
{===============================================================}
function Exist(filename : NameStr) : boolean;
var
  fil    :  file;
  status : Integer;
begin
  Assign(fil,filename);
  {$I-}
  reset(fil);
  {$I+}
  Exist := (IOResult = 0);
{$I-} Close(fil); status := IOResult; {$I+} (* Required by Turbo 3.x *)
end;                                        (* Added by Doug Stevens *)
{================================================================}
{           READ RECORD AND PLACE DATA IN ARRAYS                 }
{================================================================}
procedure MoveRecordDataToArray;
  begin
    Calculate;
    GetDataRec;
    for z := 1 to fieldperrecord do
      begin
        GetDataFromArray(asciifield[z],z);
        if dataform[z] <> ascii then
          begin
            StringToReal(asciifield[z],numfield[z],code);
          end
        else numfield[z] := 0;
      end;
  end;
{================================================================}
{           FUNCTION GET NUMBER IN GETDATA FIELD ( Z )           }
{================================================================}
function FnbrInFld(z : integer) : real;
var
  realval : real;
  begin
    GetDataFromArray(ans,z);
    if dataform[z] <> ascii then
      StringToReal(ans,realval,code)
    else realval := 0;
    FnbrInFld := realval;
  end;
{================================================================}
{                  INITIALIZE FILER FILE                         }
{================================================================}
procedure Initialize;
  label QUIT;

begin
{STARTSTART:}
  repeat
    ClrScr; exitflag := FALSE;
    GotoXY(1,22);
    write('START A LA PASCAL');    { ENTER YOUR REPORT NAME HERE }
    GotoXY(1,23);
    write('ENTER SOURCE FILE NAME : ');
    readln(sourcename);
    x := pos('.',sourcename);
    if x <> 0 then sourcename := copy(sourcename,1,x-1);
    if sourcename = 'END' then
      begin                     { Quick and dirty exit. }
        exitflag := TRUE;
        goto QUIT;
      end;
    sourcename := sourcename + '.DAT';
    fileexists := Exist(sourcename);
  until fileexists = true;
  write('ENTER CURRENT DATE (MM/DD/YY) : ');
  readln( currdate );
  if length(currdate) = 0 then currdate := '  /  /  ';
  Assign( source, sourcename );
  reset( source );
  Seek(source,1);
  blockread( source,getdata,1 );
  blockread( source,lbl,3 );
  filename := 'XXXXXX';
  for x := 1 to 6 do
    filename[x] := getdata[x];
  maxnbrrec := ChrToInt(getdata,7,4);
  nbrrecused := ChrToInt(getdata,11,4);
  rcdlen := ChrToInt(getdata,15,3);
  blockingfactor := ChrToInt(getdata,18,2);
  fieldperrecord := ChrToInt(getdata,20,2);
  filedate := '  /  /  ';
  Move(getdata[22],filedate[1],8);

{================================================================}
{  GET LABEL LENGTH, DATA LENGTH & DATA FORM INFO                }
{================================================================}

labelposn[1] := 1;
dataposn[1] := 1;

for x := 1 to fieldperrecord do
  begin
    labellength[x] :=  BcdToInt(getdata[32+x]);
    datalen[x]     :=  BcdToInt(getdata[64+x]);
    dataform[x]    :=  ord(getdata[96+x])-48;
    labelposn[x+1] :=  labelposn[x] + labellength[x];
    dataposn[x+1]  :=  dataposn[x] + datalen[x];
  end;

{================================================================}
{           TRANSLATE REPORT STRUCTURE                           }
{================================================================}

  blockread(source,getdata,1);  { SCREEN INFORMATION }
      { ESTABLISH VALUE OF DATAFORM[Z] FOR ASCII INFORMATION }
      if getdata[1] = 'S' then ascii := 9 else ascii := 15;
  for x := 1 to fieldperrecord do
    begin
      w := x*4+1;
      row[x]       := BcdToInt(getdata[w]);
      column[x] := BcdToInt(getdata[w+1])*10+trunc(BcdToInt(getdata[w+2])/10);
      {FIELDNBR[X]  := BCDTOIN(GETDATA[W+3]);} { not implemented }
    end;
{================================================================}
{          INITIALIZE VARIABLES FOR ENTRY INTO FILER             }
{================================================================}
  datarecord := nbrrecused;
  Calculate;
  diskrecnowinmem := diskrecord -1; { ENSURE DISK READ FIRST TIME}
  filerecchgd := false;      { ENSURE NO WRITE BEFORE FIRST READ }
  lastrecused := 0;               { SET LAST RECORD USED TO ZERO }
  nbrdiskrecused := diskrecord;     { ESTABLISH MAX DISK REC NBR }
  recaddedtofile := false; { FLAG TO INDICATE CHANGE IN FILE SIZE}
QUIT:
end;  { INTIIALIZE PROCEDURE }
{================================================================}
{                      PROCEDURE NEWPAGE                         }
{================================================================}
procedure NewPage;
begin
  write(Lst,^l);      { FORMFEED COMMAND }
  line := 1;
end;
{================================================================}
{                 PROCEDURE PAGE TITLE                           }
{================================================================}
procedure PageTitle;
begin
  writeln(Lst,'                   SAMPLE REPORT TITLE               ');
  write(Lst,currdate,'                                            ');
  writeln(Lst,'       PAGE ',page);
  writeln(Lst);
  writeln(Lst);
  page := page +1;
  line := line +4;      { FOUR LINES IN THIS REPORT TITLE }
end;
{================================================================}
{                 PROCEDURE DATA HEADING                         }
{================================================================}
procedure DataHeading;
begin
  writeln(Lst,'      NAME                   COMPANY       ACCOUNT 1    ACCOUNT 2');
  writeln(Lst,'=================================================================');
  writeln(Lst);
  line := line +3;         { THREE LINES IN THIS HEADING }
end;
{================================================================}
{                 PROCEDURE PRINT SUB TOTALS                     }
{================================================================}
procedure PrintSubTotals;
begin
  writeln(Lst,'                                        ============   ==========');
  write(Lst,'SUB TOTAL :                               ');
  ans := EditNbr(subtotal[9],10,2,'$');   { SUB TOTAL FOR ACCOUNT 1 }
  write (Lst,ans);
  ans := EditNbr(subtotal[10],13,1,' ');   { SUB TOTAL FOR ACCOUNT 2 }
  writeln(Lst,ans);
  writeln(Lst);

  for x := 1 to 31 do                          { ZERO ALL SUBTOTALS }
    subtotal[x] := 0;

  line := line + 3;         { THREE LINES PRINTED IN THIS SUB TOTAL }

  if line > pagefulllinecount - 3 then
    begin
      NewPage;
      PageTitle;
    end;
end;
{================================================================}
{                 PROCEDURE PRINT GRAND TOTALS                   }
{================================================================}
procedure PrintGrandTotals;
begin
  writeln(Lst,'                                        ============   ==========');
  write(Lst,'GRAND TOTAL :                          ');
  ans := EditNbr(grandtotal[9],13,2,'$');   { SUB TOTAL FOR ACCOUNT 1 }
  write (Lst,ans);
  ans := EditNbr(grandtotal[10],13,1,' ');   { SUB TOTAL FOR ACCOUNT 2 }
  writeln(Lst,ans);
end;



{================================================================}
{                  OUTPUT CODE GOES HERE                         }
{================================================================}
begin

  Initialize;                   { ID AND READ IN FILE PARAMETERS }
  if exitflag then goto QUIT;
  page := 1;                             { INITIALIZE FOR REPORT }
  line := 1;
  pagefulllinecount := 60;
  datarecord := 1;                      { SET UP SUB TOTAL TEST }
  MoveRecordDataToArray;
  prevcontents := asciifield[1];
  for x := 1 to 31 do                { CLEAR SUB & GRAND TOTALS }
    begin
      subtotal[x] := 0;
      grandtotal[x] := 0;
    end;

  PageTitle;                       {  PRINT TITLE ON TOP OF PAGE }

  DataHeading;                              { PRINT DATA HEADING }


  {==============================================================}
  {                 PROCESS BODY OF REPORT                       }
  {==============================================================}

  for datarecord := 1 to nbrrecused do
    begin
      MoveRecordDataToArray;
      {========================================}
      {   CHECK TO SEE IF SUB TOTAL IS REQD    }
      {========================================}
      if asciifield[1] <> prevcontents then
        begin
          prevcontents := asciifield[1];
          PrintSubTotals;
        end;
      {========================================}
      {       WRITE LINE OF DATA HERE          }
      {========================================}
      write(Lst,asciifield[1],' ',asciifield[2],' ');
      ans := EditNbr(numfield[9],10,2,'$');   {  ACCOUNT REC }
      write(Lst,ans);
      ans := EditNbr(numfield[10],13,1,' '); {  AMT PAST DUE }
      writeln(Lst,ans);
      {=======================================}
      {   UPDATE SUB TOTALS & GRAND TOTALS    }
      {=======================================}
      for x := 1 to 31 do
        begin
          subtotal[x] := subtotal[x] + numfield[x];
          grandtotal[x] := grandtotal[x] + numfield[x];
        end;
      {=======================================}
      {   INCREMENT LINE AND CHECK FOR EOP    }
      {=======================================}
      line := line + 1;
      if line > pagefulllinecount then
        begin
          NewPage;
          PageTitle;
          DataHeading;
        end;
    end;  { FOR DATARECORD := 1 TO  }

  PrintSubTotals;
  PrintGrandTotals;

{================================================================}
{                    END PROGRAM                                 }
{================================================================}
QUIT:
end.