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

Last change on this file since 1147 was 460, checked in by Kevin Toppenberg, 17 years ago

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