source: cprs/branches/tmg-cprs/CPRS-Chart/fProbEdt.pas@ 1547

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

Initial upload of TMG-CPRS 1.0.26.69
File size: 37.3 KB
RevLine 
[453]1//kt -- Modified with SourceScanner on 7/24/2007
2unit fProbEdt;
3
4interface
5
6uses
7 SysUtils, windows, Messages, Classes, Graphics, Controls,
8 Forms, Dialogs, StdCtrls, Buttons, ExtCtrls, Grids,
9 ORCtrls, Vawrgrid, uCore, Menus, uConst, DKLang;
10
11const
12 SOC_QUIT = 1; { close single dialog }
13
14type
15 TfrmdlgProb = class(TForm)
16 Label1: TLabel;
17 Label5: TLabel;
18 edResDate: TCaptionEdit;
19 Label7: TLabel;
20 edUpdate: TCaptionEdit;
21 pnlBottom: TPanel;
22 bbQuit: TBitBtn;
23 bbFile: TBitBtn;
24 pnlComments: TPanel;
25 Bevel1: TBevel;
26 lblCmtDate: TOROffsetLabel;
27 lblComment: TOROffsetLabel;
28 lblCom: TStaticText;
29 bbAdd: TBitBtn;
30 bbRemove: TBitBtn;
31 lstComments: TORListBox;
32 bbEdit: TBitBtn;
33 pnlTop: TPanel;
34 lblAct: TLabel;
35 rgStatus: TKeyClickRadioGroup;
36 rgStage: TKeyClickRadioGroup;
37 bbChangeProb: TBitBtn;
38 edProb: TCaptionEdit;
39 gbTreatment: TGroupBox;
40 ckSC: TCheckBox;
41 ckRad: TCheckBox;
42 ckAO: TCheckBox;
43 ckENV: TCheckBox;
44 ckHNC: TCheckBox;
45 ckMST: TCheckBox;
46 ckVerify: TCheckBox;
47 edRecDate: TCaptionEdit;
48 cbServ: TORComboBox;
49 cbLoc: TORComboBox;
50 lblLoc: TLabel;
51 cbProv: TORComboBox;
52 Label3: TLabel;
53 edOnsetdate: TCaptionEdit;
54 Label6: TLabel;
55 DKLanguageController1: TDKLanguageController;
56 procedure bbQuitClick(Sender: TObject);
57 procedure bbAddComClick(Sender: TObject);
58 procedure FormShow(Sender: TObject);
59 procedure FormClose(Sender: TObject; var Action: TCloseAction);
60 procedure bbFileClick(Sender: TObject);
61 procedure bbRemoveClick(Sender: TObject);
62 procedure cbProvKeyPress(Sender: TObject; var Key: Char);
63 procedure rgStatusClick(Sender: TObject);
64 procedure cbProvClick(Sender: TObject);
65 procedure cbLocClick(Sender: TObject);
66 procedure cbLocKeyPress(Sender: TObject; var Key: Char);
67 procedure SetDefaultProb(Alist:TstringList;prob:string);
68 procedure ControlChange(Sender: TObject);
69 function BadDates:Boolean;
70 procedure cbProvDropDown(Sender: TObject);
71 procedure cbLocDropDown(Sender: TObject);
72 procedure FormCreate(Sender: TObject);
73 procedure bbChangeProbClick(Sender: TObject);
74 procedure cbLocNeedData(Sender: TObject; const StartFrom: String;
75 Direction, InsertAt: Integer);
76 procedure cbProvNeedData(Sender: TObject; const StartFrom: String;
77 Direction, InsertAt: Integer);
78 procedure cbServNeedData(Sender: TObject; const StartFrom: String;
79 Direction, InsertAt: Integer);
80 procedure bbEditClick(Sender: TObject);
81 private
82 //kt Begin Mod (change Consts to Vars) 7/24/2007
83 TX_INACTIVE_CODE : string; //kt
84 TC_INACTIVE_CODE : string; //kt
85 //kt End Mod -------------------
86 { Private declarations }
87 FEditing: Boolean;
88 FInitialShow: Boolean;
89 FModified: Boolean;
90 FProviderID: Int64;
91 FLocationID: Longint;
92 FDisplayGroupID: Integer;
93 FInitialFocus: TWinControl;
94 FCtrlMap: TStringList;
95 FSourceOfClose: Integer;
96 FOnInitiate: TNotifyEvent;
97 fChanged:boolean;
98 FSilent: boolean;
99 FCanQuit: boolean;
100
101 procedure UMTakeFocus(var Message: TMessage); message UM_TAKEFOCUS;
102 procedure ShowComments;
103 procedure GetEditedComments;
104 procedure GetNewComments(Reason:char);
105 function OkToQuit:boolean;
106 protected
107 procedure CreateParams(var Params: TCreateParams); override;
108 procedure DoShow; override;
109 procedure Loaded; override;
110 procedure ClearDialogControls; virtual;
111 function LackRequired: Boolean; virtual;
112 procedure LoadDefaults; virtual;
113 property InitialFocus: TWinControl read FInitialFocus write FInitialFocus;
114 public
115 { Public declarations }
116 Reason:Char;
117 problemIFN:String;
118 subjProb:string; {parameters for problem being added}
119 constructor Create(AOwner: TComponent); override ;
120 destructor Destroy; override;
121 property DisplayGroupID: Integer read FDisplayGroupID write FDisplayGroupID;
122 property Editing: Boolean read FEditing write FEditing;
123 property Silent: Boolean read FSilent write FSilent;
124 property ProviderID: Int64 read FProviderID write FProviderID;
125 property LocationID: Longint read FLocationID write FLocationID;
126 property SourceOfClose: Integer read FSourceOfClose write FSourceOfClose;
127 property OnInitiate: TNotifyEvent read FOnInitiate write FOnInitiate;
128 procedure SetFontSize( NewFontSize: integer);
129 property CanQuit: boolean read FCanQuit write FCanQuit;
130 end ;
131
132implementation
133
134{$R *.DFM}
135
136uses ORFn, uProbs, fProbs, rProbs, fCover, rCover, rCore, fProbCmt, fProbLex, rPCE, uInit ;
137
138type
139 TDialogItem = class { for loading edits & quick orders }
140 ControlName: string;
141 DialogPtr: Integer;
142 Instance: Integer;
143 end;
144
145function TfrmdlgProb.OkToQuit:boolean;
146begin
147 Result := not fChanged;
148end;
149
150procedure TfrmdlgProb.bbQuitClick(Sender: TObject);
151begin
152 if OkToQuit then
153 begin
154 frmProblems.lblProbList.caption := frmProblems.pnlRight.Caption ;
155 close;
156 end
157 else
158 begin
159 if (not FSilent) and
160// (InfoBox('Discard changes?', 'Add/Edit a Problem', MB_YESNO or MB_ICONQUESTION) <> IDYES) then <-- original line. //kt 7/24/2007
161 (InfoBox(DKLangConstW('fProbEdt_Discard_changesx'), DKLangConstW('fProbEdt_AddxEdit_a_Problem'), MB_YESNO or MB_ICONQUESTION) <> IDYES) then //kt added 7/24/2007
162 begin
163 FCanQuit := False;
164 exit;
165 end
166 else
167 begin
168 frmProblems.lblProbList.caption := frmProblems.pnlRight.Caption ;
169 FCanQuit := True;
170 close;
171 end;
172 end;
173end;
174
175procedure TfrmdlgProb.bbAddComClick(Sender: TObject);
176var
177 cmt: string ;
178begin
179 cmt := NewComment ;
180 if StrToInt(Piece(cmt, U, 1)) > 0 then
181 begin
182 lstComments.Items.Add(Pieces(cmt, U, 2, 3)) ;
183 fChanged := true;
184 end ;
185end;
186
187procedure TfrmdlgProb.bbEditClick(Sender: TObject);
188var
189 cmt: string ;
190begin
191 if lstComments.ItemIndex < 0 then Exit;
192 cmt := EditComment(lstComments.Items[lstComments.ItemIndex]) ;
193 if StrToInt(Piece(cmt, U, 1)) > 0 then
194 begin
195 lstComments.Items[lstComments.ItemIndex] := Pieces(cmt, U, 2, 3) ;
196 fChanged := true;
197 end ;
198end;
199
200procedure TfrmdlgProb.FormShow(Sender: TObject);
201var
202 alist: TstringList;
203 Anchorses: Array of TAnchors;
204 i: integer;
205begin
206 if ProbRec <> nil then exit;
207 if (ResizeWidth(Font,MainFont,Width) >= Parent.ClientWidth) and
208 (ResizeHeight(Font,MainFont,Height) >= Parent.ClientHeight) then
209 begin //This form won't fit when it resizes, so we have to take Drastic Measures
210 SetLength(Anchorses, dlgProbs.ControlCount);
211 for i := 0 to ControlCount - 1 do
212 begin
213 Anchorses[i] := Controls[i].Anchors;
214 Controls[i].Anchors := [akLeft, akTop];
215 end;
216 SetFontSize(MainFontSize);
217 RequestAlign;
218 for i := 0 to ControlCount - 1 do
219 Controls[i].Anchors := Anchorses[i];
220 end
221 else
222 begin
223 SetFontSize(MainFontSize);
224 RequestAlign;
225 end;
226 frmProblems.mnuView.Enabled := False;
227 frmProblems.mnuAct.Enabled := False ;
228 frmProblems.lstView.Enabled := False;
229 frmProblems.bbNewProb.Enabled := False ;
230 Alist := TstringList.create;
231 try
232 if Reason = 'E' then
233// lblact.caption := 'Editing:' <-- original line. //kt 7/24/2007
234 lblact.caption := DKLangConstW('fProbEdt_Editingx') //kt added 7/24/2007
235 else if Reason = 'A' then
236// lblact.caption := 'Adding' <-- original line. //kt 7/24/2007
237 lblact.caption := DKLangConstW('fProbEdt_Adding') //kt added 7/24/2007
238 else {display, comment edit or remove problem}
239 begin
240// case reason of 'C','c': lblact.caption := 'Comment Edit'; <-- original line. //kt 7/24/2007
241 case reason of 'C','c': lblact.caption := DKLangConstW('fProbEdt_Comment_Edit'); //kt added 7/24/2007
242// 'R','r': lblact.caption := 'Remove Problem:'; <-- original line. //kt 7/24/2007
243 'R','r': lblact.caption := DKLangConstW('fProbEdt_Remove_Problemx'); //kt added 7/24/2007
244 end; {case}
245 {ckVerify.Enabled:=false;}
246 cbProv.Enabled := false;
247 cbLoc.Enabled := false;
248 bbRemove.enabled := false;
249 rgStatus.Enabled := false;
250 rgStage.Enabled := false;
251 edRecdate.enabled := false;
252 edResdate.enabled := false;
253 edOnsetDate.enabled := false;
254 ckSC.enabled := false;
255 ckRAD.enabled := false;
256 ckAO.enabled := false;
257 ckENV.enabled := false;
258 ckHNC.enabled := false;
259 ckMST.enabled := false;
260// if Reason = 'R' then bbFile.caption := 'Remove'; <-- original line. //kt 7/24/2007
261 if Reason = 'R' then bbFile.caption := DKLangConstW('fProbEdt_Remove'); //kt added 7/24/2007
262 end;
263 edProb.Caption := lblact.Caption;
264 if Piece(subjProb,U,3) <> '' then
265 edProb.Text := Piece(subjProb, u, 2) + ' (' + Piece(subjProb, u, 3) + ')'
266 else
267 edProb.Text := Piece(subjProb, u, 2);
268 {line up problem action and title}
269 {edProb.Left:=lblAct.left+lblAct.width+2;}
270 {get problem}
271 if Reason <> 'A' then
272 begin {edit,remove or display existing problem}
273 problemIFN := Piece(subjProb, u, 1);
274 //AList.Assign(EditLoad(ProblemIFN,pProviderID,PLPt.ptVAMC)) ;
275 AList.Assign(EditLoad(ProblemIFN,User.DUZ,PLPt.ptVAMC)) ; //V17.5 RV
276 end
277 else {new problem}
278 SetDefaultProb(Alist, subjProb);
279 if Alist.count = 0 then
280 begin
281// InfoBox('No Data on Host for problem ' + ProblemIFN, 'Information', MB_OK or MB_ICONINFORMATION); <-- original line. //kt 7/24/2007
282 InfoBox(DKLangConstW('fProbEdt_No_Data_on_Host_for_problem') + ProblemIFN, DKLangConstW('fProbEdt_Information'), MB_OK or MB_ICONINFORMATION); //kt added 7/24/2007
283 close;
284 exit;
285 end;
286 ProbRec := TProbRec.Create(Alist); {create a problem object}
287 ProbRec.PIFN := ProblemIFN;
288 ProbRec.EnteredBy.DHCPtoKeyVal(inttostr(User.DUZ) + u + User.Name);
289 ProbRec.RecordedBy.DHCPtoKeyVal(inttostr(Encounter.Provider) + u + Encounter.ProviderName);
290 {fill in defaults}
291 edOnsetdate.text := ProbRec.DateOnsetStr;
292 if Probrec.status <> 'A' then
293 begin
294 rgStatus.itemindex := 1;
295 rgStage.Visible := False ;
296 end;
297 if Probrec.Priority = 'A' then
298 rgStage.itemindex := 0
299 else if Probrec.Priority = 'C' then
300 rgStage.itemindex := 1
301 else
302 rgStage.itemindex := 2;
303 rgStatus.TabStop := (rgStatus.ItemIndex = -1);
304 rgStage.TabStop := (rgStage.ItemIndex = -1);
305 edRecDate.text := Probrec.DateRecStr;
306 edUpdate.text := Probrec.DateModStr;
307 edResDate.text := ProbRec.DateResStr;
308 edUpdate.enabled := false;
309 if pos(Reason,'CR') = 0 then
310 with PLPt do
311 begin
312 if UpperCase(Reason) = 'E' then
313 begin
314 ckSC.Enabled := ProbRec.SCProblem or PtServiceConnected;
315 ckSC.checked := ProbRec.SCProblem;
316 end
317 else
318 begin
319 ckSC.enabled := PtServiceConnected ;
320 ckSC.checked := ProbRec.SCProblem and PtServiceConnected ;
321 end;
322 ckAO.enabled := PtAgentOrange ;
323 ckRAD.enabled := PtRadiation ;
324 ckENV.enabled := PtEnvironmental ;
325 ckHNC.enabled := PtHNC ;
326 ckMST.enabled := PtMST ;
327 ckAO.checked := Probrec.AOProblem and PtAgentOrange;
328 ckRAD.checked := Probrec.RADProblem and PtRadiation;
329 ckENV.checked := Probrec.ENVProblem and PtEnvironmental;
330 ckHNC.checked := Probrec.HNCProblem and PtHNC;
331 ckMST.checked := Probrec.MSTProblem and PtMST;
332 end ;
333 cbProv.InitLongList(ProbRec.RespProvider.extern) ;
334 if (ProbRec.RespProvider.intern <> '') and (StrToInt64Def(ProbRec.RespProvider.intern, 0) > 0) then
335 cbProv.SelectByIEN(StrToInt64(ProbRec.RespProvider.intern)) ;
336
337 if UpperCase(Reason) = 'A' then
338 begin
339 if Encounter.Inpatient then
340 begin
341 cbLoc.visible:=false;
342 cbServ.Visible:=true;
343// lblLoc.caption:='Service:'; <-- original line. //kt 7/24/2007
344 lblLoc.caption:=DKLangConstW('fProbEdt_Servicex'); //kt added 7/24/2007
345 cbServ.InitLongList('');
346 end
347 else
348 begin
349 cbLoc.visible:=true;
350 cbServ.Visible:=false;
351// lblLoc.caption:='Clinic:'; <-- original line. //kt 7/24/2007
352 lblLoc.caption:=DKLangConstW('fProbEdt_Clinicx'); //kt added 7/24/2007
353 cbLoc.InitLongList(Encounter.LocationName) ;
354 cbLoc.SelectByIEN(Encounter.Location);
355 end;
356 end
357 else
358 begin
359 if (ProbRec.Service.DHCPField = '^') and (ProbRec.Clinic.DHCPField <> '^') then
360 begin
361 cbLoc.visible:=true;
362 cbServ.Visible:=false;
363// lblLoc.caption:='Clinic:'; <-- original line. //kt 7/24/2007
364 lblLoc.caption:=DKLangConstW('fProbEdt_Clinicx'); //kt added 7/24/2007
365 cbLoc.InitLongList(ProbRec.Clinic.Extern) ;
366 cbLoc.SelectByID(ProbRec.Clinic.Intern) ;
367 end
368 else if (ProbRec.Clinic.DHCPField = '^') and (ProbRec.Service.DHCPField <> '^') then
369 begin
370 cbLoc.visible:=false;
371 cbServ.Visible:=true;
372// lblLoc.caption:='Service:'; <-- original line. //kt 7/24/2007
373 lblLoc.caption:=DKLangConstW('fProbEdt_Servicex'); //kt added 7/24/2007
374 cbServ.InitLongList(ProbRec.Service.Extern) ;
375 cbServ.SelectByID(ProbRec.Service.Intern) ;
376 end
377 else
378 begin
379 if Encounter.Inpatient then
380 begin
381 cbLoc.visible:=false;
382 cbServ.Visible:=true;
383// lblLoc.caption:='Service:'; <-- original line. //kt 7/24/2007
384 lblLoc.caption:=DKLangConstW('fProbEdt_Servicex'); //kt added 7/24/2007
385 cbServ.InitLongList('');
386 end
387 else
388 begin
389 cbLoc.visible:=true;
390 cbServ.Visible:=false;
391// lblLoc.caption:='Clinic:'; <-- original line. //kt 7/24/2007
392 lblLoc.caption:=DKLangConstW('fProbEdt_Clinicx'); //kt added 7/24/2007
393 cbLoc.InitLongList('') ;
394 end;
395 end;
396 end;
397 cbLoc.Caption := lblLoc.Caption;
398
399 if Pos(Reason,'E,C') > 0 then ShowComments ;
400 if ProbRec.CmtIsXHTML then
401 begin
402 bbAdd.Enabled := FALSE;
403 bbEdit.Enabled := FALSE;
404 bbRemove.Enabled := FALSE;
405 pnlComments.Hint := ProbRec.CmtNoEditReason;
406 end
407 else
408 begin
409 bbAdd.Enabled := TRUE;
410 bbEdit.Enabled := TRUE;
411 bbRemove.Enabled := TRUE;
412 pnlComments.Hint := '';
413 end ;
414 // =================== changed code - REV 7/30/98 =========================
415 // PlUser.usVerifyTranscribed is a SITE requirement, not a user ability
416 if Reason = 'A' then
417 begin
418 if PlUser.usVerifyTranscribed and not PlUser.usPrimeUser then
419 ckVerify.Checked := False
420 else
421 ckVerify.Checked := True;
422 end
423 else ckVerify.checked := (Probrec.condition = 'P');
424 //===========================================================================
425 (* if (PlUSer.usVerifyTranscribed) and (Reason='A') then
426 begin {some users can add and verify}
427 {ckVerify.visible:=true;}
428 ckVerify.checked:=true; {assume it will be entered verified}
429 end {others can add and edit verified status}
430 else if (PlUSer.usVerifyTranscribed) and (PlUser.usPrimeUser) then
431 begin
432 {ckVerify.visible:=true; }
433 ckVerify.checked:=(Probrec.condition='P');
434 end; *)
435 if Reason <> 'A' then fChanged := False else fChanged := True; {initialize form for changes}
436 finally
437 alist.free;
438 end;
439end;
440
441procedure TfrmdlgProb.ShowComments;
442var
443 i:integer;
444begin
445 with ProbRec do
446 for i:=0 to Pred(fComments.count) do
447 lstComments.Items.Add(TComment(fComments[i]).ExtDateAdd + '^' + TComment(fComments[i]).Narrative);
448end;
449
450
451procedure TfrmdlgProb.FormClose(Sender: TObject; var Action: TCloseAction);
452var
453 Alist: TStringList;
454begin
455 AList := TStringList.Create;
456 try
457 //frmProblems.lblProbList.caption := frmProblems.pnlRight.Caption ; {moved to bbQuit - only on CANCEL}
458 TWinControl(parent).visible := false;
459 with frmProblems do
460 begin
461 pnlProbList.Visible := False ;
462 edProbEnt.text := '';
463 pnlView.BringToFront ;
464 pnlView.Show ;
465 mnuView.Enabled := True;
466 mnuAct.Enabled := True ;
467 lstView.Enabled := True ;
468 bbNewProb.Enabled := true ;
469 if fChanged then LoadPatientProblems(AList,PLUser.usViewAct[1],false);
470 end ;
471 Action := caFree;
472 finally
473 AList.Free;
474 end;
475end;
476
477{--------------------------------- file ---------------------------------}
478
479procedure TfrmdlgProb.bbFileClick(Sender: TObject);
480//const
481//TX_INACTIVE_CODE = 'This problem references an inactive ICD code.' + #13#10 + <-- original line. //kt 7/24/2007
482// 'The code must be updated using the ''Change''' + #13#10 + <-- original line. //kt 7/24/2007
483// 'button before it can be saved'; <-- original line. //kt 7/24/2007
484//TC_INACTIVE_CODE = 'Inactive Code'; <-- original line. //kt 7/24/2007
485var
486 AList: TstringList;
487 remcom, vu, ut: string;
488 i: integer;
489 TX_INACTIVE_CODE : string; //kt
490 TC_INACTIVE_CODE : string; //kt
491begin
492 TX_INACTIVE_CODE := DKLangConstW('fProbEdt_This_problem_references_an_inactive_ICD_codex') + #13#10 +
493 DKLangConstW('fProbEdt_The_code_must_be_updated_using_the_xxChangexx') + #13#10 +
494 DKLangConstW('fProbEdt_button_before_it_can_be_saved');
495 TC_INACTIVE_CODE := DKLangConstW('fProbEdt_Inactive_Code');
496 if (Reason <> 'R') and (Reason <> 'r') then
497 if (rgStatus.itemindex=-1) or (cbProv.itemindex=-1) then
498 begin
499// InfoBox('Status and Responsible Provider are required.', 'Information', MB_OK or MB_ICONINFORMATION); <-- original line. //kt 7/24/2007
500 InfoBox(DKLangConstW('fProbEdt_Status_and_Responsible_Provider_are_requiredx'), DKLangConstW('fProbEdt_Information'), MB_OK or MB_ICONINFORMATION); //kt added 7/24/2007
501 exit;
502 end;
503 if Reason in ['C','c','E','e'] then
504 if not IsActiveICDCode(ProbRec.Diagnosis.extern) then
505 begin
506 InfoBox(TX_INACTIVE_CODE, TC_INACTIVE_CODE, MB_ICONWARNING or MB_OK);
507 exit;
508 end;
509 if BadDates then exit;
510 Alist:=TStringList.create;
511 try
512 screen.cursor := crHourGlass;
513 {if (ckVerify.visible) then }
514 if (ckVerify.Checked) then
515 ProbRec.Condition := 'P'
516 else
517 Probrec.Condition := 'T';
518 if rgStatus.itemindex = 0 then
519 Probrec.status := 'A'
520 else if rgstatus.itemindex = 1 then
521 Probrec.status := 'I';
522 if rgStage.itemindex = 0 then
523 Probrec.Priority := 'A'
524 else if rgStage.itemindex = 1 then
525 Probrec.Priority := 'C';
526 ProbRec.DateOnsetStr := edOnsetDate.text;
527 ProbRec.DateResStr := edResDate.text;{aka inactivation date}
528 ProbRec.DateRecStr := edRecDate.text;{recorded anywhere}
529 if edUpdate.text = '' then
530 ProbRec.DateModStr := DatetoStr(trunc(FMNow))
531 else
532 ProbRec.DateModStr := edUpdate.text; {last update}
533 (*if ckSC.enabled then *)Probrec.SCProblem := ckSC.checked;
534 if ckRAD.enabled then Probrec.RadProblem := ckrad.Checked;
535 if ckAO.enabled then ProbRec.AOProblem := ckAO.checked;
536 if ckENV.enabled then ProbRec.ENVProblem := ckENV.Checked;
537 if ckHNC.enabled then ProbRec.HNCProblem := ckHNC.Checked;
538 if ckMST.enabled then ProbRec.MSTProblem := ckMST.Checked;
539 if cbProv.itemindex = -1 then {Get provider}
540 begin
541 Probrec.respProvider.intern := '0';
542 Probrec.RespProvider.extern := '';
543 end
544 else
545 ProbRec.RespProvider.DHCPtoKeyVal(cbProv.Items[cbProv.itemindex]);
546 if cbLoc.itemindex = -1 then {Get Clinic}
547 begin
548 Probrec.Clinic.intern := '';
549 Probrec.Clinic.extern := '';
550 end
551 else
552 ProbRec.Clinic.DHCPtoKeyVal(cbLoc.Items[cbLoc.itemindex]);
553 if cbServ.itemindex = -1 then {Get Service}
554 begin
555 Probrec.Service.intern := '';
556 Probrec.Service.extern := '';
557 end
558 else
559 Probrec.Service.DHCPtoKeyVal(cbServ.Items[cbServ.itemindex]);
560 if ProbRec.Commentcount > 0 then GetEditedComments;
561 GetNewComments(Reason);
562 case Reason of
563 'E','e','C','c': {edits or comments}
564 begin
565 ut := '';
566 if PLUser.usPrimeUser then ut := '1';
567 //AList.Assign(EditSave(ProblemIFN,pProviderID,PLPt.ptVAMC,ut,ProbRec.FilerObject)) ;
568 AList.Assign(EditSave(ProblemIFN,User.DUZ,PLPt.ptVAMC,ut,ProbRec.FilerObject)) ; //V17.5 RV
569 end;
570 'A','a': {new problem}
571 AList.Assign(AddSave(PLPt.GetGMPDFN(Patient.DFN, Patient.Name),
572 pProviderID,PLPt.ptVAMC,ProbRec.FilerObject)) ; //*DFN*
573 'R','r': {remove problem}
574 begin
575 remcom := '';
576 if Probrec.commentcount > 0 then
577 if TComment(Probrec.comments[pred(probrec.commentcount)]).IsNew then
578 remcom := TComment(Probrec.comments[pred(probrec.commentcount)]).Narrative;
579 AList.Assign(ProblemDelete(ProbRec.PIFN,User.DUZ,PLPt.ptVAMC,remcom)) ; //changed in v14
580 //AList.Assign(ProblemDelete(ProbRec.PIFN,Encounter.Provider,PLPt.ptVAMC,remcom)) ;
581 end
582 else exit;
583 end; {case}
584 screen.cursor := crDefault;
585 if Alist.count < 1 then
586// InfoBox('Broker time out filing on Host. Try again in a moment or cancel', 'Information', MB_OK or MB_ICONINFORMATION) <-- original line. //kt 7/24/2007
587 InfoBox(DKLangConstW('fProbEdt_Broker_time_out_filing_on_Hostx_Try_again_in_a_moment_or_cancel'), DKLangConstW('fProbEdt_Information'), MB_OK or MB_ICONINFORMATION) //kt added 7/24/2007
588 else if Alist[0] = '1' then
589 begin
590 Alist.clear;
591 vu:=PLUser.usViewAct;
592 fChanged := True; {ensure update of problem list on close}
593 //frmProblems.LoadPatientProblems(AList,vu[1],false);
594 { update cover sheet problem list }
595 with frmCover do
596 for i := ComponentCount - 1 downto 0 do
597 begin
598 if Components[i] is TORListBox then
599 begin
600 case Components[i].Tag of
601 10: ListActiveProblems((Components[i] as TORListBox).Items);
602 end;
603 end;
604 end;
605 Close;
606 end
607 else
608// InfoBox('Unable to lock record for filing on Host. Try again in a moment or cancel', <-- original line. //kt 7/24/2007
609 InfoBox(DKLangConstW('fProbEdt_Unable_to_lock_record_for_filing_on_Hostx_Try_again_in_a_moment_or_cancel'), //kt added 7/24/2007
610// 'Information', MB_OK or MB_ICONINFORMATION); <-- original line. //kt 7/24/2007
611 DKLangConstW('fProbEdt_Information'), MB_OK or MB_ICONINFORMATION); //kt added 7/24/2007
612 finally
613 Alist.free
614 end;
615end;
616
617procedure TfrmdlgProb.GetEditedComments;
618var
619 i: integer;
620begin
621 for i := 0 to pred(ProbRec.CommentCount) do
622 if i < lstComments.Items.Count then with lstComments do
623 begin
624 if Items[i] = 'DELETED' then
625 TComment(ProbRec.fComments[i]).Narrative := '' {this deletes the comment}
626 else
627 begin
628 TComment(ProbRec.fComments[i]).DateAdd := Piece(lstComments.Items[i], U, 1) ;
629 TComment(ProbRec.fComments[i]).Narrative := Piece(lstComments.Items[i], U, 2) ;
630 end;
631 end;
632end;
633
634procedure TfrmdlgProb.GetNewComments(Reason: char);
635var
636 i, start: integer;
637begin
638 {don't display previous comments for add comment or remove problem functions}
639 if (Reason <> 'R') then
640 start := ProbRec.CommentCount
641 else
642 start := 0;
643 for i := start to Pred(lstComments.Items.Count) do
644 begin
645 with lstComments do
646 begin
647 if (lstComments.Items[i] <> 'DELETED') and (Piece(lstComments.Items[i], u, 2) <> '') then
648 ProbRec.AddNewComment(Piece(lstComments.Items[i],u,2));
649 end;
650 end;
651 end;
652
653procedure TfrmdlgProb.bbRemoveClick(Sender: TObject);
654begin
655 if (lstComments.Items.Count = 0) or (lstComments.ItemIndex < 0) then exit ;
656 lstComments.Items[lstComments.ItemIndex] := 'DELETED' ;
657 fChanged := true;
658end;
659
660procedure TfrmdlgProb.cbProvKeyPress(Sender: TObject; var Key: Char);
661begin
662 if key = #13 then
663 SendMessage(cbProv.Handle, CB_SHOWDROPDOWN, 1, 0) {Opens list}
664 else
665 SendMessage(cbProv.Handle, CB_SHOWDROPDOWN, 0, 0) {Closes list}
666end;
667
668procedure TfrmdlgProb.rgStatusClick(Sender: TObject);
669begin
670 if rgStatus.Itemindex = 1 then
671 begin
672 edResDate.text := DateToStr(Date) ;
673 rgStage.Visible := False ;
674 end
675 else
676 begin
677 edResDate.text := '';
678 rgStage.Visible := True ;
679 end ;
680 FChanged := True;
681end;
682
683procedure TfrmdlgProb.cbProvClick(Sender: TObject);
684begin
685 SendMessage(cbProv.Handle, CB_SHOWDROPDOWN, 0, 0); {Closes list}
686end;
687
688procedure TfrmdlgProb.cbLocClick(Sender: TObject);
689begin
690 SendMessage(cbLoc.Handle, CB_SHOWDROPDOWN, 0, 0); {Closes list}
691end;
692
693procedure TfrmdlgProb.cbLocKeyPress(Sender: TObject; var Key: Char);
694begin
695 if key = #13 then
696 SendMessage(cbLoc.Handle, CB_SHOWDROPDOWN, 1, 0) {Opens list}
697 else
698 SendMessage(cbLoc.Handle, CB_SHOWDROPDOWN, 0, 0) {Closes list}
699end;
700
701
702procedure TfrmdlgProb.SetDefaultProb(Alist: TStringList; prob: string);
703var
704 Today: string;
705
706 function Permanent: char;
707 begin
708 // =================== changed code - REV 7/30/98 =========================
709 // PlUser.usVerifyTranscribed is a SITE requirement, not a USER ability
710 if PlUser.usVerifyTranscribed and not PlUser.usPrimeUser then
711 result:='T'
712 else
713 result:='P';
714 //===========================================================================
715 { if PLUser.usPrimeUser or (PlUser.usVerifyTranscribed) then
716 result:='P'
717 else
718 result:='T';}
719 end;
720
721begin {BODY }
722 Today := PLPt.Today;
723 if Piece(prob, u, 4) <> '' then
724 alist.add('NEW' + v + '.01' + v +Piece(prob, u, 4) + u + Piece(prob, u, 3))
725 else
726 alist.add('NEW' + v + '.01' + v + u); {no icd code}
727 {Leave ien of .05 undefined - let host save routine compute it}
728 alist.add('NEW' + v + '.05' + v + u + Piece(prob,u,2));{actual text}
729 alist.add('NEW' + v + '.06' + v + PLPt.PtVAMC);
730 alist.add('NEW' + v + '.08' + v + Today);
731 alist.add('NEW' + v + '.12' + v + 'A' + u + 'ACTIVE');
732 alist.add('NEW' + v + '.13' + v + '');
733 alist.add('NEW' + v + '1.01' + v + Piece(prob,u,1) + u + Piece(prob,u,2));{standardized text}
734 alist.add('NEW' + v + '1.02' + v + Permanent); {Permanent or Transcribed status}
735 alist.add('NEW' + v + '1.03' + v + inttostr(Encounter.Provider) + u + Encounter.Providername); {ent by}
736 alist.add('NEW' + v + '1.04' + v + inttostr(Encounter.Provider) + u + Encounter.Providername); {recording prov}
737 alist.add('NEW' + v + '1.05' + v + inttostr(Encounter.Provider) + u + Encounter.Providername); {resp prov}
738 alist.add('NEW' + v + '1.06' + v + PLUser.usService); {user's service/section}
739 alist.add('NEW' + v + '1.07' + v + '');
740 alist.add('NEW' + v + '1.08' + v + '') ;{IntToStr(Encounter.Location));}
741 alist.add('NEW' + v + '1.09' + v + Today);
742 alist.add('NEW' + v + '1.1' + v + '0' + u + 'NO'); {SC}
743 alist.add('NEW' + v + '1.11' + v + '0' + u + 'NO'); {AO}
744 alist.add('NEW' + v + '1.12' + v + '0' + u + 'NO'); {RAD}
745 alist.add('NEW' + v + '1.13' + v + '0' + u + 'NO'); {ENV}
746 alist.add('NEW' + v + '1.14' + v + '');
747end;
748
749
750function TfrmdlgProb.BadDates:Boolean;
751var
752 ds:string;
753 i:integer;
754
755 procedure Msg(msg: string);
756 begin
757// InfoBox('Dates must be in format m/d/y or m/d or y, or T+d or T-d' + <-- original line. //kt 7/24/2007
758 InfoBox(DKLangConstW('fProbEdt_Dates_must_be_in_format_mxdxy_or_mxd_or_yx_or_Txd_or_Txd') + //kt added 7/24/2007
759// #13#10 + msg + ' is formatted improperly.' + <-- original line. //kt 7/24/2007
760 #13#10 + msg + DKLangConstW('fProbEdt_is_formatted_improperlyx') + //kt added 7/24/2007
761// #13#10 + ' Please check the other dates as well.', <-- original line. //kt 7/24/2007
762 #13#10 + DKLangConstW('fProbEdt_Please_check_the_other_dates_as_wellx'), //kt added 7/24/2007
763// 'Information', MB_OK or MB_ICONINFORMATION); <-- original line. //kt 7/24/2007
764 DKLangConstW('fProbEdt_Information'), MB_OK or MB_ICONINFORMATION); //kt added 7/24/2007
765 end;
766begin
767 result:=True; {initialize for error condition}
768 if edRecDate.text <>'' then
769 begin
770 ds:=DateStringOk(edRecDate.text);
771 if ds = 'ERROR' then
772 begin
773// msg('Recorded'); <-- original line. //kt 7/24/2007
774 msg(DKLangConstW('fProbEdt_Recorded')); //kt added 7/24/2007
775 exit;
776 end;
777 end ;
778 if edResDate.text <>'' then
779 begin
780 ds:=DateStringOk(edResDate.text);
781 if ds = 'ERROR' then
782 begin
783// msg('Resolved'); <-- original line. //kt 7/24/2007
784 msg(DKLangConstW('fProbEdt_Resolved')); //kt added 7/24/2007
785 exit;
786 end;
787 end ;
788 if edOnsetDate.text <>'' then
789 begin
790 ds:=DateStringOk(edOnsetDate.text);
791 if ds = 'ERROR' then
792 begin
793// msg('Onset'); <-- original line. //kt 7/24/2007
794 msg(DKLangConstW('fProbEdt_Onset')); //kt added 7/24/2007
795 exit;
796 end;
797 if StrToFMDateTime(edOnsetDate.Text) > FMNow then
798 begin
799// InfoBox('Onset dates in the future are not allowed.', 'Information', MB_OK or MB_ICONINFORMATION); <-- original line. //kt 7/24/2007
800 InfoBox(DKLangConstW('fProbEdt_Onset_dates_in_the_future_are_not_allowedx'), DKLangConstW('fProbEdt_Information'), MB_OK or MB_ICONINFORMATION); //kt added 7/24/2007
801 Exit;
802 end;
803 end ;
804 for i:=0 to pred(lstComments.Items.Count) do
805 begin
806 if Piece(lstComments.Items[i],u,2)<>'' then {may have blank lines at bottom}
807 begin
808 ds:=DateStringOk(Piece(lstComments.Items[i],u,1));
809 if ds='ERROR' then
810 begin
811// msg('Comment #' + inttostr(i)); <-- original line. //kt 7/24/2007
812 msg(DKLangConstW('fProbEdt_Comment_x') + inttostr(i)); //kt added 7/24/2007
813 exit;
814 end;
815 end;
816 end;
817 result:=False; {made it through, so no bad dates}
818end;
819
820procedure TfrmdlgProb.ControlChange(Sender: TObject);
821begin
822 fChanged:=true;
823end;
824
825destructor TfrmdlgProb.Destroy;
826begin
827 ProbRec.free;
828 ProbRec := nil;
829 FCtrlMap.Free;
830 if fprobs.dlgProbs <> nil then fprobs.dlgProbs := nil;
831 if (not Application.Terminated) and (not uInit.TimedOut) then {prevents GPF if system close box is clicked
832 while frmDlgProbs is visible}
833 if Assigned(frmProblems) then PostMessage(frmProblems.Handle, UM_CLOSEPROBLEM, 0, 0);
834 inherited Destroy ;
835end;
836
837procedure TfrmdlgProb.cbProvDropDown(Sender: TObject);
838var
839 alist:TstringList;
840 i:integer;
841 v:string;
842begin
843 v := uppercase(cbProv.text);
844 if (v <> '') then
845 begin
846 alist := TstringList.create;
847 try
848 AList.Assign(ProviderList('',25,V,V)) ;
849 if alist.count > 0 then
850 begin
851 if cbProv.items.count + 25 > 100 then
852 for i := 0 to 75 do {don't allow more than 100 to build up}
853 cbProv.Items.delete(i);
854 for i := 0 to pred(alist.count) do
855 cbProv.Items.add(Alist[i]); {add new ones to list}
856 end;
857 finally
858 alist.free;
859 end;
860 end;
861end;
862
863procedure TfrmdlgProb.cbLocDropDown(Sender: TObject);
864var
865 alist: TstringList;
866 v: string;
867begin
868 v := uppercase(cbLoc.text);
869 alist := TstringList.create;
870 try
871 AList.Assign(ClinicSearch(' ')) ;
872 if alist.count > 0 then cbLoc.Items.assign(Alist);
873 finally
874 alist.free;
875 end;
876end;
877
878procedure TfrmdlgProb.FormCreate(Sender: TObject);
879begin
880 FSilent := False;
881 if rgStatus.ItemIndex = -1
882 then
883 InitialFocus := rgStatus
884 else
885 InitialFocus := rgStatus.Controls[rgStatus.ItemIndex] as TWinControl;
886end;
887
888{ old TPLDlgForm Methods }
889
890constructor TfrmdlgProb.Create(AOwner: TComponent);
891{ It is unusual to not call the inherited Create first, but necessary in this case; some
892 of the TMStruct objects need to be created before the form gets its OnCreate event. }
893begin
894 FCtrlMap := TStringList.Create; { FCtrlMap[n]='CtrlName=PtrID' }
895 inherited Create(AOwner);
896 FInitialShow := True;
897 FModified := False;
898 FEditing := False;
899end;
900
901procedure TfrmdlgProb.CreateParams(var Params: TCreateParams);
902begin
903 inherited CreateParams(Params);
904 { to make the form a child window }
905 with Params do
906 begin
907 if Owner is TPanel then
908 WndParent := (Owner as TPanel).Handle
909 else {pdr}
910 WndParent := Application.MainForm.Handle;
911 Style := ws_Child or ws_ClipSiblings;
912 X := 0;
913 Y := 0;
914 end;
915end;
916
917procedure TfrmdlgProb.Loaded;
918begin
919 inherited Loaded;
920 { allow the form to be treated as a child form }
921 Visible := False;
922 Position := poDefault;
923 BorderIcons := [];
924 BorderStyle := bsNone;
925 HandleNeeded;
926end;
927
928procedure TfrmdlgProb.DoShow;
929begin
930 FInitialShow := False;
931 inherited DoShow;
932end;
933
934procedure TfrmdlgProb.SetFontSize( NewFontSize: integer);
935begin
936 ResizeAnchoredFormToFont( self );
937end;
938
939{ base form procedures (shared by all ordering dialogs) }
940
941
942procedure TfrmdlgProb.ClearDialogControls; { Reset all the controls in the dialog }
943var
944 i: Integer;
945begin
946 for i := 0 to ControlCount - 1 do
947 begin
948 if Controls[i] is TLabel then Continue;
949 if Controls[i] is TButton then Continue;
950 end;
951 LoadDefaults; { added for lab to reset cleared lists }
952end;
953
954procedure TfrmdlgProb.LoadDefaults;
955begin
956 { by default nothing - should override in specific dialog }
957end;
958
959
960
961function TfrmdlgProb.LackRequired: Boolean;
962begin
963 Result := False; { should override to check for additional required fields }
964end;
965
966
967procedure TfrmdlgProb.UMTakeFocus(var Message: TMessage);
968begin
969 if FInitialFocus = nil then exit; {PDR}
970 if (FInitialFocus.visible) and (FInitialFocus.enabled) then FInitialFocus.SetFocus;
971end;
972
973procedure TfrmdlgProb.bbChangeProbClick(Sender: TObject);
974const
975 TX799 = '799.9';
976var
977 newprob: string ;
978 frmPLLex: TfrmPLLex;
979begin
980 if PLUser.usUseLexicon then
981 begin
982 frmPLLex:=TfrmPLLex.create(Application);
983 try
984 frmPLLex.showmodal;
985 finally
986 frmPLLex.Free;
987 end;
988 end
989 else
990 begin
991// PLProblem := InputBox('Change problem','Enter new problem name: ','') ; <-- original line. //kt 7/24/2007
992 PLProblem := InputBox(DKLangConstW('fProbEdt_Change_problem'),DKLangConstW('fProbEdt_Enter_new_problem_namex'),'') ; //kt added 7/24/2007
993 if PLProblem<>'' then
994 PLProblem := u + PLProblem + u + TX799 + u
995 else
996 exit ;
997 end ;
998
999 {problems are in the form of: ien^.01^icd^icdifn , although only the .01 is required}
1000 if PLProblem='' then exit ;
1001 newprob := PLProblem ;
1002 if frmProblems.HighlightDuplicate(NewProb, Piece(newprob, U, 2) + #13#10#13#10 +
1003// 'This problem would be a duplicate.'+#13#10 + <-- original line. //kt 7/24/2007
1004 DKLangConstW('fProbEdt_This_problem_would_be_a_duplicatex')+#13#10 + //kt added 7/24/2007
1005// 'Return to the list and see the highlighted problem.', <-- original line. //kt 7/24/2007
1006 DKLangConstW('fProbEdt_Return_to_the_list_and_see_the_highlighted_problemx'), //kt added 7/24/2007
1007 mtInformation, 'CHANGE') then
1008 exit {bail out - don't want dups}
1009 else
1010 begin
1011 {ien^.01^icd^icdifn - see SetDefaultProblem}
1012 {Set new problem properties}
1013 ProbRec.Problem.DHCPtoKeyVal(Piece(NewProb,u,1) + u + Piece(NewProb,u,2)) ; {1.01}
1014 ProbRec.Diagnosis.DHCPtoKeyVal(Piece(NewProb,u,4) + u + Piece(NewProb,u,3)) ; {.01}
1015 ProbRec.Narrative.DHCPtoKeyVal(u + Piece(NewProb,u,2)); {.05}
1016
1017 {mark it as changed}
1018 fchanged := true ;
1019
1020 {Redraw heading}
1021 if Piece(NewProb,u,3)<>'' then
1022 edProb.Text:=Piece(NewProb,u,2) + ' (' + Piece(NewProb,u,3) + ')'
1023 else
1024 edProb.Text:=Piece(NewProb,u,2) + ' (799.9)'; {code not found, or free-text entry}
1025 end ;
1026end ;
1027
1028procedure TfrmdlgProb.cbLocNeedData(Sender: TObject; const StartFrom: String;
1029 Direction, InsertAt: Integer);
1030begin
1031 cbLoc.ForDataUse(SubSetOfClinics(StartFrom, Direction));
1032end;
1033
1034procedure TfrmdlgProb.cbProvNeedData(Sender: TObject; const StartFrom: String;
1035 Direction, InsertAt: Integer);
1036begin
1037 cbProv.ForDataUse(SubSetOfProviders(StartFrom, Direction));
1038end;
1039
1040procedure TfrmdlgProb.cbServNeedData(Sender: TObject; const StartFrom: String;
1041 Direction, InsertAt: Integer);
1042begin
1043 cbServ.ForDataUse(ServiceSearch(StartFrom, Direction));
1044end;
1045
1046end.
Note: See TracBrowser for help on using the repository browser.