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

Last change on this file since 1495 was 830, checked in by Kevin Toppenberg, 14 years ago

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