|
DataMuseum.dkPresents historical artifacts from the history of: CP/M |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about CP/M Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - metrics - download
Length: 25984 (0x6580)
Types: TextFile
Names: »CHECKS.PAS«
└─⟦dd59903ef⟧ Bits:30005887 Klub diskette for udveksling af software
└─⟦this⟧ »CHECKS.PAS«
PROGRAM checks;
æ Pascal/z version--This is an update from Disk #15 of CheckBk(alias
NOW). The author sez the interesting improvements are the availability
of on-line changes in code assignments, and ability to edit and
reconform the data stored in the file. He has had a little bug in
the 'Dump' portion of the program. If it is selected from the menu
it may or may not lose some data . So if anyone traps that bug be
sure and let us know.å
CONST max_items = 300;
max_codes = 50;
max_add_code = 10;
disk_file = 'A:CHECK82';
left = 7; æ Number of digits to the left of the dp å
right = 2; æ " " " " " right " " " å
æ Number of bytes it takes to represent a fixed-point number å
bytes = (left + right + 1) div 2;
æ Length of a fixed-point converted string å
maxchars = ((left * 4) div 3) + right + 3;
TYPE
signtyp = (plus, minus);
carrytyp = 0..1;
æ The basic unit of a fixed-point number, takes 1 byte of storage. å
byte = 0..255;
modetyp = (none, suplzer, supltzer, wdollar, wcomma, wboth);
æ This is the type around which this whole package is based. å
fixed = record
sign: signtyp;
digits: arrayÆ1..bytesÅ of byte
end;
æ This is a string type which holds a fixed-point number converted å
æ to ASCII. å
fixstr = string maxchars;
$STRING0 = STRING 0;
$STRING255 = STRING 255;
item_data = RECORD
item_number : INTEGER;
month : INTEGER;
day : INTEGER;
year : INTEGER;
amount : FIXED;
description : STRING 30;
code : INTEGER;
END;
VAR command : CHAR;
code_description : ARRAY Æ1..max_codesÅ OF STRING 15;
items : ARRAY Æ1..max_itemsÅ OF item_data;
item_last : 1..max_items;
data_file : FILE of item_data;
lines_printed : 0..80;
code_amount : ARRAY Æ1..max_codesÅ OF FIXED;
entry_year : INTEGER;
swaped : BOOLEAN;
answer : CHAR;
result : INTEGER;
æ This is set by the fixed point functions. It is set true if there å
æ was an overflow. å
fixederror: boolean;
æ This is the carry flag. It is used by the fixed point functions. å
æ The user's code doesn't play with it. å
carry: carrytyp;
(****************************************************************)
(* *)
(* Ithaca InterSystems' Pascal/Z Fixed-Point Package *)
(* *)
(* Written by Robert Bedichek August 1980 *)
(* *)
(****************************************************************)
procedure setlength( var y:$string0; x: integer ); external;
function length( x:$string255 ): integer; external;
(* The next two external functions are in LIB.REL and are automatically *)
(* linked in when the library is being linked in. They add and *)
(* subtract two decimal digits packed into a byte using Z-80 decimal *)
(* arithmetic. *)
function addbyte( var carry: carrytyp; a, b: byte ):byte; external;
function subbyte( var carry: carrytyp; a, b: byte ):byte; external;
function add( a, b: fixed ): fixed;
(************************************************************************)
(* The value of this function is the signed sum of the two value *)
(* parameters. The global variable 'fixederror' is set if there was *)
(* an overflow. *)
(* *)
(* *)
(* *)
(************************************************************************)
var
carry: 0..1;
i: integer;
res: fixed;
begin
carry := 0;
if a.sign = b.sign then (* Like signs, just add *)
begin
add.sign := a.sign;
for i := 1 to bytes do
add.digitsÆ i Å := addbyte( carry, a.digitsÆ i Å, b.digitsÆ i Å );
fixederror := (carry = 1)
end
else (* Unlike signs, subract negative op from pos. *)
begin
fixederror := false;
if a.sign = plus then
for i := 1 to bytes do
res.digitsÆ i Å := subbyte(carry, a.digitsÆ i Å, b.digitsÆ i Å)
else
for i := 1 to bytes do
res.digitsÆ i Å := subbyte(carry, b.digitsÆ i Å, a.digitsÆ i Å);
if carry = 0 then res.sign := plus
else
begin
res.sign := minus;
carry := 0;
(* Take nines complement of the result by subtracting it from zero. *)
for i := 1 to bytes do
res.digitsÆ i Å := subbyte( carry, 0, res.digitsÆ i Å)
end;
add := res
end
end;
function sub( minuend, subtrahend: fixed ): fixed;
(************************************************************************)
(* The value of this function is the signed difference of the two *)
(* value parameters. The global variable 'fixederror' is set if the *)
(* is an overflow. *)
(* *)
(* *)
(* *)
(************************************************************************)
begin
(* Just reverse the sign of the subtrahend and add. *)
if subtrahend.sign = plus then subtrahend.sign := minus
else subtrahend.sign := plus;
sub := add( minuend, subtrahend )
end;
procedure shiftleft( var a: fixed );
(************************************************************************)
(* This procedure shifts all of the packed decimal digits in the *)
(* passed parameter left one position. A zero is shifted into the *)
(* least significant position. The digit shifted out is lost. *)
(* *)
(* *)
(* *)
(************************************************************************)
var
i: integer;
next: byte;
begin
for i := bytes downto 1 do
begin
if i > 1 then next := (a.digitsÆ i - 1 Å div 16)
else next := 0;
a.digitsÆ i Å := ((a.digitsÆ i Å * 16) + next) mod 256
end
end; (* shiftleft *)
procedure shiftright( var a: fixed );
(************************************************************************)
(* This procedure shifts all of the packed decimal digits in the passed *)
(* parameter right one position. A zero is shifted into the most *)
(* significant position. The digits shifted out is lost. *)
(* *)
(* *)
(* *)
(************************************************************************)
var
i: integer;
next: byte;
begin
for i := 1 to bytes do
begin
if i < bytes then next := (a.digitsÆ i + 1 Å mod 16) * 16
else next := 0;
a.digitsÆ i Å := (a.digitsÆ i Å div 16) + next
end
end; (* shiftright *)
function fixtostr( a: fixed; mode: modetyp; trailing: byte ): fixstr;
(************************************************************************)
(* This function returns a formatted string. The 'mode' parameter *)
(* specifies which formatting operation is to take place. The *)
(* 'trailing' parameter specifies the maximum number of digits to the *)
(* right of the decimal point that are to appear. *)
(* *)
(* *)
(************************************************************************)
var
i, j: byte;
result: fixstr;
begin
if trailing > right then trailing := right;
(* Make the 'result' string have 'maxchars' spaces *)
setlength( result, 0 );
for i := 1 to maxchars do append( result, ' ' );
resultÆ maxchars - right Å := '.';
(* Put the digits to the right of the dp into the string *)
for i := maxchars downto maxchars - (right - 1) do
begin
resultÆ i Å := chr((a.digitsÆ 1 Å mod 16) + ord('0'));
shiftright( a )
end;
(* Leave 'trailing' digits to the right of the decimal point *)
for i := maxchars downto (maxchars - (right - trailing)) + 1 do
resultÆ i Å := ' ';
(* Put the digits to the left of the dp into the string *)
j := maxchars - right - 1;
for i := maxchars - right - 1 downto maxchars - left - right do
begin
(* Put a comma between every third digit if 'mode' tells us to *)
if ((((maxchars - right - 1) - i) mod 3) = 0) and
(i < (maxchars - right - 1)) and
(mode >= wcomma) then
begin
resultÆ j Å := ',';
j := j - 1
end;
resultÆ j Å := chr((a.digitsÆ 1 Å mod 16) + ord('0'));
j := j - 1;
shiftright( a )
end;
(* Suppress leading zeros if mode is anything other than 'none' *)
j := j + 1;
if mode > none then
while ((resultÆ j Å = '0') or (resultÆ j Å = ','))
and (j < maxchars - right - 1) do
begin
resultÆ j Å := ' ';
j := j + 1
end;
(* Put a dollar sign in front of the most significant digit if *)
(* 'mode' is 'wdollar' or 'wboth' *)
j := j - 1;
if (mode = wdollar) or (mode = wboth) then
begin
resultÆ j Å := '$';
j := j - 1
end;
(* If the number being converted is negative put a minus sign in *)
(* front of the dollar sign or (if there is no dollar sign) the most *)
(* most significant digit. *)
if a.sign = minus then resultÆ j Å := '-';
(* If we are supposed to suppress leading and trailing zeros *)
(* (mode = supltzer), suppress the trailing ones here. *)
if mode = supltzer then
begin
j := maxchars - ( right - trailing );
while resultÆ j Å = '0' do
begin
resultÆ j Å := ' ';
j := j - 1
end
end;
fixtostr := result
end; (* fixtostr *)
function strtofix( a: fixstr ): fixed;
(************************************************************************)
(* This converts the passed string to fixed point. All characters *)
(* other than the minus sign (-), decimal point(.), and the decimal *)
(* digits (0123456789) are skipped over and ignored. *)
(* *)
(* *)
(* *)
(************************************************************************)
var
rightcount, i: byte;
righthalf: boolean; (* True when scanning digits to right of dp *)
result: fixed;
begin
righthalf := false;
rightcount := 0;
for i := 1 to bytes do result.digitsÆ i Å := 0;
result.sign := plus;
for i := 1 to length( a ) do
if aÆ i Å = '.' then righthalf := true
else
if aÆ i Å = '-' then result.sign := minus
else
if (rightcount < right) and (aÆ i Å <= '9') and (aÆ i Å >= '0')
then
begin
shiftleft( result );
result.digitsÆ1Å := result.digitsÆ1Å + ord(aÆiÅ) - ord('0');
if righthalf then rightcount := rightcount + 1
end;
for i := rightcount to right - 1 do shiftleft( result );
strtofix := result
end; (* strtofix *)
PROCEDURE initialize;
æ set inital values å
VAR count : 0..max_items;
BEGIN
item_last := 1;
FOR count := 1 TO max_codes DO
code_descriptionÆcountÅ := ' ';
code_descriptionÆ1Å := 'Balance forward';
code_descriptionÆ2Å := 'Deposit ';
code_descriptionÆ3Å := 'NOW interest ';
code_descriptionÆ4Å := 'Misc. add ';
code_descriptionÆ11Å := 'House payment ';
code_descriptionÆ12Å := 'Car payment ';
code_descriptionÆ13Å := 'Gas & Electric ';
code_descriptionÆ14Å := 'Gasoline ';
code_descriptionÆ15Å := 'Credit cards ';
code_descriptionÆ16Å := 'Auto insurance ';
code_descriptionÆ17Å := 'Entertainment ';
code_descriptionÆ18Å := 'Telephone ';
code_descriptionÆ19Å := 'Auto maint. ';
code_descriptionÆ20Å := 'Subscriptions ';
code_descriptionÆ21Å := 'Clothing ';
code_descriptionÆ22Å := 'Computer parts ';
code_descriptionÆ23Å := 'Travel/hotels ';
code_descriptionÆ24Å := 'Contributions ';
code_descriptionÆ25Å := 'Misc auto ';
code_descriptionÆ26Å := 'Investments ';
code_descriptionÆ27Å := 'Education ';
code_descriptionÆ28Å := 'Water & sewer ';
code_descriptionÆ29Å := 'Taxes ';
code_descriptionÆ30Å := 'Books ';
code_descriptionÆ31Å := 'Food ';
code_descriptionÆ32Å := 'Drugs ';
code_descriptionÆ33Å := 'Medical service';
code_descriptionÆ34Å := 'Tyme withdrawl ';
code_descriptionÆ35Å := 'Misc insurance ';
code_descriptionÆ36Å := 'Dental ';
code_descriptionÆ37Å := 'Pro tools/equip';
code_descriptionÆ38Å := 'Pro subscript. ';
code_descriptionÆ39Å := 'Pro books ';
code_descriptionÆ40Å := 'Auto Registrat.';
code_descriptionÆ41Å := 'Slip rent ';
code_descriptionÆ42Å := 'Boat expenses ';
code_descriptionÆ43Å := 'Sewing/knitting';
code_descriptionÆ49Å := 'Misc. subtract ';
code_descriptionÆ50Å := 'Misc. expenses ';
END;
PROCEDURE newpage;
æ print form-feed and 2 blank lines å
BEGIN
WRITELN(CHR(12));
WRITELN;
WRITELN;
lines_printed := 0;
END;
PROCEDURE instructions;
æ print description of program operation å
VAR answer : CHAR;
count : INTEGER;
BEGIN
newpage;
WRITELN(' Checkbook program - For Wesley & Shirley Jenkins ');
WRITELN(' Version 1.23 ');
WRITELN;
WRITE(' Want instructions ? ');
READ(answer);
WRITELN;
IF (answer = 'Y') OR (answer = 'y') THEN
BEGIN
newpage;
WRITELN(' -- Commands --');
WRITELN;
WRITELN(' A - Add an item');
WRITELN(' R - Remove an item');
WRITELN(' P - Print all items');
WRITELN(' B - Print by balance');
WRITELN(' S - Sort by date');
WRITELN(' D - Dump to disk');
WRITELN(' L - Load from disk');
WRITELN(' M - Modify an item');
WRITELN(' Q - Quit');
WRITELN(' H - Hardcopy all items');
WRITELN(' I - Hardcopy instructions and codes');
WRITELN(' J - Hardcopy balance');
WRITELN;
WRITELN;
WRITELN('Code Description');
FOR count := 1 TO 27 DO
WRITE('-');
WRITELN;
FOR count := 1 TO 50 DO
IF code_descriptionÆcountÅ <> ' ' THEN
WRITELN(count:3,' ',code_descriptionÆcountÅ);
END;
END;
PROCEDURE heading;
æ print heading for new page of item printout å
VAR count : 0..79;
BEGIN
WRITE(' Item Date Amount Description');
WRITE(' Code');
WRITELN;
FOR COUNT := 1 TO 79 DO WRITE('-');
WRITELN;
END;
PROCEDURE item_print(count : INTEGER);
æ print data on one item å
BEGIN
WITH itemsÆcountÅ DO
BEGIN
WRITE(item_number:5);
WRITE(month:5,'/');
IF day < 10 THEN
WRITE('0',day:1)
ELSE
WRITE(day:2);
WRITE('/',year:2);
WRITE(FIXTOSTR(amount,WBOTH,2));
WRITE(' ',description);
WRITE(' ',code_descriptionÆcodeÅ);
END;
END;
PROCEDURE print_instructions;
æ Output to printer, commands & codes å
VAR file_out : TEXT;
count : INTEGER;
BEGIN
REWRITE('Lst:',file_out);
WRITELN(file_out,CHR(12));
WRITELN(file_out,' ------Commands---------------------- ');
WRITELN(file_out,' A - Add an item');
WRITELN(file_out,' R - Remove an item');
WRITELN(file_out,' P - Print all items');
WRITELN(file_out,' B - Print by balance');
WRITELN(file_out,' S - Sort by date');
WRITELN(file_out,' D - Dump to disk');
WRITELN(file_out,' L - Load from disk');
WRITELN(file_out,' M - Modify an item');
WRITELN(file_out,' Q - Quit');
WRITELN(file_out,' H - Hardcopy all items');
WRITELN(file_out,' I - Hardcopy instructions and codes');
WRITELN(file_out,' J - Hardcopy balance');
WRITELN(file_out);
WRITELN(file_out,'Code Description');
WRITELN(file_out,CHR(9),'---------------------------');
FOR count := 1 TO max_codes DO
WRITELN(file_out,count:3,' ',code_descriptionÆcountÅ);
WRITELN(file_out);
WRITELN;
END;
PROCEDURE print_all;
æ print data for all items in file å
VAR count : INTEGER;
BEGIN
newpage;
heading;
FOR count := 1 TO item_last-1 DO
BEGIN
IF lines_printed = 20 THEN
BEGIN
newpage;
heading;
END;
item_print(count);
lines_printed := lines_printed +1;
WRITELN;
END;
WRITELN;
END;
PROCEDURE hardcopy_heading;
æ prints hardcopy heading for printout å
VAR file_out : TEXT;
count : INTEGER;
BEGIN
REWRITE('Lst:',file_out);
WRITELN(file_out,CHR(12));
WRITE(file_out,' Item Date Amount Description');
WRITE(file_out,' Code');
WRITELN(file_out);
FOR count := 1 TO 79 DO WRITE(file_out,'-');
WRITELN(file_out);
lines_printed := 3;
END;
PROCEDURE copy_all;
æ Hardcopys all items in file å
VAR count : 0..79;
file_out : TEXT;
BEGIN
hardcopy_heading;
FOR count := 1 TO item_last-1 DO
BEGIN
IF lines_printed = 75 THEN
hardcopy_heading;
WITH itemsÆcountÅ DO
BEGIN
REWRITE('Lst:',file_out);
WRITE(file_out,item_number:5);
WRITE(file_out,month:5,'/');
IF day < 10 THEN
WRITE(file_out,'0',day:1)
ELSE
WRITE(file_out,day:2);
WRITE(file_out,'/',year:2);
WRITE(file_out,FIXTOSTR(amount,WBOTH,2));
WRITE(file_out,' ',description);
WRITE(file_out,' ',code_descriptionÆcodeÅ);
WRITELN(file_out);
END;
lines_printed := lines_printed +1;
END;
END;
PROCEDURE print_balance;
æ Print totals by categories and net balance å
VAR item : 1..max_items;
balance : FIXED;
BEGIN
FOR item := 1 TO max_codes DO
code_amountÆitemÅ := STRTOFIX('0');
balance := STRTOFIX('0');
FOR item := 1 TO item_last-1 DO
WITH itemsÆitemÅ DO
code_amountÆcodeÅ := ADD(code_amountÆcodeÅ, amount);
FOR item := 1 TO max_add_code DO
balance := ADD(balance, code_amountÆitemÅ);
FOR item := max_add_code+1 TO max_codes DO
balance := SUB(balance, code_amountÆitemÅ);
newpage;
WRITELN(' Category Amount');
FOR item := 1 TO 32 DO
WRITE('-');
WRITELN;
FOR item := 1 TO max_codes DO
IF code_amountÆitemÅ <> STRTOFIX('0') THEN
WRITELN(code_descriptionÆitemÅ,' -',FIXTOSTR(code_amountÆitemÅ,WBOTH, 2 ));
FOR item := 1 TO 32 DO
WRITE('-');
WRITELN;
WRITELN('Balance -',FIXTOSTR(balance, WBOTH, 2));
WRITELN;
END;
PROCEDURE kopy_balance;
æ hardcopy balance sheet to printer å
VAR item : 1..max_items;
balance : FIXED;
file_out : TEXT;
BEGIN
FOR item := 1 TO max_codes DO
code_amountÆitemÅ := STRTOFIX('0');
balance := STRTOFIX('0');
FOR item := 1 TO item_last-1 DO
WITH itemsÆitemÅ DO
code_amountÆcodeÅ := ADD(code_amountÆcodeÅ, amount);
FOR item := 1 TO max_add_code DO
balance := ADD(balance, code_amountÆitemÅ);
FOR item := max_add_code+1 TO max_codes DO
balance := SUB(balance, code_amountÆitemÅ);
REWRITE('Lst:',file_out);
WRITELN(file_out,CHR(12));
WRITELN(file_out,' Category Amount');
FOR item := 1 TO 32 DO
WRITE(file_out,'-');
WRITELN(file_out);
FOR item := 1 TO max_codes DO
IF code_amountÆitemÅ <>STRTOFIX('0') THEN
BEGIN
WRITE(file_out,code_descriptionÆitemÅ,' -');
WRITELN(file_out,FIXTOSTR(code_amountÆitemÅ,WBOTH, 2 ));
END;
FOR item := 1 TO 32 DO
WRITE(file_out,'-');
WRITELN(file_out);
WRITELN(file_out,'Balance -',FIXTOSTR(balance, WBOTH, 2));
WRITELN(file_out);
END;
PROCEDURE remove;
æ remove item from file å
VAR remove : CHAR;
found,item : INTEGER;
item_remove : INTEGER;
BEGIN
found :=0;
WRITELN;
WRITE(' Remove item number - ');
READ(item_remove);
FOR item := 1 TO item_last-1 DO
IF itemsÆitemÅ.item_number = item_remove THEN
found := item;
WRITELN;
IF found <> 0 THEN
BEGIN
heading;
item_print(found);
WRITELN;
WRITELN;
WRITE(' Remove ? ');
READ(remove);
IF (remove = 'Y') OR (remove = 'y') THEN
BEGIN
FOR item := found TO item_last-1 DO
itemsÆitemÅ := itemsÆitem+1Å;
item_last := item_last-1;
END;
END;
IF found = 0 THEN
WRITELN(' Item not in list.....');
END;
PROCEDURE entry;
æ console entry of check/deposit data å
VAR ch : CHAR;
number : STRING 20;
BEGIN
REPEAT
WITH itemsÆitem_lastÅ DO
BEGIN
description := ' ';
WRITELN;
WRITE(' Item number ? ');
READLN(item_number);
WRITE(' Month ? ');
READ(month);
WRITE(' Date ? ');
READ(day);
WRITE(' Amount ? ');
READ(number);
amount := STRTOFIX(number);
WRITELN(' _____________________________');
WRITE(' Description ? ');
READLN(description);
WHILE LENGTH(description) <> 30 DO
APPEND(description,' ');
WRITE(' Code ? ');
READ(code);
year := entry_year;
WRITELN;
END;
heading;
item_print(item_last);
WRITELN;
WRITELN;
WRITE(' Correct ? ');
READ(ch);
UNTIL (ch ='Y') OR (ch = 'y');
itemsÆitem_last+1Å := itemsÆitem_lastÅ;
itemsÆitem_last+1Å.item_number := 0;
item_last := item_last+1;
WRITELN;
END;
PROCEDURE modify;
æ modify a field in an item å
VAR found,item : INTEGER;
number : STRING 20;
name : STRING 30;
item_modify : INTEGER;
answer : CHAR;
A,B,C,D,N,R : STRING 3;
BEGIN
A:=CHR(27);
B:=CHR(48);
C:=CHR(64);
APPEND(A,B);
APPEND(A,C);
N:=A;
A:=CHR(27);
B:=CHR(48);
D:=CHR(80);
APPEND(A,B);
APPEND(A,D);
R:=A;
found := 0;
WRITELN;
WRITE(' Modify Item number - ');
READ(item_modify);
WRITELN;
FOR item := 1 TO item_last-1 DO
IF itemsÆitemÅ.item_number=item_modify THEN
found := item;
WRITELN;
IF found<>0 THEN
BEGIN
heading;
item_print(found);
WRITELN;
WRITE(R,'I',N,'tem # ');
WRITE(R,'M',N,'onth ');
WRITE(R,'D',N,'ate ');
WRITE(R,'A',N,'mount ');
WRITE(R,'N',N,'ame or description ');
WRITELN(R,'C',N,'ode');
WRITELN;
WRITELN(' Modify one of the above fields ');
WRITE(' Enter letter of the field to be changed?- ');
READ(answer);
WRITELN;
CASE answer OF
'I','i':BEGIN
WRITE(' New item number- ');
READLN(itemsÆfoundÅ.item_number);
WRITELN;
END;
'M','m':BEGIN
WRITE(' New month- ');
READ(itemsÆfoundÅ.month);
WRITELN;
END;
'D','d':BEGIN
WRITE(' New day- ');
READ(itemsÆfoundÅ.day);
WRITELN;
END;
'A','a':BEGIN
WRITE(' New amount- ');
READ(number);
WRITELN;
itemsÆfoundÅ.amount:=STRTOFIX(number);
END;
'N','n':BEGIN
WRITE(' New name or description- ');
READLN(name);
WRITELN;
WHILE LENGTH(name)<>30 DO
APPEND(name,' ');
itemsÆfoundÅ.description:=name;
END;
'C','c':BEGIN
WRITE(' New code #- ');
READ(itemsÆfoundÅ.code);
WRITELN;
END;
END;
END;
END;
PROCEDURE swap_items(item : INTEGER ; VAR swaped : BOOLEAN);
æ exchange file data at location with location+1 å
BEGIN
itemsÆmax_itemsÅ := itemsÆitemÅ;
itemsÆitemÅ := itemsÆitem+1Å;
itemsÆitem+1Å := itemsÆmax_itemsÅ;
swaped := TRUE
END;
PROCEDURE date_sort;
æ sort data file by date å
VAR finish , item : 0..max_items;
date_first , date_second : REAL;
item_first , item_second : INTEGER;
BEGIN
finish := item_last-2;
REPEAT
swaped := FALSE;
FOR item := 1 TO finish DO
BEGIN
WITH itemsÆitemÅ DO
BEGIN
date_first := year * 10000.0 + month * 100.0 + day;
item_first := item_number;
END;
WITH itemsÆitem+1Å DO
BEGIN
date_second := year * 10000.0 + month * 100.0 + day;
item_second := item_number;
END;
IF date_first > date_second THEN
swap_items(item,swaped);
IF (date_first = date_second) AND (item_first > item_second) THEN
swap_items(item,swaped);
END;
IF finish > 2 THEN
finish := finish -1;
UNTIL NOT swaped
END;
PROCEDURE dump;
æ write file of item information to disk å
VAR count : INTEGER;
BEGIN
RESET(disk_file, data_file);
REWRITE(disk_file,data_file);
FOR count := 1 TO item_last DO
WRITE(data_file,itemsÆcountÅ);
END;
PROCEDURE read_disk;
æ load data from disk to file å
BEGIN
WRITELN;
RESET(disk_file,data_file);
item_last := 1;
REPEAT
READ(data_file,itemsÆitem_lastÅ);
WRITE('.');
IF item_last MOD 10 = 0 THEN
WRITELN;
item_last := item_last + 1;
UNTIL itemsÆitem_last-1Å.item_number = 0;
item_last := item_last -1;
WRITELN;
END;
PROCEDURE prog_commands;
æ console entry of program command å
BEGIN
WRITELN;
WRITE(' Command ? ');
READ(command);
CASE command OF
'A','a' : entry;
'B','b' : print_balance;
'P','p' : print_all;
'R','r' : remove;
'S','s' : date_sort;
'D','d' : dump;
'L','l' : read_disk;
'M','m' : modify;
'H','h' : copy_all;
'I','i' : print_instructions;
'J','j' : kopy_balance;
ELSE :
IF (command = 'Q') OR (command ='q') THEN
WRITELN(' Leaving Program')
ELSE
WRITELN(' Invalid command .....')
END;
END;
æ Mainline Program å
BEGIN
initialize;
instructions;
WRITELN;
WRITE(' Enter year " 2-digit " for new entries - ');
READ(entry_year);
WRITELN;
WRITELN;
REPEAT
prog_commands;
UNTIL (command = 'q') OR (command = 'Q');
WRITELN;
WRITE(' Save file ? ');
READ(answer);
IF (answer ='Y') OR (answer = 'y') THEN
dump;
END.
«eof»