Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Blame
Revision Log

source: cprs/branches/foia-cprs/CPRS-Chart/fProbs.pas@ 459

Last change on this file since 459 was 459, checked in by Kevin Toppenberg, 16 years ago
Adding foia-cprs branch
File size: 65.5 KB

Line
1	unit fProbs;
2	{$O-}
3	interface
4
5	uses
6	Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
7	fHSplit, StdCtrls, ExtCtrls, Menus, ORCtrls, Buttons, uProbs,
8	Grids, Vawrgrid, ORfn, uCore, fProbEdt, uConst, ComCtrls ;
9
10	type
11	TfrmProblems = class(TfrmHSplit)
12	mnuProbs: TMainMenu;
13	mnuView: TMenuItem;
14	mnuViewChart: TMenuItem;
15	mnuChartCover: TMenuItem;
16	mnuChartProbs: TMenuItem;
17	mnuChartMeds: TMenuItem;
18	mnuChartOrders: TMenuItem;
19	mnuChartNotes: TMenuItem;
20	mnuChartCslts: TMenuItem;
21	mnuChartDCSumm: TMenuItem;
22	mnuChartLabs: TMenuItem;
23	mnuChartReports: TMenuItem;
24	mnuAct: TMenuItem;
25	mnuActNew: TMenuItem;
26	Z3: TMenuItem;
27	mnuActChange: TMenuItem;
28	mnuActInactivate: TMenuItem;
29	mnuActRemove: TMenuItem;
30	mnuActVerify: TMenuItem;
31	Z4: TMenuItem;
32	mnuActAnnotate: TMenuItem;
33	Z1: TMenuItem;
34	mnuViewActive: TMenuItem;
35	mnuViewBoth: TMenuItem;
36	popProb: TPopupMenu;
37	popChange: TMenuItem;
38	popInactivate: TMenuItem;
39	popRestore: TMenuItem;
40	popRemove: TMenuItem;
41	popVerify: TMenuItem;
42	N36: TMenuItem;
43	popAnnotate: TMenuItem;
44	N37: TMenuItem;
45	pnlProbList: TORAutoPanel;
46	pnlProbCats: TPanel;
47	lblProbCats: TLabel;
48	lstCatPick: TORListBox;
49	pnlProbEnt: TPanel;
50	pnlProbDlg: TPanel;
51	wgProbData: TCaptionListBox;
52	mnuViewInactive: TMenuItem;
53	mnuViewRemoved: TMenuItem;
54	N1: TMenuItem;
55	mnuActRestore: TMenuItem;
56	mnuViewFilters: TMenuItem;
57	N2: TMenuItem;
58	lblProbList: TOROffsetLabel;
59	pnlView: TPanel;
60	N3: TMenuItem;
61	popViewDetails: TMenuItem;
62	lstView: TORListBox;
63	lblView: TOROffsetLabel;
64	N4: TMenuItem;
65	mnuActDetails: TMenuItem;
66	bbNewProb: TORAlignButton;
67	lblProbEnt: TLabel;
68	mnuViewSave: TMenuItem;
69	mnuViewRestoreDefault: TMenuItem;
70	mnuViewComments: TMenuItem;
71	sptProbPanel: TSplitter;
72	pnlButtons: TPanel;
73	bbOtherProb: TORAlignButton;
74	bbCancel: TORAlignButton;
75	pnlProbs: TPanel;
76	lblProblems: TLabel;
77	lstProbPick: TORListBox;
78	edProbEnt: TCaptionEdit;
79	mnuChartSurgery: TMenuItem;
80	HeaderControl: THeaderControl;
81	procedure mnuChartTabClick(Sender: TObject);
82	procedure lstProbPickClick(Sender: TObject);
83	procedure lstProbPickDblClick(Sender: TObject);
84	procedure lstCatPickClick(Sender: TObject);
85	procedure lstProbActsClick(Sender: TObject);
86	procedure pnlRightResize(Sender:TObject);
87	procedure pnlProbEntResize(Sender: TObject);
88	procedure wgProbDataClick(Sender: TObject);
89	procedure wgProbDataDblClick(Sender: TObject);
90	procedure edProbEntKeyPress(Sender: TObject; var Key: Char);
91	procedure bbOtherProbClick(Sender: TObject);
92	procedure FormCreate(Sender: TObject);
93	procedure bbCancelClick(Sender: TObject);
94	procedure lstViewClick(Sender: TObject);
95	procedure FormDestroy(Sender: TObject);
96	procedure mnuViewSaveClick(Sender: TObject);
97	procedure mnuViewRestoreDefaultClick(Sender: TObject);
98	procedure mnuViewCommentsClick(Sender: TObject);
99	procedure wgProbDataMeasureItem(Control: TWinControl; Index: Integer;
100	var Height: Integer);
101	procedure wgProbDataDrawItem(Control: TWinControl; Index: Integer;
102	Rect: TRect; State: TOwnerDrawState);
103	procedure HeaderControlSectionResize(HeaderControl: THeaderControl;
104	Section: THeaderSection);
105	procedure lstViewExit(Sender: TObject);
106	procedure FormShow(Sender: TObject);
107	procedure FormHide(Sender: TObject);
108	procedure pnlRightExit(Sender: TObject);
109	procedure bbNewProbExit(Sender: TObject);
110	procedure FormMouseMove(Sender: TObject; Shift: TShiftState; X,
111	Y: Integer);
112	private
113	FContextString: string;
114	FFilterString: string;
115	FAllProblems: TStringList; //Unfiltered list of problems
116	FProblemsVisible: TStringList; //Parallels FAllProblems. "Y" for visible
117	FItemData: TStringList; //Parallels Grid. String representation of integer indexes into FAllProblems
118	// FProblemsVisible[FItemData[i]] = 'Y'
119	FWarningShown: boolean;
120	FOldFramePnlPatientExit: TNotifyEvent;
121	FMousing: TDateTime;
122	FSilent: boolean;
123	procedure frmFramePnlPatientExit(Sender: TObject);
124	procedure UMCloseProblem(var Message:TMessage); message UM_CLOSEPROBLEM; {pdr}
125	procedure ApplyViewFilters;
126	// procedure UMPLFilter(var Message:TMessage); message UM_PLFILTER; {pdr}
127	procedure UMPLLexicon(var Message:TMessage); message UM_PLLEX; {pdr}
128	procedure GetRowCount;
129	procedure RefreshList;
130	procedure SetGridPieces(Pieces: string);
131	procedure ShowPnlView();
132	function PlainText( MString: string): string;
133	function MString( index: integer): string;
134	public
135	function AllowContextChange(var WhyNot: string): Boolean; override;
136	procedure LoadProblems;
137	procedure LoadUserCats(AList:Tstringlist);
138	procedure LoadUserProbs(AList:TstringList);
139	procedure AddProblem;
140	procedure EditProblem(const why:char);
141	procedure LoadPatientParams(AList:TstringList);
142	procedure LoadUserParams(Alist:TstringList);
143	procedure UpdateProblem(const why:char;Line: string;AllProblemsIndex:integer);
144	procedure RestoreProblem;
145	procedure LoadPatientProblems(AList:TstringList;const status:char;init:boolean);
146	procedure ClearPtData; override;
147	procedure DisplayPage; override;
148	procedure NoRowSelected;
149	procedure RowSelected;
150	procedure ClearGrid;
151	procedure RequestPrint; override;
152	procedure SetFontSize( NewFontSize: integer); override;
153	function HighlightDuplicate( NewProb: string; const Msg: string;
154	DlgType: TMsgDlgType; Action: string): boolean;
155	property Silent: Boolean read FSilent write FSilent;
156	end;
157
158	function EncounterPresent: Boolean;
159
160	const
161	TX_PROV_LOC = 'A provider and location must be selected before' + #13#10 +
162	'entering or making any change to a problem.';
163	TC_PROV_LOC = 'Incomplete Information';
164	TX_INVALID_PATIENT = 'Problem list is unavailable: Patient DFN is undefined.';
165	TC_NO_PATIENT = 'No patient is selected';
166	TX_INACTIVE_CODE_V = 'references an inactive ICD code, and must be updated' + #13#10 +
167	'using the ''Change'' option before it can be verified.';
168	TC_INACTIVE_CODE = 'Inactive Code';
169	TX_INACTIVE_CODE = 'This problem references an inactive ICD code,' + #13#10 +
170	'and must be updated using the ''Change'' option.';
171	TX_ADD_REMOVED = 'Cannot add to the "Removed Problem List"';
172	TC_ADD_REMOVED = 'Unable to add';
173
174	RPT_PROBLIST = 21;
175	CT_PROBLEMS = 2;
176
177	// GridColWidths[i] = 0 for columns that are always hidden
178	// GridColWidths[i] = -1 for one (and only one) adjustable column
179	GridColWidths: Array[0..15] of integer =(0, 5, -1, 9, 9, 0, 12, 12, 12, 0, 0, 0, 0, 0, 0, 0);
180
181	var
182	frmProblems: TfrmProblems;
183	dlgProbs:TfrmdlgProb;
184	gFontHeight: Integer;
185	gFontWidth: Integer;
186	gFixedWidth: Integer;
187
188	implementation
189
190	uses fFrame, fProbFlt, fProbLex, rProbs, rcover, fCover, fRptBox,
191	fProbCmt, fEncnt, fReportsPrint, fReports, rPCE, DateUtils;
192
193	{$R *.DFM}
194
195	function TfrmProblems.AllowContextChange(var WhyNot: string): Boolean;
196	begin
197	Result := inherited AllowContextChange(WhyNot); // sets result = true
198	//if dlgProbs <> nil then Result := dlgProbs.OkToQuit;
199	//if dlgProbs <> nil then dlgProbs.bbQuitClick(Self);
200	//need to check here and set to false if quit was cancelled or true if accepted
201
202	if dlgProbs <> nil then
203	case BOOLCHAR[frmFrame.CCOWContextChanging] of
204	'1': begin
205	WhyNot := 'Changes to current problem will be discarded.';
206	Result := False;
207	end;
208	'0': begin
209	if WhyNot = 'COMMIT' then
210	begin
211	FSilent := True;
212	dlgProbs.Silent := True;
213	dlgProbs.bbQuitClick(Self);
214	end
215	else
216	begin
217	dlgProbs.bbQuitClick(Self);
218	Result := dlgProbs.CanQuit;
219	end;
220	end;
221	end;
222
223	end;
224
225	procedure TfrmProblems.ClearPtData;
226	begin
227	inherited ClearPtData;
228	ClearGrid;
229	lblProbList.Caption := '';
230	wgProbData.Caption := lblProbList.Caption;
231	FWarningShown := False;
232	end;
233
234	procedure TfrmProblems.DisplayPage;
235	begin
236	inherited DisplayPage;
237	frmFrame.ShowHideChartTabMenus(mnuViewChart);
238	frmFrame.mnuFilePrint.Tag := CT_PROBLEMS;
239	frmFrame.mnuFilePrint.Enabled := True;
240	frmFrame.mnuFilePrintSetup.Enabled := True;
241	if InitPatient then
242	begin
243	FWarningShown := False;
244	if PLUser <> nil then
245	begin
246	PLUser.Destroy;
247	PLUser := nil;
248	end;
249	//ClearPtData;
250	ShowPnlView;
251	pnlButtons.SendToBack;
252	pnlButtons.Hide;
253	LoadProblems ;
254	end;
255	end;
256
257	procedure TfrmProblems.mnuChartTabClick(Sender: TObject);
258	begin
259	inherited;
260	frmFrame.mnuChartTabClick(Sender);
261	end;
262
263	{------------------------ pdr - Problem list gadget event methods ------------}
264	procedure TfrmProblems.lstCatPickClick(Sender: TObject);
265	var
266	AList:TStringList;
267	begin
268	AList:=TStringList.create;
269	try
270	LoadUserProbs(AList);
271	finally
272	AList.free;
273	end;
274	end;
275
276	procedure TfrmProblems.lstProbActsClick(Sender: TObject);
277	var
278	act, i, j: integer;
279	Alist: TstringList;
280	cmt, ProblemIFN, ut, x, line, comments: string ;
281	ProbRec: TProbRec ;
282	ContextString, FilterString: string;
283	FilterChanged: boolean;
284	AllProblemsIndex: integer;
285	begin
286	if PLPt = nil then
287	begin
288	InfoBox(TX_INVALID_PATIENT, TC_NO_PATIENT, MB_OK or MB_ICONWARNING);
289	Exit;
290	end;
291	act := TComponent(Sender).tag ;
292	if act = 0 then exit;
293	// make sure a visit (time & location) is available before creating the problem
294	case act of
295	100: {add new problem}
296	begin
297	if PlUser.usViewAct = 'R' then
298	begin
299	InfoBox(TX_ADD_REMOVED, TC_ADD_REMOVED, MB_ICONINFORMATION or MB_OK);
300	exit;
301	end;
302	if not EncounterPresent then exit;
303	PLProblem := '';
304	AList := TStringList.Create;
305	pProviderID := Encounter.Provider;
306	pProviderName := Encounter.ProviderName ;
307	try
308	if pnlView.Visible then
309	begin
310	pnlView.SendToBack;
311	pnlProbCats.Show;
312	pnlProbCats.BringToFront;
313	pnlButtons.Visible := True;
314	if PLUser.usUseLexicon then
315	begin
316	lblProbCats.Visible := True;
317	lstCatPick.Visible := True;
318	lblProblems.Visible := True;
319	lstProbPick.Visible := True;
320	lstCatPick.Clear ;
321	LoadUserCats(AList);
322	bbOtherProb.Visible := True;
323	pnlProbList.Visible := True;
324	lstCatPick.TabStop := True;
325	lstProbPick.TabStop := True;
326	lstView.TabStop := False;
327	bbNewProb.TabStop := False;
328	pnlProbList.BringToFront ;
329	pnlProbCats.ClientHeight := (pnlProbList.ClientHeight - pnlButtons.ClientHeight) div 2;
330	pnlProbEnt.Visible := False;
331	pnlProbEnt.SendToBack;
332	if (lstCatPick.Items.Count = 1) then
333	if Piece(lstCatPick.Items[0], U, 1) = '-1' then
334	bbOtherProbClick(Self);
335	end
336	else
337	begin
338	bbOtherProb.Visible := False;
339	edProbEnt.Visible := True;
340	lblProbEnt.Visible := True;
341	pnlProbEnt.Visible := True;
342	pnlProbEnt.BringToFront;
343	pnlProbList.Visible := False;
344	lstCatPick.TabStop := False;
345	lstProbPick.TabStop := False;
346	lstView.TabStop := True;
347	bbNewProb.TabStop := True;
348	pnlProbList.SendToBack ;
349	edProbEnt.text := '';
350	if pnlProbEnt.Visible then edProbEnt.SetFocus;
351	end;
352	end
353	else
354	begin
355	if (lstProbPick.itemindex < 0) and (edProbEnt.text = '') then
356	InfoBox('Select a Problem to add from lists' + #13#10 + ' on left or enter a new one ',
357	'Information', MB_OK or MB_ICONINFORMATION)
358	else
359	begin
360	AddProblem;
361	lstProbPick.itemindex := -1;
362	end;
363	end ;
364	finally
365	AList.Free;
366	end;
367	end;
368	200: {Inactivate}
369	begin
370	if PlUser.usViewAct = 'R' then
371	begin
372	InfoBox('Cannot inactivate a problem on the "Removed Problem List"',
373	'Information', MB_OK or MB_ICONINFORMATION);
374	exit;
375	end;
376	if (wgProbData.ItemIndex < 0) or (Piece(MString(wgProbData.itemindex), U, 3) = '') then
377	InfoBox('Select a patient problem from the grid on right',
378	'Information', MB_OK or MB_ICONINFORMATION)
379	else
380	begin
381	if not EncounterPresent then exit;
382	pProviderID := Encounter.Provider;
383	pProviderName := Encounter.ProviderName ;
384	AllProblemsIndex := 0;
385	repeat
386	begin
387	if wgProbData.Selected[AllProblemsIndex] then
388	begin
389	Line := FAllProblems[AllProblemsIndex];
390	if CharAt(Piece(Line, U, 2), 1) = 'A' then
391	UpdateProblem('I',Line,AllProblemsIndex)
392	else
393	InfoBox('Problem "' + Trim(UpperCase(Piece(Piece(Line, U, 3), #13, 1))) + '" is already inactive.',
394	'Problem not updated', MB_ICONINFORMATION or MB_OK);
395	end;
396	inc(AllProblemsIndex);
397	end;
398	until AllProblemsIndex >= wgProbData.Count;
399	RefreshList;
400	end;
401	if (PlUser.usViewAct='A') then
402	begin
403	AList := TStringList.Create ;
404	LoadPatientProblems(Alist,'A',False) ;
405	NoRowSelected ;
406	end;
407	RefreshList;
408	end;
409	250: {Verify}
410	begin
411	if not PLuser.usVerifyTranscribed then exit ;
412	if PlUser.usViewAct = 'R' then
413	begin
414	InfoBox('Cannot verify a problem on the "Removed Problem List"',
415	'Information', MB_OK or MB_ICONINFORMATION);
416	exit;
417	end;
418	if (wgProbData.ItemIndex < 0) or (Piece(MString(wgProbData.ItemIndex), U, 3) = '') then
419	InfoBox('Select a patient problem from the grid on right',
420	'Information', MB_OK or MB_ICONINFORMATION)
421	else
422	begin
423	if not EncounterPresent then exit;
424	pProviderID := Encounter.Provider;
425	pProviderName := Encounter.ProviderName ;
426	AllProblemsIndex := 0;
427	repeat
428	begin
429	if wgProbData.Selected[AllProblemsIndex] then
430	begin
431	Line := FAllProblems[AllProblemsIndex];
432	if Pos('#',Piece(Line, U, 2)) > 0 then
433	InfoBox('Problem "' + Trim(UpperCase(Piece(Piece(Line, U, 3), #13, 1))) + '" ' + #13#10 +
434	TX_INACTIVE_CODE_V, TC_INACTIVE_CODE, MB_ICONWARNING or MB_OK)
435	else if Pos('(u)',Piece(Line, U, 2)) = 0 then
436	InfoBox('Problem "' + Trim(UpperCase(Piece(Piece(Line, U, 3), #13, 1))) + '" is already verified.',
437	'Problem not updated', MB_ICONINFORMATION or MB_OK)
438	else
439	UpdateProblem('V',Line,AllProblemsIndex);
440	end;
441	inc(AllProblemsIndex);
442	end;
443	until AllProblemsIndex >= wgProbData.Count;
444	RefreshList;
445	mnuActVerify.Enabled := False;
446	popVerify.Enabled := False;
447	end;
448	end;
449	300: {detail}
450	with wgProbData do
451	begin
452	if ItemIndex < 0 then
453	InfoBox('Select a problem from the grid for Detail Display',
454	'Information', MB_OK or MB_ICONINFORMATION)
455	else if StrToIntDef(Piece(MString(ItemIndex), U, 1),0)>0 then
456	ReportBox(DetailProblem(StrToInt(Piece(MString(ItemIndex), U, 1))),
457	Piece(Piece(MString(ItemIndex), U, 3), #13, 1), True);
458	end;
459	400: {edit}
460	begin
461	if PlUser.usViewAct = 'R' then
462	begin
463	InfoBox('Cannot select a problem to edit from the "Removed Problem List"',
464	'Information', MB_OK or MB_ICONINFORMATION);
465	exit;
466	end;
467	if wgProbData.ItemIndex < 0 then
468	InfoBox('Select a problem from the grid to Edit', 'Information', MB_OK or MB_ICONINFORMATION)
469	else
470	begin
471	if not EncounterPresent then exit;
472	pProviderID := Encounter.Provider;
473	pProviderName := Encounter.ProviderName ;
474	EditProblem('E');
475	end
476	end;
477	500: {Remove}
478	begin
479	if not PlUser.usPrimeUser then exit ;
480	if PlUser.usViewAct = 'R' then
481	begin
482	InfoBox('Cannot remove from the "Removed Problem List"' +#13#10 + 'Use "Restore Problem"',
483	'Information', MB_OK or MB_ICONINFORMATION);
484	exit;
485	end;
486	if wgProbData.ItemIndex < 0 then
487	InfoBox('Select a problem from the grid to remove', 'Information', MB_OK or MB_ICONINFORMATION)
488	else
489	begin
490	if not EncounterPresent then exit;
491	pProviderID := Encounter.Provider;
492	pProviderName := Encounter.ProviderName ;
493	EditProblem('R');
494	end;
495	end;
496	550: {Restore}
497	begin
498	if not PlUser.usPrimeUser then exit ;
499	if PlUser.usViewAct <> 'R' then
500	begin
501	InfoBox('View the Removed Problems Display, and select a record to restore.',
502	'Information', MB_OK or MB_ICONINFORMATION);
503	exit;
504	end;
505	if wgProbData.ItemIndex < 0 then
506	InfoBox('Select a problem to restore from the grid on right', 'Information', MB_OK or MB_ICONINFORMATION)
507	else
508	begin
509	if not EncounterPresent then exit;
510	pProviderID := Encounter.Provider;
511	pProviderName := Encounter.ProviderName ;
512	RestoreProblem;
513	end;
514	end;
515	600: {Add Comment}
516	begin
517	if PlUser.usViewAct = 'R' then
518	begin
519	InfoBox('Cannot add a comment to a removed problem', 'Information', MB_OK or MB_ICONINFORMATION);
520	exit;
521	end;
522	if wgProbData.ItemIndex < 0 then
523	InfoBox('Select a problem to annotate from the grid on right', 'Information', MB_OK or MB_ICONINFORMATION)
524	else
525	begin
526	if not EncounterPresent then exit;
527	pProviderID := Encounter.Provider;
528	pProviderName := Encounter.ProviderName ;
529	AList := TStringList.Create;
530	ProblemIFN := Piece(MString(wgProbData.ItemIndex), U, 1);
531	AList.Assign(EditLoad(ProblemIFN, pProviderID, PLPt.ptVAMC)) ;
532	if Alist.count = 0 then
533	begin
534	InfoBox('No Data on Host for problem ' + ProblemIFN, 'Information', MB_OK or MB_ICONINFORMATION);
535	close;
536	exit;
537	end;
538	ProbRec:=TProbRec.Create(Alist); {create a problem object}
539	try
540	ProbRec.PIFN := ProblemIFN;
541	if not IsActiveICDCode(ProbRec.Diagnosis.extern) then
542	begin
543	InfoBox(TX_INACTIVE_CODE, TC_INACTIVE_CODE, MB_ICONWARNING or MB_OK);
544	exit;
545	end ;
546	cmt := NewComment ;
547	if (StrToInt(Piece(cmt, U, 1)) > 0) and (Piece(cmt, U, 3) <> '') then
548	begin
549	ProbRec.AddNewComment(Piece(cmt, U, 3));
550	ut := '';
551	If PLUser.usPrimeUser then ut := '1';
552	AList.Assign(EditSave(ProblemIFN,pProviderID,PLPt.ptVAMC,ut,ProbRec.FilerObject)) ;
553	LoadPatientProblems(AList,PlUser.usViewAct[1],true);
554	end ;
555	finally
556	Alist.Free ;
557	ProbRec.Free ;
558	end ;
559	end ;
560	end;
561	700: {Active only}
562	begin
563	Alist := TstringList.create;
564	try
565	PlUser.usViewAct := 'A';
566	LoadPatientProblems(Alist,'A',false);
567	SetPiece(FContextString, ';', 3, 'A');
568	GetRowCount;
569	finally
570	Alist.free;
571	end;
572	end;
573	800: {inactive Only}
574	begin
575	Alist := TstringList.create;
576	try
577	PlUser.usViewAct := 'I';
578	LoadPatientProblems(Alist,'I',false);
579	SetPiece(FContextString, ';', 3, 'I');
580	GetRowCount;
581	finally
582	Alist.free;
583	end;
584	end;
585	900: {all problems display}
586	begin
587	Alist := TstringList.create;
588	try
589	PlUser.usViewAct := 'B';
590	LoadPatientProblems(Alist,'B',false);
591	SetPiece(FContextString, ';', 3, 'B');
592	GetRowCount;
593	finally
594	Alist.free;
595	end;
596	end;
597	950: {Removed Problems Display}
598	begin
599	Alist := TstringList.create;
600	try
601	PlUser.usViewAct := 'R';
602	LoadPatientProblems(Alist,'R',false);
603	SetPiece(FContextString, ';', 3, 'R');
604	GetRowCount;
605	finally
606	Alist.free;
607	end;
608	end;
609	975: {Select viewing filters}
610	begin
611	lstView.ItemIndex := -1;
612	ContextString := '^;;' + PLUser.usViewAct[1] + ';' + PLUser.usViewComments;
613	GetViewFilters(Font.Size, PLFilters, ContextString, FilterString, FilterChanged);
614	if not FilterChanged then exit;
615	FContextString := ContextString;
616	FFilterString := FilterString;
617	if (Piece(ContextString, ';', 3) <> PLUser.usViewAct[1]) then
618	begin
619	AList := TStringList.Create;
620	try
621	PLUser.usViewAct := Piece(ContextString, ';', 3);
622	LoadPatientProblems(Alist, PLUser.usViewAct[1], False);
623	finally
624	AList.Free;
625	end;
626	end;
627	if (Piece(ContextString, ';', 4) <> PLUser.usViewComments) then with FAllProblems do
628	begin
629	for i := 0 to Count - 1 do
630	begin
631	if Objects[i] = nil then continue;
632	x := Piece(Piece(Strings[i], U, 3), #13, 1);
633	if Piece(ContextString, ';', 4) = '1' then
634	begin
635	comments := '';
636	for j := 0 to TStringList(Objects[i]).Count - 1 do
637	comments := comments + ' ' + TStringList(Objects[i]).Strings[j] + #13#10;
638	//comments := comments + ' CMT: ' + TStringList(Items.Objects[i]).Strings[j] + #13#10;
639	line := Strings[i];
640	SetPiece(line, U, 3, x + #13#10 + comments);
641	Strings[i] := line;
642	mnuViewComments.Checked := True;
643	end
644	else
645	begin
646	line := Strings[i];
647	SetPiece(line, U, 3, x);
648	Strings[i] := line;
649	mnuViewComments.Checked := False;
650	end;
651	end;
652	RefreshList;
653	PLUser.usViewComments := Piece(ContextString, ';', 4);
654	end;
655	pnlRightResize(Self);
656	end ;
657	end;
658	end;
659
660	procedure TfrmProblems.lstProbPickClick(Sender: TObject);
661	begin
662	if PlUser.usViewAct = 'R' then exit;
663	pProviderID := Encounter.Provider ;
664	AddProblem;
665	TListBox(sender).itemindex := -1;
666	end;
667
668	procedure TfrmProblems.pnlProbEntResize(Sender: TObject);
669	(*var
670	i:integer;*)
671	begin
672	(* for i := 0 to pred(twincontrol(sender).controlcount) do
673	begin
674	twincontrol(sender).controls[i].width := twincontrol(sender).width - 4;
675	twincontrol(sender).controls[i].left := 2;
676	end;*)
677	end;
678
679	procedure TfrmProblems.wgProbDataClick(Sender: TObject);
680	var
681	S: string;
682	begin
683	pnlRight.font.color := self.font.color;
684	S := MString(wgProbData.ItemIndex);
685	pnlRight.caption := Piece(Piece(S, U , 3), #13, 1);
686	if (Piece(S, U, 1) = '') or
687	(Pos('No data available', Piece(S, U, 2)) > 0) or
688	(Pos('No problems found.', Piece(S, U, 2)) > 0)
689	then NoRowSelected else RowSelected ;
690	end;
691
692	procedure TfrmProblems.wgProbDataDblClick(Sender: TObject);
693	begin
694	lstProbActsClick(mnuActDetails);
695	end;
696
697	procedure TfrmProblems.lstProbPickDblClick(Sender: TObject);
698	begin
699	if PlUser.usViewAct = 'R' then exit;
700	pProviderID := Encounter.Provider ;
701	AddProblem;
702	TListBox(sender).itemindex := -1;
703	end;
704
705	procedure TfrmProblems.edProbEntKeyPress(Sender: TObject; var Key: Char);
706	begin
707	if key=#13 then lstProbPickDblClick(sender);
708	end;
709
710	procedure TfrmProblems.bbOtherProbClick(Sender: TObject);
711	var
712	frmPLLex: TfrmPLLex;
713	begin
714	if not PLUser.usUseLexicon then exit; {don't allow lookup}
715	frmPLLex := TFrmPLLex.create(Application);
716	try
717	frmPLLex.showmodal;
718	finally
719	frmPLLex.Free;
720	end;
721	end;
722
723	procedure TfrmProblems.UMCloseProblem(var Message:TMessage);
724	begin
725	pnlView.BringToFront ;
726	ShowPnlView;
727	bbCancel.Enabled := True ;
728	bbOtherProb.enabled := true; {restore lexicon access}
729	pnlButtons.Visible := False;
730	pnlButtons.SendToBack;
731	pnlProbEnt.Visible := (not PLUser.usUseLexicon) ;
732	if PLuser.usViewAct = 'A' then
733	pnlRight.caption := ACTIVE_LIST_CAP
734	else if PLuser.usViewAct = 'I' then
735	pnlRight.caption := INACTIVE_LIST_CAP
736	else if PLuser.usViewAct = 'B' then
737	pnlRight.caption := BOTH_LIST_CAP
738	else if PLuser.usViewAct = 'R' then
739	pnlRight.caption := REMOVED_LIST_CAP
740	else
741	begin
742	PlUser.usViewAct := 'A';
743	pnlRight.caption := ACTIVE_LIST_CAP;
744	end;
745	if dlgProbs <> nil then dlgProbs:=nil;
746	end;
747
748	//procedure TfrmProblems.UMPLFilter(var Message:TMessage);
749	procedure TfrmProblems.ApplyViewFilters;
750	var
751	i: integer;
752	wantnulls: boolean;
753	begin
754	{the following escape is necessitated by change in default row height which
755	corrupts display of hidden rows in wgProbData. Since the default rowheight
756	is changed with each change in screen size, this gets called once before
757	PLFilters is created}
758	if PLFilters = nil then exit; {not initialized}
759	{show all rows}
760	wantnulls := (PLFilters.ProviderList.indexof('-1') > -1);
761	for i := 0 to pred(FProblemsVisible.count) do FProblemsVisible[i] := 'Y';
762
763	{filter for provider}
764	if PLFilters.ProviderList.Count > 0 then
765	if PLFilters.ProviderList[0] <> '0' then { 0 signifies all }
766	for i := 0 to pred(FAllProblems.count) do
767	if Piece(FAllProblems[i], U, 1) <> '' then {don't want to disappear empty rows}
768	if (PLFilters.ProviderList.indexof(Piece(FAllProblems[i], U, 10)) < 0) or
769	((Piece(FAllProblems[i], U, 10) = '') and (not wantnulls)) then
770	FProblemsVisible[i] := 'N';
771
772	if PLUser.usCurrentView = PL_UF_VIEW then exit; {Bail out - no filtering by Loc}
773
774	{conditionally filter for clinic(s) - may be multiple selected}
775	if PLUser.usCurrentView = PL_OP_VIEW then
776	begin
777	wantnulls := (PLFilters.ClinicList.indexof('-1') > -1);
778	if PLFilters.ClinicList.Count = 0 then exit;
779	if PLFilters.ClinicList[0] <> '0' then { 0 signifies all }
780	for i := 0 to pred(FAllProblems.count) do
781	if (Piece(FAllProblems[i], U, 1) <> '') and {don't want to disappear empty rows}
782	(FProblemsVisible[i] = 'Y') then {don't want if already filtered}
783	begin
784	if (Piece(FAllProblems[i], U ,11) <> '') and {clinic not on user list}
785	(PLFilters.ClinicList.indexof(Piece(FAllProblems[i], U, 11)) < 0) then
786	FProblemsVisible[i] := 'N'
787	else if ((Piece(FAllProblems[i], U, 11) = '') and (not wantnulls)) then {no clinic recorded}
788	FProblemsVisible[i] := 'N';
789	end;
790	end
791	else
792	{conditionally filter for service - may be multiple selected}
793	begin
794	wantnulls := (PLFilters.ServiceList.indexof('-1') > -1);
795	if PLFilters.ServiceList.Count = 0 then exit;
796	if PLFilters.ServiceList[0] <> '0' then { 0 signifies all }
797	for i := 0 to pred(FAllProblems.count) do
798	if (Piece(FAllProblems[i], U, 1) <> '') and {don't want to disappear empty rows}
799	(FProblemsVisible[i] = 'Y') then {don't want if already filtered}
800	begin
801	if (Piece(FAllProblems[i], U, 12) <> '') and {Service not on user list}
802	(PLFilters.ServiceList.indexof(Piece(FAllProblems[i], U, 12)) < 0) then
803	FProblemsVisible[i] := 'N'
804	else if (Piece(FAllProblems[i], U, 12) = '') and (not wantnulls) then {no Service recorded}
805	FProblemsVisible[i] := 'N';
806	end;
807	end;
808	end;
809
810	procedure TfrmProblems.GetRowCount;
811	var
812	ShownProbs, TotalProbs: integer;
813	begin
814	if (wgProbData.Items.Count > 0) and (Piece(wgProbData.Items[0], U, 1) <> '') then
815	ShownProbs := wgProbData.Items.Count
816	else
817	ShownProbs := 0;
818
819	if (FAllProblems.Count > 0) and (Piece(FAllProblems[0], U, 1) <> '') then
820	TotalProbs := FAllProblems.Count
821	else
822	TotalProbs := 0;
823
824	case PLUser.usViewAct[1] of
825	'A': lblProbList.Caption := ACTIVE_LIST_CAP ;
826	'I': lblProbList.Caption := INACTIVE_LIST_CAP ;
827	'B': lblProbList.Caption := BOTH_LIST_CAP ;
828	'R': lblProbList.Caption := REMOVED_LIST_CAP ;
829	end;
830	lblProbList.Caption := lblProbList.Caption + ' (' + IntToStr(ShownProbs) + ' of ' + IntToStr(TotalProbs) + ')';
831	wgProbData.Caption := lblProbList.Caption;
832	end;
833
834
835	procedure TfrmProblems.UMPLLexicon(var Message:TMessage);
836	begin
837	if PLProblem = '' then exit; {shouldn't happen but...}
838	if dlgProbs = nil then AddProblem;
839	end;
840
841	procedure TfrmProblems.SetGridPieces( Pieces: string);
842	var
843	i, AdjustCol, cxUsed: Integer;
844	PieceSet: set of 0..High(GridColWidths);
845	x: string;
846	begin
847	PieceSet := [];
848	x := Pieces;
849	while x <> '' do begin
850	PieceSet := PieceSet + [StrToIntDef(Piece(x, ',', 1), 1)-1];
851	if Pos(',', x) = 0 then
852	break;
853	x := Copy(x, Pos(',',x)+1, Length(x));
854	end;
855	AdjustCol := 0;
856	cxUsed := 0;
857	for i := 0 to High(GridColWidths) do
858	if i in PieceSet then
859	begin
860	if GridColWidths[i] > -1 then
861	begin
862	if GridColWidths[i] > 0 then
863	begin
864	HeaderControl.Sections[i].MaxWidth := 10000;
865	HeaderControl.Sections[i].Width := ForChars(GridColWidths[i], gFontWidth);
866	cxUsed := cxUsed + HeaderControl.Sections[i].Width;
867	end
868	else
869	begin
870	HeaderControl.Sections[i].Width := 0;
871	HeaderControl.Sections[i].MaxWidth := 0;
872	end;
873	end
874	else
875	AdjustCol := i;
876	end
877	else
878	begin
879	HeaderControl.Sections[i].Width := 0;
880	HeaderControl.Sections[i].MaxWidth := 0;
881	end;
882	HeaderControl.Sections[AdjustCol].AutoSize := True;
883	HeaderControl.Sections[AdjustCol].Width := HeaderControl.Width - cxUsed;
884	end;
885
886	procedure TfrmProblems.pnlRightResize(Sender: TObject);
887	begin
888	if PLUser = nil then exit;
889	if PLUser.usCurrentView = PL_IP_VIEW then
890	SetGridPieces('2,3,4,5,8,9')
891	else if PLUser.usCurrentView = PL_OP_VIEW then
892	SetGridPieces('2,3,4,5,7');
893	{have to do this to recover hidden rows}
894	ApplyViewFilters;
895	RefreshList;
896	GetRowCount;
897	//PostMessage(frmProblems.Handle, UM_PLFILTER,0,0);
898	end;
899
900	procedure TfrmProblems.FormCreate(Sender: TObject);
901	begin
902	inherited;
903	FAllProblems := TStringList.Create;
904	FProblemsVisible := TStringList.Create;
905	FItemData := TStringList.Create;
906	PageID := CT_PROBLEMS;
907	wgProbData.Color := ReadOnlyColor;
908	GetFontInfo(Canvas.Handle, gFontWidth, gFontHeight);
909	end;
910
911	procedure TfrmProblems.LoadUserParams(Alist:TstringList);
912	var
913	i: integer;
914	begin
915	AList.Assign(InitUser(User.DUZ)) ;
916	//AList.Assign(InitUser(Encounter.Provider)) ;
917	PLUser := TPLUserParams.create(Alist);
918	FContextString := PLUser.usDefaultContext;
919	FFilterString := PLUser.usDefaultView + '/';
920	if PLFilters <> nil then
921	begin
922	if PLUser.usDefaultView = 'C' then with PLFilters.ClinicList do
923	for i := 0 to Count - 1 do
924	if Piece(Strings[i], U, 1) <> '-1' then
925	FFilterString := FFilterString + Piece(Strings[i], U, 1) + '/';
926	if PLUser.usDefaultView = 'S' then with PLFilters.ServiceList do
927	for i := 0 to Count - 1 do
928	if Piece(Strings[i], U, 1) <> '-1' then
929	FFilterString := FFilterString + Piece(Strings[i], U, 1) + '/';
930	end;
931	mnuViewComments.Checked := (PLUser.usViewComments = '1');
932	if PLUser.usTesting then
933	InfoBox('WARNING - Test User Parameters in Effect', 'Warning', MB_OK or MB_ICONWARNING);
934	pnlRightResize(Self);
935	end;
936
937	procedure TfrmProblems.LoadPatientParams(AList:TstringList);
938	begin
939	AList.Assign(InitPt(Patient.DFN)) ;
940	PLPt := TPLPt.create(Alist);
941	end;
942
943	procedure TfrmProblems.ClearGrid;
944	var
945	i:integer;
946	begin
947	with FAllProblems do for i := 0 to Count - 1 do
948	if Objects[i] <> nil then
949	begin
950	TStringList(Objects[i]).Free;
951	Objects[i] := nil;
952	end;
953	wgprobdata.Clear;
954	FAllProblems.Clear;
955	FProblemsVisible.Clear;
956	end;
957
958
959	procedure TfrmProblems.LoadPatientProblems(AList:TStringList; const Status:char; init:boolean);
960	var {init should only be true when initializing a list for a new patient}
961	x, line, ver, prio, comments: string;
962	i, j, inact: Integer;
963	st: char;
964	CmtList: TStringList;
965	//SCCond, tmpSCstr: string;
966
967	procedure ReverseList(Alist:TstringList);
968	var
969	i,j:integer;
970	begin
971	i:=0;
972	j:=pred(Alist.count);
973	while i<j do
974	begin
975	alist.exchange(i,j);
976	inc(i);
977	dec(j);
978	end;
979	end;
980
981	begin {Body}
982	CmtList := TStringList.Create;
983	if PLFilters=nil then {create view filter lists}
984	PLFilters:=TPLFilters.create;
985	try
986	ClearGrid;
987	inact := 0;
988	if PLPt = nil then
989	begin
990	InfoBox(TX_INVALID_PATIENT, TC_NO_PATIENT, MB_OK or MB_ICONWARNING);
991	AList.Clear;
992	AList.Add('No data available');
993	end
994	else
995	begin
996	st:=status;
997	if st= '' then st := 'A'; {default to active list}
998	AList.Assign(ProblemList(Patient.DFN,St)) ;
999	end;
1000	if Status = 'R' then
1001	SetGridPieces('3,4,5,7,8,9')
1002	else
1003	SetGridPieces('2,3,4,5,7,8,9');
1004	if Alist.count > 1 then Alist.delete(0); {get rid of first element - it is a list count}
1005	SortByPiece(AList, u, 6); { Sort by FM date/time }
1006	SetListFMDateTime('MMM dd yyyy',AList, u, 6); { Change FM date to MM/DD/YY }
1007	SetListFMDateTime('MMM dd yyyy',AList, u, 5); { Change FM date to MM/DD/YY }
1008	if PLUser.usReverseChronDisplay then {reverse chron order if required}
1009	ReverseList(Alist);
1010	{populate the grid}
1011	if ((Alist.Count = 1) and (pos('No data available', Alist[0]) > 0))then
1012	begin
1013	FAllProblems.Add('^^No problems found.');
1014	FProblemsVisible.Add('Y');
1015	RefreshList;
1016	Alist.Clear ;
1017	NoRowSelected;
1018	exit ;
1019	end ;
1020	for i := 0 to pred(Alist.count) do
1021	begin
1022	FAllProblems.Add('');
1023	FProblemsVisible.Add('Y');
1024	comments := '';
1025	CmtList.Clear;
1026	x := AList[i];
1027	if (Piece(x, U, 18) = '#') and (CharAt(UpperCase(Status), 1) in ['A', 'B', 'I', 'R']) then
1028	begin
1029	ver := '#'; // inactive ICD code flag takes precedence over unverified flag
1030	if (Piece(x, U, 2) = 'A') then inact := inact + 1;
1031	end
1032	else if (PlUSer.usVerifyTranscribed) and
1033	(Piece(x, U, 9) = 'T') then
1034	ver := '(u)'
1035	else
1036	ver := ' ';
1037	if Piece(x, U, 14) = 'A' then prio := ' * ' else prio := ' ' ;
1038	Line := '';
1039	SetPiece(Line, U, 2, Piece(x, U, 2) + prio + ver);
1040	if Piece(x, U, 15) = '1' then //problem has comments
1041	begin
1042	CmtList.Assign(GetProblemComments(Piece(x, U, 1)));
1043	if FAllProblems.Objects[i] = nil then FAllProblems.Objects[i]:= TStringList.Create;
1044	TStringList(FAllProblems.Objects[i]).Assign(CmtList);
1045	end;
1046
1047	SetPiece(Line, U, 3, Piece(x, U, 3));
1048	if PLUser.usViewComments = '1' then
1049	begin
1050	for j := 0 to CmtList.Count-1 do
1051	comments := comments + ' ' + CmtList.Strings[j] + #13#10;
1052	SetPiece(Line, U, 3, Piece(Line, U, 3) + #13#10 + comments);
1053	end;
1054	SetPiece(Line, U, 4, Trim(Piece(x, U, 5))); {onset date}
1055	SetPiece(Line, U, 5, Trim(Piece(x, U, 6))); {last updated}
1056	SetPiece(Line, U, 7, MixedCase(Piece(Piece(x, U, 10), ';', 2))); {location name}
1057	SetPiece(Line, U, 8, MixedCase(Piece(Piece(x, U, 12), ';', 2))); {provider name}
1058	SetPiece(Line, U, 9, MixedCase(Piece(Piece(x, U, 13), ';', 2))); {service name}
1059	{hidden cells}
1060	SetPiece(Line, U, 1, Piece(x, U, 1)); {problem IEN}
1061	SetPiece(Line, U, 6, Piece(x, U, 7)); {service connected status}
1062	SetPiece(Line, U, 11, Piece(Piece(x, U, 10), ';', 1)); {location IEN}
1063	SetPiece(Line, U, 13, Piece(x, U, 11)); {loc type}
1064	SetPiece(Line, U, 10, Piece(Piece(x, U, 12), ';', 1)); {responsible provider IEN}
1065	SetPiece(Line, U, 12, Piece(Piece(x, U, 13), ';', 1)); {service IEN}
1066	SetPiece(Line, U, 14, Piece(x, U, 4)); {code}
1067	SetPiece(Line, U, 15, Piece(x, U, 17)); {Service-connected conditions}
1068	SetPiece(Line, U, 16, Piece(x, U, 18)); {# = inactive ICD code stored with problem}
1069	FAllProblems[i] := Line;
1070	end;
1071	Alist.clear;
1072	if not init then
1073	SetViewFilters(Alist)
1074	else
1075	InitViewFilters(Alist);
1076	ApplyViewFilters;
1077	RefreshList;
1078	lstProbPick.ItemIndex := -1;
1079	if (ProbRec <> nil) and (ProbRec.PIFN <> '') then
1080	begin
1081	for i := 0 to wgProbData.Items.count-1 do
1082	if (Piece(MString(i), U, 1) = ProbRec.PIFN) then
1083	wgProbData.ItemIndex := i ;
1084	wgProbDataClick(Self);
1085	end
1086	else
1087	wgProbData.ItemIndex := -1;
1088	if (wgProbData.Items.Count > 0) and (wgProbData.ItemIndex > -1) then
1089	RowSelected
1090	else
1091	NoRowSelected;
1092	pnlRightResize(Self);
1093	if (not FWarningShown) and (inact > 0) and (CharAt(UpperCase(Status), 1) in ['A', 'B']) then
1094	begin
1095	InfoBox('There are ' + IntToStr(inact) + ' active problem(s) flagged with a "#" as having' + #13#10 +
1096	'inactive ICD codes as of today''s date. Please correct these' + #13#10 +
1097	'problems using the "Change" option.', 'Inactive ICD Codes Found', MB_ICONWARNING or MB_OK);
1098	FWarningShown := True;
1099	end;
1100	finally
1101	CmtList.Free;
1102	end;
1103	end;
1104
1105	procedure TfrmProblems.LoadUserCats(AList:TStringList);
1106	begin
1107	if not PLUser.usUseLexicon then exit; {Bail out if not to use lexicon}
1108	Alist.clear;
1109	AList.Assign(UserProblemCategories(Encounter.Provider,Encounter.Location)) ;
1110	if Alist.count = 0 then
1111	begin
1112	lstCatPick.Items.Add('-1^None defined - use OTHER') ;
1113	lstProbPick.Visible := False ;
1114	lblProblems.Visible := False ;
1115	exit ;
1116	end ;
1117	lstCatPick.Items.assign(AList);
1118	lstCatPick.itemindex := 0;
1119	lstCatPickClick(frmProblems);
1120	end;
1121
1122	procedure TfrmProblems.LoadUserProbs(AList:TStringList);
1123	var
1124	catien: string;
1125	begin
1126	if not PLUser.usUseLexicon then exit; {Bail out if not to use lexicon}
1127	if lstCatPick.itemindex < 0 then exit; {bail out}
1128	Alist.clear;
1129	catien := IntToStr(lstCatPick.itemIEN);
1130	AList.Assign(UserProblemList(catien)) ;
1131	{File 125.12, Each line contains: PROBLEM^DISPLAY TEXT^CODE^CODE IFN }
1132	{code ifn is derived}
1133	lstProbPick.Items.assign(Alist);
1134	end;
1135
1136	procedure TfrmProblems.LoadProblems;
1137	var
1138	AList: TStringList;
1139	i: integer;
1140	begin
1141	pProviderID := 0;
1142	AList := TStringList.Create;
1143	try
1144	lstView.ItemIndex := -1;
1145	StatusText('Retrieving problem list...') ;
1146	if (PLUser = nil) or InitPatient then LoadUserParams(Alist);
1147	Alist.clear;
1148	if Patient.DFN <> '' then LoadPatientParams(Alist);
1149	Alist.clear;
1150	LoadPatientProblems(AList,PlUser.usViewAct[1],true); {initialize patient list}
1151	lstView.ItemIndex := -1;
1152	AList.clear;
1153	lstCatPick.Clear ;
1154	LoadUserCats(AList);
1155	{SET APPLICATION DEFAULTS}
1156	if (not PLUser.usPrimeUser) then
1157	begin {activities available to GMPLUSER only}
1158	mnuActRestore.enabled := False;
1159	mnuActRemove.enabled:=false;
1160	mnuViewRemoved.Enabled := False;
1161	popRemove.enabled:=false;
1162	popRestore.enabled := False;
1163	i := lstView.Items.IndexOf('Removed');
1164	if i > -1 then lstView.Items.Delete(i);
1165	mnuActVerify.enabled:=false;
1166	popVerify.enabled:=false;
1167	end;
1168	if (not PLUser.usVerifyTranscribed) then
1169	begin
1170	mnuActVerify.enabled:=false;
1171	popVerify.enabled:=false;
1172	end;
1173	finally
1174	AList.Free;
1175	StatusText('') ;
1176	end;
1177	end;
1178
1179	function TfrmProblems.HighlightDuplicate( NewProb: string; const Msg: string;
1180	DlgType: TMsgDlgType; Action: string): boolean;
1181	var
1182	dup: string;
1183	cmplist: TstringList;
1184	cmpp, i: integer;
1185	collapserow: boolean;
1186	begin
1187	Result := False;
1188	if Piece(newprob, U, 1) = '' then
1189	dup := CheckForDuplicateProblem('1', Piece(newprob, U, 2))
1190	else
1191	dup := CheckForDuplicateProblem(Piece(newprob,U,1), Piece(newprob, U, 2));
1192
1193	if (Piece(dup, U, 1) <> '0') then
1194	// if adding, check all existing problems for duplicates
1195	// if changing, exclude curent problem from duplicate check
1196	if (Action = 'ADD') or ((Action = 'CHANGE') and (Piece(dup, U, 1) <> ProbRec.PIFN)) then
1197	begin
1198	if (Piece(dup, U, 2) <> PLUser.usViewAct) and (PLUser.usViewAct <> 'B') then
1199	begin
1200	lstView.SelectByID(Piece(dup, U, 2));
1201	lstViewClick(Self);
1202	end;
1203	cmplist:=Tstringlist.create;
1204	try {find and highlight duplicate problem - match problem text minus trailing '*'}
1205	for i := 0 to FAllProblems.Count - 1 do
1206	cmpList.Add(TrimRight(Piece(Piece(Piece(FAllProblems[i], U, 3), #13, 1), '*', 1)));
1207	cmpp:=cmpList.indexof(TrimRight(Piece(Piece(newprob, U, 2), '*', 1)));
1208	finally
1209	cmplist.free;
1210	end;
1211	if cmpp > -1 then
1212	begin
1213	collapserow:= (FProblemsVisible[cmpp] <> 'Y');
1214	if CollapseRow then
1215	wgProbData.Items.Insert(0, FAllProblems[cmpp]);
1216	//translate from FAllProblems index to wgProbData index
1217	for i := 0 to wgProbData.Items.Count - 1 do
1218	begin
1219	if StrToInt(FItemData[i]) = cmpp then with wgProbData do
1220	begin
1221	TopIndex := i;
1222	ItemIndex := i;
1223	Selected[i] := True;
1224	break;
1225	end;
1226	end;
1227	case DlgType of
1228	mtInformation:
1229	InfoBox(Msg, 'Information', MB_OK or MB_ICONINFORMATION);
1230	mtConfirmation:
1231	Result := InfoBox(Msg, 'Confirmation', MB_YESNO or MB_ICONQUESTION) <> IDYES;
1232	end;
1233	if collapserow then wgProbData.Items.Delete(0);
1234	end;
1235	end;
1236	end;
1237
1238	procedure TfrmProblems.AddProblem;
1239	const
1240	TX799 = '799.9';
1241	var
1242	newprob: string;
1243	begin
1244	if (PLPt.ptDead<>'') then {Check for dead patient}
1245	if InfoBox('This Patient has been deceased since ' + PLPt.ptDead + #13#10 +
1246	' Proceed with problem addition?', 'Confirmation', MB_YESNO or MB_ICONQUESTION) = IDNO then
1247	exit; {bail out - if don't want to add to dead}
1248	{problems are in the form of: ien^.01^icd^icdifn , although only the .01 is required}
1249	if PLProblem <> '' then
1250	begin
1251	newProb:=PLProblem;
1252	PLProblem:='';
1253	end
1254	else if edProbEnt.text<>'' then
1255	begin
1256	newprob:= u + edProbEnt.text + u + TX799 + u; {free text problem entry from editbox}
1257	edProbEnt.Visible := False;
1258	lblProbEnt.Visible := False;
1259	edProbEnt.Text := '';
1260	end
1261	else if lstProbPick.itemindex > -1 then {problem selected from user list}
1262	{Each line contains: PROBLEM^DISPLAY TEXT^CODE^CODE IFN }
1263	newprob:=lstProbPick.Items[lstProbPick.itemindex];
1264	if NewProb='' then exit; {should never happen}
1265	bbCancel.Enabled := False ;
1266	bbOtherProb.enabled:=false; {don't let them invoke lexicon till add completed}
1267
1268	// ============= new duplicate checking code ===================
1269	if HighlightDuplicate(NewProb, 'This problem is a duplicate of the highlighted problem'
1270	+ #13#10 + ' Proceed?', mtConfirmation, 'ADD') then
1271	begin
1272	bbCancel.Enabled := True ;
1273	bbOtherProb.enabled:=true; {don't let them invoke lexicon till add completed}
1274	exit; {bail out - if don't want dups}
1275	end ;
1276	//============================== End new code =========================
1277	if ProbRec = nil then
1278	begin
1279	pnlRight.Caption := lblProbList.caption ;
1280	lblProbList.caption:='Add Problem';
1281	wgProbData.Caption := lblProbList.Caption;
1282	pnlProbDlg.Visible := True;
1283	pnlProbDlg.BringToFront ;
1284	dlgProbs:=TFrmDlgProb.create(pnlProbDlg);
1285	dlgProbs.HorzScrollBar.Range := dlgProbs.ClientWidth;
1286	dlgProbs.VertScrollBar.Range := dlgProbs.ClientHeight;
1287	dlgProbs.parent:=pnlProbDlg;
1288	dlgProbs.Align := alClient ;
1289	dlgProbs.Reason:='A';
1290	dlgProbs.SubjProb:=newprob;
1291	dlgProbs.show;
1292	PostMessage(dlgProbs.Handle, UM_TAKEFOCUS, 0, 0);
1293	end
1294	else
1295	InfoBox('Current Add/Edit/Display activity must be completed' + #13#10 +
1296	'before another record may be added',
1297	'Information', MB_OK or MB_ICONINFORMATION);
1298	end;
1299
1300	procedure TfrmProblems.EditProblem(const why: char);
1301	var
1302	prob: string;
1303	reas: string;
1304	begin
1305	prob := Piece(MString(wgProbData.ItemIndex), U, 1);
1306	if (prob <> '') and (ProbRec = nil) then
1307	begin
1308	StatusText('Retrieving selected problem...') ;
1309	bbCancel.Enabled := False ;
1310	bbOtherProb.enabled := false; {don't let them invoke lexicon till edit completed}
1311	case why of
1312	'E','e','C','c' : reas := 'Edit Problem';
1313	'D','d' : reas := 'Display Problem';
1314	'R','r' : reas := 'Remove Problem';
1315	end;
1316	pnlRight.Caption := lblProbList.caption ;
1317	lblProbList.caption := reas;
1318	wgProbData.Caption := lblProbList.Caption;
1319	pnlProbDlg.Visible := True;
1320	pnlProbDlg.BringToFront ;
1321	dlgProbs := TFrmDlgProb.create(pnlProbDlg);
1322	dlgProbs.HorzScrollBar.Range := dlgProbs.ClientWidth;
1323	dlgProbs.VertScrollBar.Range := dlgProbs.ClientHeight;
1324	dlgProbs.parent := pnlProbDlg;
1325	dlgProbs.Align := alClient ;
1326	dlgProbs.Reason := why;
1327	with wgProbData do dlgProbs.subjProb:=prob + u + Piece(Piece(MString(itemindex), U, 3), #13, 1) + u + Piece(MString(itemindex), U, 14);
1328	StatusText('') ;
1329	dlgProbs.Show;
1330	PostMessage(dlgProbs.Handle, UM_TAKEFOCUS, 0, 0);
1331	end
1332	else
1333	begin
1334	case why of
1335	'E','e','C','c' : reas := 'Edited';
1336	'D','d' : reas := 'Displayed';
1337	'R','r' : reas := 'Removed';
1338	end;
1339	InfoBox('Current Add/Edit/Display activity must be completed' + #13#10 +
1340	'before another record may be ' + reas,
1341	'Information', MB_OK or MB_ICONINFORMATION);
1342	end;
1343	end;
1344
1345	procedure TfrmProblems.UpdateProblem(const why:char; Line: string; AllProblemsIndex: integer);
1346	var
1347	Alist: TstringList;
1348	ProblemIFN: string;
1349	sv: string;
1350	i: integer;
1351
1352	begin
1353	alist := TstringList.create;
1354	try
1355	problemIFN := Piece(Line, U, 1);
1356	{get the basic info - could shortcut, but try this for now}
1357	AList.Assign(EditLoad(ProblemIFN,pProviderID,PLPt.ptVAMC)) ;
1358	probRec := TProbrec.create(Alist);
1359	probRec.PIFN := problemIFN;
1360	ProbRec.RespProvider.DHCPtoKeyVal(inttostr(Encounter.Provider) + u + Encounter.ProviderName); {REV - V13}
1361	Alist.clear;
1362	case why of
1363	'I': begin
1364	ProbRec.status := 'I';
1365	{assume resolution date now with this option. user should do full edit otherwise}
1366	ProbRec.DateResStr := 'T';
1367	Probrec.DateModStr := 'T';
1368	AList.Assign(ProblemUpdate(ProbRec.AltFilerObject)) ;
1369	end;
1370	'V': begin
1371	if not IsActiveICDCode(ProbRec.Diagnosis.extern) then
1372	begin
1373	InfoBox(TX_INACTIVE_CODE, TC_INACTIVE_CODE, MB_ICONWARNING or MB_OK);
1374	exit;
1375	end;
1376	Probrec.condition := 'P';
1377	Probrec.DateModStr := 'T';
1378	AList.Assign(ProblemVerify(ProbRec.PIFN)) ;
1379	end;
1380	end;
1381
1382	if Alist.count<1 then {show error message}
1383	InfoBox('Unable to update record ', 'Information', MB_OK or MB_ICONINFORMATION)
1384	else if Alist[0]<'1' then
1385	InfoBox('Unable to update record: ' + #13#10 + ' ' + Alist[1] + ' (' + Probrec.PIFN + ')',
1386	'Information', MB_OK or MB_ICONINFORMATION)
1387	{show inactivated problem}
1388	else if (why='I') then
1389	begin
1390	if (PlUser.usViewAct='A') then
1391	FProblemsVisible[AllProblemsIndex] := 'N'
1392	else
1393	begin
1394	SetPiece(line, U, 2, 'I');
1395	FAllProblems[AllProblemsIndex] := line;
1396	end;
1397	end
1398	else if (why='V') then {show verified problem}
1399	begin
1400	sv := Piece(Line, U, 2);
1401	SetPiece(line, U, 2, Copy(sv,1,4)); //remove (u)
1402	FAllProblems[AllProblemsIndex] := line;
1403	end;
1404	finally
1405	with frmCover do
1406	for i := ComponentCount - 1 downto 0 do
1407	begin
1408	if Components[i] is TORListBox then
1409	begin
1410	case Components[i].Tag of
1411	10: ListActiveProblems((Components[i] as TORListBox).Items);
1412	end;
1413	end;
1414	end;
1415	alist.free;
1416	ProbRec.free;
1417	ProbRec := nil;
1418	end;
1419	end;
1420
1421	procedure TfrmProblems.RestoreProblem;
1422	const
1423	TC_RESTORE_EDIT = 'Unable to restore';
1424	TX_RESTORE_EDIT = 'This problem references an inactive ICD code,' + #13#10 +
1425	'and must be updated using the ''Change'' option' + #13#10 +
1426	'before it can be restored.' + #13#10 + #13#10 +
1427	'Would you like to edit this problem?';
1428	var
1429	Alist:TstringList;
1430	i: integer;
1431	AProbRec: TProbRec;
1432	ProblemIFN: string;
1433	begin
1434	Alist := TStringList.create;
1435	ProblemIFN := Piece(MString(wgProbData.ItemIndex), U, 1);
1436	AList.Assign(EditLoad(ProblemIFN, pProviderID, PLPt.ptVAMC)) ;
1437	AProbRec:=TProbRec.Create(Alist); {create a problem object}
1438	try
1439	if not IsActiveICDCode(AProbRec.Diagnosis.extern) then
1440	begin
1441	if InfoBox(TX_RESTORE_EDIT, TC_RESTORE_EDIT, MB_YESNO or MB_ICONWARNING) = IDYES then
1442	begin
1443	AProbRec.Status := 'A';
1444	EditProblem('C');
1445	end
1446	else
1447	Exit;
1448	end
1449	else
1450	begin
1451	Alist.Assign(ProblemReplace(ProblemIFN)) ;
1452	if Alist[0] <> '1' then
1453	InfoBox('Unable to restore the problem record: ' + #13#10 + ' (' + AProbrec.PIFN + ')',
1454	'Information', MB_OK or MB_ICONINFORMATION)
1455	else
1456	LoadPatientProblems(AList, 'R', False);
1457	GetRowCount;
1458	end;
1459	finally
1460	with frmCover do
1461	for i := ComponentCount - 1 downto 0 do
1462	begin
1463	if Components[i] is TORListBox then
1464	begin
1465	case Components[i].Tag of
1466	10: ListActiveProblems((Components[i] as TORListBox).Items);
1467	end;
1468	end;
1469	end;
1470	AList.free;
1471	AProbRec.Free;
1472	end;
1473	end;
1474
1475	procedure TfrmProblems.NoRowSelected;
1476	begin
1477	mnuActDetails.enabled := false;
1478	mnuActChange.enabled := false;
1479	mnuActVerify.enabled := false;
1480	mnuActInactivate.enabled := false;
1481	mnuActRestore.enabled := false;
1482	mnuActRemove.enabled := false;
1483	mnuActAnnotate.enabled := false;
1484	popChange.enabled := false;
1485	popVerify.enabled := false;
1486	popInactivate.enabled := false;
1487	popRestore.enabled := false;
1488	popRemove.enabled := false;
1489	popAnnotate.enabled := false;
1490	popViewDetails.enabled := False;
1491	end ;
1492
1493	procedure TfrmProblems.RowSelected;
1494	var
1495	AnyUnver, AnyAct: integer;
1496	i: integer;
1497	begin
1498	if wgProbData.SelCount > 1 then
1499	begin
1500	mnuActDetails.enabled := false;
1501	mnuActChange.enabled := false;
1502	mnuActRestore.enabled := false;
1503	mnuActRemove.enabled := false;
1504	mnuActAnnotate.enabled := false;
1505	popChange.enabled := false;
1506	popRestore.enabled := false;
1507	popRemove.enabled := false;
1508	popAnnotate.enabled := false;
1509	popViewDetails.enabled := false;
1510	AnyUnver := 0;
1511	AnyAct := 0;
1512	for i := 0 to wgProbData.Count - 1 do
1513	begin
1514	if wgProbData.Selected[i] and (Copy(Piece(MString(i), U, 2),5,3)='(u)') then
1515	AnyUnver := AnyUnVer + 1;
1516	if wgProbData.Selected[i] and (Copy(Piece(MString(i), U, 2),1,1) = 'A') then
1517	AnyAct := AnyAct + 1;
1518	end;
1519	mnuActVerify.enabled := PLUser.usVerifyTranscribed and
1520	PLUser.usPrimeUser and (AnyUnver > 0);
1521	popVerify.enabled := PLUser.usVerifyTranscribed and
1522	PLUser.usPrimeUser and (AnyUnver > 0);
1523	mnuActInactivate.enabled := (AnyAct > 0);
1524	popInactivate.enabled := (AnyAct > 0);
1525	end
1526	else
1527	begin
1528	mnuActDetails.enabled := true;
1529	mnuActChange.enabled := true;
1530	mnuActRestore.enabled := PLUser.usPrimeUser;
1531	mnuActRemove.enabled := PLUser.usPrimeUser;
1532	mnuActAnnotate.enabled := true;
1533	popChange.enabled := true;
1534	popRestore.enabled := PLUser.usPrimeUser;
1535	popRemove.enabled := PLUser.usPrimeUser;
1536	popAnnotate.enabled := true;
1537	popViewDetails.enabled := true ;
1538	mnuActVerify.enabled := PLUser.usVerifyTranscribed and
1539	PLUser.usPrimeUser and
1540	(Copy(Piece(MString(wgProbData.ItemIndex), U, 2),5,3)='(u)') ;
1541	popVerify.enabled := PLUser.usVerifyTranscribed and
1542	PLUser.usPrimeUser and
1543	(Copy(Piece(MString(wgProbData.ItemIndex), U, 2),5,3)='(u)') ;
1544	mnuActInactivate.enabled := Copy(Piece(MString(wgProbData.ItemIndex), U, 2),1,1) = 'A' ;
1545	popInactivate.enabled := Copy(Piece(MString(wgProbData.ItemIndex), U, 2),1,1) = 'A' ;
1546	end;
1547
1548	//Disable menu actions for REMOVED problems list display
1549	if PLUser.usViewAct = 'R' then
1550	begin
1551	mnuActAnnotate.Enabled := False;
1552	mnuActChange.Enabled := False;
1553	mnuActInactivate.Enabled := False;
1554	mnuActRemove.Enabled := False;
1555	mnuActVerify.Enabled := False;
1556	popAnnotate.Enabled := False;
1557	popChange.Enabled := False;
1558	popInactivate.Enabled := False;
1559	popRemove.Enabled := False;
1560	popVerify.Enabled := False;
1561	end;
1562	end ;
1563
1564	procedure TfrmProblems.bbCancelClick(Sender: TObject);
1565	begin
1566	inherited;
1567	//Hide Panels
1568	pnlButtons.Hide;
1569	pnlButtons.SendToBack;
1570	pnlProbCats.Hide;
1571	pnlProbCats.SendToBack;
1572
1573	//Show pnlView & Add Back to tab Order
1574	ShowPnlView;
1575	end;
1576
1577	procedure TfrmProblems.lstViewClick(Sender: TObject);
1578	begin
1579	inherited;
1580	case lstView.ItemIndex of
1581	0: tag := 700 ; {Active}
1582	1: tag := 800 ; {Inactive}
1583	2: tag := 900 ; {Both}
1584	3: tag := 950 ; {Removed}
1585	{ 4: tag := 975 ; {Filters...}
1586	end ;
1587	lstProbActsClick(Self) ;
1588	end;
1589
1590	function EncounterPresent: Boolean;
1591	{ make sure a location and provider are selected, returns false if not }
1592	begin
1593	Result := True;
1594	if (Encounter.Provider = 0) or (Encounter.Location = 0) then
1595	begin
1596	UpdateEncounter(NPF_ALL); {KCM}
1597	frmFrame.DisplayEncounterText;
1598	end;
1599	if (Encounter.Provider = 0) or (Encounter.Location = 0) then
1600	begin
1601	if not frmFrame.CCOWDrivedChange then
1602	InfoBox(TX_PROV_LOC, TC_PROV_LOC, MB_OK or MB_ICONWARNING); {!!!}
1603	Result := False;
1604	end;
1605	end;
1606
1607	procedure TfrmProblems.FormDestroy(Sender: TObject);
1608	begin
1609	ClearGrid;
1610	FItemData.Free;
1611	FAllProblems.Free;
1612	FProblemsVisible.Free;
1613	inherited;
1614	end;
1615
1616	procedure TfrmProblems.mnuViewSaveClick(Sender: TObject);
1617	begin
1618	inherited;
1619	if PLPt = nil then
1620	begin
1621	InfoBox(TX_INVALID_PATIENT, TC_NO_PATIENT, MB_OK or MB_ICONWARNING);
1622	Exit;
1623	end;
1624	if InfoBox('Replace current defaults?','Confirmation', MB_YESNO or MB_ICONQUESTION) = IDYES then
1625	begin
1626	with PLUser do
1627	begin
1628	usDefaultContext := FContextString;
1629	usDefaultView := Piece(FFilterString, '/', 1);
1630	end;
1631	SaveViewPreferences(FFilterString + U + FContextString);
1632	end;
1633	end;
1634
1635	procedure TfrmProblems.mnuViewRestoreDefaultClick(Sender: TObject);
1636	begin
1637	inherited;
1638	if PLPt = nil then
1639	begin
1640	InfoBox(TX_INVALID_PATIENT, TC_NO_PATIENT, MB_OK or MB_ICONWARNING);
1641	Exit;
1642	end;
1643	if PLFilters <> nil then
1644	begin
1645	PLFilters.Destroy;
1646	PLFilters := nil;
1647	end;
1648	if PLUser <> nil then
1649	begin
1650	PLUser.Destroy;
1651	PLUser := nil;
1652	end;
1653	ShowPnlView;
1654	LoadProblems ;
1655	end;
1656
1657	procedure TfrmProblems.mnuViewCommentsClick(Sender: TObject);
1658	var
1659	x, line, comments: string;
1660	i, j: integer;
1661	begin
1662	inherited;
1663	if PLPt = nil then
1664	begin
1665	InfoBox(TX_INVALID_PATIENT, TC_NO_PATIENT, MB_OK or MB_ICONWARNING);
1666	Exit;
1667	end;
1668	mnuViewComments.Checked := not mnuViewComments.Checked;
1669	SetPiece(FContextString, ';', 4, BOOLCHAR[mnuViewComments.Checked]);
1670	PLUser.usViewComments := BOOLCHAR[mnuViewComments.Checked];
1671	with FAllProblems do
1672	begin
1673	for i := 0 to Count - 1 do
1674	begin
1675	if Objects[i] = nil then continue;
1676	x := Piece(Piece(Strings[i], U, 3), #13, 1);
1677	if PLUser.usViewComments = '1' then
1678	begin
1679	comments := '';
1680	for j := 0 to TStringList(Objects[i]).Count - 1 do
1681	comments := comments + ' ' + TStringList(Objects[i]).Strings[j] + #13#10;
1682	//comments := comments + ' CMT: ' + TStringList(Items.Objects[i]).Strings[j] + #13#10;
1683	Line := Strings[i];
1684	SetPiece(Line, U, 3, x + #13#10 + comments);
1685	Strings[i] := Line;
1686	end
1687	else
1688	begin
1689	Line := Strings[i];
1690	SetPiece(Line, U, 3, x);
1691	Strings[i] := Line;
1692	end;
1693	end;
1694	end;
1695	RefreshList;
1696	end;
1697
1698	procedure TfrmProblems.RequestPrint;
1699	begin
1700	inherited;
1701	if PLPt = nil then
1702	begin
1703	InfoBox(TX_INVALID_PATIENT, TC_NO_PATIENT, MB_OK or MB_ICONWARNING);
1704	Exit;
1705	end;
1706	uReportType := '';
1707	PrintReports(IntToStr(RPT_PROBLIST), 'Problem List')
1708	end;
1709
1710	procedure TfrmProblems.SetFontSize( NewFontSize: integer);
1711	var
1712	OldParent: TWinControl;
1713	begin
1714	OldParent := nil;
1715	if Assigned(dlgProbs) then begin
1716	OldParent := dlgProbs.Parent;
1717	dlgProbs.Parent := nil;
1718	end;
1719	try
1720	{These labels are hidden in an ORAutoPanel, so have to be sized manually}
1721	lblProbCats.Height := ResizeHeight( Font, MainFont, lblProbCats.Height);
1722	lblProblems.Height := ResizeHeight( Font, MainFont, lblProblems.Height);
1723	inherited SetFontSize( NewFontSize);
1724	finally
1725	if Assigned(dlgProbs) then
1726	dlgProbs.Parent := OldParent;
1727	end;
1728	if Assigned(dlgProbs) then
1729	dlgProbs.SetFontSize( MainFontSize);
1730	end;
1731
1732	procedure TfrmProblems.RefreshList;
1733	var
1734	i: integer;
1735	begin
1736	RedrawSuspend(wgProbData.Handle);
1737	wgProbData.Clear;
1738	FItemData.Clear;
1739	for i := 0 to FAllProblems.Count-1 do
1740	if FProblemsVisible[i] = 'Y' then begin
1741	FItemData.Add(IntToStr(i));
1742	if Piece(FAllProblems[i], U, 1) <> '' then
1743	wgProbData.Items.Add(PlainText(FAllProblems[i]))
1744	else
1745	wgProbData.Items.Add(FAllProblems[i]);
1746	end;
1747	wgProbData.Invalidate;
1748	RedrawActivate(wgProbData.Handle);
1749	end;
1750
1751	procedure TfrmProblems.wgProbDataMeasureItem(Control: TWinControl;
1752	Index: Integer; var Height: Integer);
1753	var
1754	ARect: TRect;
1755	x: string;
1756	NewHeight: Integer;
1757	begin
1758	inherited;
1759	NewHeight := Height;
1760	with wgProbData do if Index < Items.Count then
1761	begin
1762	ARect := ItemRect(Index);
1763	ARect.Left := HeaderControl.Sections[0].Width + HeaderControl.Sections[1].Width + 2;
1764	ARect.Right := ARect.Left + HeaderControl.Sections[2].Width - 6;
1765	x := Piece(MString(Index), U, 3);
1766	NewHeight := WrappedTextHeightByFont( Canvas, Font, x, ARect);
1767	if NewHeight > 255 then NewHeight := 255; // windows appears to only look at 8 bits KCM
1768	if NewHeight < 13 then NewHeight := 13; // show at least one line KCM
1769	end; {if Index}
1770	Height := NewHeight;
1771	end;
1772
1773	procedure TfrmProblems.wgProbDataDrawItem(Control: TWinControl;
1774	Index: Integer; Rect: TRect; State: TOwnerDrawState);
1775	var
1776	i: integer;
1777	begin
1778	inherited;
1779	with wgProbData do if Index < Items.Count then
1780	begin
1781	ListGridDrawLines(wgProbData, HeaderControl, Index, State);
1782	for i := 0 to HeaderControl.Sections.Count -1 do
1783	ListGridDrawCell(wgProbData, HeaderControl, Index, i, Piece(MString(Index),U,i+1), i = 2);
1784	end; {if Index}
1785	end;
1786
1787	function TfrmProblems.PlainText(MString: string): string;
1788	var
1789	i: integer;
1790	begin
1791	result := '';
1792	with HeaderControl do
1793	for i := 0 to Sections.Count -1 do
1794	if Sections[i].MaxWidth > 0 then
1795	if Trim(Piece(MString, U, i+1)) <> '' then
1796	result := result + Sections[i].Text + ': ' + Piece(MString, U, i+1) + CRLF;
1797	end;
1798
1799	function TfrmProblems.MString(index: integer): string;
1800	begin
1801	if index = -1 then
1802	result := ''
1803	else
1804	result := FAllProblems[StrToInt(FItemData[index])];
1805	end;
1806
1807	procedure TfrmProblems.HeaderControlSectionResize(
1808	HeaderControl: THeaderControl; Section: THeaderSection);
1809	begin
1810	inherited;
1811	wgProbData.Invalidate;
1812	end;
1813
1814	{Tab Order tricks. Need to change
1815	lstView
1816
1817	bbNewProb
1818	bbOtherProb
1819	bbCancel
1820
1821	pnlProbDlg
1822	wgProbData
1823
1824	to
1825	lstView
1826
1827	pnlProbDlg
1828	wgProbData
1829
1830	bbNewProb
1831	bbOtherProb
1832	bbCancel
1833	}
1834
1835	procedure TFrmProblems.lstViewExit(Sender: TObject);
1836	begin
1837	inherited;
1838	if IncSecond(FMousing,1) < Now then
1839	begin
1840	if (Screen.ActiveControl = bbNewProb) or
1841	(Screen.ActiveControl = bbOtherProb) or
1842	(Screen.ActiveControl = bbCancel) then
1843	FindNextControl( bbCancel, True, True, False).SetFocus;
1844	end;
1845	FMousing := 0;
1846	end;
1847
1848	procedure TFrmProblems.pnlRightExit(Sender: TObject);
1849	begin
1850	inherited;
1851	if IncSecond(FMousing,1) < Now then
1852	begin
1853	if (Screen.ActiveControl = frmFrame.pnlPatient) then
1854	begin
1855	if lstView.Visible then
1856	FindNextControl( lstView, True, True, False).SetFocus
1857	else
1858	FindNextControl( edProbEnt, True, True, False).SetFocus
1859	end
1860	else
1861	if (Screen.ActiveControl = bbNewProb) or
1862	(Screen.ActiveControl = bbOtherProb) or
1863	(Screen.ActiveControl = bbCancel) then
1864	begin
1865	if bbNewProb.Visible then
1866	FindNextControl( bbNewProb, False, True, False).SetFocus
1867	else
1868	FindNextControl( bbOtherProb, False, True, False).SetFocus;
1869	end;
1870	end;
1871	FMousing := 0;
1872	end;
1873
1874	procedure TFrmProblems.bbNewProbExit(Sender: TObject);
1875	begin
1876	inherited;
1877	if IncSecond(FMousing,1) < Now then
1878	begin
1879	if (Screen.ActiveControl = pnlProbDlg) or
1880	(Screen.ActiveControl = wgProbData) then
1881	frmFrame.pnlPatient.SetFocus
1882	else
1883	if (Screen.ActiveControl = lstView) or
1884	(Screen.ActiveControl = lstCatPick) then
1885	FindNextControl( frmFrame.pnlPatient, False, True, False).SetFocus;
1886	end;
1887	FMousing := 0;
1888	end;
1889
1890	procedure TFrmProblems.frmFramePnlPatientExit(Sender: TObject);
1891	begin
1892	FOldFramePnlPatientExit(Sender);
1893	inherited;
1894	if IncSecond(FMousing,1) < Now then
1895	begin
1896	if (Screen.ActiveControl = pnlProbDlg) or
1897	(Screen.ActiveControl = wgProbData) then
1898	FindNextControl( pnlProbDlg, False, True, False).SetFocus;
1899	end;
1900	FMousing := 0;
1901	end;
1902
1903	procedure TFrmProblems.FormHide(Sender: TObject);
1904	begin
1905	inherited;
1906	frmFrame.pnlPatient.OnExit := FOldFramePnlPatientExit;
1907	end;
1908
1909	procedure TFrmProblems.FormShow(Sender: TObject);
1910	begin
1911	inherited;
1912	FOldFramePnlPatientExit := frmFrame.pnlPatient.OnExit;
1913	frmFrame.pnlPatient.OnExit := frmFramePnlPatientExit;
1914	end;
1915
1916	procedure TfrmProblems.FormMouseMove(Sender: TObject; Shift: TShiftState;
1917	X, Y: Integer);
1918	begin
1919	inherited;
1920	FMousing := Now;
1921	end;
1922
1923	procedure TfrmProblems.ShowPnlView;
1924	begin
1925	pnlView.BringToFront;
1926	pnlView.Show;
1927	lstView.TabStop := true;
1928	bbNewProb.TabStop := true;
1929	end;
1930
1931	end.
1932
1933

Note: See TracBrowser for help on using the repository browser.

Download in other formats: