Module

fAllgyFind

Path

C:\CPRS\CPRS30\fAllgyFind.pas

Last Modified

7/15/2014 3:26:36 PM

Units Used in Interface

Name Comments
fAutoSz -

Units Used in Implementation

Name Comments
fARTFreeTextMsg -
rODAllergy -

Classes

Name Comments
TfrmAllgyFind -

Procedures

Name Owner Declaration Scope Comments
AllergyLookup - procedure AllergyLookup(var Allergy: string; NKAEnabled: boolean); Interfaced -
BuildAgentTree TfrmAllgyFind procedure BuildAgentTree(AgentList: TStrings; const Parent: string; Node: TORTreeNode); Public/Published -
ckNoKnownAllergiesClick TfrmAllgyFind procedure ckNoKnownAllergiesClick(Sender: TObject); Public/Published -
cmdCancelClick TfrmAllgyFind procedure cmdCancelClick(Sender: TObject); Public/Published -
cmdOKClick TfrmAllgyFind procedure cmdOKClick(Sender: TObject); Public/Published -
cmdSearchClick TfrmAllgyFind procedure cmdSearchClick(Sender: TObject); Public/Published -
FormCreate TfrmAllgyFind procedure FormCreate(Sender: TObject); Public/Published -
tvAgentDblClick TfrmAllgyFind procedure tvAgentDblClick(Sender: TObject); Public/Published -
txtSearchChange TfrmAllgyFind procedure txtSearchChange(Sender: TObject); Public/Published -

Global Variables

Name Type Declaration Comments
ScreenReader Boolean ScreenReader: boolean; -
uFileCount Integer uFileCount: integer; -

Constants

Name Declaration Scope Comments
IMG_MATCHES_FOUND 1 Global -
IMG_NO_MATCHES 2 Global -
ST_FOUND 'Select from the matching entries on the list, or search again.' Global -
ST_NONE_FOUND 'No matching items were found.' Global -
ST_SEARCHING 'Searching for allergies...' Global -
TC_BULLETIN_ERROR 'Unable to Send Bulletin' Global -
TC_FREE_TEXT 'Causative Agent Not On File - No Matches for ' Global -
TX_3_CHAR 'Enter at least 3 characters for a search.' Global -
TX_BULLETIN 'Bulletin has been sent.' + CRLF + Global -
TX_BULLETIN_ERROR 'Free text entries are no longer allowed.' + #13#10 + Global -
TX_FREE_TEXT 'The agent you typed was not found in the database.' + CRLF + Global
TX_FREE_TEXT  = 'Would you like to request that this term be added to' + #13#10 +
                  'the list of available allergies?' + #13#10 + #13#10 +
                  '"YES" will send a bulletin to request addition of your' + #13#10 +
                  'entry to the ALLERGY file for future use, since '   + #13#10 +
                  'free-text entries for a patient are not allowed.' + #13#10 + #13#10 +
                  '"NO" will allow you to enter another search term.  Please' + #13#10 +
                  'check your spelling, try alternate spellings or a trade name,' + #13#10 +
                  'or contact your allergy coordinator for assistance.' + #13#10 + #13#10 +
                  '"CANCEL" will abort this entry process completely.';
 NEW TEXT SUBSTITUTED IN V26.50 - RV


Module Source

1     unit fAllgyFind;
2     
3     interface
4     
5     uses
6       Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
7       fAutoSz, StdCtrls, ORFn, ORCtrls, ComCtrls, ImgList, VA508AccessibilityManager,
8       VA508ImageListLabeler, ExtCtrls;
9     
10    type
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    
39    procedure AllergyLookup(var Allergy: string; NKAEnabled: boolean);
40    
41    implementation
42    
43    {$R *.DFM}
44    
45    uses rODAllergy, fARTFreeTextMsg, VA508AccessibilityRouter;
46    
47    const
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.';
88    var
89      uFileCount: integer;
90      ScreenReader: boolean;
91    
92    procedure AllergyLookup(var Allergy: string; NKAEnabled: boolean);
93    var
94      frmAllgyFind: TfrmAllgyFind;
95    begin
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;
125   end;
126   
127   procedure TfrmAllgyFind.FormCreate(Sender: TObject);
128   begin
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;
140   end;
141   
142   procedure TfrmAllgyFind.txtSearchChange(Sender: TObject);
143   begin
144     inherited;
145     cmdSearch.Default := True;
146     cmdOK.Default := False;
147     cmdOK.Enabled := False;
148   end;
149   
150   procedure TfrmAllgyFind.cmdSearchClick(Sender: TObject);
151   var
152     AList: TStringlist;
153     tmpNode1: TORTreeNode;
154     i: integer;
155   begin
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;
248   end;
249   
250   procedure TfrmAllgyFind.cmdOKClick(Sender: TObject);
251   var
252     x, AGlobal: string;
253     tmpList: TStringList;
254     OKtoContinue: boolean ;
255   begin
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;
327   end;
328   
329   procedure TfrmAllgyFind.cmdCancelClick(Sender: TObject);
330   begin
331     inherited;
332     FAllergy := '';
333     Close;
334   end;
335   
336   procedure TfrmAllgyFind.ckNoKnownAllergiesClick(Sender: TObject);
337   begin
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;
354   end;
355   
356   procedure TfrmAllgyFind.BuildAgentTree(AgentList: TStrings; const Parent: string; Node: TORTreeNode);
357   var
358     MyID, MyParent, Name: string;
359     i: Integer;
360     ChildNode, tmpNode: TORTreeNode;
361     HasChildren, Found: Boolean;
362   begin
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;
398   end;
399    
400   procedure TfrmAllgyFind.tvAgentDblClick(Sender: TObject);
401   begin
402     inherited;
403     cmdOKClick(Self);
404   end;
405   
406   end.

Module Calls (2 levels)


fAllgyFind
 ├fAutoSz
 │ └fBase508Form
 ├rODAllergy
 │ ├rCore
 │ ├uCore
 │ └rMisc
 └fARTFreeTextMsg
   └fAutoSz...

Module Called-By (2 levels)


   fAllgyFind
  fARTAllgy┤ 
  uOrders┤ │ 
   fCover┤ │ 
fAllgyBox┘ │ 
   fODAllgy┘