source: cprs/trunk/CPRS-Chart/fProbEdt.pas@ 1800

Last change on this file since 1800 was 1679, checked in by healthsevak, 10 years ago

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