Module

fProbEdt

Path

C:\CPRS\CPRS30\fProbEdt.pas

Last Modified

7/15/2014 3:26:38 PM

Initialization Code

initialization
  SpecifyFormIsNotADialog(TfrmdlgProb);

end.

Units Used in Interface

Name Comments
fBase508Form -
uConst -
uCore -

Units Used in Implementation

Name Comments
fCover -
fProbCmt -
fProbLex -
fProbs -
rCore -
rCover -
rOrders -
rPCE -
rProbs -
uInit -
uProbs -

Classes

Name Comments
TDialogItem For loading edits & quick orders
TfrmdlgProb -

Procedures

Name Owner Declaration Scope Comments
bbAddComClick TfrmdlgProb procedure bbAddComClick(Sender: TObject); Public/Published -
bbChangeProbClick TfrmdlgProb procedure bbChangeProbClick(Sender: TObject); Public/Published -
bbEditClick TfrmdlgProb procedure bbEditClick(Sender: TObject); Public/Published -
bbFileClick TfrmdlgProb procedure bbFileClick(Sender: TObject); Public/Published --------------------------------- file ---------------------------------
bbQuitClick TfrmdlgProb procedure bbQuitClick(Sender: TObject); Public/Published -
bbRemoveClick TfrmdlgProb procedure bbRemoveClick(Sender: TObject); Public/Published -
cbLocClick TfrmdlgProb procedure cbLocClick(Sender: TObject); Public/Published -
cbLocDropDown TfrmdlgProb procedure cbLocDropDown(Sender: TObject); Public/Published -
cbLocKeyPress TfrmdlgProb procedure cbLocKeyPress(Sender: TObject; var Key: Char); Public/Published -
cbLocNeedData TfrmdlgProb procedure cbLocNeedData(Sender: TObject; const StartFrom: String; Direction, InsertAt: Integer); Public/Published -
cbProvClick TfrmdlgProb procedure cbProvClick(Sender: TObject); Public/Published -
cbProvDropDown TfrmdlgProb procedure cbProvDropDown(Sender: TObject); Public/Published -
cbProvKeyPress TfrmdlgProb procedure cbProvKeyPress(Sender: TObject; var Key: Char); Public/Published -
cbProvNeedData TfrmdlgProb procedure cbProvNeedData(Sender: TObject; const StartFrom: String; Direction, InsertAt: Integer); Public/Published -
cbServNeedData TfrmdlgProb procedure cbServNeedData(Sender: TObject; const StartFrom: String; Direction, InsertAt: Integer); Public/Published -
ckNSCClick TfrmdlgProb procedure ckNSCClick(Sender: TObject); Public/Published -
ckTreatments TfrmdlgProb procedure ckTreatments(value: String; ckBox: Integer); Public/Published
Used to set the checkboxes in order to properly set yes and no boxes
   Send How ckbox should be set and which box
   Value -> 1 Set to Yes, 2 Set to No, 0 Set Unknown
   ckBox:
     0 -> Service Connected
     1 -> Agent Orange
     2 -> Radiation
     3 -> Southwest Asia Conditions
     4 -> Shipboard Hazard and Defense
     5 -> MST
     6 -> Head and/or Neck Cancer
ClearDialogControls TfrmdlgProb procedure ClearDialogControls; virtual; Protected
Base form procedures (shared by all ordering dialogs) 

 Reset all the controls in the dialog
ControlChange TfrmdlgProb procedure ControlChange(Sender: TObject); Public/Published -
CreateParams TfrmdlgProb procedure CreateParams(var Params: TCreateParams); override; Protected -
DoShow TfrmdlgProb procedure DoShow; override; Protected -
FormClose TfrmdlgProb procedure FormClose(Sender: TObject; var Action: TCloseAction); Public/Published -
FormCreate TfrmdlgProb procedure FormCreate(Sender: TObject); Public/Published -
FormShow TfrmdlgProb procedure FormShow(Sender: TObject); Public/Published -
GetEditedComments TfrmdlgProb procedure GetEditedComments; Private -
GetNewComments TfrmdlgProb procedure GetNewComments(Reason:char); Private -
LoadDefaults TfrmdlgProb procedure LoadDefaults; virtual; Protected -
Loaded TfrmdlgProb procedure Loaded; override; Protected -
Msg - procedure Msg(msg: string); Local -
rgStatusClick TfrmdlgProb procedure rgStatusClick(Sender: TObject); Public/Published -
rgStatusEnter TfrmdlgProb procedure rgStatusEnter(Sender: TObject); Public/Published -
SetDefaultProb TfrmdlgProb procedure SetDefaultProb(Alist:TstringList;prob:string); Public/Published -
SetFontSize TfrmdlgProb procedure SetFontSize( NewFontSize: integer); Public -
ShowClinicLocationCombo TfrmdlgProb procedure ShowClinicLocationCombo; Private -
ShowComments TfrmdlgProb procedure ShowComments; Private -
ShowServiceCombo TfrmdlgProb procedure ShowServiceCombo; Private -
UMTakeFocus TfrmdlgProb procedure UMTakeFocus(var Message: TMessage); message UM_TAKEFOCUS; Private -

Functions

Name Owner Declaration Scope Comments
BadDates TfrmdlgProb function BadDates:Boolean; Public/Published -
LackRequired TfrmdlgProb function LackRequired: Boolean; virtual; Protected -
OkToQuit TfrmdlgProb function OkToQuit:boolean; Private -
Permanent - function Permanent: char; Local -
TreatmentsCked TfrmdlgProb function TreatmentsCked(ckBox: Integer):String; Public/Published
Return 1 for checked 0 for not checked, and '' for unknown
  ckBox:
     0 -> Service Connected
     1 -> Agent Orange
     2 -> Radiation
     3 -> Southwest Asia Conditions
     4 -> Shipboard Hazard and Defense
     5 -> MST
     6 -> Head and/or Neck Cancer

Constants

Name Declaration Scope Comments
SOC_QUIT 1 { close single dialog } Interfaced Close single dialog


Module Source

1     unit fProbEdt;
2     
3     interface
4     
5     uses
6       SysUtils, windows, Messages, Classes, Graphics, Controls,
7       Forms, Dialogs, StdCtrls, Buttons, ExtCtrls, Grids,
8       ORCtrls, Vawrgrid, uCore, Menus, uConst, fBase508Form,
9       VA508AccessibilityManager;
10    
11    const
12      SOC_QUIT = 1;        { close single dialog }
13    
14    type
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        ckYSC: TCheckBox;
41        ckYRad: TCheckBox;
42        ckYAO: TCheckBox;
43        ckYENV: TCheckBox;
44        ckYHNC: TCheckBox;
45        ckYMST: TCheckBox;
46        ckYSHAD: TCheckBox;
47        ckNSC: TCheckBox;
48        ckNRad: TCheckBox;
49        ckNAO: TCheckBox;
50        ckNENV: TCheckBox;
51        ckNHNC: TCheckBox;
52        ckNMST: TCheckBox;
53        ckNSHAD: TCheckBox;
54        ckVerify: TCheckBox;
55        edRecDate: TCaptionEdit;
56        cbServ: TORComboBox;
57        cbLoc: TORComboBox;
58        lblLoc: TLabel;
59        cbProv: TORComboBox;
60        Label3: TLabel;
61        edOnsetdate: TCaptionEdit;
62        Label6: TLabel;
63        procedure bbQuitClick(Sender: TObject);
64        procedure bbAddComClick(Sender: TObject);
65        procedure FormShow(Sender: TObject);
66        procedure FormClose(Sender: TObject; var Action: TCloseAction);
67        procedure bbFileClick(Sender: TObject);
68        procedure bbRemoveClick(Sender: TObject);
69        procedure cbProvKeyPress(Sender: TObject; var Key: Char);
70        procedure rgStatusClick(Sender: TObject);
71        procedure cbProvClick(Sender: TObject);
72        procedure cbLocClick(Sender: TObject);
73        procedure cbLocKeyPress(Sender: TObject; var Key: Char);
74        procedure SetDefaultProb(Alist:TstringList;prob:string);
75        procedure ControlChange(Sender: TObject);
76        function  BadDates:Boolean;
77        procedure cbProvDropDown(Sender: TObject);
78        procedure cbLocDropDown(Sender: TObject);
79        procedure FormCreate(Sender: TObject);
80        procedure bbChangeProbClick(Sender: TObject);
81        procedure cbLocNeedData(Sender: TObject; const StartFrom: String;
82          Direction, InsertAt: Integer);
83        procedure cbProvNeedData(Sender: TObject; const StartFrom: String;
84          Direction, InsertAt: Integer);
85        procedure cbServNeedData(Sender: TObject; const StartFrom: String;
86          Direction, InsertAt: Integer);
87        procedure bbEditClick(Sender: TObject);
88        procedure ckTreatments(value: String; ckBox: Integer);
89        function  TreatmentsCked(ckBox: Integer):String;
90        procedure ckNSCClick(Sender: TObject);
91        procedure rgStatusEnter(Sender: TObject);
92      private
93        { Private declarations }
94        FEditing: Boolean;
95        FInitialShow: Boolean;
96        FModified: Boolean;
97        FProviderID: Int64;
98        FLocationID: Longint;
99        FDisplayGroupID: Integer;
100       FInitialFocus: TWinControl;
101       FCtrlMap: TStringList;
102       FSourceOfClose: Integer;
103       FOnInitiate: TNotifyEvent;
104       fChanged:boolean;
105       FSilent: boolean;
106       FCanQuit: boolean;
107       FSearchString: String;
108   
109       procedure UMTakeFocus(var Message: TMessage); message UM_TAKEFOCUS;
110       procedure ShowComments;
111       procedure GetEditedComments;
112       procedure GetNewComments(Reason:char);
113       function  OkToQuit:boolean;
114       procedure ShowServiceCombo;
115       procedure ShowClinicLocationCombo;
116     protected
117       procedure CreateParams(var Params: TCreateParams); override;
118       procedure DoShow; override;
119       procedure Loaded; override;
120       procedure ClearDialogControls; virtual;
121       function  LackRequired: Boolean; virtual;
122       procedure LoadDefaults; virtual;
123       property  InitialFocus: TWinControl read FInitialFocus write FInitialFocus;
124     public
125       { Public declarations }
126       Reason:Char;
127       problemIFN:String;
128       subjProb:string; {parameters for problem being added}
129       constructor Create(AOwner: TComponent); override ;
130       destructor Destroy; override;
131       property DisplayGroupID: Integer read FDisplayGroupID write FDisplayGroupID;
132       property Editing: Boolean read FEditing write FEditing;
133       property Silent: Boolean read FSilent write FSilent;
134       property ProviderID: Int64 read FProviderID write FProviderID;
135       property LocationID: Longint read FLocationID write FLocationID;
136       property SourceOfClose: Integer read FSourceOfClose write FSourceOfClose;
137       property OnInitiate: TNotifyEvent read FOnInitiate write FOnInitiate;
138       procedure SetFontSize( NewFontSize: integer);
139       property CanQuit: boolean read FCanQuit write FCanQuit;
140     end ;
141   
142   implementation
143   
144   {$R *.DFM}
145   
146   uses ORFn, uProbs, fProbs, rProbs, fCover, rCover, rCore, rOrders, fProbCmt, fProbLex, rPCE, uInit  ,
147        VA508AccessibilityRouter;
148   
149   type
150     TDialogItem = class { for loading edits & quick orders }
151       ControlName: string;
152       DialogPtr: Integer;
153       Instance: Integer;
154     end;
155   
156   function TfrmdlgProb.OkToQuit:boolean;
157   begin
158     Result := not fChanged;
159   end;
160   
161   procedure TfrmdlgProb.bbQuitClick(Sender: TObject);
162   begin
163     if OkToQuit then
164       begin
165         frmProblems.lblProbList.caption := frmProblems.pnlRight.Caption ;
166         frmProblems.wgProbData.TabStop := True; //CQ #15531 part (c) [CPRS v28.1] {TC}.
167         //correct JAWS from reading the 'Edit Problem' caption of the wgProbData captionlistbx.
168         if AnsiCompareText(frmProblems.wgProbData.Caption, 'Edit Problem')=0 then
169            frmProblems.wgProbData.Caption := frmProblems.lblProbList.caption;
170         close;
171       end
172     else
173       begin
174         if (not FSilent) and
175            (InfoBox('Discard changes?', 'Add/Edit a Problem', MB_YESNO or MB_ICONQUESTION) <> IDYES) then
176           begin
177             FCanQuit := False;
178             exit;
179           end
180         else
181           begin
182             frmProblems.lblProbList.caption := frmProblems.pnlRight.Caption ;
183             frmProblems.wgProbData.TabStop := True; //CQ #15531 part (c) [CPRS v28.1] {TC}.
184             //correct JAWS from reading the 'Edit Problem' caption of the wgProbData captionlistbx.
185             if AnsiCompareText(frmProblems.wgProbData.Caption, 'Edit Problem')=0 then
186                frmProblems.wgProbData.Caption := frmProblems.lblProbList.caption;
187             FCanQuit := True;
188             close;
189           end;
190       end;
191   end;
192   
193   procedure TfrmdlgProb.bbAddComClick(Sender: TObject);
194   var
195     cmt: string    ;
196   begin
197     cmt := NewComment ;
198     if StrToInt(Piece(cmt, U, 1)) > 0 then
199       begin
200         lstComments.Items.Add(Pieces(cmt, U, 2, 3)) ;
201         fChanged := true;
202       end ;
203   end;
204   
205   procedure TfrmdlgProb.bbEditClick(Sender: TObject);
206   var
207     cmt: string    ;
208   begin
209     if lstComments.ItemIndex < 0 then Exit;
210     cmt := EditComment(lstComments.Items[lstComments.ItemIndex]) ;
211     if StrToInt(Piece(cmt, U, 1)) > 0 then
212       begin
213         lstComments.Items[lstComments.ItemIndex] := Pieces(cmt, U, 2, 3) ;
214         fChanged := true;
215       end ;
216   end;
217   
218   procedure TfrmdlgProb.ckNSCClick(Sender: TObject);
219   var
220     ChkBoxName :string;
221   begin
222     inherited;
223     fChanged:=true;
224     ChkBoxName := AnsiUpperCase(TCheckBox(Sender).Name);
225     if (ChkBoxName = 'CKYSC') and TCheckBox(Sender).Checked then ckNSC.Checked := not ckYSC.Checked;
226     if (ChkBoxName = 'CKNSC') and TCheckBox(Sender).Checked then ckYSC.Checked := not ckNSC.Checked;
227     if (ChkBoxName = 'CKYAO') then ckNAO.Checked := not ckYAO.Checked;
228     if (ChkBoxName = 'CKNAO') then ckYAO.Checked := not ckNAO.Checked;
229     if (ChkBoxName = 'CKYRAD') then ckNRAD.Checked := not ckYRAD.Checked;
230     if (ChkBoxName = 'CKNRAD') then ckYRAD.Checked := not ckNRAD.Checked;
231     if (ChkBoxName = 'CKYENV') then ckNENV.Checked := not ckYENV.Checked;
232     if (ChkBoxName = 'CKNENV') then ckYENV.Checked := not ckNENV.Checked;
233     if (ChkBoxName = 'CKYSHAD') then ckNSHAD.Checked := not ckYSHAD.Checked;
234     if (ChkBoxName = 'CKNSHAD') then ckYSHAD.Checked := not ckNSHAD.Checked;
235     if (ChkBoxName = 'CKYMST') then ckNMST.Checked := not ckYMST.Checked;
236     if (ChkBoxName = 'CKNMST') then ckYMST.Checked := not ckNMST.Checked;
237     if (ChkBoxName = 'CKYHNC') then ckNHNC.Checked := not ckYHNC.Checked;
238     if (ChkBoxName = 'CKNHNC') then ckYHNC.Checked := not ckNHNC.Checked;
239   end;
240   
241   procedure TfrmdlgProb.ckTreatments(value: String; ckBox: Integer);
242   { Used to set the checkboxes in order to properly set yes and no boxes
243      Send How ckbox should be set and which box
244      Value -> 1 Set to Yes, 2 Set to No, 0 Set Unknown
245      ckBox:
246        0 -> Service Connected
247        1 -> Agent Orange
248        2 -> Radiation
249        3 -> Southwest Asia Conditions
250        4 -> Shipboard Hazard and Defense
251        5 -> MST
252        6 -> Head and/or Neck Cancer
253   }
254   Var
255    yptr,nptr :^TCheckBox;
256   begin
257     case ckBox of
258       0 : begin
259             //Sevice Connected
260             yptr := @ckYSC;
261             nptr := @ckNSC;
262           end;
263       1 : begin
264             //Agent Orange
265             yptr := @ckYAO;
266             nptr := @ckNAO;
267           end;
268       2 : begin
269             //Radiation
270             yptr := @ckYRAD;
271             nptr := @ckNRAD;
272           end;
273       3 : begin
274             //Southwest Asia Conditions
275             yptr := @ckYENV;
276             nptr := @ckNENV;
277           end;
278       4 : begin
279             //Shipboard Hazard and Defense
280             yptr := @ckYSHAD;
281             nptr := @ckNSHAD;
282           end;
283       5 : begin
284             //MST
285             yptr := @ckYMST;
286             nptr := @ckNMST;
287           end;
288       6 : begin
289             //Head and/or Neck Cancer
290             yptr := @ckYHNC;
291             nptr := @ckNHNC;
292           end;
293       else begin
294              Exit;
295            end;
296     end;
297   
298     if Value = '1' then  // Yes is selected
299     begin
300        TCheckBox(yptr^).Checked := True;
301        TCheckBox(nptr^).Checked := False;
302     end
303     else if value = '0' then  // No is selected
304     begin
305        TCheckBox(yptr^).Checked := False;
306        TCheckBox(nptr^).Checked := True;
307     end
308     else  //Unknown
309     begin
310        TCheckBox(yptr^).Checked := False;
311        TCheckBox(nptr^).Checked := False;
312     end;
313   
314   end;
315   
316   function TfrmdlgProb.TreatmentsCked(ckBox: Integer):String;
317   { Return 1 for checked 0 for not checked, and '' for unknown
318     ckBox:
319        0 -> Service Connected
320        1 -> Agent Orange
321        2 -> Radiation
322        3 -> Southwest Asia Conditions
323        4 -> Shipboard Hazard and Defense
324        5 -> MST
325        6 -> Head and/or Neck Cancer
326   }
327   Var
328    yptr,nptr :^TCheckBox;
329   begin
330     case ckBox of
331       0 : begin
332             //Sevice Connected
333             yptr := @ckYSC;
334             nptr := @ckNSC;
335           end;
336       1 : begin
337             //Agent Orange
338             yptr := @ckYAO;
339             nptr := @ckNAO;
340           end;
341       2 : begin
342             //Radiation
343             yptr := @ckYRAD;
344             nptr := @ckNRAD;
345           end;
346       3 : begin
347             //Southwest Asia Conditions
348             yptr := @ckYENV;
349             nptr := @ckNENV;
350           end;
351       4 : begin
352             //Shipboard Hazard and Defense
353             yptr := @ckYSHAD;
354             nptr := @ckNSHAD;
355           end;
356       5 : begin
357             //MST
358             yptr := @ckYMST;
359             nptr := @ckNMST;
360           end;
361       6 : begin
362             //Head and/or Neck Cancer
363             yptr := @ckYHNC;
364             nptr := @ckNHNC;
365           end;
366       else begin
367              Result := '';
368              Exit;
369            end;
370   
371     end;
372       if TCheckBox(yptr^).Checked then Result := '1'
373       else if TCheckBox(nptr^).Checked then Result := '0'
374       else Result := '';
375   end;
376   
377   
378   procedure TfrmdlgProb.FormShow(Sender: TObject);
379   var
380     alist: TstringList;
381     Anchorses: Array of TAnchors;
382     i: integer;
383   begin
384     if ProbRec <> nil then exit;
385     if (ResizeWidth(Font,MainFont,Width) >= Parent.ClientWidth) and
386       (ResizeHeight(Font,MainFont,Height) >= Parent.ClientHeight) then
387     begin  //This form won't fit when it resizes, so we have to take Drastic Measures
388       SetLength(Anchorses, dlgProbs.ControlCount);
389       for i := 0 to ControlCount - 1 do
390       begin
391         Anchorses[i] := Controls[i].Anchors;
392         Controls[i].Anchors := [akLeft, akTop];
393       end;
394       SetFontSize(MainFontSize);
395       RequestAlign;
396       for i := 0 to ControlCount - 1 do
397         Controls[i].Anchors := Anchorses[i];
398     end
399     else
400     begin
401       SetFontSize(MainFontSize);
402       RequestAlign;
403     end;
404     frmProblems.mnuView.Enabled := False;
405     frmProblems.mnuAct.Enabled := False ;
406     frmProblems.lstView.Enabled := False;
407     frmProblems.bbNewProb.Enabled := False ;
408     Alist := TstringList.create;
409     try
410       if Reason = 'E' then
411         lblact.caption := 'Editing:'
412       else if Reason = 'A' then
413         lblact.caption := 'Adding'
414       else {display, comment edit or remove problem}
415         begin
416           case reason of 'C','c': lblact.caption := 'Comment Edit';
417                          'R','r': lblact.caption := 'Remove Problem:';
418           end; {case}
419           {ckVerify.Enabled:=false;}
420           cbProv.Enabled       := false;
421           cbLoc.Enabled        := false;
422           bbRemove.enabled     := false;
423           rgStatus.Enabled     := false;
424           rgStage.Enabled      := false;
425           edRecdate.enabled    := false;
426           edResdate.enabled    := false;
427           edOnsetDate.enabled  := false;
428           ckYSC.enabled         := false;
429           ckYRAD.enabled        := false;
430           ckYAO.enabled         := false;
431           ckYENV.enabled        := false;
432           ckYHNC.enabled        := false;
433           ckYMST.enabled        := false;
434           ckYSHAD.enabled       := false;
435           ckNSC.enabled         := false;
436           ckNRAD.enabled        := false;
437           ckNAO.enabled         := false;
438           ckNENV.enabled        := false;
439           ckNHNC.enabled        := false;
440           ckNMST.enabled        := false;
441           ckNSHAD.enabled       := false;
442           if Reason = 'R' then bbFile.caption := 'Remove';
443         end;
444       edProb.Caption := lblact.Caption;
445       edProb.Text := Piece(subjProb, u, 2);
446   
447       if Piece(subjProb, '|', 2) <> '' then
448         FSearchString := Piece(subjProb, '|', 2);
449   
450       {line up problem action and title}
451       {edProb.Left:=lblAct.left+lblAct.width+2;}
452       {get problem}
453       if Reason <> 'A' then
454         begin {edit,remove or display existing problem}
455           problemIFN := Piece(subjProb, u, 1);
456           FastAssign(EditLoad(ProblemIFN, User.DUZ, PLPt.ptVAMC), AList) ;   //V17.5   RV
457         end
458       else {new  problem}
459         SetDefaultProb(Alist, subjProb);
460       if Alist.count = 0 then
461         begin
462           InfoBox('No Data on Host for problem ' + ProblemIFN, 'Information', MB_OK or MB_ICONINFORMATION);
463           close;
464           exit;
465         end;
466       ProbRec := TProbRec.Create(Alist); {create a problem object}
467       ProbRec.PIFN := ProblemIFN;
468       ProbRec.EnteredBy.DHCPtoKeyVal(inttostr(User.DUZ) + u + User.Name);
469       ProbRec.RecordedBy.DHCPtoKeyVal(inttostr(Encounter.Provider) + u + Encounter.ProviderName);
470       {fill in defaults}
471       edOnsetdate.text := ProbRec.DateOnsetStr;
472       if Probrec.status <> 'A' then
473         begin
474           rgStatus.itemindex := 1;
475           rgStage.Visible := False ;
476         end;
477       if Probrec.Priority = 'A' then
478         rgStage.itemindex := 0
479       else if Probrec.Priority = 'C' then
480         rgStage.itemindex := 1
481       else
482         rgStage.itemindex := 2;
483       rgStatus.TabStop := (rgStatus.ItemIndex = -1);
484       rgStage.TabStop := (rgStage.ItemIndex = -1);
485       edRecDate.text := Probrec.DateRecStr;
486       edUpdate.text := Probrec.DateModStr;
487       edResDate.text := ProbRec.DateResStr;
488       edUpdate.enabled := false;
489       if pos(Reason,'CR') = 0 then
490         with PLPt do
491           begin
492             if PtServiceConnected then
493             begin
494               ckYSC.Enabled := True;
495               ckNSC.Enabled := True;
496               ckTreatments(ProbRec.SCProblem,0);
497             end
498             else
499             begin
500               ckYSC.Enabled := False;
501               ckNSC.Enabled := False;
502             end;
503   
504             if PtAgentOrange then
505             begin
506               ckYAO.Enabled := True;
507               ckNAO.Enabled := True;
508               ckTreatments(ProbRec.AOProblem,1);
509             end
510             else
511             begin
512               ckYAO.Enabled := False;
513               ckNAO.Enabled := False;
514             end;
515   
516             if PtRadiation then
517             begin
518               ckYRad.Enabled := True;
519               ckNRad.Enabled := True;
520               ckTreatments(Probrec.RADProblem,2);
521             end
522             else
523             begin
524               ckYRad.Enabled := False;
525               ckNRad.Enabled := False;
526             end;
527   
528             if PtEnvironmental then
529             begin
530               ckYENV.Enabled := True;
531               ckNENV.Enabled := True;
532               ckTreatments(ProbRec.ENVProblem,3);
533             end
534             else
535             begin
536               ckYENV.Enabled := False;
537               ckNENV.Enabled := False;
538             end;
539   
540             if PtSHAD then
541             begin
542               ckYSHAD.Enabled := True;
543               ckNSHAD.Enabled := True;
544               ckTreatments(ProbRec.SHADProlem,4);
545             end
546             else
547             begin
548               ckYSHAD.Enabled := False;
549               ckNSHAD.Enabled := False;
550             end;
551   
552             if PtMST then
553             begin
554               ckYMST.Enabled := True;
555               ckNMST.Enabled := True;
556               ckTreatments(ProbRec.MSTProblem,5);
557             end
558             else
559             begin
560               ckYMST.Enabled := False;
561               ckNMST.Enabled := False;
562             end;
563   
564             if PtHNC then
565             begin
566               ckYHNC.Enabled := True;
567               ckNHNC.Enabled := True;
568               ckTreatments(ProbRec.HNCProblem,6);
569             end
570             else
571             begin
572               ckYHNC.Enabled := False;
573               ckNHNC.Enabled := False;
574             end;
575           end ;
576   
577       {cbProv.InitLongList(ProbRec.RespProvider.extern) ;
578       if (ProbRec.RespProvider.intern <> '') and (StrToInt64Def(ProbRec.RespProvider.intern, 0) > 0) then
579         cbProv.SelectByIEN(StrToInt64(ProbRec.RespProvider.intern));}
580   
581       if (Encounter.Provider > 0) and PersonHasKey(Encounter.Provider, 'PROVIDER') then
582         begin
583           cbProv.InitLongList(Encounter.ProviderName);
584           cbProv.SelectByIEN(Encounter.Provider);
585         end
586       else cbProv.InitLongList('');
587   
588   
589       if UpperCase(Reason) = 'A' then
590         begin
591           if Encounter.Inpatient then
592             begin
593               ShowServiceCombo();
594               cbServ.InitLongList('');
595             end
596           else
597             begin
598               ShowClinicLocationCombo();
599               cbLoc.InitLongList(Encounter.LocationName);
600               cbLoc.SelectByIEN(Encounter.Location);
601             end;
602         end
603       else
604         begin
605           {if (ProbRec.Service.DHCPField = '^') and  (ProbRec.Clinic.DHCPField <> '^') then
606             begin
607               ShowClinicLocationCombo();
608               cbLoc.InitLongList(ProbRec.Clinic.Extern);
609               cbLoc.SelectByID(ProbRec.Clinic.Intern);
610             end
611           else if (ProbRec.Clinic.DHCPField = '^') and  (ProbRec.Service.DHCPField <> '^') then
612             begin
613               ShowServiceCombo();
614               cbServ.InitLongList(ProbRec.Service.Extern);
615               cbServ.SelectByID(ProbRec.Service.Intern);
616             end
617           else}
618           if Encounter.Inpatient then
619             begin
620               ShowServiceCombo();
621               cbServ.InitLongList('');
622             end
623           else if (Encounter.Location > 0) and IsClinicLoc(Encounter.Location) then
624             begin
625               ShowClinicLocationCombo();
626               cbLoc.InitLongList(Encounter.LocationName);
627               cbLoc.SelectByIEN(Encounter.Location);
628             end
629           else
630             begin
631               ShowClinicLocationCombo();
632               cbLoc.InitLongList('');
633             end;
634         end;
635       cbLoc.Caption := lblLoc.Caption;
636   
637       ShowComments;
638       if ProbRec.CmtIsXHTML then
639         begin
640           bbAdd.Enabled := FALSE;
641           bbEdit.Enabled := FALSE;
642           bbRemove.Enabled := FALSE;
643           pnlComments.Hint := ProbRec.CmtNoEditReason;
644         end
645       else
646         begin
647           bbAdd.Enabled := TRUE;
648           bbEdit.Enabled := TRUE;
649           bbRemove.Enabled := TRUE;
650           pnlComments.Hint := '';
651         end ;
652      // ===================  changed code - REV 7/30/98  =========================
653      // PlUser.usVerifyTranscribed is a SITE requirement, not a user ability
654       if Reason = 'A' then
655         begin
656           if PlUser.usVerifyTranscribed and not PlUser.usPrimeUser then
657             ckVerify.Checked := False
658           else
659             ckVerify.Checked := True;
660         end
661       else ckVerify.checked := (Probrec.condition = 'P');
662      //===========================================================================
663      (* if (PlUSer.usVerifyTranscribed) and (Reason='A') then
664         begin {some users can add and verify}
665           {ckVerify.visible:=true;}
666           ckVerify.checked:=true; {assume it will be entered verified}
667         end {others can add and edit verified status}
668       else if (PlUSer.usVerifyTranscribed) and (PlUser.usPrimeUser) then
669         begin
670           {ckVerify.visible:=true; }
671           ckVerify.checked:=(Probrec.condition='P');
672         end;  *)
673       if Reason <> 'A' then fChanged := False else fChanged := True; {initialize form for changes}
674       if rgStatus.ItemIndex = -1 then
675         InitialFocus := rgStatus
676       else
677         InitialFocus := rgStatus.Buttons[rgStatus.ItemIndex] as TWinControl;
678     finally
679       alist.free;
680     end;
681   end;
682   
683   procedure TfrmdlgProb.ShowComments;
684   var
685     i:integer;
686   begin
687     with ProbRec do
688       for i:=0 to Pred(fComments.count) do
689         lstComments.Items.Add(TComment(fComments[i]).ExtDateAdd + '^' + TComment(fComments[i]).Narrative);
690   end;
691   
692   
693   procedure TfrmdlgProb.FormClose(Sender: TObject; var Action: TCloseAction);
694   var
695     Alist: TStringList;
696   begin
697     AList := TStringList.Create;
698     try
699       //frmProblems.lblProbList.caption := frmProblems.pnlRight.Caption ;  {moved to bbQuit - only on CANCEL}
700       TWinControl(parent).visible := false;
701       with frmProblems do
702         begin
703           pnlProbList.Visible := False ;
704           edProbEnt.text := '';
705           pnlView.BringToFront ;
706           pnlView.Show   ;
707           mnuView.Enabled := True;
708           mnuAct.Enabled := True ;
709           lstView.Enabled := True ;
710           bbNewProb.Enabled := true ;
711           if fChanged then LoadPatientProblems(AList, PLUser.usViewAct[1], False);
712         end ;
713       Action := caFree;
714    finally
715       AList.Free;
716     end;
717   end;
718   
719   {--------------------------------- file ---------------------------------}
720   
721   procedure TfrmdlgProb.bbFileClick(Sender: TObject);
722   const
723     TX_INACTIVE_ICODE   = 'This problem references an inactive ICD-9-CM code.' + #13#10 +
724                           'The code must be updated using the ''Change''' + #13#10 +
725                           'button before it can be saved';
726     TC_INACTIVE_ICODE   = 'Inactive ICD-9-CM Code';
727     TX_INACTIVE_SCODE   = 'This problem references an inactive SNOMED CT code.' + #13#10 +
728                           'The code must be updated using the ''Change''' + #13#10 +
729                           'button before it can be saved';
730     TC_INACTIVE_SCODE   = 'Inactive SNOMED CT Code';
731   var
732     AList: TstringList;
733     remcom, vu, ut, PtID: string;
734     NTRTCallResult: String;
735     DateOfInterest: TFMDateTime;
736     SvcCat: Char;
737   begin
738     SvcCat := Encounter.VisitCategory;
739     if (SvcCat = 'E') or (SvcCat = 'H') then
740       DateOfInterest := FMNow
741     else
742       DateOfInterest := Encounter.DateTime;
743     frmProblems.wgProbData.TabStop := True;  //CQ #15531 part (c) [CPRS v28.1] {TC}.
744     if (Reason <> 'R') and (Reason <> 'r') then
745       if (rgStatus.itemindex=-1) or (cbProv.itemindex=-1) then
746       begin
747         InfoBox('Status and Responsible Provider are required.', 'Information', MB_OK or MB_ICONINFORMATION);
748         exit;
749       end;
750     if CharInSet(Reason, ['C','c','E','e']) then
751     begin
752       if not IsActiveICDCode(ProbRec.Diagnosis.extern, DateOfInterest) then
753       begin
754         InfoBox(TX_INACTIVE_ICODE, TC_INACTIVE_ICODE, MB_ICONWARNING or MB_OK);
755         exit;
756       end
757       else if (ProbRec.SCTConcept.extern <> '') and not IsActiveSCTCode(ProbRec.SCTConcept.extern, DateOfInterest) then
758       begin
759         InfoBox(TX_INACTIVE_SCODE, TC_INACTIVE_SCODE, MB_ICONWARNING or MB_OK);
760         exit;
761       end;
762     end;
763     if BadDates then exit;
764     Alist:=TStringList.create;
765     try
766       screen.cursor := crHourGlass;
767         {if (ckVerify.visible) then }
768       if (ckVerify.Checked) then
769         ProbRec.Condition := 'P'
770       else
771         Probrec.Condition := 'T';
772       if rgStatus.itemindex = 0 then
773         Probrec.status := 'A'
774       else if rgstatus.itemindex = 1 then
775         Probrec.status := 'I';
776       case rgStage.ItemIndex of
777            0: ProbRec.Priority := 'A';
778            1: ProbRec.Priority := 'C'
779            else
780              ProbRec.Priority := '@';
781       end;
782       ProbRec.DateOnsetStr := edOnsetDate.text;
783       ProbRec.DateResStr   := edResDate.text;{aka inactivation date}
784       ProbRec.DateRecStr   := edRecDate.text;{recorded anywhere}
785       if edUpdate.text = '' then
786         ProbRec.DateModStr := DatetoStr(trunc(FMNow))
787       else
788         ProbRec.DateModStr := edUpdate.text; {last update}
789       (*if ckSC.enabled then *)Probrec.SCProblem    := TreatmentsCked(0);
790       if ckYAO.enabled then ProbRec.AOProblem    := TreatmentsCked(1);
791       if ckYRAD.enabled then Probrec.RadProblem  := TreatmentsCked(2);
792       if ckYENV.enabled then ProbRec.ENVProblem  := TreatmentsCked(3);
793       if ckYSHAD.Enabled then ProbRec.SHADProlem := TreatmentsCked(4);
794       if ckYMST.enabled then ProbRec.MSTProblem  := TreatmentsCked(5);
795       if ckYHNC.enabled then ProbRec.HNCProblem  := TreatmentsCked(6);
796       if cbProv.itemindex = -1 then {Get provider}
797         begin
798           Probrec.respProvider.intern := '0';
799           Probrec.RespProvider.extern := '';
800         end
801       else
802         ProbRec.RespProvider.DHCPtoKeyVal(cbProv.Items[cbProv.itemindex]);
803       if cbLoc.itemindex = -1 then {Get Clinic}
804         begin
805           Probrec.Clinic.intern := '';
806           Probrec.Clinic.extern := '';
807         end
808       else
809         ProbRec.Clinic.DHCPtoKeyVal(cbLoc.Items[cbLoc.itemindex]);
810       if cbServ.itemindex = -1 then  {Get Service}
811         begin
812           Probrec.Service.intern := '';
813           Probrec.Service.extern := '';
814         end
815       else
816         Probrec.Service.DHCPtoKeyVal(cbServ.Items[cbServ.itemindex]);
817   
818       if RequestNTRT then
819       begin
820         ProbRec.NTRTRequested.intern := '1';
821         ProbRec.NTRTRequested.extern := 'True';
822         if NTRTComment <> '' then
823         begin
824           ProbRec.NTRTComment.intern := NTRTComment;
825           ProbRec.NTRTComment.extern := NTRTComment;
826         end;
827       end;
828   
829       if ProbRec.Commentcount > 0 then GetEditedComments;
830       GetNewComments(Reason);
831       case Reason of
832         'E','e','C','c': {edits or comments}
833           begin
834             ut := '';
835             if PLUser.usPrimeUser then ut := '1';
836             FastAssign(EditSave(ProblemIFN, User.DUZ, PLPt.ptVAMC, ut, ProbRec.FilerObject, FSearchString), AList) ;    //V17.5  RV
837           end;
838         'A','a':  {new problem}
839            FastAssign(AddSave(PLPt.GetGMPDFN(Patient.DFN, Patient.Name),
840              pProviderID, PLPt.ptVAMC, ProbRec.FilerObject, FSearchString), AList) ;  //*DFN*
841         'R','r': {remove problem}
842            begin
843              remcom := '';
844              if Probrec.commentcount > 0 then
845                if TComment(Probrec.comments[pred(probrec.commentcount)]).IsNew then
846                  remcom := TComment(Probrec.comments[pred(probrec.commentcount)]).Narrative;
847              FastAssign(ProblemDelete(ProbRec.PIFN, User.DUZ, PLPt.ptVAMC, remcom), AList) ;    //changed in v14
848            end
849       else exit;
850       end; {case}
851       screen.cursor := crDefault;
852       if Alist.count < 1 then
853         InfoBox('Broker time out filing on Host. Try again in a moment or cancel', 'Information', MB_OK or MB_ICONINFORMATION)
854       else if Alist[0] = '1' then
855         begin
856           Alist.clear;
857           vu:=PLUser.usViewAct;
858           fChanged := True;  {ensure update of problem list on close}
859           Changes.RefreshCoverPL := True;
860           if RequestNTRT then
861           begin
862             PtID := Patient.Name + ' (' + Copy(Patient.Name, 0, 1) + Copy(Patient.SSN, (Length(Patient.SSN) - 3), 4) + ')';
863             NTRTCallResult := ProblemNTRTBulletin(FSearchString, Piece(ProbRec.RespProvider.DHCPField, U, 1), PtID, NTRTComment);
864             if piece(NTRTCallResult, '^', 1) <> '1' then
865               InfoBox('Your NTRT Request bulletin for ' + FSearchString + ' could not be generated: '#13#10#13#10 +
866                 piece(NTRTCallResult, '^', 2) + #13#10#13#10'Please contact IRM.', 'Bulletin Failed!', MB_ICONERROR or MB_OK);
867             RequestNTRT := False;
868           end;
869           Close;
870         end
871       else
872         InfoBox('Unable to lock record for filing on Host. Try again in a moment or cancel',
873           'Information', MB_OK or MB_ICONINFORMATION);
874     finally
875       Alist.free
876     end;
877   end;
878   
879   procedure TfrmdlgProb.GetEditedComments;
880   var
881     i: integer;
882   begin
883     for i := 0 to pred(ProbRec.CommentCount) do
884       if i < lstComments.Items.Count then with lstComments do
885         begin
886           if Items[i] = 'DELETED' then
887             TComment(ProbRec.fComments[i]).Narrative := '' {this deletes the comment}
888           else
889             begin
890               TComment(ProbRec.fComments[i]).DateAdd := Piece(lstComments.Items[i], U, 1) ;
891               TComment(ProbRec.fComments[i]).Narrative := Piece(lstComments.Items[i], U, 2) ;
892             end;
893         end;
894   end;
895   
896   procedure TfrmdlgProb.GetNewComments(Reason: char);
897   var
898     i, start: integer;
899   begin
900     {don't display previous comments for add comment or remove problem functions}
901     if (Reason <> 'R') then
902       start := ProbRec.CommentCount
903     else
904       start := 0;
905     for i := start to Pred(lstComments.Items.Count) do
906      begin
907       with lstComments do
908        begin
909         if (lstComments.Items[i] <> 'DELETED') and (Piece(lstComments.Items[i], u, 2) <> '') then
910          ProbRec.AddNewComment(Piece(lstComments.Items[i],u,2));
911        end;
912      end;
913     end;
914   
915   procedure TfrmdlgProb.bbRemoveClick(Sender: TObject);
916   begin
917    if (lstComments.Items.Count = 0) or (lstComments.ItemIndex < 0) then exit ;
918    lstComments.Items[lstComments.ItemIndex] := 'DELETED' ;
919    fChanged := true;
920   end;
921   
922   procedure TfrmdlgProb.cbProvKeyPress(Sender: TObject; var Key: Char);
923   begin
924     if key = #13 then
925       SendMessage(cbProv.Handle, CB_SHOWDROPDOWN, 1, 0) {Opens list}
926     else
927       SendMessage(cbProv.Handle, CB_SHOWDROPDOWN, 0, 0) {Closes list}
928   end;
929   
930   procedure TfrmdlgProb.rgStatusClick(Sender: TObject);
931   begin
932    if rgStatus.Itemindex = 1 then
933      begin
934        edResDate.text  := DateToStr(Date) ;
935        rgStage.Visible := False ;
936      end
937    else
938      begin
939        edResDate.text  := '';
940        rgStage.Visible := True ;
941      end ;
942    FChanged := True;
943   end;
944   
945   procedure TfrmdlgProb.rgStatusEnter(Sender: TObject);
946   begin
947     inherited;
948     bbFile.Default := True;
949     bbFile.Invalidate;
950   end;
951   
952   procedure TfrmdlgProb.cbProvClick(Sender: TObject);
953   begin
954     SendMessage(cbProv.Handle, CB_SHOWDROPDOWN, 0, 0); {Closes list}
955   end;
956   
957   procedure TfrmdlgProb.cbLocClick(Sender: TObject);
958   begin
959     SendMessage(cbLoc.Handle, CB_SHOWDROPDOWN, 0, 0); {Closes list}
960   end;
961   
962   procedure TfrmdlgProb.cbLocKeyPress(Sender: TObject; var Key: Char);
963   begin
964     if key = #13 then
965       SendMessage(cbLoc.Handle, CB_SHOWDROPDOWN, 1, 0) {Opens list}
966     else
967       SendMessage(cbLoc.Handle, CB_SHOWDROPDOWN, 0, 0) {Closes list}
968   end;
969   
970   
971   procedure TfrmdlgProb.SetDefaultProb(Alist: TStringList; prob: string);
972   var
973     Today, ICDCode: string;
974     EncounterDate : TFMDateTime;
975   
976     function Permanent: char;
977     begin
978     // ===================  changed code - REV 7/30/98  =========================
979     // PlUser.usVerifyTranscribed is a SITE requirement, not a USER ability
980       if PlUser.usVerifyTranscribed and not PlUser.usPrimeUser then
981         result:='T'
982       else
983         result:='P';
984     //===========================================================================
985     { if PLUser.usPrimeUser or (PlUser.usVerifyTranscribed) then
986       result:='P'
987      else
988       result:='T';}
989     end;
990   
991   begin  {BODY }
992     Today := PLPt.Today;
993     EncounterDate := Trunc(Encounter.DateTime);
994     if Pos('ICD-9-CM',Piece(prob, u, 3)) > 0 then
995       ICDCode := Piece(Piece(Piece(prob, u, 3),' ',2),')',1)
996     else
997       ICDCode := Piece(prob, u, 3);
998     if Piece(prob, u, 4) <> '' then
999       alist.add('NEW' + v + '.01' + v +Piece(prob, u, 4) + u + ICDCode)
1000    else
1001      alist.add('NEW' + v + '.01' + v + u); {no icd code}
1002    {Leave ien of .05 undefined - let host save routine compute it}
1003    alist.add('NEW' + v + '.05' + v + u + Piece(prob,u,2));{actual text}
1004    alist.add('NEW' + v + '.06' + v + PLPt.PtVAMC);
1005    alist.add('NEW' + v + '.08' + v + Today);
1006    alist.add('NEW' + v + '.12' + v + 'A' + u + 'ACTIVE');
1007    alist.add('NEW' + v + '.13' + v + '');
1008    alist.add('NEW' + v + '1.01' + v + Piece(prob,u,1) + u + Piece(prob,u,2));{standardized text}
1009    alist.add('NEW' + v + '1.02' +  v + Permanent); {Permanent or Transcribed status}
1010    alist.add('NEW' + v + '1.03' + v + inttostr(Encounter.Provider) + u + Encounter.Providername); {ent by}
1011    alist.add('NEW' + v + '1.04' + v + inttostr(Encounter.Provider) + u + Encounter.Providername); {recording prov}
1012    alist.add('NEW' + v + '1.05' + v + inttostr(Encounter.Provider) + u + Encounter.Providername); {resp prov}
1013    alist.add('NEW' + v + '1.06' + v + PLUser.usService); {user's service/section}
1014    alist.add('NEW' + v + '1.07' + v + '');
1015    alist.add('NEW' + v + '1.08' + v + '') ;{IntToStr(Encounter.Location));}
1016    alist.add('NEW' + v + '1.09' + v + Today);
1017    alist.add('NEW' + v + '1.1' +  v + '0' + u + 'NO'); {SC}
1018    alist.add('NEW' + v + '1.11' + v + '0' + u + 'NO'); {AO}
1019    alist.add('NEW' + v + '1.12' + v + '0' + u + 'NO'); {RAD}
1020    alist.add('NEW' + v + '1.13' + v + '0' + u + 'NO'); {ENV}
1021    alist.add('NEW' + v + '1.14' + v + ''); {Priority: 'A', 'C', or ''}
1022    alist.add('NEW' + v + '1.15' + v + '0' + u + 'NO'); {HNC}
1023    alist.add('NEW' + v + '1.16' + v + '0' + u + 'NO'); {MST}
1024    alist.add('NEW' + v + '1.17' + v + '0' + u + 'NO'); {CV}
1025    alist.add('NEW' + v + '1.18' + v + '0' + u + 'NO'); {SHAD}
1026    if Piece(prob, u, 6) <> '' then
1027      alist.Add('NEW' + v + '80001' + v + Piece(prob, u, 6) + u + Piece(prob, u, 6)); {SCT Concept}
1028    if Piece(prob, u, 7) <> '' then
1029      alist.Add('NEW' + v + '80002' + v + Piece(Piece(prob, u, 7), '|', 1) + u + Piece(Piece(prob, u, 7), '|', 1)); {SCT Designation}
1030    alist.add('NEW' + v + '80201' + v + Piece(FloatToStr(EncounterDate),'.',1) + u + FormatFMDateTime('mmm dd yyyy',EncounterDate));   {Code Date/Date of Interest}
1031    alist.add('NEW' + v + '80202' + v + Encounter.GetICDVersion);   {Code System}
1032  end;
1033  
1034  
1035  function TfrmdlgProb.BadDates:Boolean;
1036  var
1037    ds:string;
1038    i:integer;
1039  
1040    procedure Msg(msg: string);
1041    begin
1042  // CQ #16123 - Modified error text to clarify proper date formats - JCS
1043      InfoBox('Dates must be in format m/d/yy, m/d/yyyy, m/d, m/yyyy, yyyy, T+d or T-d' +
1044        #13#10 + msg + ' is formatted improperly.' +
1045        #13#10 + '     Please check the other dates as well.',
1046        'Information', MB_OK or MB_ICONINFORMATION);
1047    end;
1048  begin
1049    result:=True;  {initialize for error condition}
1050    if edRecDate.text <>'' then
1051      begin
1052        ds:=DateStringOK(edRecDate.text);
1053        if ds = 'ERROR' then
1054          begin
1055            msg('Recorded');
1056            exit;
1057          end;
1058      end ;
1059    if edResDate.text <>'' then
1060      begin
1061        ds:=DateStringOK(edResDate.text);
1062        if ds = 'ERROR' then
1063          begin
1064            msg('Resolved');
1065            exit;
1066          end;
1067      end ;
1068    if edOnsetDate.text <>'' then
1069      begin
1070        ds:=DateStringOK(edOnsetDate.text);
1071        if ds = 'ERROR' then
1072          begin
1073            msg('Onset');
1074            exit;
1075          end;
1076        if StrToFMDateTime(edOnsetDate.Text) > FMNow then
1077          begin
1078            InfoBox('Onset dates in the future are not allowed.', 'Information', MB_OK or MB_ICONINFORMATION);
1079            Exit;
1080          end;
1081      end ;
1082    for i:=0 to pred(lstComments.Items.Count) do
1083      begin
1084        if Piece(lstComments.Items[i],u,2)<>'' then {may have blank lines at bottom}
1085          begin
1086            ds:=DateStringOK(Piece(lstComments.Items[i],u,1));
1087            if ds='ERROR' then
1088              begin
1089                msg('Comment #' + inttostr(i));
1090                exit;
1091              end;
1092          end;
1093      end;
1094    result:=False;  {made it through, so no bad dates}
1095  end;
1096  
1097  procedure TfrmdlgProb.ControlChange(Sender: TObject);
1098  begin
1099    fChanged:=true;
1100  end;
1101  
1102  destructor TfrmdlgProb.Destroy;
1103  begin
1104    ProbRec.free;
1105    ProbRec := nil;
1106    FCtrlMap.Free;
1107    if fProbs.dlgProbs <> nil then fProbs.dlgProbs := nil;
1108    if (not Application.Terminated) and (not uInit.TimedOut) then   {prevents GPF if system close box is clicked
1109                                                                     while frmDlgProbs is visible}
1110       if Assigned(frmProblems) then PostMessage(frmProblems.Handle, UM_CLOSEPROBLEM, 0, 0);
1111    inherited Destroy ;
1112  end;
1113  
1114  procedure TfrmdlgProb.cbProvDropDown(Sender: TObject);
1115  var
1116    alist:TstringList;
1117    i:integer;
1118    v:string;
1119  begin
1120    v := uppercase(cbProv.text);
1121    if (v <> '') then
1122      begin
1123        alist := TstringList.create;
1124        try
1125          FastAssign(ProviderList('', 25, V, V), AList) ;
1126          if alist.count > 0 then
1127            begin
1128              if cbProv.items.count + 25 > 100 then
1129                for i := 0 to 75 do {don't allow more than 100 to build up}
1130                  cbProv.Items.delete(i);
1131                for i := 0 to pred(alist.count) do
1132                  cbProv.Items.add(Alist[i]); {add new ones to list}
1133            end;
1134        finally
1135          alist.free;
1136        end;
1137     end;
1138  end;
1139  
1140  procedure TfrmdlgProb.cbLocDropDown(Sender: TObject);
1141  var
1142    alist: TstringList;
1143    v: string;
1144  begin
1145    v := uppercase(cbLoc.text);
1146    alist := TstringList.create;
1147    try
1148      FastAssign(ClinicSearch(' '), AList) ;
1149      if alist.count > 0 then FastAssign(Alist, cbLoc.Items);
1150    finally
1151      alist.free;
1152    end;
1153  end;
1154  
1155  procedure TfrmdlgProb.FormCreate(Sender: TObject);
1156  begin
1157    FSilent := False;
1158  end;
1159  
1160  { old TPLDlgForm Methods }
1161  
1162  constructor TfrmdlgProb.Create(AOwner: TComponent);
1163  { It is unusual to not call the inherited Create first, but necessary in this case; some
1164    of the TMStruct objects need to be created before the form gets its OnCreate event.        }
1165  begin
1166    inherited Create(AOwner);
1167    FCtrlMap := TStringList.Create;       { FCtrlMap[n]='CtrlName=PtrID'                        }
1168    FInitialShow := True;
1169    FModified := False;
1170    FEditing := False;
1171  end;
1172  
1173  procedure TfrmdlgProb.CreateParams(var Params: TCreateParams);
1174  begin
1175    inherited CreateParams(Params);
1176    { to make the form a child window }
1177    with Params do
1178      begin
1179        if Owner is TPanel then
1180          WndParent := (Owner as TPanel).Handle
1181        else {pdr}
1182          WndParent := Application.MainForm.Handle;
1183        Style := ws_Child or ws_ClipSiblings;
1184        X := 0;
1185        Y := 0;
1186     end;
1187  end;
1188  
1189  procedure TfrmdlgProb.Loaded;
1190  begin
1191    inherited Loaded;
1192    { allow the form to be treated as a child form }
1193    Visible := False;
1194    Position := poDefault;
1195    BorderIcons := [];
1196    BorderStyle := bsNone;
1197    HandleNeeded;
1198  end;
1199  
1200  procedure TfrmdlgProb.DoShow;
1201  begin
1202    FInitialShow := False;
1203    inherited DoShow;
1204  end;
1205  
1206  procedure TfrmdlgProb.SetFontSize( NewFontSize: integer);
1207  begin
1208    ResizeAnchoredFormToFont( self );
1209  end;
1210  
1211  procedure TfrmdlgProb.ShowClinicLocationCombo;
1212  begin
1213    cbLoc.visible := true;
1214    cbServ.Visible := false;
1215    lblLoc.caption := 'Clinic:';
1216  end;
1217  
1218  procedure TfrmdlgProb.ShowServiceCombo;
1219  begin
1220    cbLoc.visible := false;
1221    cbServ.Visible := true;
1222    lblLoc.caption := 'Service:';
1223  end;
1224  
1225  { base form procedures (shared by all ordering dialogs) }
1226  
1227  
1228  procedure TfrmdlgProb.ClearDialogControls;             { Reset all the controls in the dialog }
1229  var
1230    i: Integer;
1231  begin
1232    for i := 0 to ControlCount - 1 do
1233    begin
1234      if Controls[i] is TLabel then Continue;
1235      if Controls[i] is TButton then Continue;
1236    end;
1237    LoadDefaults;                                       { added for lab to reset cleared lists }
1238  end;
1239  
1240  procedure TfrmdlgProb.LoadDefaults;
1241  begin
1242    { by default nothing - should override in specific dialog }
1243  end;
1244  
1245  
1246  
1247  function TfrmdlgProb.LackRequired: Boolean;
1248  begin
1249    Result := False;  { should override to check for additional required fields }
1250  end;
1251  
1252  
1253  procedure TfrmdlgProb.UMTakeFocus(var Message: TMessage);
1254  begin
1255    if FInitialFocus = nil then exit; {PDR}
1256    if (FInitialFocus.visible) and (FInitialFocus.enabled) then
1257    begin
1258      FInitialFocus.SetFocus();
1259      Invalidate;
1260    end;
1261  end;
1262  
1263  procedure TfrmdlgProb.bbChangeProbClick(Sender: TObject);
1264  const
1265    TX799 = '799.9';
1266  var
1267     newprob: string ;
1268     frmPLLex: TfrmPLLex;
1269  begin
1270    if PLUser.usUseLexicon then
1271      begin
1272        frmPLLex:=TfrmPLLex.Create(Application);
1273        try
1274          frmPLLex.showmodal;
1275        finally
1276          frmPLLex.Free;
1277        end;
1278      end
1279    else
1280      begin
1281        PLProblem := InputBox('Change problem','Enter new problem name: ','') ;
1282        if PLProblem<>'' then
1283          PLProblem := u + PLProblem + u + TX799 + u
1284        else
1285          exit ;
1286      end ;
1287  
1288    {problems are in the form of: ien^.01^icd^icdifn , although only the .01 is required}
1289    if PLProblem='' then exit ;
1290    newprob := PLProblem;
1291  
1292    if Piece(NewProb, '|', 2) <> '' then
1293    begin
1294      FSearchString := Piece(NewProb, '|', 2);
1295      NewProb := Piece(NewProb, '|', 1);
1296    end;
1297  
1298    if frmProblems.HighlightDuplicate(NewProb, Piece(newprob, U, 2) + #13#10#13#10 +
1299        'This problem would be a duplicate.'+#13#10 +
1300        'Return to the list and see the highlighted problem.',
1301        mtInformation, 'CHANGE') then
1302      exit {bail out - don't want dups}
1303    else
1304      begin
1305        {ien^.01^icd^icdifn - see SetDefaultProblem}
1306        {Set new problem properties}
1307        ProbRec.Problem.DHCPtoKeyVal(Piece(NewProb,u,1) + u + Piece(NewProb,u,2)) ;    {1.01}
1308        ProbRec.Diagnosis.DHCPtoKeyVal(Piece(NewProb,u,4) + u + Piece(NewProb,u,3)) ;   {.01}
1309        ProbRec.Narrative.DHCPtoKeyVal(u + Piece(NewProb,u,2));                         {.05}
1310        ProbRec.SCTConcept.DHCPtoKeyVal(Piece(NewProb, u, 6) + u + Piece(NewProb, u, 6));
1311        ProbRec.SCTDesignation.DHCPtoKeyVal(Piece(NewProb, u, 7) + u + Piece(NewProb, u, 7));
1312  
1313        {mark it as changed}
1314        fchanged := true ;
1315  
1316        {Redraw heading}
1317        edProb.Text:=Piece(NewProb,u,2);
1318      end ;
1319  end ;
1320  
1321  procedure TfrmdlgProb.cbLocNeedData(Sender: TObject; const StartFrom: String;
1322    Direction, InsertAt: Integer);
1323  begin
1324    cbLoc.ForDataUse(SubSetOfClinics(StartFrom, Direction));
1325  end;
1326  
1327  procedure TfrmdlgProb.cbProvNeedData(Sender: TObject; const StartFrom: String;
1328    Direction, InsertAt: Integer);
1329  begin
1330    cbProv.ForDataUse(SubSetOfProviders(StartFrom, Direction));
1331  end;
1332  
1333  procedure TfrmdlgProb.cbServNeedData(Sender: TObject; const StartFrom: String;
1334    Direction, InsertAt: Integer);
1335  begin
1336    cbServ.ForDataUse(ServiceSearch(StartFrom, Direction));
1337  end;
1338  
1339  initialization
1340    SpecifyFormIsNotADialog(TfrmdlgProb);
1341  
1342  end.

Module Calls (2 levels)


fProbEdt
 ├uCore
 │ ├rCore
 │ ├uConst
 │ ├uCombatVet
 │ ├rTIU
 │ ├rOrders
 │ ├rConsults
 │ └uOrders
 ├uConst
 ├fBase508Form
 │ ├uConst
 │ └uHelpManager
 ├uProbs
 │ ├uConst
 │ ├rCore...
 │ └uCore...
 ├fProbs
 │ ├fHSplit
 │ ├uProbs...
 │ ├uCore...
 │ ├fProbEdt...
 │ ├uConst
 │ ├fBase508Form...
 │ ├fFrame
 │ ├fProbflt
 │ ├fProbLex
 │ ├rProbs
 │ ├rCover
 │ ├fRptBox
 │ ├rCore...
 │ ├fProbCmt
 │ ├fEncnt
 │ ├fReportsPrint
 │ ├fReports
 │ └rPCE
 ├rProbs...
 ├rCore...
 ├rOrders...
 ├fProbCmt...
 ├fProbLex...
 ├rPCE...
 └uInit
   └fTimeout

Module Called-By (2 levels)


       fProbEdt
       fProbs┘ 
     fFrame┤   
fProbEdt...┤   
   fProbflt┤   
   fProbLex┘