source: cprs/trunk/CPRS-Chart/fAllgyFind.pas@ 1721

Last change on this file since 1721 was 1679, checked in by healthsevak, 10 years ago

Updating the working copy to CPRS version 28
File size: 14.9 KB
Line 
1unit fAllgyFind;
2
3interface
4
5uses
6 Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
7 fAutoSz, StdCtrls, ORFn, ORCtrls, ComCtrls, ImgList, VA508AccessibilityManager,
8 VA508ImageListLabeler, ExtCtrls;
9
10type
11 TfrmAllgyFind = class(TfrmAutoSz)
12 txtSearch: TCaptionEdit;
13 cmdSearch: TButton;
14 cmdOK: TButton;
15 cmdCancel: TButton;
16 lblSearch: TLabel;
17 lblSelect: TLabel;
18 stsFound: TStatusBar;
19 ckNoKnownAllergies: TCheckBox;
20 tvAgent: TORTreeView;
21 imTree: TImageList;
22 lblDetail: TLabel;
23 lblSearchCaption: TLabel;
24 imgLblAllgyFindTree: TVA508ImageListLabeler;
25 NoAllergylbl508: TVA508StaticText;
26 procedure cmdSearchClick(Sender: TObject);
27 procedure cmdCancelClick(Sender: TObject);
28 procedure FormCreate(Sender: TObject);
29 procedure cmdOKClick(Sender: TObject);
30 procedure txtSearchChange(Sender: TObject);
31 procedure BuildAgentTree(AgentList: TStrings; const Parent: string; Node: TORTreeNode);
32 procedure ckNoKnownAllergiesClick(Sender: TObject);
33 procedure tvAgentDblClick(Sender: TObject);
34 private
35 FAllergy: string ;
36 FExpanded : boolean;
37 end;
38
39procedure AllergyLookup(var Allergy: string; NKAEnabled: boolean);
40
41implementation
42
43{$R *.DFM}
44
45uses rODAllergy, fARTFreeTextMsg, VA508AccessibilityRouter;
46
47const
48 IMG_MATCHES_FOUND = 1;
49 IMG_NO_MATCHES = 2;
50
51 TX_3_CHAR = 'Enter at least 3 characters for a search.';
52 ST_SEARCHING = 'Searching for allergies...';
53 ST_FOUND = 'Select from the matching entries on the list, or search again.';
54 ST_NONE_FOUND = 'No matching items were found.';
55 TC_FREE_TEXT = 'Causative Agent Not On File - No Matches for ';
56(* TX_FREE_TEXT = 'Would you like to request that this term be added to' + #13#10 +
57 'the list of available allergies?' + #13#10 + #13#10 +
58 '"YES" will send a bulletin to request addition of your' + #13#10 +
59 'entry to the ALLERGY file for future use, since ' + #13#10 +
60 'free-text entries for a patient are not allowed.' + #13#10 + #13#10 +
61 '"NO" will allow you to enter another search term. Please' + #13#10 +
62 'check your spelling, try alternate spellings or a trade name,' + #13#10 +
63 'or contact your allergy coordinator for assistance.' + #13#10 + #13#10 +
64 '"CANCEL" will abort this entry process completely.';*)
65 // NEW TEXT SUBSTITUTED IN V26.50 - RV
66 TX_FREE_TEXT = 'The agent you typed was not found in the database.' + CRLF +
67 'Consider the common causes of search failure:' + CRLF +
68 ' Misspellings' + CRLF +
69 ' Typing more than one agent in a single entry ' + CRLF +
70 ' Typing "No known allergies"' + CRLF +
71 CRLF +
72 'Select "NO" to attempt the search again. Carefully check your spelling,'+ CRLF +
73 'try an alternate spelling, a trade name, a generic name or just entering' + CRLF +
74 'the first few characters (minimum of 3). Enter only one allergy at a time.' + CRLF +
75 'Use the "No Known Allergies" check box to mark a patient as NKA.' + CRLF +
76 CRLF +
77 'Select "YES" to send a bulletin to the allergy coordinator to request assistance.' + CRLF +
78 'Only do this if you''ve tried alternate methods of finding the causative agent' + CRLF +
79 'and have been unsuccessful.' + CRLF +
80 CRLF +
81 'Select "CANCEL" to abort this entry process.';
82
83 TX_BULLETIN = 'Bulletin has been sent.' + CRLF +
84 'NOTE: This reactant was NOT added for this patient.';
85 TC_BULLETIN_ERROR = 'Unable to Send Bulletin';
86 TX_BULLETIN_ERROR = 'Free text entries are no longer allowed.' + #13#10 +
87 'Please contact your allergy coordinator if you need assistance.';
88var
89 uFileCount: integer;
90 ScreenReader: boolean;
91
92procedure AllergyLookup(var Allergy: string; NKAEnabled: boolean);
93var
94 frmAllgyFind: TfrmAllgyFind;
95begin
96 frmAllgyFind := TfrmAllgyFind.Create(Application);
97 try
98 ResizeFormToFont(TForm(frmAllgyFind));
99 //TDP - CQ#19731 Need adjust 508StaticText label slightly when font 12 or larger
100 case frmAllgyFind.Font.Size of
101 18: frmAllgyFind.NoAllergylbl508.Left := frmAllgyFind.NoAllergylbl508.Left - 10;
102 14: frmAllgyFind.NoAllergylbl508.Left := frmAllgyFind.NoAllergylbl508.Left - 6;
103 12: frmAllgyFind.NoAllergylbl508.Left := frmAllgyFind.NoAllergylbl508.Left - 3;
104 end;
105 frmAllgyFind.ckNoKnownAllergies.Enabled := NKAEnabled;
106 //TDP - CQ#19731 make sure NoAllergylbl508 is enabled and visible if
107 // ckNoKnownAllergies is disabled
108 if (ScreenReaderSystemActive) and (frmAllgyFind.ckNoKnownAllergies.Enabled = False) then
109 begin
110 frmAllgyFind.NoAllergylbl508.Enabled := True;
111 frmAllgyFind.NoAllergylbl508.Visible := True;
112 end;
113 //TDP - CQ#19731 make sure NoAllergylbl508 is not enabled or visible if
114 // ckNoKnownAllergies is enabled
115 if frmAllgyFind.ckNoKnownAllergies.Enabled = True then
116 begin
117 frmAllgyFind.NoAllergylbl508.Enabled := False;
118 frmAllgyFind.NoAllergylbl508.Visible := False;
119 end;
120 frmAllgyFind.ShowModal;
121 Allergy := frmAllgyFind.FAllergy;
122 finally
123 frmAllgyFind.Release;
124 end;
125end;
126
127procedure TfrmAllgyFind.FormCreate(Sender: TObject);
128begin
129 inherited;
130 FAllergy := '';
131 cmdOK.Enabled := False;
132 //TDP - CQ#19731 Allow tab to empty search results (tvAgent) when JAWS running
133 // and provide 508 hint
134 if ScreenReaderSystemActive then
135 begin
136 tvAgent.TabStop := True;
137 amgrMain.AccessText[tvAgent] := 'No Search Items to Display';
138 ScreenReader := True;
139 end;
140end;
141
142procedure TfrmAllgyFind.txtSearchChange(Sender: TObject);
143begin
144 inherited;
145 cmdSearch.Default := True;
146 cmdOK.Default := False;
147 cmdOK.Enabled := False;
148end;
149
150procedure TfrmAllgyFind.cmdSearchClick(Sender: TObject);
151var
152 AList: TStringlist;
153 tmpNode1: TORTreeNode;
154 i: integer;
155begin
156 inherited;
157 if Length(txtSearch.Text) < 3 then
158 begin
159 InfoBox(TX_3_CHAR, 'Information', MB_OK or MB_ICONINFORMATION);
160 Exit;
161 end;
162 StatusText(ST_SEARCHING);
163 FExpanded := False;
164 AList := TStringList.Create;
165 try
166 if tvAgent.Items <> nil then tvAgent.Items.Clear;
167 FastAssign(SearchForAllergies(UpperCase(txtSearch.Text)), AList);
168 uFileCount := 0;
169 for i := 0 to AList.Count - 1 do
170 if Piece(AList[i], U, 5) = 'TOP' then uFileCount := uFileCount + 1;
171 if AList.Count = uFileCount then
172 begin
173 lblSelect.Visible := False;
174 txtSearch.SetFocus;
175 txtSearch.SelectAll;
176 cmdOK.Default := False;
177 cmdSearch.Default := True;
178 stsFound.SimpleText := ST_NONE_FOUND;
179
180 //TDP - CQ#19731 Provide 508 hint for empty search results (tvAgent) when JAWS active.
181 if ScreenReader then amgrMain.AccessText[tvAgent] := 'No Search Items to Display'
182 //TDP - CQ#19731 Stop tab to empty search results (tvAgent) when JAWS not active.
183 else tvAgent.TabStop := False;
184
185 cmdOKClick(Self);
186 end else
187 begin
188 //if tvAgent.Items <> nil then tvAgent.Items.Clear;
189 AList.Insert(0, 'TOP^' + IntToStr(Alist.Count - uFileCount) + ' matches found.^^^0^+');
190 AList.Add('FREETEXT^Add new free-text allergy^^^TOP^+');
191 AList.Add('^' + UpperCase(txtSearch.Text) + '^^^FREETEXT^');
192 BuildAgentTree(AList, '0', nil);
193 tmpNode1 := TORTreeNode(tvAgent.Items.getFirstNode);
194 tmpNode1.Expand(False);
195 tmpNode1 := TORTreeNode(tmpNode1.GetFirstChild);
196 if tmpNode1.HasChildren then
197 begin
198 tmpNode1.Text := tmpNode1.Text + ' (' + IntToStr(tmpNode1.Count) + ')';
199 tmpNode1.Bold := True;
200 tmpNode1.StateIndex := IMG_MATCHES_FOUND;
201 tmpNode1.Expand(True);
202 FExpanded := True;
203 end
204 else
205 begin
206 tmpNode1.Text := tmpNode1.Text + ' (no matches)';
207 tmpNode1.StateIndex := IMG_NO_MATCHES;
208 end;
209 while tmpNode1 <> nil do
210 begin
211 tmpNode1 := TORTreeNode(tmpNode1.GetNextSibling);
212 if tmpNode1 <> nil then
213 if tmpNode1.HasChildren then
214 begin
215 tmpNode1.Text := tmpNode1.Text + ' (' + IntToStr(tmpNode1.Count) + ')';
216 tmpNode1.StateIndex := IMG_MATCHES_FOUND;
217 if not FExpanded then
218 begin
219 tmpNode1.Bold := True;
220 tmpNode1.Expand(True);
221 FExpanded := True;
222 end;
223 end
224 else
225 begin
226 tmpNode1.StateIndex := IMG_NO_MATCHES;
227 tmpNode1.Text := tmpNode1.Text + ' (no matches)';
228 end;
229 end;
230 lblSelect.Visible := True;
231
232 //TDP - CQ#19731 Clear 508 hint when JAWS active.
233 if ScreenReader then amgrMain.AccessText[tvAgent] := ''
234 //TDP - CQ#19731 Allow tab to search results (tvAgent) when JAWS not active.
235 else tvAgent.TabStop := True;
236
237 tvAgent.SetFocus;
238 cmdSearch.Default := False;
239 cmdOK.Enabled := True;
240 stsFound.SimpleText := ST_FOUND;
241 end;
242 finally
243 AList.Free;
244 StatusText('');
245 if stsFound.SimpleText = '' then stsFound.TabStop := False
246 else if ScreenReaderSystemActive then stsFound.TabStop := True;
247 end;
248end;
249
250procedure TfrmAllgyFind.cmdOKClick(Sender: TObject);
251var
252 x, AGlobal: string;
253 tmpList: TStringList;
254 OKtoContinue: boolean ;
255begin
256 inherited;
257 if ckNoKnownAllergies.Checked then
258 begin
259 FAllergy := '-1^No Known Allergy^';
260 Close;
261 end
262 else if (txtSearch.Text = '') and ((tvAgent.Selected = nil) or (tvAgent.Items.Count = uFileCount)) then
263 {bail out - no search term present, and (no items currently in tree or none selected)}
264 begin
265 FAllergy := '';
266 Exit ;
267 end
268 else if ((tvAgent.Selected = nil) or
269 (tvAgent.Items.Count = uFileCount) or
270 (Piece(TORTreeNode(tvAgent.Selected).StringData, U, 5) = 'FREETEXT')) then
271 {entry of free text agent - retry, send bulletin, or abort entry}
272 begin
273 FAllergy := '';
274 case InfoBox(TX_FREE_TEXT, TC_FREE_TEXT + UpperCase(txtSearch.Text), MB_YESNOCANCEL or MB_DEFBUTTON2 or MB_ICONQUESTION)of
275 ID_YES : // send bulletin and abort free-text entry
276 begin
277 tmpList := TStringList.Create;
278 try
279 OKtoContinue := False;
280 GetFreeTextARTComment(tmpList, OKtoContinue);
281 if not OKtoContinue then
282 begin
283 stsFound.SimpleText := '';
284 txtSearch.SetFocus;
285 Exit;
286 end;
287 x := SendARTBulletin(UpperCase(txtSearch.Text), tmpList);
288 if Piece(x, U, 1) = '-1' then
289 InfoBox(TX_BULLETIN_ERROR, TC_BULLETIN_ERROR, MB_OK or MB_ICONWARNING)
290 else if Piece(x, U, 1) = '1' then
291 InfoBox(TX_BULLETIN, 'Information', MB_OK or MB_ICONINFORMATION)
292 else
293 InfoBox(Piece(x, U, 2), TC_BULLETIN_ERROR, MB_OK or MB_ICONWARNING);
294 finally
295 tmpList.Free;
296 end;
297 Close;
298 end;
299 ID_NO : // clear status message, and allow repeat search
300 begin
301 stsFound.SimpleText := '';
302 txtSearch.SetFocus;
303 Exit;
304 end;
305 ID_CANCEL: // abort entry and return to order menu or whatever
306 Close;
307 end;
308 end
309 else if Piece(TORTreeNode(tvAgent.Selected).StringData, U, 6) = '+' then
310 {bail out - tree grouper selected}
311 begin
312 FAllergy := '';
313 Exit;
314 end
315 else
316 {matching item selected}
317 begin
318 FAllergy := TORTreeNode(tvAgent.Selected).StringData;
319 x := Piece(FAllergy, U, 2);
320 AGlobal := Piece(FAllergy, U, 3);
321 if ((Pos('GMRD', AGlobal) > 0) or (Pos('PSDRUG', AGlobal) > 0)) and (Pos('<', x) > 0) then
322 //x := Trim(Piece(x, '<', 1));
323 x := Copy(x, 1, Length(Piece(x, '<', 1)) - 1);
324 SetPiece(FAllergy, U, 2, x);
325 Close;
326 end;
327end;
328
329procedure TfrmAllgyFind.cmdCancelClick(Sender: TObject);
330begin
331 inherited;
332 FAllergy := '';
333 Close;
334end;
335
336procedure TfrmAllgyFind.ckNoKnownAllergiesClick(Sender: TObject);
337begin
338 inherited;
339 with ckNoKnownAllergies do
340 begin
341 txtSearch.Enabled := not Checked;
342 cmdSearch.Enabled := not Checked;
343 lblSearch.Enabled := not Checked;
344 lblSelect.Enabled := not Checked;
345 tvAgent.Enabled := not Checked;
346
347 // CQ #15770 - Allow OK button again if unchecked and items exist - JCS
348 //cmdOK.Enabled := Checked;
349 if Checked then
350 cmdOK.Enabled := True
351 else
352 cmdOK.Enabled := (tvAgent.Items.Count > 0);
353 end;
354end;
355
356procedure TfrmAllgyFind.BuildAgentTree(AgentList: TStrings; const Parent: string; Node: TORTreeNode);
357var
358 MyID, MyParent, Name: string;
359 i: Integer;
360 ChildNode, tmpNode: TORTreeNode;
361 HasChildren, Found: Boolean;
362begin
363 tvAgent.Items.BeginUpdate;
364 with AgentList do for i := 0 to Count - 1 do
365 begin
366 Found := False;
367 MyParent := Piece(Strings[i], U, 5);
368 if (MyParent = Parent) then
369 begin
370 MyID := Piece(Strings[i], U, 1);
371 Name := Piece(Strings[i], U, 2);
372 HasChildren := Piece(Strings[i], U, 6) = '+';
373 if Node <> nil then
374 begin
375 if Node.HasChildren then
376 begin
377 tmpNode := TORTreeNode(Node.GetFirstChild);
378 while tmpNode <> nil do
379 begin
380 if tmpNode.Text = Piece(Strings[i], U, 2) then Found := True;
381 tmpNode := TORTreeNode(Node.GetNextChild(tmpNode));
382 end;
383 end
384 else
385 Node.StateIndex := 0;
386 end;
387 if Found then
388 Continue
389 else
390 begin
391 ChildNode := TORTreeNode(tvAgent.Items.AddChild(Node, Name));
392 ChildNode.StringData := AgentList[i];
393 if HasChildren then BuildAgentTree(AgentList, MyID, ChildNode);
394 end;
395 end;
396 end;
397 tvAgent.Items.EndUpdate;
398end;
399
400procedure TfrmAllgyFind.tvAgentDblClick(Sender: TObject);
401begin
402 inherited;
403 cmdOKClick(Self);
404end;
405
406end.
Note: See TracBrowser for help on using the repository browser.