source: cprs/branches/foia-cprs/CPRS-Chart/fProbEdt.pas@ 459

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

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