{***************************************************************
 ***            IMPORT FROM PPMS							               ***
 ***************************************************************}
program KPPMS;

{$L+}   {Local symbol generation}
{$D+}   {Debug on - can leave in - no change to size of exe}

{For debugging only}
{$R+}   {Range checking - Take out when debugged}
{$Q+}   {Overflow checking}
{$S+}   {Stack overflow checking}

uses
{$IFDEF MSDOS}
		overlay, overinit,
{$ENDIF}

		sbs,
		global,
		tasks,
		doslink,
		crt, views,
		kperson,
		dattime, kmaint, files, minilib, setup, app,
		scodes, errors, kwplink, kletter, khistory, kmore, extras,
		kaltadd, kppmedcl, kevent, kinvoice,
		pchain,  {pure chain details}
		kfixit, {for dbase check}
		kamapp;

{$IFDEF MSDOS}
	{$O menus}
	{$O views}
	{$O dialogs}
	{$O objects}

	{$O inpflds}
	{$O kmaint}
	{$O mlist}
	{$O setup}
	{$O errors}
	{$O scodes}
	{$O kwplink}
	{$O kletter}
	{$O khistory}
	{$O kmore}
	{$O extras}
	{$O kaltadd}
	{$O kppmedcl}
	{$O kevent}
	{$O kinvoice}
	{$O pchain}
	{$O chview}
	{$O pchview}
	{$O editors}
	{$O etvision}
	{$O files}


{$ENDIF}

{CONFIG FOR DATABASE}

{Latest system has all the above commented IN}

{$DEFINE FIcvms}					{File 2 has 4 byte pointers}
{$DEFINE LIWPLink}				{LI has WP link fields, ie LI10 and LI11}
{$DEFINE LILEcvms}				{LILE pointer is 4 byte}

const
	NoDRLICons = 20;  {Latest system has 20, pre DRFix has 15}

	CPPMSDataPath = '\ppms\sbs-dat\';  {Can override path from command line or .cfg}

	PPMSSBMSCode = 'SBM';
	PPMSSBMSText = 'From SBMS';

{=== DEFINE PPMS RECORDS ======}
type
	TPtr = integer;							{standard pointer}
	T4Ptr = longint;						{newer, extended pointers}

	TMaxRec =	record
{$IFDEF FIcvms}
							Max : T4Ptr;
{$ELSE}
							Max : TPtr;
{$ENDIF}
							Lock : byte;
						end;

	TdirIdxRec = 	record
									DI1 : array[1..40] of char;
									DI2 : array[1..30] of char;
									DIDR  : TPtr;
								end;
	TDirDatRec =	record
									DR1 : array[1..30] of char;
									DR2 : array[1..30] of char;
									DR3 : array[1..10] of char;
									DR4 : array[1..13] of char;
									DR : array[5..8] of array[1..30] of char;
									DR9 : array[1..15] of char;
									DR10 : byte;
									DR11 : char;
									DR12 : array[1..25] of char;
									DR13 : char;
									DRSE : TPtr;
									DRLI : array[1..NoDRLICons] of TPtr;
									DRDI : TPtr;
									DRLK : byte;
								end;

	POld2NewIDArray = ^TOld2NewIDArray;
	TOld2NewIDArray = array[0..4999] of T4Ptr;

var
	PPMSDataPath : string[70];
	Ccon : byte;  {Current consultant}
	NoCcons : byte;
	ChoiceCCon : byte;  {Choice of consultant, if not all}

	MaxFile : file of TMaxRec;
	DirDone : boolean;

	Max : TMaxRec;
	TimerStart, TimerEnd  : TTime;
	HoleTime : word;
	LastTimeHoled : TTime;

	DirOld2NewID : POld2NewIDArray;		{Conversion from old pointers to new for directory}
	Old2NewID : POld2NewIDArray;  {Conversion for current consultant's patients}

	ProBox : PProgressBox;

	IOR : word;   {For IOResults}

	User : array[1..20] of record
					ID : string;
					Name : string;
					Password : string;
					Status : byte;
	end;

	WorkCreateMH : TMoreItemInitParameter;    {parameter record for more/history items}

{***************************************
 ***    CONVERSION ROUTINES          ***
 ***************************************}
procedure SetDateUnpack2(var Date : Tdate; OldDate : word);
begin
	if OldDate = 0 then
		Date.Clear
	else
		Date.SetToNum(OldDate mod 32, (OldDate div 32) mod 16, 1980+(OldDate div 512), DatErr);
end;


function exp2(power : integer) : real;  {Returns 2^power}
var b : byte;
		L : real;
begin
	L := 1;
	if power>29 then Power := 29;
	if power>=0 then for b := 1 to power do L := L *2
		else for b := 1 to -power do L := L/2;
	exp2 := L;
end;


{========= 4 BYTE CVMS ============}
type TByte4 = array[1..4] of byte;

function CVMS(MSFormat : longint) : longint;  {Definitely convert from microsoft}
var B : TByte4;
		M : single;  {mantissa}

begin
	B := TByte4(MSFormat);
	{Found by trial and... error... - no sign just now}
	if MSFormat = 0 then
		CVMS := 0
	else begin
		M := ((B[3] + (B[2] + B[1] / $100) / $100) / $100) *2; {mantissa}
		cvms := trunc(exp2(B[4]-129) * (1+M));
	end;
end;

{========= 8 BYTE CVMD ============}
type TByte8 = array[1..8] of byte;

function CVMD(MSFormat : double) : double;  { Definitely convert from microsoft}
var B : TByte8;
		S : integer;    {sign}
		E : integer;    {exponant}
		M : double;     {mantissa}

begin
	B := TByte8(MSFormat);
	{Found by trial and... error... - no sign just now}
	if MSFormat = 0 then
		CVMD := 0
	else begin
		E := B[8]-129;    {Exponant}
		if (B[7] and $80)>0 then S := -1 else S := +1;  {Sign}
		M := (((B[7] and $7F) + (B[6] + B[5] / $100) / $100) / $100) * 2;
		CVMD := S * (1 + M) * exp2(E);
	end;
end;


{======== SCODE CONVERSION =============}
function SCodeConv(OldCode : word) : string;
var S : string;
begin
	if OldCode=0 then
		SCOdeConv := ''
	else begin
		{Add consultant no to avoid conflict}
{		S := hex(OldCode);
		if length(S)=3 then S[1] := chr(ord(S[1])+ccon)  {Should separate them enough}
{									 else S := chr(64 + ccon) + S;     {Add cons character on beginning}
{		SCodeConv := S;
{}
		{There is no conflict just now}
		SCodeConv := L2Str(OldCode);
	end;
end;


{*************************************************************************
 ***                    FILE HANDLING ROUTINES                         ***
 *************************************************************************}

function GetMax(Rec : word) : T4Ptr;
var MaxRec : TMaxRec;
begin
	Seek(MaxFile,Rec-1);
	Read(MaxFile, MaxRec);
{$IFDEF FIcvms}	GetMax := cvms(MaxRec.Max);
{$ELSE}					GetMax := MaxRec.Max;  {$ENDIF}
end;


procedure DoMakeHoles;
{Calls MakeHoles but times it as well}
begin
	TimerStart.SetToNow;
	Desktop^.Delete(ProBox); {remove progress box so desktop is clear}
	MakeHoles(@PersonStream^.Index, 2);{}
	DeskTop^.Insert(ProBox);{redisplay progress box}
	TimerEnd.SetToNow;
	HoleTime := TimerEnd.Secs - TimerStart.Secs;
	LastTimeHoled.SetToNow;  {For checking how long it has been since the last hole maker}
end;


procedure StorePerson(Person : PPerson; Cons : byte; OldID : T4Ptr);
var PersonIdx : longint;
		PersonID : longint;
begin
	 {Store}
	 TimerStart.SetToNow;
	 PersonIdx := -1;
	 PersonStream^.PutAtIdx(PersonIdx,Person, cmNew, lkIgnore); {Insert new one}
	 PersonID := Person^.Idx2Dat;
	 TimerEnd.SetToNow;

	 {Set ID index array}
	 if Cons = 0 	then DirOld2NewID^[OldID] := PersonID
								else Old2NewID^[OldID] := PersonID;

	 {Check to see if time for holes - do if sorting is taking 2 or more secs}
	 if ((TimerEnd.Secs - TimerStart.Secs) >= 2) then DoMakeHoles;
			{and ((TimerStart.Secs - LastTimeHoled.Secs) > 400) {and it's been more than 400secs since last one
			Causes a problem of course if running over midnight....}
end;


{************************************************************
 ***         READ STRING EXTENSIONS                       ***
 ************************************************************}

type TSERec = record
							SE : array[1..30] of char;
							SESE : TPtr;
						end;

function ReadSE(FileName : string; RecNo : longint; NoLines : byte) : string;
var
	SEFile : file of TSERec;
	SERec : TSERec;
	Rec : longint;
	S : string;
	Test : longint;

begin
{$I-}
	S := '';
	if RecNo >0 then begin
		assign(SEFile, PPMSDataPath+FileName);
		reset(SEFile);
		IOR := IOResult;
		if IOR<>0 then
			DBAseWarning('Error '+L2Str(IOR)+' opening '+FileName,'Returning ""')
		else begin
			for Rec := RecNo to RecNo + NoLines -1 do begin
				Seek(SEFile,Rec-1);
				Read(SEFile,SERec);
				IOR := IOResult;
				if IOR<>0 then
					DBaseWarning('Error '+L2Str(IOR)+' reading Rec '+L2Str(Rec-1),'Returning ""')
				else begin
					S := S + SERec.SE;
					if (SERec.SESE = 0) and (Rec < RecNo + NoLines -1) then
								writeln('Warning: SESE =0 but more lines expected. Reading anyway');
				end;
			end;
			close(SEFile);
		end;
		IOR := IOResult;
	end;
{$I+}
	ReadSE := S;
end;


{***********************************************************
 ****              READ PPMS USER FILE                   ***
 ***********************************************************}
procedure ReadPPMSUsers;
var UserFile : text;
		S : string;
		I : integer;
		NoLines : integer;

begin
	{Clear User Array}
	for I := 1 to 20 do begin
		USer[I].ID := '';
		User[I].Name := '';
		User[I].Status := 0;
	end;

	Assign(USerFile, PPMSDataPath+'PPUS.SER');
	reset(UserFile);

	ReadCSV(UserFile, S);
	NoLines := S2Lint(S);
	for I := 1 to NoLines do begin
		ReadCSV(UserFile, User[I].ID);
		ReadCSV(UserFile, User[I].Name);
		ReadCSV(USerFile, S);  {Password}
		ReadCSV(USerFile, S); User[I].Status := S2Byte(S);
	end;

	close(UserFile);
end;



{*********************************************************
 ***                 LETTER                            ***
 *********************************************************}
type
	TLtrIdxRec = record
									LI1 : word;  {Date}
									LI2 : byte;  {Cons no and no copies}
									LI : array[3..6] of byte;   {Keywords/search codes}
									LI7 : byte; 	{type of letter, no pages}
									LI8 : word;   {No lines of letter in le file}
									LI9 : byte;   {Letter sent indicator}
{$IFDEF LIWPLink}
									LI10 : byte;	{Number of blocks?}
									LI11 : byte;  {Type of letter & version}
{$ENDIF}
									LIPT : TPtr;
									LIDR : TPtr;
{$IFDEF LILEcvms}		LILE : T4Ptr; {$ELSE}  LILE : TPtr; {$ENDIF}
									LILI : TPtr;  {Chain ptr for dr}
								end;

	TLtrDatRec = record
									LE : array[1..128] of char;
							 end;

procedure ImportLetter(LIRec : TPtr; Person : PPerson; PersonID,ToWho : longint; header : string; Codes : string; Cons : byte);
var LI,LI2 : TLtrIdxRec;
		LE : TLtrDatRec;
		WPLtr : PWPLtr;
		I,NoBlocks,LERec,Rec : longint;
		S, S2 : string;
		LtrTextFile : text;
		ChainItem : PPureChainItem;
		LtrDatFile : file of TLtrDatRec;
		LtrIdxFile : file of TLtrIdxRec;
		Date : TDate;
		LIVer : byte;

begin
	if Lirec >0 then begin

		Assign(LtrIdxFile, PPMSDataPath+'PPLI-'+PadZero(L2Str(Cons),2)+'.DAT');
		reset(LtrIdxFile);

		{Follow chain}
		while lirec>0 do begin
			THinkingOn('Importing Letter '+L2Str(Lirec));

			Seek(LtrIdxFile, LIRec-1);
			Read(LtrIdxFile, LI);

			SetDateUnpack2(Date, LI.li1);

			{$IFDEF LILEcvms} LERec := cvms(LI.LILE); {$ELSE} LERec := LI.LILE; {$ENDIF}

			if (LERec>0) and (LI.LI1>0) then begin  {Has a date and LERec>0)

				{Set chain "index" record}
				WorkCreateMH.Person := nil;
				WorkCreateMH.PersonID := PersonID;
				WorkCreateMH.Ptr2Chain := -1;

				New(WPLtr, init(@WorkCreateMH));

				SetDateUnpack2(WPLtr^.Date,LI.li1);	{date}

				WPLtr^.ToWho := ToWho;
				WpLtr^.ByWho := -1;
				for I := 3 to 6 do if LI.LI[I]<>0 then WPltr^.Codes := WPLtr^.Codes + ' '+SCodeConv(LI.LI[I]);
				WPLtr^.Codes := WPLtr^.Codes + Codes;   {Whatevers passed as a parameter}
				WPLtr^.Ref   := '';
				WPLtr^.Header:= Header;
				WPLtr^.Copies:= (LI.LI2 and $F0) div $10;
				WPLtr^.EditorType := edWP51;

{$IFDEF LIWPLink}
				NoBlocks := LI.li10;
{$ELSE}
				NoBlocks := 0;
{$ENDIF}
				Assign(LtrDatFile, PPMSDataPath+'PPLE-'+PadZero(L2Str(Cons),2)+'.DAT');	Reset(LtrDatFile);

				if NoBlocks = 0 then begin
					{ sort of botch fix, from pple.sub, (WHY?) reads next lirec to
					 see where that points to - takes difference as noblocks.}
					if (LI.LI11 and $0F)=0 then begin
{						Seek(LtrIdxFile, LIRec +1 -1); {} {Automatically reads from the next one}
						Read(LtrIDxFile, LI2);
						{$IFDEF LILEcvms} Noblocks := cvms(LI2.lile)-LERec; {$ELSE} NoBlocks := LI2.LILE - LERec; {$ENDIF}
{					end else begin
						Seek(LtrDatFile, cvms(LI.LILE) -1);
						Read(LtrDatFile, LE);
						NoBlocks := ord(LE.LE[1]);
{}					end;
				end;

				{Write out letter text}
				Assign(LtrTextFile, WPLocalPath + WPLtrFileName);		rewrite(LtrTextFile);

				write(LtrTextFile,WPBeginMarker);

				for Rec := LERec to LERec+Noblocks-1 do begin
					Seek(LtrDatFile, Rec -1);
					Read(LtrDatFile, LE);

					S := LE.LE;
{$IFDEF LIWPLink}
					LIVer := LI.LI11;
{$ELSE}
					LIVer := $01;  {Set to old editor format}
{$ENDIF}

					if ((LIVer and $0F) = 1) and (rec = LERec) then S := copy(S, 2, length(S));  {chop off first byte}

					if (LIVer and $F0)=0 then begin
						{Convert from PPMS editor to WP format}
						S2 := '';
						for I := 1 to length(S) do
							if copy(S,I,1) = #20 then S2 := S2 + #13#10
																	 else S2 := S2 + copy(S,I,1);
						S := S2;
					end;

					write(LtrTextFile, S);
				end; {for}

				close(LtrTextFile);
				close(LtrDatFile);

				FileAdmin[fiHistory]^.LogOn;
				HistoryFile^.PutDataItem(Person^.Ptr2His, Rec, srWPLtr, WPLtr, cmNew);
{				PersonStream^.PutAtID(PersonID, Person, lkIgnore);  {Update pointer}
				{Make sure calling routine does the above line if nec}
				FileAdmin[fiHistory]^.LogOff;

				Dispose(WPLtr, done);
			end;  {if cvms}

			LIRec := LI.LILI;

		end; {while lirec>0}

		close(LtrIdxFile);

		ThinkingOff;

	end; {if lirec>0}
end; {proc}


{****************************************
 ***        IMPORT DIRECTORY          ***
 ****************************************}
procedure ImportDirectory;
var
	Dimax : T4Ptr;
	DrRec, Rec : longint;
	DirIdxRec : TDirIdxRec;
	DirDatRec : TDirDatRec;
	Person : PPerson;
	Search : string;
	I,I2,CommentLines,NoPhones : integer;
	S,LtrCodes : string;
	DirDatFile : file of TDirDatRec;
	DirIdxFile : file of TDirIdxRec;

begin
	Assign(DirDatFile, PPMSDataPath+'PPDR.DAT'); reset(DirDatFile);
	Assign(DirIdxFile, PPMSDataPath+'PPDI.DAT'); reset(DirIdxFile);

	FileAdmin[fiHistory]^.LogOn;  {Should be enough file handles to do this one as well}

	dimax := GetMax(8);

	for rec := 1 to dimax do begin

		{READ & DISPLAY RECORD}
		Seek(dirIdxFile, Rec-1);
		read(DirIdxFile, DirIdxRec);

		ProBox^.Update(DelSpaceR(DirIdxRec.DI1),'DIREC',Rec,DiMax);
		if ProBox^.Command = cmCancel then halt;

		DrRec := DirIdxRec.DiDr;

		if (DrRec > 0) then begin
			Seek(DirDatFile, DrRec-1);
			Read(DirDatFile, DirDatRec);

			{CONVERT TO KAMELEON FORMAT}
			New(Person, init);

			Person^.SurName  := DelSpaceR(DirIdxRec.DI1);
			Person^.ForName  := DelSpaceR(DirIdxRec.DI2);
			Person^.Title    := DelSpaceR(DirDatRec.DR3);
			Person^.DearName := DelSpaceR(DirDatRec.DR1);
			Person^.Company := False;

			for I := 1 to 4 do Person^.Address[I+2] := DelSpaceR(DirDatRec.DR[I+4]);
			Person^.PostCode := DelSpaceR(DirDatRec.DR9);
			Person^.Country  := '';
			Person^.TelNo[1] := DelSpaceR(DirDatRec.DR12);
			Person^.DOReg.SetToToday;

			{Add type to search code}
			Search := DirDatRec.dr13; if search = 'O' then Search := ' ';
			if Search[1] < #32 then Search := 'P'+L2Str(ord(Search[1])*10); {Mark as personal}

			{Add search area to kameleon search code}
			I2 := 1;
			for I :=0 to 7 do begin
				if (ord(DirDatRec.DR11) and I2)<>0 then Search := Search + ' ' + L2Str(I); {Just mark in numbers}
				I2 := I2*2;
			end;
			Search := Search + ' ' + PPMSSBMSCode;   {Mark as from old SBMS/PPMS system}
			Person^.Search := Search;

			if DirDatRec.DRSE >0 then begin
				CommentLines := (ord(DirDatRec.dr10) and $70) div $10; {no of half comment lines}
				NoPhones := (ord(DirDatRec.dr10) and $0C) div $04; 		 {no of extra phones}

				S := ReadSE('PPSE-08.DAT',DirDatRec.DRSE,CommentLines + NoPhones); {Read string extensions}

				{extract phones}
				for I := 1 to NoPhones do begin
					Person^.TelNo[I+1] := DelSpaceR(copy(S,  1, 30));
					S := copy(S, 31, length(S));
				end;
				Person^.Comment := DelSpaceR(S);
			end;

			{where to store qualifications, secretary?}
			if DirDatRec.dr2<>space(length(DirDatRec.dr2)) then Person^.comment := Person^.comment+' SEC:'+DirDatRec.dr2;

			{Don't store if personal to another consultant}
			if (Search[1] <> 'P') or (ord(DirDatRec.dr13)=CCon) then begin

				StorePerson(Person, 0,DRRec);  {Store, consultant number and old id}

				{Import Letters}
{				for I := 1 to NoDRLICons do begin}
				I := CCon; begin    {For split dbase - ie do each directory once for each patient subset}
					if (NoCcons>1) then LtrCodes := 'P'+L2Str(I) else LtrCodes := '';  {Set Private To code}
					if (User[I].Status = 2) and (DirDatRec.DRLI[I]>0) then  {If valid cons pointer (JIC deleted - Facit (Sales) on mum's)}
							ImportLetter(DirDatRec.DRLI[I], Person, Person^.Idx2Dat, Person^.Idx2Dat, 'LETTER', LtrCodes,I); {Import letter}
				end;

				if Person^.Ptr2His<>-1 then PersonStream^.PutAtID(Person^.Idx2Dat, Person, lkIgnore);  {Update pointer}
			end;


			Dispose(Person, done); Person := nil;
		end; {if not hole}

	end; {for loop}

	close(DirIdxFile);
	close(DirDatFile);
	FileAdmin[fiHistory]^.LogOff;

end; {Procedure}


{*****************************************************************************
 ***                                                                       ***
 ***                      IMPORT PATIENTS                                  ***
 ***                                                                       ***
 *****************************************************************************}

type
	TPPMSDate = array[1..3] of byte;

	TPatIdxRec = record
								PI1 : array[1..25] of char;
								PI2 : array[1..25] of char;
								PT  : TPtr;
							end;

	TPatDatRec = 	record
									PT1 : array[1..20] of char;
									PT2 : byte;  {ins scheme}
									PT3 : array[1..14] of char;
									PT  : array[4..7] of array[1..30] of char;
									PT8 : array[1..15] of char;
									PT9 : array[1..20] of char;
									PT10: array[1..20] of char;
									PT11: byte;
									PT12: byte;
									PT13: TPPMSDate;
									PT14: char;   {sex}
									PT15: word;
									PT16: array[1..25] of char;
									SE  : TPtr;
									EV1 : TPtr;
									EV2 : TPtr;
									PA  : T4Ptr;
									PI  : TPtr;
									PTPT	: TPtr;
									DR  : array[1..5] of TPtr;
									LK	: byte;
								end;

{*****************************************************************************
 ***                      IMPORT EVENTS CHAIN                              ***
 *****************************************************************************}
type
	TEvRec = record
						EV1 : byte;
						EV2 : word;
						EV  : array[3..12] of word;
						EVEV: TPtr;
						SE  : TPtr;
						LI  : array[1..7] of TPtr;
						IP  : TPtr;
						PT  : TPtr;
	end;


procedure ImportEventsChain(PT : TPatDatRec; Person : PPerson; PersonID : longint);
var
	EVFile : file of TEvRec;
	EvMax : longint;
	EV : TEVRec;
	EVRec : longint;
	Date : TDate;
	ToWho : longint;
	GenEVent : PGenEvent;
	Letter,JustLetter : boolean;
	I : integer;
	Header : string;

begin
	Assign(EVFile, PPMSDataPath + 'PPEV-'+PadZero(L2Str(CCon),2)+'.DAT'); reset(EVFile);
	FileAdmin[fiHistory]^.LogOn;

	EVRec := PT.EV2;  {First in chain - ie most recent}

	while EVRec>0 do begin
			ThinkingOn('Doing Event');

			Seek(EVFile, EVRec-1);
			Read(EVFile, EV);

			SetDateUnpack2(Date, EV.EV2);
			ThinkingOn('Doing Event '+Date.Digit8);

			if (EV.PT>0) and (not Date.Blank) then begin  {not deleted}

				{Check to see if it's just a letter - no codes etc}
				Letter := False; for I := 1 to 7 do if EV.LI[I]<>0 then Letter := True;  {Yes we have a letter}

				JustLetter := True;
				for I := 3 to 12 do if EV.EV[I] <>0 then JustLetter := False; {codes}
				if EV.SE<>0 then JustLetter := False; {comments}
				{if (EV.EV[3]<>0) and (Letter = False) then JustLetter := False;
																					{If event code but no letter, must write code. o/w put with letter}

				if not JustLetter then begin

					WorkCreateMH.Person := nil;
					WorkCreateMH.PersonID := PersonID;
					WorkCreateMH.Ptr2Chain := -1;
					New(GenEvent, init(@WorkCreateMH));

					GenEvent^.Date := Date;
					GenEvent^.Code := SCodeConv(EV.EV[3]);
					for I := 1 to 3 do if EV.EV[I+3]<>0 then GenEvent^.Diagnosis := GenEvent^.Diagnosis + SCodeConv(EV.EV[I+3])+' ';
					for I := 1 to 3 do if EV.EV[I+6]<>0 then GenEvent^.Treatment := GenEvent^.Treatment + SCodeConv(EV.EV[I+6])+' ';
					for I := 1 to 3 do if EV.EV[I+9]<>0 then GenEvent^.Outcome   := GenEvent^.Outcome   + SCodeConv(EV.EV[I+9])+' ';

					GenEvent^.Comment^.Append(ReadSE('PPSE-05.DAT', EV.SE, (EV.EV1 and $03)));

					{Store into chain}
					HistoryFile^.PutDataItem(Person^.Ptr2His, I, srGenEvent, GenEVent, cmNew);

					Dispose(GenEvent, done);

				end;

				{Check for letters}
				for I := 1 to 7 do begin

						if EV.LI[I]>0 then begin

								Header := 'LETTER';

								case I of
										1 : ToWho := PersonID;
										2 : ToWho := DirOld2NewID^[PT.DR[1]];
										3 : ToWho := DirOld2NewID^[PT.DR[2]];
										4 : ToWho := DirOld2NewID^[PT.DR[3]];
										5 : ToWho := DirOld2NewID^[PT.DR[4]];
										6 : ToWho := DirOld2NewID^[PT.DR[5]];
										7 : begin ToWho := PersonID; Header := 'NOTES'; end;
								end;

								close(EVFile); {Have to close it down due to max 15 files open at once}
								FileAdmin[fiHistory]^.LogOff;  {Ditto}

								ImportLetter(EV.LI[I], Person, PersonID, ToWho, Header, '', CCon);

								FileAdmin[fiHistory]^.LogOn;
								Assign(EVFile, PPMSDataPath + 'PPEV-'+PadZero(L2Str(CCon),2)+'.DAT'); reset(EVFile);{}

							end;

						end; {for I}

			end; {if not deleted}

			EVRec := EV.EVEV;

	end; {while EVRec>0}

	close(EVFile);
	FileAdmin[fiHistory]^.LogOff;
end;


{*****************************************************************************
 ***                      IMPORT PATIENTS                                  ***
 *****************************************************************************}

type
	TPARec = record
							PA1 : word;
							PA2 : double;   {Total}
							PA3 : double;   {Balance unpaid}
							PA4 : byte;
							PA5 : byte;     {Cons number}
							PA6 : double;   {VAT on PA2}
							PT  : TPtr;
							SE  : T4Ptr;
							PV  : T4Ptr;
							PA  : T4Ptr;
						end;

	TPVRec = 	record
							PV1 : word;  {Date}
							PV2 : word;  {scode}
							PV3 : double;  {price}
							PV4 : word; {nom ledger account}
							PV5 : double;  {VAT on PV3}
							PV  : T4Ptr;
							PA  : T4Ptr;
							EV  : TPtr;
							SE  : TPtr;
							TR  : array[1..3] of word;  {Treatment/action codes}
					end;


procedure ImportPatients;
var
	PatIdxFile : file of TPatIdxRec;
	PatDatFile : file of TPatDatRec;
	PI : TPatIdxRec;
	PT : TPatDatRec;
	PTMax,PTrec,PIRec, PersonID : longint;
	Person : PPerson;
	NoAddress, NoPhones, NoComments : byte;
	S : string;
	AltAdd : array[1..5] of string[30];
	I : integer;
	Medical : PMedical;
	AltAddress : PAltAddress;
	DoMedical : boolean;
	RecNo : longint;

	{For invoice import}
	PAFile : file of TPaRec;
	PVFile : file of TPVRec;
	PARec, PVRec,PTMin : longint;
	PA : TPArec;
	PV : TPVRec;
	Invoice : PInvoice;
	InvoiceItem : PInvoiceItem;

begin
	Assign(PatIdxFile, PPMSDataPath + 'PPPI-'+PadZero(L2Str(CCon),2)+'.DAT'); reset(PatIdxFile);
	Assign(PatDatFile, PPMSDataPath + 'PPPT-'+PadZero(L2Str(CCon),2)+'.DAT'); reset(PatDatFile);

	PTMax := GetMax(120+CCon);

	PTMin := 1;

	for ptrec := PTmin to ptmax do begin

		Seek(PatDatFile, PTRec-1);
		Read(PatDatFile, PT);
		pirec := pt.pi;

		if pirec>0 then begin

			Seek(PatIdxFile, PIRec-1);
			Read(PatIdxFile, PI);

			ProBox^.Update(DelSpaceR(PI.PI1),'PTREC',PtRec,PtMax);
			if ProBox^.Command = cmCancel then halt;

			if PI.PT = ptrec then begin {just check that not blank ptrec}

				New(Person, init);

				Person^.Surname := DelSpaceR(PI.PI1);
				Person^.ForName := DelSPaceR(PI.PI2);
				Person^.Title   := DelSPaceR(PT.PT3);
				Person^.DearName:= DelSpaceR(PT.PT16);
				Person^.DOB.SetToNum(PT.PT13[1],PT.PT13[2],PT.PT13[3]+1850,DatErr);  {DOB}
				Person^.Company := False;
				for I := 3 to 6 do Person^.Address[I] := DelSpaceR(PT.PT[I+1]);
				Person^.Postcode := DelSpaceR(PT.PT8);
				SetDateUnpack2(Person^.DOReg, PT.PT15);  {Date of reg}

				{Telephone Numbers}
				if DelSPaceR(PT.PT9)<>''  then Person^.TelNo[1] := DelSpaceR(PT.PT9) + ' (H)';
				if DelSpaceR(PT.PT10)<>'' then Person^.TelNo[2] := DelSpaceR(PT.PT10) + ' (W)' else Person^.TelNo[1] := DelSpaceR(PT.PT9);
																												{If no work no, don't put a label on the home one}

				{Search line}
{				if NoCCons >1 then Person^.Search := L2Str(ccon*10)+' ';  {Set to Consultant #}
				Person^.Search := Person^.Search + UCase(PT.PT14)+' ';  {sex/prospect/client}
				Person^.Search := Person^.Search + PPMSSBMSCode;   {Mark as coming from old system}
	{if sbms system}
				if PT.PT2<>0 then Person^.Search := Person^.Search+' I'+L2Str(PT.PT2); {Insurance - can be ref}

				{String extensions}
				noPhones   := (PT.PT11 and $0C) div $04;  {no of extra phones}
				NoComments := (PT.PT11 and $30) div $10;  {no of half comment lines}
				if (PT.PT11 and $03)<>0 then NoAddress := 5 else NoAddress := 0;       {Alt address type}

				S := ReadSE('PPSE-03.DAT', PT.SE, NoAddress + (NoPhones+1) div 2 + NoComments);

				{Comment line}
				Person^.Comment := copy(S,1,30*NoComments);
				S := copy(S,30*NoComments +1, length(S));

				{Alternative Address}
				for I := 1 to NoAddress do begin
					if I=NoAddress then begin
						AltAdd[I] := Copy(S,1,15);
						S := Copy(S,16,length(S));
					end else begin
						AltADd[I] := Copy(S,1,30);
						S := Copy(S,31,length(S));
					end;
				end;

				{Other phones}
				for I := 3 to 4 do begin
					Person^.TelNo[I] := copy(S,1, 20);
					S := copy(S,21,1);
				end;

				Person^.Ptr2Inv := Old2NewID^[PT.PTPT];       {Old to new ptr}

				Person^.Ptr2Ref := DirOld2NewID^[PT.DR[2]]; {Old dir ptr to new Kam ptr}

				StorePerson(Person, Ccon, PTRec);  {Store person, consultant no and old ID}
				PersonID := Person^.Idx2Dat;

{$IFNDEF PersonOnly}
				{======= MORE TYPE ADDITIONS ===========}
				{If ppms system:}
{				if (PT.PT2<>0) or (PT.DR[1] <>0) or (PT.DR[3]<>0) or (PT.DR[4]<>0) or
						(PT.DR[5]<>0) then DoMedical := TRue else DoMedical := False;
				{o/w}
				if (PT.DR[1] <>0) or (PT.DR[3]<>0) or (PT.DR[4]<>0) or (PT.DR[5]<>0) then
						DoMedical := TRue else DoMedical := False;


				if (NoAddress >5) or DoMedical then FileAdmin[fiMore]^.LogOn;

				{Check for alternate address}
				if (NoAddress >5) then begin

					ThinkingOn('Doing AltAddress');

					WorkCreateMH.Person := nil;
					WorkCreateMH.PersonID := PersonID;
					WorkCreateMH.Ptr2Chain := -1;
					New(AltAddress, init(@WorkCreateMH));

					for I := 4 to 7 do AltAddress^.Address[I] := AltAdd[I-3];
					AltAddress^.PostCode := AltAdd[5];

					MoreFile^.PutDataItem(Person^.Ptr2Det, I, srAltAddress, AltAddress, cmNew);
{}
					Dispose(AltAddress, done);
				end;

				{CHeck for medical details}
				if DoMedical then begin
					ThinkingOn('  Doing Medical...');

					WorkCreateMH.Person := nil;
					WorkCreateMH.PersonID := PersonID;
					WorkCreateMH.Ptr2Chain := -1;

					New(Medical, init(@WorkCreateMH));

					Medical^.GP := DirOld2NewID^[PT.DR[1]];
					for I := 1 to 3 do Medical^.Doc[I] := DirOld2NewID^[PT.DR[2+I]];
					Medical^.InsScheme := SCodeConv(PT.PT2);
					Medical^.InsNo := PT.PT1;

					{Store into chain}
					MoreFile^.PutDataItem(Person^.Ptr2Det, I, srMedical, Medical, cmNew);
{}
					Dispose(Medical, done);
				end;
{}
				if FileAdmin[fiMore]^.Count>0 then FileAdmin[fiMore]^.LogOff;   {Close down more file}


				{======== DO HISTORY TYPES OF OBJECTS ===========}

{				if (PT.EV2>0) or (cvms(PT.PA)>0) then FileAdmin[fiHistory]^.LogOn;{}

				if PT.EV2>0 then ImportEventsChain(PT, Person, PersonID);

				{CHECK FOR INVOICES}
				if cvms(PT.PA)>0 then begin
					PARec := cvms(PT.PA);

					while PARec>0 do begin
						ThinkingOn('Doing Invoice');
						if Keypressed then halt;

						Assign(PAFile, PPMSDataPath + 'PPPA-'+PadZero(L2Str(CCon),2)+'.DAT'); reset(PaFile);
						Seek(PAFile, PArec -1);
						Read(PAFile, PA);
						close(PAFile);   {Having real trouble opening enough files}

						if (PA.PT>0) and ((PA.PA4 and $08)=0) then begin  {not deleted}

							WorkCreateMH.Person := nil;
							WorkCreateMH.PersonID := PersonID;
							WorkCreateMH.Ptr2Chain := -1;
							New(Invoice, init(@WorkCreateMH));

							SetDateUnpack2(Invoice^.Date, PA.PA1);

							Invoice^.Comment^.Append(ReadSE('PPSE-06.DAT',cvms(PA.SE),4));  {Comment box}

							Invoice^.Total.SetTo(cvmd(PA.PA2));
							Invoice^.VAT.SetTo(cvmd(PA.PA6));
							Invoice^.Due.SetTo(cvmd(PA.PA3));
							if (PA.PA4 and $10)<>0 then Invoice^.Estimate := True;
							if (PA.PA4 and $04)<>0 then Invoice^.WrittenOff := True;
							Invoice^.Ref := L2Str(PARec);

							PVRec := cvms(PA.PV);

							Assign(PVFile, PPMSDataPath + 'PPPV-'+PadZero(L2Str(CCon),2)+'.DAT'); reset(PVFile);

							{Import items}
							while PVRec>0 do begin
								Seek(PVFile, PVRec -1);
								Read(PVFile, PV);

								New(InvoiceItem, init);

								with InvoiceItem^ do begin
									SetDateUnpack2(Date, PV.PV1);
									Code := SCodeConv(PV.PV2);
									for I := 1 to 3 do CodeLine := CodeLine + SCodeConv(PV.TR[I])+' ';
									Comment := ReadSE('PPSE-07.DAT', PV.SE, 1);
									Quantity := L2Str(1);
									Price.SetTo(CVMD(PV.PV3));

									{Sort out VAT}
									VAT.SetTo(CVMD(PV.PV5));

									if Code = '999' then begin
										Code := 'PAY'; {Kameleon payment code}

										{payment Price *includes* the VAT???, so first of all extract that}
										{ x + x*VATrate = Price}
										{ x (1 + VATrate) = Price}
										{ price excl VAT = x = Price / (1+VATrate)}
										{ correct VAT = price - (price excl VAT = (price / (1+VATRate))}
										if Price.inPence >0 then begin {o/w division by zero error}
											TotalincVAT.SetTo(Price.inPounds);
											VATRate := (VAT.inPence/TotalincVAT.inPence)*100;
											Price.SetTo(TotalincVAT.inPounds / (1+VATRate));
											VAT.SetTo(TotalincVAT.inPounds - Price.inPounds); {difference}
										end;
									end;

									NomCat := PV.PV4;

								end;

								{Insert into invoice}
								Invoice^.ChainFile^.Insert(Invoice^.FirstItem, InvoiceItem, RecNo);

								PVRec := cvms(PV.PV);
							end;

							close(PVFile);

							{Store into chain}
							FileAdmin[fiHistory]^.LogOn;
							HistoryFile^.PutDataItem(Person^.Ptr2His, I, srInvoice, Invoice, cmNew);
							FileAdmin[fiHistory]^.LogOff;

							Dispose(Invoice, done);

						end; {not deleted}

						PARec := cvms(PA.PA);

					end; {for all parec's  in chain}

				end;   {If pointer to invoice chain}

				if FileAdmin[fiHistory]^.Count>0 then FileAdmin[fiHistory]^.LogOff;

				{Update detail/history pointer}
				if (Person^.Ptr2His<>-1) or (Person^.Ptr2Det<>-1) then
								PersonStream^.PutAtID(PersonID, Person, lkIgnore);  {Update pointer}

{$ENDIF}

				dispose(Person, done);

				ThinkingOff;

			end; {if bak ptr = pirec}

		end; {if pirec>0}

	end; {for all PT's}

	close(PatIdxFile);
	close(PatDatFile);

end;



{ *****************************
' ***      SENTENCE CODES   ***
' *****************************}
procedure ImportSColl(KamFileName, PPMSFileName : string);
var PPMSFile : text;
		S : string;
		NoCodes, I : longint;
		SCodeFile : TDataStream;
		Collection : PScodeCollection;
		SCodeItem,SCodeITemDup : PSCodeItem;
		Code : string[3];
		Desc : string;

begin
	KamFileName := ucase(KamFileName);  {For checks below}
	writeln('  SColl '+KamFileName+'...');

	{Open input file}
	Assign(PPMSFile, PPMSDataPath + PPMSFileName); reset(PPMSFile);

	{Read header}
	ReadCSV(PPMSFile,S); NoCodes := S2Lint(S);
	if NoCodes >999 then NoCodes := NoCodes mod 1000; {JIC locked}
	ReadCSV(PPMSFile,S); {Read name of collection}

	{See if collection already exists}
	SCodeFile.Init(KamFileName,1);
	Collection := PSCodeCollection(SCodeFile.Get);
	if Collection = nil then New(Collection, init);
	ScodeFile.Done;

	{Load & Transfer Codes}
	for I := 1 to NoCodes do begin
		{Read codes}
		ReadCSV(PPMSFile, S); Code := SCodeConv(S2Lint(S));
		ReadCSV(PPMSFile, S);	Desc := S;

		if (KamFileName = 'KPERSRCH.SC') and (PPMSFileName[5]='0') then Code := 'I'+Code; {Convert insurance to search}

		{Create}
		if KamFileName = 'KEVENTS.SC' then SCodeItem := CreateCostedSCodeItem(Code, S)
			else SCodeItem := CreateStdSCodeItem(Code, S);
		SCodeItemDup := Collection^.CheckDupCode(SCodeItem);

		if (SCodeITemDup<>nil) and (ScodeItemDup^.Description^<>SCodeItem^.Description^) then begin
			{Code duplicated, and different text}
			S :='Inserted Code '+SCodeItem^.Code+' '+SCodeItem^.Description^+
					' already present as '+ScodeItemDup^.Code+' '+SCodeItemDup^.Description^;
			writeln(S);
			RecordError('IMPORT',S,'');
		end;

		Collection^.Insert(SCodeItem);
	end;

	{Special codes}
	if KamFileName = 'KPERSRCH.SC' then begin
		Collection^.Insert(New(PSCodeItem, init('S','Supplier')));
		Collection^.Insert(New(PSCodeItem, init('C','Client')));
		Collection^.Insert(New(PSCodeItem, init('P','Prospect')));
		Collection^.Insert(New(PSCodeItem, init('M','Male')));
		Collection^.Insert(New(PSCodeItem, init('F','Female')));
		Collection^.Insert(New(PSCodeItem, init(PPMSSBMSCode,PPMSSBMSText)));

		{Put consultant markers in}
		for I := 1 to 20 do
			if USer[I].Status = 2 then Collection^.Insert(New(PSCodeITem, init(L2Str(I*10), User[I].Name)));
	end;

	if KamFileName = 'KLETTERS.SC' then begin
		{Private to consultant... marker}
		for I := 1 to 20 do
			if User[I].Status = 2 then Collection^.Insert(New(PSCodeITem, init('P'+L2Str(I), User[I].Name)));
	end;


	{Store collection}
	SCodeFile.Init(KamFileName, 1);
	SCodeFile.Put(Collection);
	SCodeFile.CheckStatus('Stored SCodes '+KamFileName);
	SCodeFile.Done;

	close(PPMSFile);
	Dispose(Collection, done);
end;


procedure ImportSCodes;
begin
	writeln('Sentence Codes...');
	ImportSColl('kinsurance.SC',	'PPSN0-'+PadZero(L2Str(CCon),2)+'.SER');
	ImportSColl('kaccats.SC',			'PPSN1-'+PadZero(L2Str(CCon),2)+'.SER');
	ImportSColl('kevents.SC',			'PPSN2-'+PadZero(L2Str(CCon),2)+'.SER');
	ImportSColl('kassment.SC',	'PPSN3-'+PadZero(L2Str(CCon),2)+'.SER');
	ImportSColl('kaction.SC',	'PPSN4-'+PadZero(L2Str(CCon),2)+'.SER');
	ImportSColl('koutcome.SC',		'PPSN5-'+PadZero(L2Str(CCon),2)+'.SER');
	ImportSColl('KLETTERS.SC',		'PPSN6-'+PadZero(L2Str(CCon),2)+'.SER');
	ImportSColl('KPERSRCH.SC',		'PPSN7-'+PadZero(L2Str(CCon),2)+'.SER');
{For SBMS convertion}
	ImportSColl('KPerSrch.SC',    'PPSN0-'+PadZero(L2Str(CCon),2)+'.SER');
	writeln('Done');
end;


{***************************************
 ***          MAIN LOOP              ***
 ***************************************}
var
	PtMAx : longint;
	Kameleon : TKAmeleonApp;
	I : integer;
	RootPath : string[70];

begin
	Kameleon.Init;

	ProBOx := NewProgressBox('IMPORT FROM PPMS',space(40),'  ');
	ProBox^.SetState(sfActive, true); {Bright lines, etc}

	PPMSDataPath := ParamStr(1);     {Take from command line}
	if PPMSDataPath = '' then PPMSDataPath := CPPMSDataPath;
	DirDone := False;
	ChoiceCcon := 0;

	ReadPPMSUsers;     {Read old users}

	{Set up old2new id pointer arrays}
	New(DirOld2NewID); for I := 0 to 4999 do DirOld2NewID^[I] := -1;

	{Open Import Files}
{$I-}
	Assign(MaxFile, PPMSDataPath+'PPFI.DAT');    reset(MaxFile);
	IOR := IOResult; if IOR<>0 then DBaseWarning('Could not open PPFI.DAT','');
{$I+}

	{First run through and see how many consultants there are}
	NoCCons := 0;
	for ccon := 1 to 20 do
		if GetMax(120+ccon)>0 then NoCcons := NoCCons +1;


	{Debug}
	DirDone := True;

	{========== RUN THROUGH CONSULTANTS =============}
	RootPath := DataPath;

	for ccon:=4 to 20 do begin
		if (choiceccon=0) or (choiceccon=ccon) then begin

			DataPath := RootPath + L2Str(CCon)+'\';

			{Check to see if this is a consultant}
			if User[Ccon].Status = 2 then begin
				writeln('CONSULTANT ',ccon);

				{Open Kameleon Files}
				CheckPath(DataPath);
				PersonStreamLogOn;

{				if not DirDone then begin{}
					ImportDirectory;  {don't want to do it every consultant, just the one}
					FixDataBase(fiCheck);
					DoMakeHoles;      {Directory in index order, so hole it}
					DirDone := True;
{				end;{}

				ImportSCodes;   {Sentence codes for this consultant}

				New(Old2NewID);
				for I := 0 to 4999 do Old2NewID^[I] := -1;   {Set no ptr to Kameleon no ptr}
				ImportPatients; {Import patients for this consultant}

				FixDataBase(fiCheck);

				dispose(Old2NewID);
				PersonStreamLogOff;

			end;


		end;
	end; {for}

	close(MaxFile);

	Dispose(DirOld2NewID);

	PauseMessage('All Done Now','');

	Desktop^.delete(PRobox);
	dispose(ProBox, done);

	Kameleon.Done;
end.



{}
