source: cprs/branches/tmg-cprs/CPRS-Chart/Consults/fODProc.pas

Last change on this file was 453, checked in by Kevin Toppenberg, 16 years ago

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