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

Last change on this file since 730 was 456, checked in by Kevin Toppenberg, 16 years ago

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