{************************************************************************
 ***                                                                  ***
 ***                      BOOK KEEPING                                ***
 ***                                                                  ***
 ************************************************************************}
{$I compdirs}

unit kBooks;

INTERFACE

uses global, objects, files, dattime, scodes, multcurr, devices, tuiedit, setup;

const
	TransactionSize = 70;

	{permanant trial-balance (ultimate root) codes}
	{the codes themselves should be set up by the install program}
	acAssets    	= 'ASS';
	acCreditors 	= 'CRD';
	acBankAccount = 'BNK';
	acLiabilites  = 'LIA';
	acDebtors		 	= 'DBT';
	acVATAccount 	= 'VAT';
	acIncome     	= 'INC';
	acExpenses   	= 'EXP';
	acPurchases  	= 'PUR';
	acDiscounts		= 'DIS';

	acOpeningBalances = 'OB'; {special category for setting opening balances}

type
	PTransaction = ^TTransaction;
	TTransaction = object(TDataItem)
		Date 		: TDate;
		FromAcc : TSCode;
		ToAcc 	: TScode;
		Desc 		: string[30];
		Amount 	: Tmoney;
		PayType : TSCode;    {Payment type?}
		Ref 		: string[8];
		CostCentres : string[11];

		constructor Init;
		destructor Done; virtual;
		procedure CommonInit;
		function DisplayLine : string;
		function Edit : word;
		function Print(prType : word; Device : PDeviceStream) : word;
		constructor Load(var S : TDataStream);
		procedure Store(var S : TDataStream);
	end;


type
	{Account Category scode}
	PAccCatScodeItem = ^TAccCatScodeItem;
	TAccCatScodeItem = object(TScodeItem)
		ParentCat : TSCode;  {parent category}
		Currency : TSCode;

		OpeningBalance : TMoney;
		ClosingBalance : TMoney;

		WorkOpeningBal : TMoney; {not stored/edited - just used in reports}
		WorkClosingBal : TMoney; {ditto}

		constructor Init(const NCode, NDesc,NParentCat : string);
		constructor Load(var S : TDataStream);
		procedure Store(var S : TDataStream);
		function DisplayLine(Maxlen : integer) : string; virtual;
		procedure AddEditFields(P : PObjectEditBox);           virtual;
	end;

	function CreateAccCatScodeItem(Const NCode, NDesc : string) : PScodeItem;


const
 RAccCatScode : TStreamRec = (
	 ObjType : srAccCatScodeItem;
	 VmtLink : Ofs(TypeOf(TAccCatScodeItem)^);
	 Load : @TAccCatScodeItem.Load;
	 Store : @TAccCatScodeItem.Store
 );


procedure InsertTransaction(Date : TDate; FromAcc, ToAcc : TSCode; Desc : string; Amount : TMOney; Ref : string);

function IsCodeinHeirarchy(IsCode,HCode : TSCode) : boolean;
function GetCodeinHeirarchy(Code,HCode : TSCode) : PAccCatSCodeItem;
function MakeHeirarchyLine(Code : TSCode) : string;
function GetParentSCode(Scode : PAccCatScodeItem) : PAccCatSCodeItem;


IMPLEMENTATION

uses
{$IFDEF WINDOWS}
	wui,	{windows}
{$ELSE}
	tui, views, menus, dialogs, {text}
{$ENDIF}
			tuiapp, tasks, {for adding options to maintenance menu}
			tuilist,
			idindex,
			kamsetup,
			vat,
			app, {desktop}
			inpdnt, {for transactions}
			help,
			kbksrpts, {for doing reports}
			indexes, indxutil, {for quicksort for reports}
			tuimsgs, {message boxes}
			minilib;


{***********************************************
 ***              TOOLS                       ***
 ***********************************************}
{checks to see if given code is equal to or in the parent heirarchy of hcode}
function IsCodeinHeirarchy(IsCode,HCode : TSCode) : boolean;
begin
	IsCodeinHeirarchy := GetCodeinHeirarchy(IsCOde, HCode)<>nil;
end;

{finds scode in heirarchy, if it exists}
{Do NOT DISPOSE}
function GetCodeinHeirarchy(Code,HCode : TSCode) : PAccCatSCodeItem;
var Scode : PAccCatSCodeItem;
begin
	if delspace(HCode)='' then
		GetCodeInHeirarchy := nil {reached top}
	else begin
		SCode := PAccCatSCodeItem(GetSCode(scAccounts, HCode));

		if delspace(Code) = delspace(HCode) then
			GetCodeinHeirarchy := SCode
		else begin
			if Scode=nil then begin
				ProgramError('Could not trace heirarchy up from code '+HCode, hcInternalErrorMsg);
				GetCodeinHeirarchy := nil;
			end else begin
				GetCodeinHeirarchy := GetCOdeinHeirarchy(Code, Scode^.ParentCat);
				dispose(Scode, done);
			end;
		end;
	end;
end;


function MakeHeirarchyLine(Code : TSCode) : string;
var SCode : PAccCatScodeItem;
begin
	SCode := PAccCatScodeItem(GetSCode(scAccounts, Code));
	if Scode<>nil then MakeHeirarchyLine := Code+' '+MakeHeirarchyLine(SCode^.ParentCat)
								else MakeHeirarchyLine := '';
end;


function GetParentScode;
begin
	GetParentSCode := PAccCatSCodeItem(GetSCode(scAccounts, SCode^.ParentCat));
end;

{***********************************************
 ***        AUTO-ENTER TRANSACTION           ***
 ***********************************************}
{Used by other programs to help automate accounts - eg kinvoice.pas}
procedure InsertTransaction;
var Transaction : PTransaction;
		TranStream : PDataStream;

begin
	{Create transaction}
	New(Transaction, init);

	Transaction^.Date.SetToDate(Date);
	Transaction^.FromAcc := FromAcc;
	Transaction^.ToAcc := ToAcc;
	Transaction^.Amount.SetTo(Amount);
	Transaction^.Ref   := Ref;
	Transaction^.Desc  := Desc;

	FileAdmin(fiTransactions)^.LogOn;
	Stream(fiTransactions)^.PutAt(Stream(fiTransactions)^.NoRecs, Transaction);
	with Stream(fiTransactions)^ do if Status<>stOk then ErrorMsg('Storing Transaction');
	FileAdmin(fiTransactions)^.LogOff;

	{add to all closing balances of heirarchy...}

	dispose(Transaction, done);

end;





{***********************************************
 ***                                         ***
 ***              TRANSACTIONS               ***
 ***                                         ***
 ***********************************************}

{**************************
 ***      INIT          ***
 **************************}
constructor TTransaction.Init;
begin
	inherited Init;
	CommonInit;
  RecNo := -1;
	Ref := '';
	Date.Clear;
end;

procedure TTransaction.CommonInit;
begin
	Amount.Init;
	SCodeCollection[scAccounts]^.LogOn;
	SCodeCollection[scPayTypes]^.LogOn;
	SCodeCollection[scCostCentres]^.LogOn;
end;

destructor TTransaction.Done;
begin
	SCodeCollection[scAccounts]^.LogOff;
	SCodeCollection[scPayTypes]^.LogOff;
	SCodeCollection[scCostCentres]^.LogOff;
end;

{***************************
 ***   STREAMING         ***
 ***************************}
const
	{--- Required for Stream ----}
	RTransaction : TStreamRec = (
		 ObjType : srTransaction;
		 VmtLink : Ofs(TypeOf(TTransaction)^);
		 Load : @TTransaction.Load;
		 Store : @TTransaction.Store
	);

constructor TTransaction.Load;
var Ver : byte;
		L : longint;
begin
	S.Read(Ver, 1);
	RecNo := -1;
	CommonInit;
	case Ver of
		1 : begin
			Date.Load(S);
			S.Read(FromAcc, sizeof(FromAcc));
			S.Read(ToAcc, sizeof(ToAcc));
			Desc := S.ReadStr;
			Amount.Init; S.Read(L, 4); Amount.Value := L;
			S.Read(PayType, sizeof(PayType));
			S.Read(Ref, sizeof(Ref));
			CostCentres := '';
		end;
		2 : begin
			Date.Load(S);
			FromAcc := S.ReadFixedStr(3);
			ToAcc 	:= S.ReadFixedStr(3);
			Desc 		:= S.ReadStr;
			Amount.Init; S.Read(L, 4); Amount.Value := L;
			PayType := S.ReadFixedStr(3);
			Ref 		:= S.ReadStr;
			CostCentres := S.ReadStr;
		end;
		3 : begin
			{v4.3 (but not updated from prev...), new money type}
			Date.Load(S);
			FromAcc := S.ReadFixedStr(3);
			ToAcc 	:= S.ReadFixedStr(3);
			Desc 		:= S.ReadStr;
			Amount.Load(S);
			PayType := S.ReadFixedStr(3);
			Ref 		:= S.ReadStr;
			CostCentres := S.ReadStr;
		end;
	else
		DBaseMessage(@S,'Ver '+N2Str(Ver)+' not recognised'#13#10'Loading Transaction',mfError,hcInternalErrorMsg);
		fail;
	end;
end;

procedure TTransaction.Store;
var StartPos : longint;
		Ver : byte;
begin
	StartPos := S.GetPos;
	Ver := 3; S.Write(Ver, 1);
	Date.Store(S);
	S.WriteFixedStr(@FromAcc, 3);
	S.WriteFixedStr(@ToAcc, 3);
	S.WriteStr(@Desc);
	Amount.Store(S);
	S.WriteFixedStr(@PayType, 3);
	S.WriteStr(@Ref);
	S.WriteStr(@CostCentres);
	TopUpRecord(S, TransactionSize, StartPos);
end;


{********************************
 **   DISPLAY LINE FOR LISTS  ***
 ********************************}
function TTransaction.DisplayLine;
begin
	DisplayLine := Date.Digit8+' '+SetLength(FromAcc,4)+SetLength(ToAcc,4)
								+SetLength(Desc,30)+PadSpaceL(Amount.Text(mtValue),8)
								+' '+SetLength(PayType,4)+SetLength(Ref,9)+N2Str(RecNo);
end;


{********************************
 ***      EDIT                ***
 ********************************}
function TTransaction.Edit;
var R : TRect;
		EditBox : PObjectEditBox;

begin
	 R.Assign(0, 0, 54, 9); {Size of box}

	 New(EditBox, init(R, 'Transaction Entry',nil));

	 with EditBox^ do begin

		 Options := Options or ofCentered;

		 Insert(New(PSkipBytes, init(6))); {recno, lockterminal, lockcount}

		 {--- Set up box interior ---}
		 { X, Y, Boxlen,  FieldLen,     Title}
		 InsTitledField( 8, 2,  10, 1, 'Date',    new(PInputDate, Init(R)));
		 PInputELine(Current)^.MustInput := True;
		 InsTitledField( 8, 3,  20, 1, 'From',     	new(PInputSCode, Init(R, scAccounts)));
		 PInputELine(Current)^.MustInput := True;
		 InsTitledField( 8, 4,  20, 1, 'To',    new(PInputSCode, Init(R, scAccounts)));
		 PInputELine(Current)^.MustInput := True;
		 InsTitledBox(   8, 5,  20, 1, 'Desc',     30);
		 PInputELine(Current)^.MustInput := True;
		 InsTitledField( 8, 6,  10, 1, 'Amount',  new(PInputMoney, Init(R)));
		 InsTitledField(37, 2,  13, 1, 'Pmt',    new(PInputScode, Init(R, scPayTypes)));
		 InsTitledField(  37, 3,   8, 1, 'Ref',  new(PInputELine, init(R, 8)));
		 InsTitledField(  37, 4,  13, 1, 'C/Ctr', New(PinputSCLine, init(R, 11, scCostCentres)));

		 {-- Buttons --}
		 InsOKButton(30, 6, @Self);
		 InsCancelButton(40, 6);

		 EndInit;
	end;

	EditBox^.SetData(Self);

	Edit := Desktop^.ExecView(EditBox);

	dispose(EditBox, Done);  {Disposes of all those internal bits}
end;


{***********************************
 ***       PRINT                 ***
 ***********************************}
function TTransaction.Print;
var D,Acc,Line : string;
		Money : TMoney;
begin
	Print := cmCancel;

	if (prType and pmScope)=prFullBlck then begin
		{---- Prints out full details ----}
		Device^.writeln(Date.Text(daAbbr)+PadSpaceL(FromAcc,4)+PadSpaceL(ToAcc,4)
				+'  '+SetLength(Desc,31)
				+PadSpaceL(Amount.text(mtRound),10)+' '
				+PadSpaceR(PayType,4)+Ref);

	end else

		if (prType and pmScope)=prOneLine then begin
			{---- Print out summary details suitable for nominal report}
			if Date.Blank then D := space(9) else D := Date.Text(daAbbr);

      if (prType and pmPrintAs)=prToAcc then begin
      	Acc := FromAcc;
				Money.SetTo(Amount);
			end else begin
				Acc := ToAcc;
				Money.Clear; Money.Subtract(Amount); {make negative}
			end;

			Line := '   '+D+' '+SetLength(Desc,31)
												+PadSpaceL(Money.text(mtValue),10)+' '
												+PadSpaceL(delspaceR(Acc),3)+' '
												+PadSpaceR(PayType,4)+Ref;

			{$IFDEF fixit} Line := Line + ' '+N2Str(RecNo); {$ENDIF}

			Device^.Writeln(Line);

		end;

	Print := cmOK;
end;

{*****************************************
 ***       Account Category SCode       **
 *****************************************}
constructor TAccCatScodeItem.Init;
begin
	inherited Init(NCode, NDesc);
	ParentCat := NParentCat;
	Currency := ProgramSetup.Get(siDefaultCurrency,'STE');
	OpeningBalance.Clear;
	ClosingBalance.Clear;
	WorkOpeningBal.Clear;
	WorkClosingBal.CLear;
end;

constructor TAccCatScodeItem.Load;
begin
	inherited Load(S);
	S.Read(ParentCat, 4);
	S.Read(Currency, 4);
	OpeningBalance.Load(S);
	ClosingBalance.Load(S);
	WorkOpeningBal.Clear;
	WorkClosingBal.CLear;
end;

procedure TAccCatScodeItem.Store;
begin
	inherited Store(S);
	S.Write(ParentCat, 4);
	S.Write(Currency, 4);
	OpeningBalance.Store(S);
	ClosingBalance.Store(S);
end;

function TAccCatScodeItem.DisplayLine;
var S : string;
		SS : string;
begin
	S := inherited DisplayLine(Maxlen);
	DisplayLine := SetLength(S, Maxlen-length(ParentCat)-2)+ParentCat+' '+char(GetIDFromCurrency(Currency));
end;

procedure TAccCatScodeItem.AddEditFields(P : PObjectEditBox);
var R : TRect;
begin
	inherited AddEditFields(P);
	with P^ do begin
		GrowTo(Size.X, Size.Y+2); {make room for extra fields}
		InsTitledField(9, 4, 21, 1, 'Parent', New(PInputSCode, init(R, scAccounts)));

		{force a parent, unless it's a root code}
		PInputELine(Current)^.MustInput := not
			((Code=acAssets) or (Code=acLiabilites) or (Code=acIncome) or (Code = acExpenses));

		InsTitledField(9, 5, 21, 1, 'Currncy', New(PInputSCode, init(R, scCurrency)));
		PINputELine(Current)^.MustInput := True;
	end;
end;

function CreateAccCatScodeItem(const NCode, NDesc : string) : PScodeItem;
begin
	CreateAccCatScodeItem := New(PAccCatScodeItem, init(NCode, NDesc,''));
end;

{Construct full account code from single code, building up parents}
{function MakeCompleteAccSCLine(Code : string) : string;
var S : string;
		SCodeItem : PAccCatSCodeItem;
begin
	S := delspace(Code);
	SCodeItem := PAccCatScodeItem(GetSCode(scAccounts, Code));
	while (SCodeItem<>nil) and (typeof(ScodeItem^)=typeof(TAccCatSCodeItem)) and {safety checks}
{				(length(S)<40) and (delspace(ScodeItem^.ParentCat)<>'') do begin {still room and parent}
		{need to add the space so that pos() works in printout to look for whether this is from/to acc}
{		S := delspace(ScodeItem^.ParentCat) + ' '+S;
		ScodeItem := PAccCatScodeItem(GetSCode(scAccounts, ScodeItem^.ParentCat));
	end;
	MakeCompleteAccSCLine := S;
end;


{***********************************************
 ***                                         ***
 ***           VIEW TRANSACTION LIST         ***
 ***                                         ***
 ***********************************************}
type
	PTranList = ^TTranList;
	TTranList = object(TListView)
		constructor Init(var Bounds : TRect; NlsType : word);
		destructor Done; virtual;
		function  GetText(const ItemNo: longint) : string; virtual; {for display}
		procedure SetRange; virtual;
	end;

constructor TTranList.Init;
begin
	inherited Init(Bounds, NlsType);
	FileAdmin(fiTransactions)^.LogOn;
	ColHeader := '  Date   Frm To  Desc                            Amount Pmt Ref      #';
end;

destructor TTranList.Done;
begin
	FileAdmin(fiTransactions)^.LogOff;
	inherited Done;
end;

function TTranList.GetText;
var Tran : Ptransaction;
begin
	Tran := PTransaction(Stream(fiTransactions)^.GetAt(ItemNo));

	GetText := Tran^.DisplayLine;

	dispose(Tran, done);
end;

procedure TTranList.SetRange;
begin
	FirstItem := 0;
	LastItem := Stream(fiTransactions)^.NoRecs-1;             {Set list range}

	inherited SetRange; {sets scroll bars}
end;





{***********************************************
 ***                                         ***
 ***           ENTER A BATCH OF EXPENSES     ***
 ***                                         ***
 ***********************************************}
function NewTransactionStream : PStream; far;
begin
	NewTransactionStream := New(PDataStream, init('KTRANS.DAT', TransactionSize, StreamBufSize));
end;

procedure ExpensesBatch; far;
var	Transaction : PTransaction;
		Control : word;
		TranStream : PDataStream;
		TransList : PTranList;
		R : TRect;

begin
	FileAdmin(fiTransactions)^.LogOn;
	TranStream := Stream(fiTransactions);

	R.XYLD(0,0,80,8);
	New(TransList, init(R, 0));
	Desktop^.Insert(New(PListWindow, init(R, 'Transactions', TransList)));
	TransList^.GoEnd;

	repeat
		New(Transaction, init);
		Control := Transaction^.Edit;
		if Control = cmOK then begin
			TranStream^.PutAt(TranStream^.NoRecs, Transaction);
			with TranStream^ do if Status<>stOk then ErrorMsg('Storing Transaction');
			TransList^.SetRange;
			TransList^.OneDown; {scroll list to end - ie where transaction went}
		end;
		dispose(Transaction, done);
	until Control = cmCancel;

	FileAdmin(fiTransactions)^.LogOff;
end;




{**********************************************
 ***         UNIT INITIALISATION            ***
 **********************************************}
begin
	{$IFDEF fixit} writeln('Initialising kaccount...'); {$ENDIF}

	New(SCodeCollection[scAccounts], init('ACCNUMS.SC','Account Catagories', CreateAccCatSCodeItem));
	New(SCodeCollection[scPayTypes], init('PAYTYPES.SC','Payment Types', StdSCodeCreator));
	New(SCodeCollection[scCostCentres], init('COSTCNTR.SC','Cost Centres', CreateAccCatSCodeItem));

	RegisterType(RAccCatScode);

{$IFDEF KBooks}
	{===== EXPENSES TASK =====}
	RegisterTask(DesktopTasks, cmNewTransaction,  @ExpensesBatch);


	{==== INITIALISE ADMIN BITS =====}
	NewFileAdmin(fiTransactions, 'Transactions Stream',NewTransactionStream);
	RegisterType(RTransaction);

	{add setup (VAT Rate etc) to maintenance menu}
{	RegisterTask(DesktopTasks, cmAccountsSetup,  EditAccountsSetup);{}
{$ENDIF}

end.

