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

Last change on this file since 1602 was 830, checked in by Kevin Toppenberg, 14 years ago

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