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