1006 lines
32 KiB
Plaintext
1006 lines
32 KiB
Plaintext
unit fProbEdt;
|
|
|
|
interface
|
|
|
|
uses
|
|
SysUtils, windows, Messages, Classes, Graphics, Controls,
|
|
Forms, Dialogs, StdCtrls, Buttons, ExtCtrls, Grids,
|
|
ORCtrls, Vawrgrid, uCore, Menus, uConst;
|
|
|
|
const
|
|
SOC_QUIT = 1; { close single dialog }
|
|
|
|
type
|
|
TfrmdlgProb = class(TForm)
|
|
Label1: TLabel;
|
|
Label5: TLabel;
|
|
edResDate: TCaptionEdit;
|
|
Label7: TLabel;
|
|
edUpdate: TCaptionEdit;
|
|
pnlBottom: TPanel;
|
|
bbQuit: TBitBtn;
|
|
bbFile: TBitBtn;
|
|
pnlComments: TPanel;
|
|
Bevel1: TBevel;
|
|
lblCmtDate: TOROffsetLabel;
|
|
lblComment: TOROffsetLabel;
|
|
lblCom: TStaticText;
|
|
bbAdd: TBitBtn;
|
|
bbRemove: TBitBtn;
|
|
lstComments: TORListBox;
|
|
bbEdit: TBitBtn;
|
|
pnlTop: TPanel;
|
|
lblAct: TLabel;
|
|
rgStatus: TKeyClickRadioGroup;
|
|
rgStage: TKeyClickRadioGroup;
|
|
bbChangeProb: TBitBtn;
|
|
edProb: TCaptionEdit;
|
|
gbTreatment: TGroupBox;
|
|
ckSC: TCheckBox;
|
|
ckRad: TCheckBox;
|
|
ckAO: TCheckBox;
|
|
ckENV: TCheckBox;
|
|
ckHNC: TCheckBox;
|
|
ckMST: TCheckBox;
|
|
ckVerify: TCheckBox;
|
|
edRecDate: TCaptionEdit;
|
|
cbServ: TORComboBox;
|
|
cbLoc: TORComboBox;
|
|
lblLoc: TLabel;
|
|
cbProv: TORComboBox;
|
|
Label3: TLabel;
|
|
edOnsetdate: TCaptionEdit;
|
|
Label6: TLabel;
|
|
procedure bbQuitClick(Sender: TObject);
|
|
procedure bbAddComClick(Sender: TObject);
|
|
procedure FormShow(Sender: TObject);
|
|
procedure FormClose(Sender: TObject; var Action: TCloseAction);
|
|
procedure bbFileClick(Sender: TObject);
|
|
procedure bbRemoveClick(Sender: TObject);
|
|
procedure cbProvKeyPress(Sender: TObject; var Key: Char);
|
|
procedure rgStatusClick(Sender: TObject);
|
|
procedure cbProvClick(Sender: TObject);
|
|
procedure cbLocClick(Sender: TObject);
|
|
procedure cbLocKeyPress(Sender: TObject; var Key: Char);
|
|
procedure SetDefaultProb(Alist:TstringList;prob:string);
|
|
procedure ControlChange(Sender: TObject);
|
|
function BadDates:Boolean;
|
|
procedure cbProvDropDown(Sender: TObject);
|
|
procedure cbLocDropDown(Sender: TObject);
|
|
procedure FormCreate(Sender: TObject);
|
|
procedure bbChangeProbClick(Sender: TObject);
|
|
procedure cbLocNeedData(Sender: TObject; const StartFrom: String;
|
|
Direction, InsertAt: Integer);
|
|
procedure cbProvNeedData(Sender: TObject; const StartFrom: String;
|
|
Direction, InsertAt: Integer);
|
|
procedure cbServNeedData(Sender: TObject; const StartFrom: String;
|
|
Direction, InsertAt: Integer);
|
|
procedure bbEditClick(Sender: TObject);
|
|
private
|
|
{ Private declarations }
|
|
FEditing: Boolean;
|
|
FInitialShow: Boolean;
|
|
FModified: Boolean;
|
|
FProviderID: Int64;
|
|
FLocationID: Longint;
|
|
FDisplayGroupID: Integer;
|
|
FInitialFocus: TWinControl;
|
|
FCtrlMap: TStringList;
|
|
FSourceOfClose: Integer;
|
|
FOnInitiate: TNotifyEvent;
|
|
fChanged:boolean;
|
|
FSilent: boolean;
|
|
FCanQuit: boolean;
|
|
|
|
procedure UMTakeFocus(var Message: TMessage); message UM_TAKEFOCUS;
|
|
procedure ShowComments;
|
|
procedure GetEditedComments;
|
|
procedure GetNewComments(Reason:char);
|
|
function OkToQuit:boolean;
|
|
protected
|
|
procedure CreateParams(var Params: TCreateParams); override;
|
|
procedure DoShow; override;
|
|
procedure Loaded; override;
|
|
procedure ClearDialogControls; virtual;
|
|
function LackRequired: Boolean; virtual;
|
|
procedure LoadDefaults; virtual;
|
|
property InitialFocus: TWinControl read FInitialFocus write FInitialFocus;
|
|
public
|
|
{ Public declarations }
|
|
Reason:Char;
|
|
problemIFN:String;
|
|
subjProb:string; {parameters for problem being added}
|
|
constructor Create(AOwner: TComponent); override ;
|
|
destructor Destroy; override;
|
|
property DisplayGroupID: Integer read FDisplayGroupID write FDisplayGroupID;
|
|
property Editing: Boolean read FEditing write FEditing;
|
|
property Silent: Boolean read FSilent write FSilent;
|
|
property ProviderID: Int64 read FProviderID write FProviderID;
|
|
property LocationID: Longint read FLocationID write FLocationID;
|
|
property SourceOfClose: Integer read FSourceOfClose write FSourceOfClose;
|
|
property OnInitiate: TNotifyEvent read FOnInitiate write FOnInitiate;
|
|
procedure SetFontSize( NewFontSize: integer);
|
|
property CanQuit: boolean read FCanQuit write FCanQuit;
|
|
end ;
|
|
|
|
implementation
|
|
|
|
{$R *.DFM}
|
|
|
|
uses ORFn, uProbs, fProbs, rProbs, fCover, rCover, rCore, fProbCmt, fProbLex, rPCE, uInit ;
|
|
|
|
type
|
|
TDialogItem = class { for loading edits & quick orders }
|
|
ControlName: string;
|
|
DialogPtr: Integer;
|
|
Instance: Integer;
|
|
end;
|
|
|
|
function TfrmdlgProb.OkToQuit:boolean;
|
|
begin
|
|
Result := not fChanged;
|
|
end;
|
|
|
|
procedure TfrmdlgProb.bbQuitClick(Sender: TObject);
|
|
begin
|
|
if OkToQuit then
|
|
begin
|
|
frmProblems.lblProbList.caption := frmProblems.pnlRight.Caption ;
|
|
close;
|
|
end
|
|
else
|
|
begin
|
|
if (not FSilent) and
|
|
(InfoBox('Discard changes?', 'Add/Edit a Problem', MB_YESNO or MB_ICONQUESTION) <> IDYES) then
|
|
begin
|
|
FCanQuit := False;
|
|
exit;
|
|
end
|
|
else
|
|
begin
|
|
frmProblems.lblProbList.caption := frmProblems.pnlRight.Caption ;
|
|
FCanQuit := True;
|
|
close;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TfrmdlgProb.bbAddComClick(Sender: TObject);
|
|
var
|
|
cmt: string ;
|
|
begin
|
|
cmt := NewComment ;
|
|
if StrToInt(Piece(cmt, U, 1)) > 0 then
|
|
begin
|
|
lstComments.Items.Add(Pieces(cmt, U, 2, 3)) ;
|
|
fChanged := true;
|
|
end ;
|
|
end;
|
|
|
|
procedure TfrmdlgProb.bbEditClick(Sender: TObject);
|
|
var
|
|
cmt: string ;
|
|
begin
|
|
if lstComments.ItemIndex < 0 then Exit;
|
|
cmt := EditComment(lstComments.Items[lstComments.ItemIndex]) ;
|
|
if StrToInt(Piece(cmt, U, 1)) > 0 then
|
|
begin
|
|
lstComments.Items[lstComments.ItemIndex] := Pieces(cmt, U, 2, 3) ;
|
|
fChanged := true;
|
|
end ;
|
|
end;
|
|
|
|
procedure TfrmdlgProb.FormShow(Sender: TObject);
|
|
var
|
|
alist: TstringList;
|
|
Anchorses: Array of TAnchors;
|
|
i: integer;
|
|
begin
|
|
if ProbRec <> nil then exit;
|
|
if (ResizeWidth(Font,MainFont,Width) >= Parent.ClientWidth) and
|
|
(ResizeHeight(Font,MainFont,Height) >= Parent.ClientHeight) then
|
|
begin //This form won't fit when it resizes, so we have to take Drastic Measures
|
|
SetLength(Anchorses, dlgProbs.ControlCount);
|
|
for i := 0 to ControlCount - 1 do
|
|
begin
|
|
Anchorses[i] := Controls[i].Anchors;
|
|
Controls[i].Anchors := [akLeft, akTop];
|
|
end;
|
|
SetFontSize(MainFontSize);
|
|
RequestAlign;
|
|
for i := 0 to ControlCount - 1 do
|
|
Controls[i].Anchors := Anchorses[i];
|
|
end
|
|
else
|
|
begin
|
|
SetFontSize(MainFontSize);
|
|
RequestAlign;
|
|
end;
|
|
frmProblems.mnuView.Enabled := False;
|
|
frmProblems.mnuAct.Enabled := False ;
|
|
frmProblems.lstView.Enabled := False;
|
|
frmProblems.bbNewProb.Enabled := False ;
|
|
Alist := TstringList.create;
|
|
try
|
|
if Reason = 'E' then
|
|
lblact.caption := 'Editing:'
|
|
else if Reason = 'A' then
|
|
lblact.caption := 'Adding'
|
|
else {display, comment edit or remove problem}
|
|
begin
|
|
case reason of 'C','c': lblact.caption := 'Comment Edit';
|
|
'R','r': lblact.caption := 'Remove Problem:';
|
|
end; {case}
|
|
{ckVerify.Enabled:=false;}
|
|
cbProv.Enabled := false;
|
|
cbLoc.Enabled := false;
|
|
bbRemove.enabled := false;
|
|
rgStatus.Enabled := false;
|
|
rgStage.Enabled := false;
|
|
edRecdate.enabled := false;
|
|
edResdate.enabled := false;
|
|
edOnsetDate.enabled := false;
|
|
ckSC.enabled := false;
|
|
ckRAD.enabled := false;
|
|
ckAO.enabled := false;
|
|
ckENV.enabled := false;
|
|
ckHNC.enabled := false;
|
|
ckMST.enabled := false;
|
|
if Reason = 'R' then bbFile.caption := 'Remove';
|
|
end;
|
|
edProb.Caption := lblact.Caption;
|
|
if Piece(subjProb,U,3) <> '' then
|
|
edProb.Text := Piece(subjProb, u, 2) + ' (' + Piece(subjProb, u, 3) + ')'
|
|
else
|
|
edProb.Text := Piece(subjProb, u, 2);
|
|
{line up problem action and title}
|
|
{edProb.Left:=lblAct.left+lblAct.width+2;}
|
|
{get problem}
|
|
if Reason <> 'A' then
|
|
begin {edit,remove or display existing problem}
|
|
problemIFN := Piece(subjProb, u, 1);
|
|
//AList.Assign(EditLoad(ProblemIFN,pProviderID,PLPt.ptVAMC)) ;
|
|
AList.Assign(EditLoad(ProblemIFN,User.DUZ,PLPt.ptVAMC)) ; //V17.5 RV
|
|
end
|
|
else {new problem}
|
|
SetDefaultProb(Alist, subjProb);
|
|
if Alist.count = 0 then
|
|
begin
|
|
InfoBox('No Data on Host for problem ' + ProblemIFN, 'Information', MB_OK or MB_ICONINFORMATION);
|
|
close;
|
|
exit;
|
|
end;
|
|
ProbRec := TProbRec.Create(Alist); {create a problem object}
|
|
ProbRec.PIFN := ProblemIFN;
|
|
ProbRec.EnteredBy.DHCPtoKeyVal(inttostr(User.DUZ) + u + User.Name);
|
|
ProbRec.RecordedBy.DHCPtoKeyVal(inttostr(Encounter.Provider) + u + Encounter.ProviderName);
|
|
{fill in defaults}
|
|
edOnsetdate.text := ProbRec.DateOnsetStr;
|
|
if Probrec.status <> 'A' then
|
|
begin
|
|
rgStatus.itemindex := 1;
|
|
rgStage.Visible := False ;
|
|
end;
|
|
if Probrec.Priority = 'A' then
|
|
rgStage.itemindex := 0
|
|
else if Probrec.Priority = 'C' then
|
|
rgStage.itemindex := 1
|
|
else
|
|
rgStage.itemindex := 2;
|
|
rgStatus.TabStop := (rgStatus.ItemIndex = -1);
|
|
rgStage.TabStop := (rgStage.ItemIndex = -1);
|
|
edRecDate.text := Probrec.DateRecStr;
|
|
edUpdate.text := Probrec.DateModStr;
|
|
edResDate.text := ProbRec.DateResStr;
|
|
edUpdate.enabled := false;
|
|
if pos(Reason,'CR') = 0 then
|
|
with PLPt do
|
|
begin
|
|
if UpperCase(Reason) = 'E' then
|
|
begin
|
|
ckSC.Enabled := ProbRec.SCProblem or PtServiceConnected;
|
|
ckSC.checked := ProbRec.SCProblem;
|
|
end
|
|
else
|
|
begin
|
|
ckSC.enabled := PtServiceConnected ;
|
|
ckSC.checked := ProbRec.SCProblem and PtServiceConnected ;
|
|
end;
|
|
ckAO.enabled := PtAgentOrange ;
|
|
ckRAD.enabled := PtRadiation ;
|
|
ckENV.enabled := PtEnvironmental ;
|
|
ckHNC.enabled := PtHNC ;
|
|
ckMST.enabled := PtMST ;
|
|
ckAO.checked := Probrec.AOProblem and PtAgentOrange;
|
|
ckRAD.checked := Probrec.RADProblem and PtRadiation;
|
|
ckENV.checked := Probrec.ENVProblem and PtEnvironmental;
|
|
ckHNC.checked := Probrec.HNCProblem and PtHNC;
|
|
ckMST.checked := Probrec.MSTProblem and PtMST;
|
|
end ;
|
|
cbProv.InitLongList(ProbRec.RespProvider.extern) ;
|
|
if (ProbRec.RespProvider.intern <> '') and (StrToInt64Def(ProbRec.RespProvider.intern, 0) > 0) then
|
|
cbProv.SelectByIEN(StrToInt64(ProbRec.RespProvider.intern)) ;
|
|
|
|
if UpperCase(Reason) = 'A' then
|
|
begin
|
|
if Encounter.Inpatient then
|
|
begin
|
|
cbLoc.visible:=false;
|
|
cbServ.Visible:=true;
|
|
lblLoc.caption:='Service:';
|
|
cbServ.InitLongList('');
|
|
end
|
|
else
|
|
begin
|
|
cbLoc.visible:=true;
|
|
cbServ.Visible:=false;
|
|
lblLoc.caption:='Clinic:';
|
|
cbLoc.InitLongList(Encounter.LocationName) ;
|
|
cbLoc.SelectByIEN(Encounter.Location);
|
|
end;
|
|
end
|
|
else
|
|
begin
|
|
if (ProbRec.Service.DHCPField = '^') and (ProbRec.Clinic.DHCPField <> '^') then
|
|
begin
|
|
cbLoc.visible:=true;
|
|
cbServ.Visible:=false;
|
|
lblLoc.caption:='Clinic:';
|
|
cbLoc.InitLongList(ProbRec.Clinic.Extern) ;
|
|
cbLoc.SelectByID(ProbRec.Clinic.Intern) ;
|
|
end
|
|
else if (ProbRec.Clinic.DHCPField = '^') and (ProbRec.Service.DHCPField <> '^') then
|
|
begin
|
|
cbLoc.visible:=false;
|
|
cbServ.Visible:=true;
|
|
lblLoc.caption:='Service:';
|
|
cbServ.InitLongList(ProbRec.Service.Extern) ;
|
|
cbServ.SelectByID(ProbRec.Service.Intern) ;
|
|
end
|
|
else
|
|
begin
|
|
if Encounter.Inpatient then
|
|
begin
|
|
cbLoc.visible:=false;
|
|
cbServ.Visible:=true;
|
|
lblLoc.caption:='Service:';
|
|
cbServ.InitLongList('');
|
|
end
|
|
else
|
|
begin
|
|
cbLoc.visible:=true;
|
|
cbServ.Visible:=false;
|
|
lblLoc.caption:='Clinic:';
|
|
cbLoc.InitLongList('') ;
|
|
end;
|
|
end;
|
|
end;
|
|
cbLoc.Caption := lblLoc.Caption;
|
|
|
|
if Pos(Reason,'E,C') > 0 then ShowComments ;
|
|
if ProbRec.CmtIsXHTML then
|
|
begin
|
|
bbAdd.Enabled := FALSE;
|
|
bbEdit.Enabled := FALSE;
|
|
bbRemove.Enabled := FALSE;
|
|
pnlComments.Hint := ProbRec.CmtNoEditReason;
|
|
end
|
|
else
|
|
begin
|
|
bbAdd.Enabled := TRUE;
|
|
bbEdit.Enabled := TRUE;
|
|
bbRemove.Enabled := TRUE;
|
|
pnlComments.Hint := '';
|
|
end ;
|
|
// =================== changed code - REV 7/30/98 =========================
|
|
// PlUser.usVerifyTranscribed is a SITE requirement, not a user ability
|
|
if Reason = 'A' then
|
|
begin
|
|
if PlUser.usVerifyTranscribed and not PlUser.usPrimeUser then
|
|
ckVerify.Checked := False
|
|
else
|
|
ckVerify.Checked := True;
|
|
end
|
|
else ckVerify.checked := (Probrec.condition = 'P');
|
|
//===========================================================================
|
|
(* if (PlUSer.usVerifyTranscribed) and (Reason='A') then
|
|
begin {some users can add and verify}
|
|
{ckVerify.visible:=true;}
|
|
ckVerify.checked:=true; {assume it will be entered verified}
|
|
end {others can add and edit verified status}
|
|
else if (PlUSer.usVerifyTranscribed) and (PlUser.usPrimeUser) then
|
|
begin
|
|
{ckVerify.visible:=true; }
|
|
ckVerify.checked:=(Probrec.condition='P');
|
|
end; *)
|
|
if Reason <> 'A' then fChanged := False else fChanged := True; {initialize form for changes}
|
|
finally
|
|
alist.free;
|
|
end;
|
|
end;
|
|
|
|
procedure TfrmdlgProb.ShowComments;
|
|
var
|
|
i:integer;
|
|
begin
|
|
with ProbRec do
|
|
for i:=0 to Pred(fComments.count) do
|
|
lstComments.Items.Add(TComment(fComments[i]).ExtDateAdd + '^' + TComment(fComments[i]).Narrative);
|
|
end;
|
|
|
|
|
|
procedure TfrmdlgProb.FormClose(Sender: TObject; var Action: TCloseAction);
|
|
var
|
|
Alist: TStringList;
|
|
begin
|
|
AList := TStringList.Create;
|
|
try
|
|
//frmProblems.lblProbList.caption := frmProblems.pnlRight.Caption ; {moved to bbQuit - only on CANCEL}
|
|
TWinControl(parent).visible := false;
|
|
with frmProblems do
|
|
begin
|
|
pnlProbList.Visible := False ;
|
|
edProbEnt.text := '';
|
|
pnlView.BringToFront ;
|
|
pnlView.Show ;
|
|
mnuView.Enabled := True;
|
|
mnuAct.Enabled := True ;
|
|
lstView.Enabled := True ;
|
|
bbNewProb.Enabled := true ;
|
|
if fChanged then LoadPatientProblems(AList,PLUser.usViewAct[1],false);
|
|
end ;
|
|
Action := caFree;
|
|
finally
|
|
AList.Free;
|
|
end;
|
|
end;
|
|
|
|
{--------------------------------- file ---------------------------------}
|
|
|
|
procedure TfrmdlgProb.bbFileClick(Sender: TObject);
|
|
const
|
|
TX_INACTIVE_CODE = 'This problem references an inactive ICD code.' + #13#10 +
|
|
'The code must be updated using the ''Change''' + #13#10 +
|
|
'button before it can be saved';
|
|
TC_INACTIVE_CODE = 'Inactive Code';
|
|
var
|
|
AList: TstringList;
|
|
remcom, vu, ut: string;
|
|
i: integer;
|
|
begin
|
|
if (Reason <> 'R') and (Reason <> 'r') then
|
|
if (rgStatus.itemindex=-1) or (cbProv.itemindex=-1) then
|
|
begin
|
|
InfoBox('Status and Responsible Provider are required.', 'Information', MB_OK or MB_ICONINFORMATION);
|
|
exit;
|
|
end;
|
|
if Reason in ['C','c','E','e'] then
|
|
if not IsActiveICDCode(ProbRec.Diagnosis.extern) then
|
|
begin
|
|
InfoBox(TX_INACTIVE_CODE, TC_INACTIVE_CODE, MB_ICONWARNING or MB_OK);
|
|
exit;
|
|
end;
|
|
if BadDates then exit;
|
|
Alist:=TStringList.create;
|
|
try
|
|
screen.cursor := crHourGlass;
|
|
{if (ckVerify.visible) then }
|
|
if (ckVerify.Checked) then
|
|
ProbRec.Condition := 'P'
|
|
else
|
|
Probrec.Condition := 'T';
|
|
if rgStatus.itemindex = 0 then
|
|
Probrec.status := 'A'
|
|
else if rgstatus.itemindex = 1 then
|
|
Probrec.status := 'I';
|
|
if rgStage.itemindex = 0 then
|
|
Probrec.Priority := 'A'
|
|
else if rgStage.itemindex = 1 then
|
|
Probrec.Priority := 'C';
|
|
ProbRec.DateOnsetStr := edOnsetDate.text;
|
|
ProbRec.DateResStr := edResDate.text;{aka inactivation date}
|
|
ProbRec.DateRecStr := edRecDate.text;{recorded anywhere}
|
|
if edUpdate.text = '' then
|
|
ProbRec.DateModStr := DatetoStr(trunc(FMNow))
|
|
else
|
|
ProbRec.DateModStr := edUpdate.text; {last update}
|
|
(*if ckSC.enabled then *)Probrec.SCProblem := ckSC.checked;
|
|
if ckRAD.enabled then Probrec.RadProblem := ckrad.Checked;
|
|
if ckAO.enabled then ProbRec.AOProblem := ckAO.checked;
|
|
if ckENV.enabled then ProbRec.ENVProblem := ckENV.Checked;
|
|
if ckHNC.enabled then ProbRec.HNCProblem := ckHNC.Checked;
|
|
if ckMST.enabled then ProbRec.MSTProblem := ckMST.Checked;
|
|
if cbProv.itemindex = -1 then {Get provider}
|
|
begin
|
|
Probrec.respProvider.intern := '0';
|
|
Probrec.RespProvider.extern := '';
|
|
end
|
|
else
|
|
ProbRec.RespProvider.DHCPtoKeyVal(cbProv.Items[cbProv.itemindex]);
|
|
if cbLoc.itemindex = -1 then {Get Clinic}
|
|
begin
|
|
Probrec.Clinic.intern := '';
|
|
Probrec.Clinic.extern := '';
|
|
end
|
|
else
|
|
ProbRec.Clinic.DHCPtoKeyVal(cbLoc.Items[cbLoc.itemindex]);
|
|
if cbServ.itemindex = -1 then {Get Service}
|
|
begin
|
|
Probrec.Service.intern := '';
|
|
Probrec.Service.extern := '';
|
|
end
|
|
else
|
|
Probrec.Service.DHCPtoKeyVal(cbServ.Items[cbServ.itemindex]);
|
|
if ProbRec.Commentcount > 0 then GetEditedComments;
|
|
GetNewComments(Reason);
|
|
case Reason of
|
|
'E','e','C','c': {edits or comments}
|
|
begin
|
|
ut := '';
|
|
if PLUser.usPrimeUser then ut := '1';
|
|
//AList.Assign(EditSave(ProblemIFN,pProviderID,PLPt.ptVAMC,ut,ProbRec.FilerObject)) ;
|
|
AList.Assign(EditSave(ProblemIFN,User.DUZ,PLPt.ptVAMC,ut,ProbRec.FilerObject)) ; //V17.5 RV
|
|
end;
|
|
'A','a': {new problem}
|
|
AList.Assign(AddSave(PLPt.GetGMPDFN(Patient.DFN, Patient.Name),
|
|
pProviderID,PLPt.ptVAMC,ProbRec.FilerObject)) ; //*DFN*
|
|
'R','r': {remove problem}
|
|
begin
|
|
remcom := '';
|
|
if Probrec.commentcount > 0 then
|
|
if TComment(Probrec.comments[pred(probrec.commentcount)]).IsNew then
|
|
remcom := TComment(Probrec.comments[pred(probrec.commentcount)]).Narrative;
|
|
AList.Assign(ProblemDelete(ProbRec.PIFN,User.DUZ,PLPt.ptVAMC,remcom)) ; //changed in v14
|
|
//AList.Assign(ProblemDelete(ProbRec.PIFN,Encounter.Provider,PLPt.ptVAMC,remcom)) ;
|
|
end
|
|
else exit;
|
|
end; {case}
|
|
screen.cursor := crDefault;
|
|
if Alist.count < 1 then
|
|
InfoBox('Broker time out filing on Host. Try again in a moment or cancel', 'Information', MB_OK or MB_ICONINFORMATION)
|
|
else if Alist[0] = '1' then
|
|
begin
|
|
Alist.clear;
|
|
vu:=PLUser.usViewAct;
|
|
fChanged := True; {ensure update of problem list on close}
|
|
//frmProblems.LoadPatientProblems(AList,vu[1],false);
|
|
{ update cover sheet problem list }
|
|
with frmCover do
|
|
for i := ComponentCount - 1 downto 0 do
|
|
begin
|
|
if Components[i] is TORListBox then
|
|
begin
|
|
case Components[i].Tag of
|
|
10: ListActiveProblems((Components[i] as TORListBox).Items);
|
|
end;
|
|
end;
|
|
end;
|
|
Close;
|
|
end
|
|
else
|
|
InfoBox('Unable to lock record for filing on Host. Try again in a moment or cancel',
|
|
'Information', MB_OK or MB_ICONINFORMATION);
|
|
finally
|
|
Alist.free
|
|
end;
|
|
end;
|
|
|
|
procedure TfrmdlgProb.GetEditedComments;
|
|
var
|
|
i: integer;
|
|
begin
|
|
for i := 0 to pred(ProbRec.CommentCount) do
|
|
if i < lstComments.Items.Count then with lstComments do
|
|
begin
|
|
if Items[i] = 'DELETED' then
|
|
TComment(ProbRec.fComments[i]).Narrative := '' {this deletes the comment}
|
|
else
|
|
begin
|
|
TComment(ProbRec.fComments[i]).DateAdd := Piece(lstComments.Items[i], U, 1) ;
|
|
TComment(ProbRec.fComments[i]).Narrative := Piece(lstComments.Items[i], U, 2) ;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TfrmdlgProb.GetNewComments(Reason: char);
|
|
var
|
|
i, start: integer;
|
|
begin
|
|
{don't display previous comments for add comment or remove problem functions}
|
|
if (Reason <> 'R') then
|
|
start := ProbRec.CommentCount
|
|
else
|
|
start := 0;
|
|
for i := start to Pred(lstComments.Items.Count) do
|
|
begin
|
|
with lstComments do
|
|
begin
|
|
if (lstComments.Items[i] <> 'DELETED') and (Piece(lstComments.Items[i], u, 2) <> '') then
|
|
ProbRec.AddNewComment(Piece(lstComments.Items[i],u,2));
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TfrmdlgProb.bbRemoveClick(Sender: TObject);
|
|
begin
|
|
if (lstComments.Items.Count = 0) or (lstComments.ItemIndex < 0) then exit ;
|
|
lstComments.Items[lstComments.ItemIndex] := 'DELETED' ;
|
|
fChanged := true;
|
|
end;
|
|
|
|
procedure TfrmdlgProb.cbProvKeyPress(Sender: TObject; var Key: Char);
|
|
begin
|
|
if key = #13 then
|
|
SendMessage(cbProv.Handle, CB_SHOWDROPDOWN, 1, 0) {Opens list}
|
|
else
|
|
SendMessage(cbProv.Handle, CB_SHOWDROPDOWN, 0, 0) {Closes list}
|
|
end;
|
|
|
|
procedure TfrmdlgProb.rgStatusClick(Sender: TObject);
|
|
begin
|
|
if rgStatus.Itemindex = 1 then
|
|
begin
|
|
edResDate.text := DateToStr(Date) ;
|
|
rgStage.Visible := False ;
|
|
end
|
|
else
|
|
begin
|
|
edResDate.text := '';
|
|
rgStage.Visible := True ;
|
|
end ;
|
|
FChanged := True;
|
|
end;
|
|
|
|
procedure TfrmdlgProb.cbProvClick(Sender: TObject);
|
|
begin
|
|
SendMessage(cbProv.Handle, CB_SHOWDROPDOWN, 0, 0); {Closes list}
|
|
end;
|
|
|
|
procedure TfrmdlgProb.cbLocClick(Sender: TObject);
|
|
begin
|
|
SendMessage(cbLoc.Handle, CB_SHOWDROPDOWN, 0, 0); {Closes list}
|
|
end;
|
|
|
|
procedure TfrmdlgProb.cbLocKeyPress(Sender: TObject; var Key: Char);
|
|
begin
|
|
if key = #13 then
|
|
SendMessage(cbLoc.Handle, CB_SHOWDROPDOWN, 1, 0) {Opens list}
|
|
else
|
|
SendMessage(cbLoc.Handle, CB_SHOWDROPDOWN, 0, 0) {Closes list}
|
|
end;
|
|
|
|
|
|
procedure TfrmdlgProb.SetDefaultProb(Alist: TStringList; prob: string);
|
|
var
|
|
Today: string;
|
|
|
|
function Permanent: char;
|
|
begin
|
|
// =================== changed code - REV 7/30/98 =========================
|
|
// PlUser.usVerifyTranscribed is a SITE requirement, not a USER ability
|
|
if PlUser.usVerifyTranscribed and not PlUser.usPrimeUser then
|
|
result:='T'
|
|
else
|
|
result:='P';
|
|
//===========================================================================
|
|
{ if PLUser.usPrimeUser or (PlUser.usVerifyTranscribed) then
|
|
result:='P'
|
|
else
|
|
result:='T';}
|
|
end;
|
|
|
|
begin {BODY }
|
|
Today := PLPt.Today;
|
|
if Piece(prob, u, 4) <> '' then
|
|
alist.add('NEW' + v + '.01' + v +Piece(prob, u, 4) + u + Piece(prob, u, 3))
|
|
else
|
|
alist.add('NEW' + v + '.01' + v + u); {no icd code}
|
|
{Leave ien of .05 undefined - let host save routine compute it}
|
|
alist.add('NEW' + v + '.05' + v + u + Piece(prob,u,2));{actual text}
|
|
alist.add('NEW' + v + '.06' + v + PLPt.PtVAMC);
|
|
alist.add('NEW' + v + '.08' + v + Today);
|
|
alist.add('NEW' + v + '.12' + v + 'A' + u + 'ACTIVE');
|
|
alist.add('NEW' + v + '.13' + v + '');
|
|
alist.add('NEW' + v + '1.01' + v + Piece(prob,u,1) + u + Piece(prob,u,2));{standardized text}
|
|
alist.add('NEW' + v + '1.02' + v + Permanent); {Permanent or Transcribed status}
|
|
alist.add('NEW' + v + '1.03' + v + inttostr(Encounter.Provider) + u + Encounter.Providername); {ent by}
|
|
alist.add('NEW' + v + '1.04' + v + inttostr(Encounter.Provider) + u + Encounter.Providername); {recording prov}
|
|
alist.add('NEW' + v + '1.05' + v + inttostr(Encounter.Provider) + u + Encounter.Providername); {resp prov}
|
|
alist.add('NEW' + v + '1.06' + v + PLUser.usService); {user's service/section}
|
|
alist.add('NEW' + v + '1.07' + v + '');
|
|
alist.add('NEW' + v + '1.08' + v + '') ;{IntToStr(Encounter.Location));}
|
|
alist.add('NEW' + v + '1.09' + v + Today);
|
|
alist.add('NEW' + v + '1.1' + v + '0' + u + 'NO'); {SC}
|
|
alist.add('NEW' + v + '1.11' + v + '0' + u + 'NO'); {AO}
|
|
alist.add('NEW' + v + '1.12' + v + '0' + u + 'NO'); {RAD}
|
|
alist.add('NEW' + v + '1.13' + v + '0' + u + 'NO'); {ENV}
|
|
alist.add('NEW' + v + '1.14' + v + '');
|
|
end;
|
|
|
|
|
|
function TfrmdlgProb.BadDates:Boolean;
|
|
var
|
|
ds:string;
|
|
i:integer;
|
|
|
|
procedure Msg(msg: string);
|
|
begin
|
|
InfoBox('Dates must be in format m/d/y or m/d or y, or T+d or T-d' +
|
|
#13#10 + msg + ' is formatted improperly.' +
|
|
#13#10 + ' Please check the other dates as well.',
|
|
'Information', MB_OK or MB_ICONINFORMATION);
|
|
end;
|
|
begin
|
|
result:=True; {initialize for error condition}
|
|
if edRecDate.text <>'' then
|
|
begin
|
|
ds:=DateStringOk(edRecDate.text);
|
|
if ds = 'ERROR' then
|
|
begin
|
|
msg('Recorded');
|
|
exit;
|
|
end;
|
|
end ;
|
|
if edResDate.text <>'' then
|
|
begin
|
|
ds:=DateStringOk(edResDate.text);
|
|
if ds = 'ERROR' then
|
|
begin
|
|
msg('Resolved');
|
|
exit;
|
|
end;
|
|
end ;
|
|
if edOnsetDate.text <>'' then
|
|
begin
|
|
ds:=DateStringOk(edOnsetDate.text);
|
|
if ds = 'ERROR' then
|
|
begin
|
|
msg('Onset');
|
|
exit;
|
|
end;
|
|
if StrToFMDateTime(edOnsetDate.Text) > FMNow then
|
|
begin
|
|
InfoBox('Onset dates in the future are not allowed.', 'Information', MB_OK or MB_ICONINFORMATION);
|
|
Exit;
|
|
end;
|
|
end ;
|
|
for i:=0 to pred(lstComments.Items.Count) do
|
|
begin
|
|
if Piece(lstComments.Items[i],u,2)<>'' then {may have blank lines at bottom}
|
|
begin
|
|
ds:=DateStringOk(Piece(lstComments.Items[i],u,1));
|
|
if ds='ERROR' then
|
|
begin
|
|
msg('Comment #' + inttostr(i));
|
|
exit;
|
|
end;
|
|
end;
|
|
end;
|
|
result:=False; {made it through, so no bad dates}
|
|
end;
|
|
|
|
procedure TfrmdlgProb.ControlChange(Sender: TObject);
|
|
begin
|
|
fChanged:=true;
|
|
end;
|
|
|
|
destructor TfrmdlgProb.Destroy;
|
|
begin
|
|
ProbRec.free;
|
|
ProbRec := nil;
|
|
FCtrlMap.Free;
|
|
if fprobs.dlgProbs <> nil then fprobs.dlgProbs := nil;
|
|
if (not Application.Terminated) and (not uInit.TimedOut) then {prevents GPF if system close box is clicked
|
|
while frmDlgProbs is visible}
|
|
if Assigned(frmProblems) then PostMessage(frmProblems.Handle, UM_CLOSEPROBLEM, 0, 0);
|
|
inherited Destroy ;
|
|
end;
|
|
|
|
procedure TfrmdlgProb.cbProvDropDown(Sender: TObject);
|
|
var
|
|
alist:TstringList;
|
|
i:integer;
|
|
v:string;
|
|
begin
|
|
v := uppercase(cbProv.text);
|
|
if (v <> '') then
|
|
begin
|
|
alist := TstringList.create;
|
|
try
|
|
AList.Assign(ProviderList('',25,V,V)) ;
|
|
if alist.count > 0 then
|
|
begin
|
|
if cbProv.items.count + 25 > 100 then
|
|
for i := 0 to 75 do {don't allow more than 100 to build up}
|
|
cbProv.Items.delete(i);
|
|
for i := 0 to pred(alist.count) do
|
|
cbProv.Items.add(Alist[i]); {add new ones to list}
|
|
end;
|
|
finally
|
|
alist.free;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TfrmdlgProb.cbLocDropDown(Sender: TObject);
|
|
var
|
|
alist: TstringList;
|
|
v: string;
|
|
begin
|
|
v := uppercase(cbLoc.text);
|
|
alist := TstringList.create;
|
|
try
|
|
AList.Assign(ClinicSearch(' ')) ;
|
|
if alist.count > 0 then cbLoc.Items.assign(Alist);
|
|
finally
|
|
alist.free;
|
|
end;
|
|
end;
|
|
|
|
procedure TfrmdlgProb.FormCreate(Sender: TObject);
|
|
begin
|
|
FSilent := False;
|
|
if rgStatus.ItemIndex = -1
|
|
then
|
|
InitialFocus := rgStatus
|
|
else
|
|
InitialFocus := rgStatus.Controls[rgStatus.ItemIndex] as TWinControl;
|
|
end;
|
|
|
|
{ old TPLDlgForm Methods }
|
|
|
|
constructor TfrmdlgProb.Create(AOwner: TComponent);
|
|
{ It is unusual to not call the inherited Create first, but necessary in this case; some
|
|
of the TMStruct objects need to be created before the form gets its OnCreate event. }
|
|
begin
|
|
FCtrlMap := TStringList.Create; { FCtrlMap[n]='CtrlName=PtrID' }
|
|
inherited Create(AOwner);
|
|
FInitialShow := True;
|
|
FModified := False;
|
|
FEditing := False;
|
|
end;
|
|
|
|
procedure TfrmdlgProb.CreateParams(var Params: TCreateParams);
|
|
begin
|
|
inherited CreateParams(Params);
|
|
{ to make the form a child window }
|
|
with Params do
|
|
begin
|
|
if Owner is TPanel then
|
|
WndParent := (Owner as TPanel).Handle
|
|
else {pdr}
|
|
WndParent := Application.MainForm.Handle;
|
|
Style := ws_Child or ws_ClipSiblings;
|
|
X := 0;
|
|
Y := 0;
|
|
end;
|
|
end;
|
|
|
|
procedure TfrmdlgProb.Loaded;
|
|
begin
|
|
inherited Loaded;
|
|
{ allow the form to be treated as a child form }
|
|
Visible := False;
|
|
Position := poDefault;
|
|
BorderIcons := [];
|
|
BorderStyle := bsNone;
|
|
HandleNeeded;
|
|
end;
|
|
|
|
procedure TfrmdlgProb.DoShow;
|
|
begin
|
|
FInitialShow := False;
|
|
inherited DoShow;
|
|
end;
|
|
|
|
procedure TfrmdlgProb.SetFontSize( NewFontSize: integer);
|
|
begin
|
|
ResizeAnchoredFormToFont( self );
|
|
end;
|
|
|
|
{ base form procedures (shared by all ordering dialogs) }
|
|
|
|
|
|
procedure TfrmdlgProb.ClearDialogControls; { Reset all the controls in the dialog }
|
|
var
|
|
i: Integer;
|
|
begin
|
|
for i := 0 to ControlCount - 1 do
|
|
begin
|
|
if Controls[i] is TLabel then Continue;
|
|
if Controls[i] is TButton then Continue;
|
|
end;
|
|
LoadDefaults; { added for lab to reset cleared lists }
|
|
end;
|
|
|
|
procedure TfrmdlgProb.LoadDefaults;
|
|
begin
|
|
{ by default nothing - should override in specific dialog }
|
|
end;
|
|
|
|
|
|
|
|
function TfrmdlgProb.LackRequired: Boolean;
|
|
begin
|
|
Result := False; { should override to check for additional required fields }
|
|
end;
|
|
|
|
|
|
procedure TfrmdlgProb.UMTakeFocus(var Message: TMessage);
|
|
begin
|
|
if FInitialFocus = nil then exit; {PDR}
|
|
if (FInitialFocus.visible) and (FInitialFocus.enabled) then FInitialFocus.SetFocus;
|
|
end;
|
|
|
|
procedure TfrmdlgProb.bbChangeProbClick(Sender: TObject);
|
|
const
|
|
TX799 = '799.9';
|
|
var
|
|
newprob: string ;
|
|
frmPLLex: TfrmPLLex;
|
|
begin
|
|
if PLUser.usUseLexicon then
|
|
begin
|
|
frmPLLex:=TfrmPLLex.create(Application);
|
|
try
|
|
frmPLLex.showmodal;
|
|
finally
|
|
frmPLLex.Free;
|
|
end;
|
|
end
|
|
else
|
|
begin
|
|
PLProblem := InputBox('Change problem','Enter new problem name: ','') ;
|
|
if PLProblem<>'' then
|
|
PLProblem := u + PLProblem + u + TX799 + u
|
|
else
|
|
exit ;
|
|
end ;
|
|
|
|
{problems are in the form of: ien^.01^icd^icdifn , although only the .01 is required}
|
|
if PLProblem='' then exit ;
|
|
newprob := PLProblem ;
|
|
if frmProblems.HighlightDuplicate(NewProb, Piece(newprob, U, 2) + #13#10#13#10 +
|
|
'This problem would be a duplicate.'+#13#10 +
|
|
'Return to the list and see the highlighted problem.',
|
|
mtInformation, 'CHANGE') then
|
|
exit {bail out - don't want dups}
|
|
else
|
|
begin
|
|
{ien^.01^icd^icdifn - see SetDefaultProblem}
|
|
{Set new problem properties}
|
|
ProbRec.Problem.DHCPtoKeyVal(Piece(NewProb,u,1) + u + Piece(NewProb,u,2)) ; {1.01}
|
|
ProbRec.Diagnosis.DHCPtoKeyVal(Piece(NewProb,u,4) + u + Piece(NewProb,u,3)) ; {.01}
|
|
ProbRec.Narrative.DHCPtoKeyVal(u + Piece(NewProb,u,2)); {.05}
|
|
|
|
{mark it as changed}
|
|
fchanged := true ;
|
|
|
|
{Redraw heading}
|
|
if Piece(NewProb,u,3)<>'' then
|
|
edProb.Text:=Piece(NewProb,u,2) + ' (' + Piece(NewProb,u,3) + ')'
|
|
else
|
|
edProb.Text:=Piece(NewProb,u,2) + ' (799.9)'; {code not found, or free-text entry}
|
|
end ;
|
|
end ;
|
|
|
|
procedure TfrmdlgProb.cbLocNeedData(Sender: TObject; const StartFrom: String;
|
|
Direction, InsertAt: Integer);
|
|
begin
|
|
cbLoc.ForDataUse(SubSetOfClinics(StartFrom, Direction));
|
|
end;
|
|
|
|
procedure TfrmdlgProb.cbProvNeedData(Sender: TObject; const StartFrom: String;
|
|
Direction, InsertAt: Integer);
|
|
begin
|
|
cbProv.ForDataUse(SubSetOfProviders(StartFrom, Direction));
|
|
end;
|
|
|
|
procedure TfrmdlgProb.cbServNeedData(Sender: TObject; const StartFrom: String;
|
|
Direction, InsertAt: Integer);
|
|
begin
|
|
cbServ.ForDataUse(ServiceSearch(StartFrom, Direction));
|
|
end;
|
|
|
|
end.
|