Module

fODProc

Path

C:\CPRS\CPRS30\Consults\fODProc.pas

Last Modified

7/15/2014 3:26:34 PM

Units Used in Interface

Name Comments
fODBase -
uConst -

Units Used in Implementation

Name Comments
fConsults -
fFrame -
fPCELex -
fPreReq -
rConsults -
rCore -
rODBase -
rPCE -
uConsults -
uCore -
uODBase -
uTemplates -
uVA508CPRSCompatibility -

Classes

Name Comments
TfrmODProc -

Procedures

Name Owner Declaration Scope Comments
cboProcNeedData TfrmODProc procedure cboProcNeedData(Sender: TObject; const StartFrom: String; Direction, InsertAt: Integer); Public/Published -
cboProcSelect TfrmODProc procedure cboProcSelect(Sender: TObject); Public/Published -
cboServiceChange TfrmODProc procedure cboServiceChange(Sender: TObject); Public/Published -
cmdLexSearchClick TfrmODProc procedure cmdLexSearchClick(Sender: TObject); Public/Published -
ControlChange TfrmODProc procedure ControlChange(Sender: TObject); Public/Published -
DisableReason - procedure DisableReason; Local -
DoSetFontSize TfrmODProc procedure DoSetFontSize( FontSize: integer); Private -
EnableReason - procedure EnableReason; Local -
FormClose TfrmODProc procedure FormClose(Sender: TObject; var Action: TCloseAction); Public/Published -
FormCreate TfrmODProc procedure FormCreate(Sender: TObject); Public/Published ********************* TfrmODProc Methods ****************
FormResize TfrmODProc procedure FormResize(Sender: TObject); Public/Published -
FormShow TfrmODProc procedure FormShow(Sender: TObject); Public/Published -
GetProvDxandValidateCode TfrmODProc procedure GetProvDxandValidateCode(AResponses: TResponses); Private -
InitDialog TfrmODProc procedure InitDialog; override; Protected -
memReasonExit TfrmODProc procedure memReasonExit(Sender: TObject); Public/Published -
memReasonKeyDown TfrmODProc procedure memReasonKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); Public/Published -
memReasonKeyPress TfrmODProc procedure memReasonKeyPress(Sender: TObject; var Key: Char); Public/Published -
memReasonKeyUp TfrmODProc procedure memReasonKeyUp(Sender: TObject; var Key: Word; Shift: TShiftState); Public/Published -
mnuPopProvDxDeleteClick TfrmODProc procedure mnuPopProvDxDeleteClick(Sender: TObject); Public/Published -
popReasonCopyClick TfrmODProc procedure popReasonCopyClick(Sender: TObject); Public/Published -
popReasonCutClick TfrmODProc procedure popReasonCutClick(Sender: TObject); Public/Published -
popReasonPasteClick TfrmODProc procedure popReasonPasteClick(Sender: TObject); Public/Published -
popReasonPopup TfrmODProc procedure popReasonPopup(Sender: TObject); Public/Published -
popReasonReformatClick TfrmODProc procedure popReasonReformatClick(Sender: TObject); Public/Published -
radInpatientClick TfrmODProc procedure radInpatientClick(Sender: TObject); Public/Published -
radOutpatientClick TfrmODProc procedure radOutpatientClick(Sender: TObject); Public/Published -
ReadServerVariables TfrmODProc procedure ReadServerVariables; Private -
SetError - procedure SetError(const x: string); Local -
SetFontSize TfrmODProc procedure SetFontSize( FontSize: integer); override; Public -
SetProvDiagPromptingMode TfrmODProc procedure SetProvDiagPromptingMode; Private -
setup508Label TfrmODProc procedure setup508Label(text: string; lbl: TVA508StaticText; ctrl: TControl); Private -
SetUpCombatVet TfrmODProc procedure SetUpCombatVet; Private -
SetupDialog TfrmODProc procedure SetupDialog(OrderAction: Integer; const ID: string); override; Public -
SetupReasonForRequest TfrmODProc procedure SetupReasonForRequest(OrderAction: integer); Private -
txtAttnNeedData TfrmODProc procedure txtAttnNeedData(Sender: TObject; const StartFrom: String; Direction, InsertAt: Integer); Public/Published -
txtProvDiagChange TfrmODProc procedure txtProvDiagChange(Sender: TObject); Public/Published -
updateService TfrmODProc procedure updateService; Private -
Validate TfrmODProc procedure Validate(var AnErrMsg: string); override; Protected -

Functions

Name Owner Declaration Scope Comments
CanFreeProcDialog - function CanFreeProcDialog(dialog : TfrmODBase) : boolean; Interfaced ********* Static Unit Methods ************
DefaultReasonForRequest TfrmODProc function DefaultReasonForRequest(Service: string; Resolve: Boolean): TStrings; Protected -
ShowPrerequisites TfrmODProc function ShowPrerequisites: boolean; Private -

Global Variables

Name Type Declaration Comments
GMRCREAF UnicodeString GMRCREAF: string; -
OkToFreeProcDialog Boolean OkToFreeProcDialog: boolean; -
ProvDx ProvDx: TProvisionalDiagnosis; -

Constants

Name Declaration Scope Comments
TC_INACTIVE_CODE 'Inactive ICD Code' Global -
TX_BAD_DATES 'Latest appropriate date must be equal to or later than earliest date.' Global -
TX_INACTIVE_CODE_OPTIONAL 'If another code is not selected, no code will be saved.' Global -
TX_INACTIVE_CODE_REQD 'Another code must be selected before the order can be saved.' Global -
TX_INACTIVE_CODE1 'The provisional diagnosis code is not active as of today''s date.' + #13#10 Global -
TX_NO_DIAG 'A provisional diagnosis must be entered for consults to this service.' Global -
TX_NO_PLACE 'A place of consultation must be specified' Global -
TX_NO_PROC 'A procedure must be specified.' Global -
TX_NO_REASON 'A reason for this procedure must be entered.' Global -
TX_NO_SERVICE 'A service must be selected to perform this procedure.' Global -
TX_NO_URGENCY 'An urgency must be specified.' Global -
TX_PAST_DATE 'Earliest appropriate date must be today or later.' Global -
TX_SELECT_DIAG 'You must use the "Lexicon" button to select a diagnosis for consults to this service.' Global -


Module Source

1     unit fODProc;
2     
3     interface
4     
5     uses
6       Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
7       fODBase, StdCtrls, ORCtrls, ExtCtrls, ComCtrls, ORfn, uConst, Buttons,
8       Menus, ORDtTm, VA508AccessibilityManager;
9     
10    type
11      TfrmODProc = class(TfrmODBase)
12        pnlMain: TPanel;
13        pnlCombatVet: TPanel;
14        lblProc: TLabel;
15        lblService: TOROffsetLabel;
16        lblReason: TLabel;
17        lblUrgency: TStaticText;
18        lblPlace: TStaticText;
19        lblAttn: TStaticText;
20        lblProvDiag: TStaticText;
21        pnlReason: TPanel;
22        memReason: TCaptionRichEdit;
23        cboUrgency: TORComboBox;
24        cboPlace: TORComboBox;
25        txtAttn: TORComboBox;
26        cboProc: TORComboBox;
27        cboCategory: TORComboBox;
28        cboService: TORComboBox;
29        cmdLexSearch: TButton;
30        gbInptOpt: TGroupBox;
31        radInpatient: TRadioButton;
32        radOutpatient: TRadioButton;
33        txtProvDiag: TCaptionEdit;
34        lblEarliest: TStaticText;
35        calEarliest: TORDateBox;
36        lblLatest: TStaticText;
37        calLatest: TORDateBox;
38        mnuPopProvDx: TPopupMenu;
39        mnuPopProvDxDelete: TMenuItem;
40        popReason: TPopupMenu;
41        popReasonCut: TMenuItem;
42        popReasonCopy: TMenuItem;
43        popReasonPaste: TMenuItem;
44        popReasonPaste2: TMenuItem;
45        popReasonReformat: TMenuItem;
46        txtCombatVet: TVA508StaticText;
47        servicelbl508: TVA508StaticText;
48        procedure FormCreate(Sender: TObject);
49        procedure txtAttnNeedData(Sender: TObject; const StartFrom: String;
50          Direction, InsertAt: Integer);
51        procedure cboProcNeedData(Sender: TObject; const StartFrom: String;
52          Direction, InsertAt: Integer);
53        procedure radInpatientClick(Sender: TObject);
54        procedure radOutpatientClick(Sender: TObject);
55        procedure ControlChange(Sender: TObject);
56        procedure cboProcSelect(Sender: TObject);
57        procedure memReasonExit(Sender: TObject);
58        procedure cmdLexSearchClick(Sender: TObject);
59        procedure cboServiceChange(Sender: TObject);
60        procedure mnuPopProvDxDeleteClick(Sender: TObject);
61        procedure txtProvDiagChange(Sender: TObject);
62        procedure popReasonCutClick(Sender: TObject);
63        procedure popReasonCopyClick(Sender: TObject);
64        procedure popReasonPasteClick(Sender: TObject);
65        procedure popReasonPopup(Sender: TObject);
66        procedure popReasonReformatClick(Sender: TObject);
67        procedure memReasonKeyUp(Sender: TObject; var Key: Word;
68          Shift: TShiftState);
69        procedure memReasonKeyDown(Sender: TObject; var Key: Word;
70          Shift: TShiftState);
71        procedure memReasonKeyPress(Sender: TObject; var Key: Char);
72        procedure FormResize(Sender: TObject);
73        procedure FormClose(Sender: TObject; var Action: TCloseAction);
74        procedure FormShow(Sender: TObject);
75      private
76        FLastProcID: string;
77        FEditCtrl: TCustomEdit;
78        FNavigatingTab: boolean;
79        procedure ReadServerVariables;
80        procedure SetProvDiagPromptingMode;
81        procedure SetupReasonForRequest(OrderAction: integer);
82        procedure GetProvDxandValidateCode(AResponses: TResponses);
83        function ShowPrerequisites: boolean;
84        procedure DoSetFontSize( FontSize: integer);
85        procedure SetUpCombatVet;
86        procedure updateService;
87        procedure setup508Label(text: string; lbl: TVA508StaticText; ctrl: TControl);
88      protected
89        procedure InitDialog; override;
90        procedure Validate(var AnErrMsg: string); override;
91        function  DefaultReasonForRequest(Service: string; Resolve: Boolean): TStrings;
92      public
93        procedure SetupDialog(OrderAction: Integer; const ID: string); override;
94        procedure SetFontSize( FontSize: integer); override;
95      end;
96    
97    
98    function CanFreeProcDialog(dialog : TfrmODBase) : boolean;
99    
100   implementation
101   
102   {$R *.DFM}
103   
104   uses
105       rODBase, rConsults, uCore, uConsults, rCore, fConsults, fPCELex, rPCE, ORClasses,
106       clipbrd, fPreReq, uTemplates, fFrame, uODBase, VA508AccessibilityRouter,
107       uVA508CPRSCompatibility;
108   
109   
110   var
111     ProvDx:  TProvisionalDiagnosis;
112     GMRCREAF: string;
113     OkToFreeProcDialog: boolean;
114   
115   const
116     TX_NO_PROC         = 'A procedure must be specified.'    ;
117     TX_NO_REASON       = 'A reason for this procedure must be entered.'  ;
118     TX_NO_SERVICE      = 'A service must be selected to perform this procedure.';
119     TX_NO_URGENCY      = 'An urgency must be specified.';
120     TX_NO_PLACE        = 'A place of consultation must be specified';
121     TX_NO_DIAG         = 'A provisional diagnosis must be entered for consults to this service.';
122     TX_SELECT_DIAG     = 'You must use the "Lexicon" button to select a diagnosis for consults to this service.';
123     TC_INACTIVE_CODE   = 'Inactive ICD Code';
124     TX_INACTIVE_CODE1  = 'The provisional diagnosis code is not active as of today''s date.' + #13#10;
125     TX_INACTIVE_CODE_REQD     = 'Another code must be selected before the order can be saved.';
126     TX_INACTIVE_CODE_OPTIONAL = 'If another code is not selected, no code will be saved.';
127     TX_PAST_DATE       = 'Earliest appropriate date must be today or later.';
128     TX_BAD_DATES       = 'Latest appropriate date must be equal to or later than earliest date.';
129   
130   { ********* Static Unit Methods ************ }
131   
132   function CanFreeProcDialog(dialog : TfrmODBase) : boolean;
133   begin
134     Result := true;
135     if (dialog is TfrmODProc) then
136       Result := OkToFreeProcDialog;
137   end;
138   
139   { ********************* TfrmODProc Methods **************** }
140   
141   procedure TfrmODProc.FormCreate(Sender: TObject);
142   begin
143     frmFrame.pnlVisit.Enabled := false;
144     AutoSizeDisabled := True;
145     inherited;
146     OkToFreeProcDialog := False;
147     DoSetFontSize(MainFontSize);
148     AllowQuickOrder := True;
149     FillChar(ProvDx, SizeOf(ProvDx), 0);
150     FillerID := 'GMRC';                     // does 'on Display' order check **KCM**
151     StatusText('Loading Dialog Definition');
152     Responses.Dialog := 'GMRCOR REQUEST';   // loads formatting info
153     StatusText('Loading Default Values');
154     CtrlInits.LoadDefaults(ODForProcedures);  // ODForProcedures returns TStrings with defaults
155     StatusText('Initializing Long List');
156     ReadServerVariables;
157     cboProc.InitLongList('') ;
158     txtAttn.InitLongList('') ;
159     PreserveControl(calEarliest);
160     PreserveControl(txtAttn);
161     PreserveControl(cboProc);
162     if (patient.CombatVet.IsEligible = True) then
163      begin
164        SetUpCombatVet;
165      end
166      else
167       begin
168         txtCombatVet.Enabled := False;
169         pnlCombatVet.SendToBack;
170       end;
171     InitDialog;
172   end;
173   
174   procedure TfrmODProc.InitDialog;
175   begin
176     inherited;
177     Changing := True;
178     FLastProcID := '';
179     with CtrlInits do
180     begin
181      SetControl(cboProc, 'ShortList');
182      cboProc.InsertSeparator;
183      if OrderForInpatient then
184       begin
185         radInpatient.Checked := True;                   //INPATIENT PROCEDURE
186         cboCategory.Items.Clear;
187         cboCategory.Items.Add('I^Inpatient');
188         cboCategory.SelectById('I');
189         SetControl(cboPlace, 'Inpt Place');
190         SetControl(cboUrgency, 'Inpt Proc Urgencies');      //S.GMRCR
191         SetControl(calEarliest, 'EarliestDate');  //wat v29
192       end
193      else
194       begin
195         radOutpatient.Checked := True;                 //OUTPATIENT PROCEDURE
196         cboCategory.Items.Clear;
197         cboCategory.Items.Add('O^Outpatient');
198         cboCategory.SelectById('O');
199         SetControl(cboPlace, 'Outpt Place');
200         SetControl(cboUrgency, 'Outpt Urgencies');     //S.GMRCO
201         SetControl(calEarliest, 'EarliestDate');  //wat v29
202       end ;
203     end ;
204     txtAttn.ItemIndex := -1;
205     memOrder.Clear ;
206     memReason.Clear;
207     cboProc.Enabled := True;
208     cboProc.Font.Color := clWindowText;
209     //cboService.Enabled := True;
210     //cboService.Font.Color := clWindowText;
211     ActiveControl := cboProc;
212     SetProvDiagPromptingMode;
213     if not ShowPrerequisites then
214       begin
215         Close;
216         Exit;
217       end;
218     if calEarliest.Text = 'T' then calEarliest.Text := 'TODAY';
219     StatusText('');
220     Changing := False;
221   end;
222   
223   procedure TfrmODProc.SetupDialog(OrderAction: Integer; const ID: string);
224   var
225     tmpResp: TResponse;
226   begin
227     inherited;
228     ReadServerVariables;
229     if OrderAction in [ORDER_COPY, ORDER_EDIT, ORDER_QUICK] then with Responses do        {*KCM*}
230     begin
231       SetControl(cboProc,       'ORDERABLE', 1);
232       if cboProc.ItemIndex < 0 then exit;
233       FastAssign(GetProcedureServices(cboProc.ItemIEN), cboService.Items);
234       Changing := True;
235       tmpResp := TResponse(FindResponseByName('CLASS',1));
236       cboCategory.SelectByID(tmpResp.IValue);
237       if tmpResp.IValue = 'I' then
238         radInpatient.Checked := True
239       else
240         radOutpatient.Checked := True ;
241       SetControl(cboUrgency,    'URGENCY',     1);
242       SetControl(cboPlace,      'PLACE',     1);
243       SetControl(txtAttn,       'PROVIDER',  1);
244       SetControl(calEarliest,   'EARLIEST',  1);
245       cboProc.Enabled := False;
246       cboProc.Font.Color := clGrayText;
247      //SetControl(cboService,    'SERVICE',   1);     // to fix OR*3.0*95 bug in v17.6  (RV)
248       tmpResp := TResponse(FindResponseByName('SERVICE',1));
249       if tmpResp <> nil then
250         cboService.SelectByID(Piece(tmpResp.IValue, U, 1))
251       else if (cboService.Items.Count = 1) then
252         cboService.ItemIndex := 0
253       else if (cboService.Items.Count > 1) then
254         cboService.ItemIndex := -1 ;
255       if cboService.ItemIndex > -1 then
256         begin
257           cboService.Enabled := False;
258           cboService.Font.Color := clGrayText;
259         end
260       else
261         begin
262           cboService.Enabled := True;
263           cboService.Font.Color := clWindowText;
264         end;
265       if (OrderAction in [ORDER_COPY, ORDER_QUICK]) and (not ShowPrerequisites) then
266         begin
267           Close;
268           Exit;
269         end;
270       SetProvDiagPromptingMode;
271       GetProvDxandValidateCode(Responses);
272       SetTemplateDialogCanceled(FALSE);
273       SetControl(memReason,     'COMMENT',   1);
274       if WasTemplateDialogCanceled then
275       begin
276         AbortOrder := True;   
277         OkToFreeProcDialog := true;
278         SetTemplateDialogCanceled(FALSE);
279         Close;
280         Exit;
281       end;
282       SetTemplateDialogCanceled(FALSE);
283       SetupReasonForRequest(OrderAction);
284       if WasTemplateDialogCanceled then
285       begin
286         AbortOrder := True;
287         OkToFreeProcDialog := true;
288         SetTemplateDialogCanceled(FALSE);
289         Close;
290         Exit;
291       end;
292       Changing := False;
293       OrderMessage(ConsultMessage(cboProc.ItemIEN));
294       ControlChange(Self);
295     end;
296   end;
297   
298   procedure TfrmODProc.Validate(var AnErrMsg: string);
299   
300     procedure SetError(const x: string);
301     begin
302       if Length(AnErrMsg) > 0 then AnErrMsg := AnErrMsg + CRLF;
303       AnErrMsg := AnErrMsg + x;
304     end;
305   
306   begin
307     inherited;
308     if cboProc.ItemIEN = 0                  then SetError(TX_NO_PROC);
309     if cboUrgency.ItemIEN = 0               then SetError(TX_NO_URGENCY);
310     if cboPlace.ItemID = ''                 then SetError(TX_NO_PLACE);
311     if (not ContainsVisibleChar(memReason.Text))
312                                             then SetError(TX_NO_REASON);
313     if cboService.ItemIEN = 0               then SetError(TX_NO_SERVICE);
314     if (ProvDx.Reqd = 'R') and (Length(txtProvDiag.Text) = 0) then
315       begin
316         if ProvDx.PromptMode = 'F'          then
317           SetError(TX_NO_DIAG)
318         else
319           SetError(TX_SELECT_DIAG);
320       end;
321     if calEarliest.FMDateTime < FMToday     then SetError(TX_PAST_DATE);
322   end;
323   
324   procedure TfrmODProc.txtAttnNeedData(Sender: TObject;
325     const StartFrom: string; Direction, InsertAt: Integer);
326   begin
327     inherited;
328     txtAttn.ForDataUse(SubSetOfPersons(StartFrom, Direction));
329   end;
330   
331   procedure TfrmODProc.cboProcNeedData(Sender: TObject;
332     const StartFrom: string; Direction, InsertAt: Integer);
333   begin
334     inherited;
335     cboProc.ForDataUse(SubSetOfProcedures(StartFrom, Direction));
336   end;
337   
338   procedure TfrmODProc.radInpatientClick(Sender: TObject);
339   begin
340     inherited;
341     with CtrlInits do
342     begin
343       SetControl(cboPlace, 'Inpt Place');
344       SetControl(cboUrgency, 'Inpt Proc Urgencies');
345       cboCategory.Items.Clear;
346       cboCategory.Items.Add('I^Inpatient') ;
347       cboCategory.SelectById('I');
348     end ;
349     ControlChange(Self);
350   end;
351   
352   procedure TfrmODProc.radOutpatientClick(Sender: TObject);
353   begin
354     inherited;
355     with CtrlInits do
356     begin
357       SetControl(cboPlace, 'Outpt Place');
358       SetControl(cboUrgency, 'Outpt Urgencies');
359       cboCategory.Items.Clear;
360       cboCategory.Items.Add('O^Outpatient');
361       cboCategory.SelectById('O');
362     end ;
363     ControlChange(Self);
364   end;
365   
366   procedure TfrmODProc.ControlChange(Sender: TObject);
367   var
368     x: string;
369     i: integer;
370   begin
371     inherited;
372     if Changing or (cboProc.ItemIEN = 0) then Exit;
373     with cboProc do
374       begin
375         if ItemIEN > 0 then
376           begin
377             i := Pos('<', Text);
378             if i > 0 then
379               begin
380                 x := Piece(Copy(Text, i + 1, 99), '>', 1);
381                 x := UpperCase(Copy(x, 1, 1)) + Copy(x, 2, 99);
382               end
383             else
384               x := Text;
385             Responses.Update('ORDERABLE', 1, ItemID, x);
386           end
387         else Responses.Update('ORDERABLE', 1, '', '');
388       end;
389     updateService();
390     with memReason     do if GetTextLen   > 0 then Responses.Update('COMMENT',   1, TX_WPTYPE, Text);
391     with cboCategory   do if ItemID     <> '' then Responses.Update('CLASS',     1, ItemID, Text);
392     with cboUrgency    do if ItemIEN      > 0 then Responses.Update('URGENCY',   1, ItemID, Text);
393     with cboPlace      do if ItemID     <> '' then Responses.Update('PLACE',     1, ItemID, Text);
394     with txtAttn       do if ItemIEN      > 0 then Responses.Update('PROVIDER',  1, ItemID, Text);
395     with calEarliest   do if Length(Text) > 0 then Responses.Update('EARLIEST',  1, Text, Text);
396     if Length(ProvDx.Text)                > 0 then Responses.Update('MISC',      1, ProvDx.Text,   ProvDx.Text)
397      else Responses.Update('MISC',      1, '',   '');
398     if Length(ProvDx.Code)                > 0 then Responses.Update('CODE',      1, ProvDx.Code,   ProvDx.Code)
399      else Responses.Update('CODE',      1, '',   '');
400   
401     memOrder.Text := Responses.OrderText;
402   end;
403   
404   procedure TfrmODProc.cboProcSelect(Sender: TObject);
405   begin
406     inherited;
407     with cboProc do
408      begin
409       if ItemIndex = -1 then Exit;
410       if ItemID <> FLastProcID then FLastProcID := ItemID else Exit;
411       Changing := True;
412       if Sender <> Self then Responses.Clear;       // Sender=Self when called from SetupDialog
413       Changing := False;
414       if CharAt(ItemID, 1) = 'Q' then
415        begin
416         Responses.QuickOrder := ExtractInteger(ItemID);
417         Responses.SetControl(cboProc, 'ORDERABLE', 1);
418         FLastProcID := ItemID;
419        end; 
420       with cboService do
421         begin
422           Clear;
423           FastAssign(GetProcedureServices(cboProc.ItemIEN), cboService.Items);
424           if Items.Count > 1 then
425             ItemIndex := -1
426           else if Items.Count = 1 then
427             begin
428               ItemIndex := 0 ;
429               Responses.Update('SERVICE', 1, ItemID, Text);
430             end
431           else
432             begin
433               if Sender = Self then    // Sender=Self when called from SetupDialog
434                 InfoBox('There are no services defined for this procedure.',
435                 'Information', MB_OK or MB_ICONINFORMATION);
436               cboProc.ItemIndex := -1;
437               InitDialog;
438               Exit ;
439             end;
440         end;
441      end;
442     with Responses do if QuickOrder > 0 then
443       begin
444         SetControl(cboProc,       'ORDERABLE', 1);
445         Changing := True;
446         with cboService do
447           begin
448             FastAssign(GetProcedureServices(cboProc.ItemIEN), cboService.Items);
449             if Items.Count > 1 then
450               ItemIndex := -1
451             else if Items.Count = 1 then
452               ItemIndex := 0 ;
453           end;
454         if not ShowPrerequisites then
455           begin
456             Close;
457             Exit;
458           end;
459         SetControl(cboCategory,   'CLASS',      1);
460         if cboCategory.ItemID = 'I' then radInpatient.Checked := True
461         else radOutpatient.Checked := True ;
462         SetControl(cboUrgency,    'URGENCY',     1);
463         SetControl(cboPlace,      'PLACE',     1);
464         SetControl(txtAttn,       'PROVIDER',  1);
465         SetControl(calEarliest,   'EARLIEST',  1);
466         SetTemplateDialogCanceled(FALSE);
467         SetControl(memReason,     'COMMENT',   1);
468         if WasTemplateDialogCanceled and OrderContainsObjects then
469         begin
470           AbortOrder := TRUE;
471           Close;
472           Exit;
473         end;
474         SetupReasonForRequest(ORDER_QUICK);
475         GetProvDxandValidateCode(Responses);
476         SetControl(cboService,    'SERVICE',   1);
477         cboProc.Enabled := False;
478         cboProc.Font.Color := clGrayText;
479         if cboService.ItemIndex > -1 then
480           begin
481             cboService.Enabled := False;
482             cboService.Font.Color := clGrayText;
483           end
484         else
485           begin
486             cboService.Enabled := True;
487             cboService.Font.Color := clWindowText;
488           end;
489         Changing := False;
490       end
491     else
492       begin
493         if cboProc.ItemIEN > 0 then
494           begin
495             if cboService.ItemIndex > -1 then
496               begin
497                 cboService.Enabled := False;
498                 cboService.Font.Color := clGrayText;
499               end
500             else
501               begin
502                 cboService.Enabled := True;
503                 cboService.Font.Color := clWindowText;
504               end;
505             if not ShowPrerequisites then
506               begin
507                 Close;
508                 Exit;
509               end;
510             FastAssign(DefaultReasonForRequest(Piece(cboProc.Items[cboProc.ItemIndex], U, 4), True), memReason.Lines);
511             SetupReasonForRequest(ORDER_NEW);
512           end;
513       end;
514     SetProvDiagPromptingMode;
515     OrderMessage(ConsultMessage(cboProc.ItemIEN));
516     ControlChange(Self) ;
517   end;
518   
519   procedure TfrmODProc.memReasonExit(Sender: TObject);
520   var
521     AStringList: TStringList;
522   begin
523     inherited;
524     AStringList := TStringList.Create;
525     try
526       AStringList.Text := memReason.Text;
527       LimitStringLength(AStringList, 74);
528       memReason.Text := AStringList.Text;
529       ControlChange(Self);
530     finally
531       AStringList.Free;
532     end;
533   end;
534   
535   procedure  TfrmODProc.ReadServerVariables;
536   begin
537     if StrToIntDef(KeyVariable['GMRCNOAT'], 0) > 0 then
538       begin
539         txtAttn.Enabled    := False;
540         txtAttn.Font.Color := clGrayText;
541         lblAttn.Enabled    := False;
542         txtAttn.Color      := clBtnFace;
543       end
544     else
545       begin
546         txtAttn.Enabled    := True;
547         txtAttn.Font.Color := clWindowText;
548         lblAttn.Enabled    := True;
549         txtAttn.Color      := clWindow;
550       end;
551   
552     if StrToIntDef(KeyVariable['GMRCNOPD'], 0) > 0 then
553       begin
554         cmdLexSearch.Enabled   := False;
555         txtProvDiag.Enabled    := False;
556         txtProvDiag.Font.Color := clGrayText;
557         lblProvDiag.Enabled    := False;
558         txtProvDiag.ReadOnly   := True;
559         txtProvDiag.Color      := clBtnFace;
560       end
561     else SetProvDiagPromptingMode;
562   
563     GMRCREAF := KeyVariable['GMRCREAF'];
564   end;
565   
566   procedure TfrmODProc.cmdLexSearchClick(Sender: TObject);
567   var
568     Match: string;
569     i: integer;
570   begin
571     inherited;
572     LexiconLookup(Match, LX_ICD);
573     if Match = '' then Exit;
574     ProvDx.Code := Piece(Piece(Match, U, 1),'/',1);
575     ProvDx.Text := Piece(Match, U, 2);
576     i := Pos(' (ICD', ProvDx.Text);
577     if i = 0 then i := Length(ProvDx.Text) + 1;
578     if ProvDx.Text[i-1] = '*' then i := i - 2;
579     ProvDx.Text := Copy(ProvDx.Text, 1, i - 1);
580     txtProvDiag.Text := ProvDx.Text + ' (' + ProvDx.Code + ')';
581     ProvDx.CodeInactive := False;
582   end;
583   
584   procedure TfrmODProc.SetProvDiagPromptingMode;
585   const
586     TX_USE_LEXICON = 'You must use the "Lexicon" button to select a provisional diagnosis for this service.';
587     TX_PROVDX_OPT  = 'Provisional Diagnosis';
588     TX_PROVDX_REQD = 'Provisional Dx (REQUIRED)';
589   begin
590     cmdLexSearch.Enabled   := False;
591     txtProvDiag.Enabled    := False;
592     txtProvDiag.ReadOnly   := True;
593     txtProvDiag.Color      := clBtnFace;
594     txtProvDiag.Font.Color := clBtnText;
595     lblProvDiag.Enabled    := False;
596     txtProvDiag.Hint       := '';
597     if cboProc.ItemIEN = 0 then Exit;
598     ProvDx.PreviousPromptMode := ProvDx.PromptMode;
599     //GetProvDxMode(ProvDx, cboService.ItemID);
600     GetProvDxMode(ProvDx, Piece(cboProc.Items[cboProc.ItemIndex], U, 4));
601     //  Returns:  string  A^B
602     //     A = O (optional), R (required) or S (suppress)
603     //     B = F (free-text) or L (lexicon)
604     if (ProvDx.PreviousPromptMode <> '') and (ProvDx.PromptMode <> ProvDx.PreviousPromptMode) then
605      begin
606        ProvDx.Code := '';
607        ControlChange(Self);
608      end;
609     with ProvDx do if (Reqd = '') or (PromptMode = '') then Exit;
610     if ProvDx.Reqd = 'R' then
611       lblProvDiag.Caption := TX_PROVDX_REQD
612     else
613       lblProvDiag.Caption := TX_PROVDX_OPT;
614     if ProvDx.Reqd = 'S' then
615       begin
616         cmdLexSearch.Enabled   := False;
617         txtProvDiag.Enabled    := False;
618         txtProvDiag.ReadOnly   := True;
619         txtProvDiag.Color      := clBtnFace;
620         txtProvDiag.Font.Color := clBtnText;
621         lblProvDiag.Enabled    := False;
622       end
623     else
624       case ProvDx.PromptMode[1] of
625         'F':  begin
626                 cmdLexSearch.Enabled   := False;
627                 txtProvDiag.Enabled    := True;
628                 txtProvDiag.ReadOnly   := False;
629                 txtProvDiag.Color      := clWindow;
630                 txtProvDiag.Font.Color := clWindowText;
631                 lblProvDiag.Enabled    := True;
632               end;
633         'L':  begin
634                 cmdLexSearch.Enabled   := True;
635                 txtProvDiag.Enabled    := True;
636                 txtProvDiag.ReadOnly   := True;
637                 txtProvDiag.Color      := clInfoBk;
638                 txtProvDiag.Font.Color := clInfoText;
639                 lblProvDiag.Enabled    := True;
640                 txtProvDiag.Hint       := TX_USE_LEXICON;
641               end;
642       end;
643   end;
644   
645   procedure TfrmODProc.setup508Label(text: string; lbl: TVA508StaticText; ctrl: TControl);
646   begin
647     if ScreenReaderSystemActive and not ctrl.Enabled then begin
648       lbl.Enabled := True;
649       lbl.Visible := True;
650       lbl.Caption := lblService.Caption + ', ' + Text;
651       lbl.Width := (ctrl.Left + ctrl.Width) - lbl.Left;
652     end else
653       lbl.Visible := false;
654   end;
655   
656   procedure TfrmODProc.cboServiceChange(Sender: TObject);
657   begin
658     inherited;
659     //SetProvDiagPromptingMode;
660     ControlChange(Self);
661   end;
662   
663   procedure TfrmODProc.mnuPopProvDxDeleteClick(Sender: TObject);
664   begin
665     inherited;
666     ProvDx.Text := '';
667     ProvDx.Code := '';
668     txtProvDiag.Text := '';
669     ControlChange(Self);
670   end;
671   
672   procedure TfrmODProc.txtProvDiagChange(Sender: TObject);
673   begin
674     inherited;
675     if ProvDx.PromptMode = 'F' then
676       ProvDx.Text := txtProvDiag.Text;
677     ControlChange(Self);
678   end;
679   
680   procedure TfrmODProc.popReasonPopup(Sender: TObject);
681   begin
682     inherited;
683     if PopupComponent(Sender, popReason) is TCustomEdit
684       then FEditCtrl := TCustomEdit(PopupComponent(Sender, popReason))
685       else FEditCtrl := nil;
686     if FEditCtrl <> nil then
687     begin
688       popReasonCut.Enabled      := FEditCtrl.SelLength > 0;
689       popReasonCopy.Enabled     := popReasonCut.Enabled;
690       popReasonPaste.Enabled    := (not TORExposedCustomEdit(FEditCtrl).ReadOnly) and
691                                      Clipboard.HasFormat(CF_TEXT);
692     end else
693     begin
694       popReasonCut.Enabled      := False;
695       popReasonCopy.Enabled     := False;
696       popReasonPaste.Enabled    := False;
697     end;
698     popReasonReformat.Enabled := True;
699   end;
700   
701   procedure TfrmODProc.popReasonCutClick(Sender: TObject);
702   begin
703     inherited;
704     FEditCtrl.CutToClipboard;
705   end;
706   
707   procedure TfrmODProc.popReasonCopyClick(Sender: TObject);
708   begin
709     inherited;
710     FEditCtrl.CopyToClipboard;
711   end;
712   
713   procedure TfrmODProc.popReasonPasteClick(Sender: TObject);
714   begin
715     inherited;
716     FEditCtrl.SelText := Clipboard.AsText;
717   end;
718   
719   procedure TfrmODProc.popReasonReformatClick(Sender: TObject);
720   begin
721     inherited;
722     if Screen.ActiveControl <> memReason then Exit;
723     ReformatMemoParagraph(memReason);
724   end;
725   
726   procedure TfrmODProc.SetupReasonForRequest(OrderAction: integer);
727   var
728     EditReason: string;
729   
730     procedure EnableReason;
731     begin
732       memReason.Color := clWindow;
733       memReason.Font.Color := clWindowText;
734       memReason.ReadOnly := False;
735       lblReason.Caption := 'Reason for Request';
736     end;
737   
738     procedure DisableReason;
739     begin
740       memReason.Color := clInfoBk;
741       memReason.Font.Color := clInfoText;
742       memReason.ReadOnly := True;
743       lblReason.Caption := 'Reason for Request  (not editable)';
744     end;
745   
746   begin
747     if ((OrderAction = ORDER_QUICK) and (cboProc.ItemID <> '') and (Length(memReason.Text) = 0)) then
748       FastAssign(DefaultReasonForRequest(Piece(cboProc.Items[cboProc.ItemIndex], U, 4), True), memReason.Lines);
749     EditReason := GMRCREAF;
750     if EditReason = '' then EditReason := ReasonForRequestEditable(Piece(cboProc.Items[cboProc.ItemIndex], U, 4));
751     case EditReason[1] of
752       '0':  EnableReason;
753       '1':  if OrderAction in [ORDER_COPY, ORDER_EDIT] then
754               EnableReason
755             else
756               DisableReason;
757       '2':  DisableReason
758     else
759       EnableReason;
760     end;
761   end;
762   
763   function TfrmODProc.ShowPrerequisites: boolean;
764   var
765     AList: TStringList;
766   const
767     TC_PREREQUISITES = 'Procedure Prerequisites - ';
768   begin
769     Result := True;
770     AbortOrder := False;
771     AList := TStringList.Create;
772     try
773       with cboProc do
774         if ItemIEN > 0 then
775           begin
776             FastAssign(GetServicePrerequisites(Piece(Items[ItemIndex], U, 4)), Alist);
777             if AList.Count > 0 then
778               begin
779                 if not DisplayPrerequisites(AList, TC_PREREQUISITES + DisplayText[ItemIndex]) then
780                   begin
781                     memOrder.Clear;
782                     Result := False;
783                     AbortOrder := True;
784                     //cmdQuitClick(Self);
785                   end
786                 else Result := True;
787               end;
788           end;
789     finally
790       AList.Free;
791     end;
792   end;
793   
794   function TfrmODProc.DefaultReasonForRequest(Service: string;
795     Resolve: Boolean): TStrings;
796   var
797     TmpSL: TStringList;
798     DocInfo: string;
799     x: string;
800     HasObjects: boolean;
801   begin
802     Resolve := FALSE ;  // override value passed in - resolve on client - PSI-05-093
803     DocInfo := '';
804     TmpSL := TStringList.Create;
805     try
806       Result := GetDefaultReasonForRequest(Piece(cboProc.Items[cboProc.ItemIndex], U, 4), Resolve);
807       FastAssign(Result, TmpSL);
808       x := TmpSL.Text;
809       ExpandOrderObjects(x, HasObjects);
810       TmpSL.Text := x;
811       Responses.OrderContainsObjects := HasObjects;
812       ExecuteTemplateOrBoilerPlate(TmpSL, StrToIntDef(Piece(Piece(cboProc.Items[cboProc.ItemIndex], U, 4), ';', 1), 0),
813                      ltProcedure, nil, 'Reason for Request: ' + cboProc.DisplayText[cboProc.ItemIndex], DocInfo);
814       AbortOrder := WasTemplateDialogCanceled;
815       Responses.OrderContainsObjects := HasObjects or TemplateBPHasObjects;
816       if AbortOrder then
817       begin
818         Result.Text := '';
819         Close;
820         Exit;
821       end
822       else
823         FastAssignWith508Msg(TmpSL, Result);
824     finally
825       TmpSL.Free;
826     end;
827   end;
828   
829   procedure TfrmODProc.memReasonKeyUp(Sender: TObject; var Key: Word;
830     Shift: TShiftState);
831   begin
832     inherited;
833     if FNavigatingTab then
834     begin
835       if ssShift in Shift then
836         FindNextControl(Sender as TWinControl, False, True, False).SetFocus //previous control
837       else if ssCtrl	in Shift then
838         FindNextControl(Sender as TWinControl, True, True, False).SetFocus; //next control
839       FNavigatingTab := False;
840     end;
841     if (key = VK_ESCAPE) then begin
842       FindNextControl(Sender as TWinControl, False, True, False).SetFocus; //previous control
843       Key := 0;
844     end;
845   end;
846   
847   procedure TfrmODProc.GetProvDxandValidateCode(AResponses: TResponses);
848   var
849     tmpDx: TResponse;
850   begin
851     with AResponses do
852       begin
853         tmpDx := TResponse(FindResponseByName('MISC',1));
854         if tmpDx <> nil then ProvDx.Text := tmpDx.Evalue;
855         tmpDx := TResponse(FindResponseByName('CODE',1));
856         if (tmpDx <> nil) and (tmpDx.EValue <> '') then
857         begin
858           if IsActiveICDCode(tmpDx.EValue) then
859             ProvDx.Code := tmpDx.Evalue
860           else
861             begin
862               if ProvDx.Reqd = 'R' then
863                 InfoBox(TX_INACTIVE_CODE1 + TX_INACTIVE_CODE_REQD, TC_INACTIVE_CODE, MB_ICONWARNING or MB_OK)
864               else
865                 InfoBox(TX_INACTIVE_CODE1 + TX_INACTIVE_CODE_OPTIONAL, TC_INACTIVE_CODE, MB_ICONWARNING or MB_OK);
866               ProvDx.Code := '';
867               ProvDx.Text := '';
868             end;
869         end;
870         txtProvDiag.Text := ProvDx.Text;
871         if ProvDx.Code <> '' then txtProvDiag.Text :=  txtProvDiag.Text + ' (' + ProvDx.Code + ')';
872       end;
873   end;
874   
875   procedure TfrmODProc.SetFontSize(FontSize: integer);
876   begin
877     inherited;
878     DoSetFontSize(FontSize);
879   end;
880   
881   procedure TfrmODProc.updateService;
882   begin
883     with cboService do
884       if ItemIEN > 0 then
885       begin
886         setup508Label(Text, servicelbl508, cboService);
887         Responses.Update('SERVICE', 1, ItemID, Text);
888       end
889       else begin
890         Responses.Update('SERVICE', 1, '', '');
891         setup508Label('No service selected.', servicelbl508, cboService);
892       end;
893   end;
894   
895   procedure TfrmODProc.DoSetFontSize(FontSize: integer);
896   begin
897     memReason.Width := pnlReason.ClientWidth;
898     memReason.Height := pnlReason.ClientHeight;// - memReason.Height;  MAC-0104-61043 - RV
899   end;
900   
901   procedure TfrmODProc.memReasonKeyDown(Sender: TObject; var Key: Word;
902     Shift: TShiftState);
903   begin
904     inherited;
905     //The navigating tab controls were inadvertantently adding tab characters
906     //This should fix it
907     FNavigatingTab := (Key = VK_TAB) and ([ssShift,ssCtrl] * Shift <> []);
908     if FNavigatingTab then
909       Key := 0;
910   end;
911   
912   procedure TfrmODProc.memReasonKeyPress(Sender: TObject; var Key: Char);
913   begin
914     inherited;
915     if FNavigatingTab then
916       Key := #0;  //Disable shift-tab processing
917   end;
918   
919   procedure TfrmODProc.FormResize(Sender: TObject);
920   begin
921     inherited;
922     if Patient.CombatVet.IsEligible then
923     begin
924       memOrder.Top := pnlCombatVet.Height + PnlReason.Top + PnlReason.Height + 7;
925      end
926     else
927      begin
928          memOrder.Top := PnlReason.Top + PnlReason.Height + 7;
929      end;
930   
931   end;
932   
933   procedure TfrmODProc.FormShow(Sender: TObject);
934   begin
935     inherited;
936     setup508Label('No service selected.', servicelbl508, cboService);
937   end;
938   
939   procedure TfrmODProc.FormClose(Sender: TObject; var Action: TCloseAction);
940   begin
941     inherited;
942     frmFrame.pnlVisit.Enabled := true;
943   end;
944   
945   procedure TfrmODProc.SetUpCombatVet;
946      begin
947        pnlCombatVet.BringToFront;
948        txtCombatVet.Enabled := True;
949        txtCombatVet.Caption := 'Combat Veteran Eligibility Expires on ' + patient.CombatVet.ExpirationDate;
950        pnlMain.Top := pnlMain.Top + pnlCombatVet.Height;
951        pnlMain.Anchors := [akLeft,akTop,akRight];
952        self.Height := self.Height + pnlCombatVet.Height;
953        pnlMain.Anchors := [akLeft,akTop,akRight,akBottom];
954     end;
955   
956   end.

Module Calls (2 levels)


fODProc
 ├fODBase
 │ ├fAutoSz
 │ ├uConst
 │ ├rOrders
 │ ├rODBase
 │ ├uCore
 │ ├UBAGlobals
 │ ├UBACore
 │ ├fOCAccept
 │ ├uODBase
 │ ├rCore
 │ ├rMisc
 │ ├fTemplateDialog
 │ ├uEventHooks
 │ ├uTemplates
 │ ├rConsults
 │ ├fOrders
 │ ├uOrders
 │ ├fFrame
 │ ├fODDietLT
 │ └rODDiet
 ├uConst
 ├rODBase...
 ├rConsults...
 ├uCore...
 ├uConsults
 │ └uConst
 ├rCore...
 ├fPCELex
 │ ├uCore...
 │ ├fBase508Form
 │ ├mTreeGrid
 │ ├rPCE
 │ ├uProbs
 │ ├rProbs
 │ └UBAGlobals...
 ├rPCE...
 ├fPreReq
 │ ├fBase508Form...
 │ ├uReports
 │ ├rReports
 │ └rMisc...
 ├uTemplates...
 ├fFrame...
 ├uODBase...
 └uVA508CPRSCompatibility
   ├uDlgComponents
   ├fFrame...
   ├uCore...
   └mTemplateFieldButton

Module Called-By (2 levels)


                     fODProc
                   uOrders┘ 
                   uCore┤   
                 fODBase┤   
                 rODBase┤   
                  fFrame┤   
                 fOrders┤   
             fOrdersSign┤   
                   fMeds┤   
               fARTAllgy┤   
                  fNotes┤   
               fConsults┤   
         fReminderDialog┤   
                 fReview┤   
            fOrdersRenew┤   
               fOrdersCV┤   
                 fODMeds┤   
                 fOMNavA┤   
         fOrderSaveQuick┤   
                  fOMSet┤   
          fOrdersRelease┤   
                 fOMHTML┤   
               fODMedNVA┤   
fODChangeUnreleasedRenew┤   
          fOrdersOnChart┤   
         fODReleaseEvent┤   
               fODActive┘