unit fProbs; {$O-} interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, fHSplit, StdCtrls, ExtCtrls, Menus, ORCtrls, Buttons, uProbs, Grids, Vawrgrid, ORfn, uCore, fProbEdt, uConst, ComCtrls ; type TfrmProblems = class(TfrmHSplit) mnuProbs: TMainMenu; mnuView: TMenuItem; mnuViewChart: TMenuItem; mnuChartCover: TMenuItem; mnuChartProbs: TMenuItem; mnuChartMeds: TMenuItem; mnuChartOrders: TMenuItem; mnuChartNotes: TMenuItem; mnuChartCslts: TMenuItem; mnuChartDCSumm: TMenuItem; mnuChartLabs: TMenuItem; mnuChartReports: TMenuItem; mnuAct: TMenuItem; mnuActNew: TMenuItem; Z3: TMenuItem; mnuActChange: TMenuItem; mnuActInactivate: TMenuItem; mnuActRemove: TMenuItem; mnuActVerify: TMenuItem; Z4: TMenuItem; mnuActAnnotate: TMenuItem; Z1: TMenuItem; mnuViewActive: TMenuItem; mnuViewBoth: TMenuItem; popProb: TPopupMenu; popChange: TMenuItem; popInactivate: TMenuItem; popRestore: TMenuItem; popRemove: TMenuItem; popVerify: TMenuItem; N36: TMenuItem; popAnnotate: TMenuItem; N37: TMenuItem; pnlProbList: TORAutoPanel; pnlProbCats: TPanel; lblProbCats: TLabel; lstCatPick: TORListBox; pnlProbEnt: TPanel; pnlProbDlg: TPanel; wgProbData: TCaptionListBox; mnuViewInactive: TMenuItem; mnuViewRemoved: TMenuItem; N1: TMenuItem; mnuActRestore: TMenuItem; mnuViewFilters: TMenuItem; N2: TMenuItem; lblProbList: TOROffsetLabel; pnlView: TPanel; N3: TMenuItem; popViewDetails: TMenuItem; lstView: TORListBox; lblView: TOROffsetLabel; N4: TMenuItem; mnuActDetails: TMenuItem; bbNewProb: TORAlignButton; lblProbEnt: TLabel; mnuViewSave: TMenuItem; mnuViewRestoreDefault: TMenuItem; mnuViewComments: TMenuItem; sptProbPanel: TSplitter; pnlButtons: TPanel; bbOtherProb: TORAlignButton; bbCancel: TORAlignButton; pnlProbs: TPanel; lblProblems: TLabel; lstProbPick: TORListBox; edProbEnt: TCaptionEdit; mnuChartSurgery: TMenuItem; HeaderControl: THeaderControl; mnuViewInformation: TMenuItem; mnuViewDemo: TMenuItem; mnuViewVisits: TMenuItem; mnuViewPrimaryCare: TMenuItem; mnuViewMyHealtheVet: TMenuItem; mnuInsurance: TMenuItem; mnuViewFlags: TMenuItem; mnuViewReminders: TMenuItem; mnuViewRemoteData: TMenuItem; mnuViewPostings: TMenuItem; mnuOptimizeFields: TMenuItem; procedure mnuChartTabClick(Sender: TObject); procedure lstProbPickClick(Sender: TObject); procedure lstProbPickDblClick(Sender: TObject); procedure lstCatPickClick(Sender: TObject); procedure lstProbActsClick(Sender: TObject); procedure pnlRightResize(Sender:TObject); procedure pnlProbEntResize(Sender: TObject); procedure wgProbDataClick(Sender: TObject); procedure wgProbDataDblClick(Sender: TObject); procedure edProbEntKeyPress(Sender: TObject; var Key: Char); procedure bbOtherProbClick(Sender: TObject); procedure FormCreate(Sender: TObject); procedure bbCancelClick(Sender: TObject); procedure lstViewClick(Sender: TObject); procedure FormDestroy(Sender: TObject); procedure mnuViewSaveClick(Sender: TObject); procedure mnuViewRestoreDefaultClick(Sender: TObject); procedure mnuViewCommentsClick(Sender: TObject); procedure wgProbDataMeasureItem(Control: TWinControl; Index: Integer; var Height: Integer); procedure wgProbDataDrawItem(Control: TWinControl; Index: Integer; Rect: TRect; State: TOwnerDrawState); procedure HeaderControlSectionResize(HeaderControl: THeaderControl; Section: THeaderSection); procedure lstViewExit(Sender: TObject); procedure FormShow(Sender: TObject); procedure FormHide(Sender: TObject); procedure pnlRightExit(Sender: TObject); procedure bbNewProbExit(Sender: TObject); procedure FormMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); procedure ViewInfo(Sender: TObject); procedure mnuViewInformationClick(Sender: TObject); procedure mnuOptimizeFieldsClick(Sender: TObject); procedure HeaderControlSectionClick(HeaderControl: THeaderControl; Section: THeaderSection); procedure HeaderControlMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); procedure HeaderControlMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); function getTotalSectionsWidth : integer; procedure setSectionWidths; procedure sptHorzMoved(Sender: TObject); private FContextString: string; FFilterString: string; FAllProblems: TStringList; //Unfiltered list of problems FProblemsVisible: TStringList; //Parallels FAllProblems. "Y" for visible FItemData: TStringList; //Parallels Grid. String representation of integer indexes into FAllProblems // FProblemsVisible[FItemData[i]] = 'Y' FWarningShown: boolean; FOldFramePnlPatientExit: TNotifyEvent; FMousing: TDateTime; FSilent: boolean; procedure frmFramePnlPatientExit(Sender: TObject); procedure UMCloseProblem(var Message:TMessage); message UM_CLOSEPROBLEM; {pdr} procedure ApplyViewFilters; // procedure UMPLFilter(var Message:TMessage); message UM_PLFILTER; {pdr} procedure UMPLLexicon(var Message:TMessage); message UM_PLLEX; {pdr} procedure GetRowCount; procedure RefreshList; procedure SetGridPieces(Pieces: string); procedure ShowPnlView(); function PlainText( MString: string): string; function MString( index: integer): string; public function AllowContextChange(var WhyNot: string): Boolean; override; procedure LoadProblems; procedure LoadUserCats(AList:Tstringlist); procedure LoadUserProbs(AList:TstringList); procedure AddProblem; procedure EditProblem(const why:char); procedure LoadPatientParams(AList:TstringList); procedure LoadUserParams(Alist:TstringList); procedure UpdateProblem(const why:char;Line: string;AllProblemsIndex:integer); procedure RestoreProblem; procedure LoadPatientProblems(AList:TstringList;const status:char;init:boolean); procedure ClearPtData; override; procedure DisplayPage; override; procedure NoRowSelected; procedure RowSelected; procedure ClearGrid; procedure RequestPrint; override; procedure SetFontSize( NewFontSize: integer); override; function HighlightDuplicate( NewProb: string; const Msg: string; DlgType: TMsgDlgType; Action: string): boolean; property Silent: Boolean read FSilent write FSilent; end; function EncounterPresent: Boolean; const TX_PROV_LOC = 'A provider and location must be selected before' + #13#10 + 'entering or making any change to a problem.'; TC_PROV_LOC = 'Incomplete Information'; TX_INVALID_PATIENT = 'Problem list is unavailable: Patient DFN is undefined.'; TC_NO_PATIENT = 'No patient is selected'; TX_INACTIVE_CODE_V = 'references an inactive ICD code, and must be updated' + #13#10 + 'using the ''Change'' option before it can be verified.'; TC_INACTIVE_CODE = 'Inactive Code'; TX_INACTIVE_CODE = 'This problem references an inactive ICD code,' + #13#10 + 'and must be updated using the ''Change'' option.'; TX_ADD_REMOVED = 'Cannot add to the "Removed Problem List"'; TC_ADD_REMOVED = 'Unable to add'; RPT_PROBLIST = 21; CT_PROBLEMS = 2; // GridColWidths[i] = 0 for columns that are always hidden // GridColWidths[i] = -1 for one (and only one) adjustable column GridColWidths: Array[0..15] of integer =(0, 5, -1, 9, 9, 0, 12, 12, 12, 0, 0, 0, 0, 0, 0, 0); type arOrigSecWidths = array[0..15] of integer; var frmProblems: TfrmProblems; dlgProbs:TfrmdlgProb; gFontHeight: Integer; gFontWidth: Integer; gFixedWidth: Integer; origWidths: arOrigSecWidths; implementation uses fFrame, fProbFlt, fProbLex, rProbs, rcover, fCover, fRptBox, fProbCmt, fEncnt, fReportsPrint, fReports, rPCE, DateUtils; {$R *.DFM} function TfrmProblems.AllowContextChange(var WhyNot: string): Boolean; begin Result := inherited AllowContextChange(WhyNot); // sets result = true //if dlgProbs <> nil then Result := dlgProbs.OkToQuit; //if dlgProbs <> nil then dlgProbs.bbQuitClick(Self); //need to check here and set to false if quit was cancelled or true if accepted if dlgProbs <> nil then case BOOLCHAR[frmFrame.CCOWContextChanging] of '1': begin WhyNot := 'Changes to current problem will be discarded.'; Result := False; end; '0': begin if WhyNot = 'COMMIT' then begin FSilent := True; dlgProbs.Silent := True; dlgProbs.bbQuitClick(Self); end else begin dlgProbs.bbQuitClick(Self); Result := dlgProbs.CanQuit; end; end; end; end; procedure TfrmProblems.ClearPtData; begin inherited ClearPtData; ClearGrid; lblProbList.Caption := ''; wgProbData.Caption := lblProbList.Caption; FWarningShown := False; end; procedure TfrmProblems.DisplayPage; begin inherited DisplayPage; frmFrame.ShowHideChartTabMenus(mnuViewChart); frmFrame.mnuFilePrint.Tag := CT_PROBLEMS; frmFrame.mnuFilePrint.Enabled := True; frmFrame.mnuFilePrintSetup.Enabled := True; if InitPatient then begin FWarningShown := False; if PLUser <> nil then begin PLUser.Destroy; PLUser := nil; end; //ClearPtData; ShowPnlView; pnlButtons.SendToBack; pnlButtons.Hide; LoadProblems ; end; end; procedure TfrmProblems.mnuChartTabClick(Sender: TObject); begin inherited; frmFrame.mnuChartTabClick(Sender); end; {------------------------ pdr - Problem list gadget event methods ------------} procedure TfrmProblems.lstCatPickClick(Sender: TObject); var AList:TStringList; begin AList:=TStringList.create; try LoadUserProbs(AList); finally AList.free; end; end; procedure TfrmProblems.lstProbActsClick(Sender: TObject); var act, i, j: integer; Alist: TstringList; cmt, ProblemIFN, ut, x, line, comments: string ; ProbRec: TProbRec ; ContextString, FilterString: string; FilterChanged: boolean; AllProblemsIndex: integer; begin if PLPt = nil then begin InfoBox(TX_INVALID_PATIENT, TC_NO_PATIENT, MB_OK or MB_ICONWARNING); Exit; end; act := TComponent(Sender).tag ; if act = 0 then exit; // make sure a visit (time & location) is available before creating the problem case act of 100: {add new problem} begin if PlUser.usViewAct = 'R' then begin InfoBox(TX_ADD_REMOVED, TC_ADD_REMOVED, MB_ICONINFORMATION or MB_OK); exit; end; if not EncounterPresent then exit; PLProblem := ''; AList := TStringList.Create; pProviderID := Encounter.Provider; pProviderName := Encounter.ProviderName ; try if pnlView.Visible then begin pnlView.SendToBack; pnlProbCats.Show; pnlProbCats.BringToFront; pnlButtons.Visible := True; if PLUser.usUseLexicon then begin lblProbCats.Visible := True; lstCatPick.Visible := True; lblProblems.Visible := True; lstProbPick.Visible := True; lstCatPick.Clear ; LoadUserCats(AList); bbOtherProb.Visible := True; pnlProbList.Visible := True; lstCatPick.TabStop := True; lstProbPick.TabStop := True; lstView.TabStop := False; bbNewProb.TabStop := False; pnlProbList.BringToFront ; pnlProbCats.ClientHeight := (pnlProbList.ClientHeight - pnlButtons.ClientHeight) div 2; pnlProbEnt.Visible := False; pnlProbEnt.SendToBack; if (lstCatPick.Items.Count = 1) then if Piece(lstCatPick.Items[0], U, 1) = '-1' then bbOtherProbClick(Self); end else begin bbOtherProb.Visible := False; edProbEnt.Visible := True; lblProbEnt.Visible := True; pnlProbEnt.Visible := True; pnlProbEnt.BringToFront; pnlProbList.Visible := False; lstCatPick.TabStop := False; lstProbPick.TabStop := False; lstView.TabStop := True; bbNewProb.TabStop := True; pnlProbList.SendToBack ; edProbEnt.text := ''; if pnlProbEnt.Visible then edProbEnt.SetFocus; end; end else begin if (lstProbPick.itemindex < 0) and (edProbEnt.text = '') then InfoBox('Select a Problem to add from lists' + #13#10 + ' on left or enter a new one ', 'Information', MB_OK or MB_ICONINFORMATION) else begin AddProblem; lstProbPick.itemindex := -1; end; end ; finally AList.Free; end; end; 200: {Inactivate} begin if PlUser.usViewAct = 'R' then begin InfoBox('Cannot inactivate a problem on the "Removed Problem List"', 'Information', MB_OK or MB_ICONINFORMATION); exit; end; if (wgProbData.ItemIndex < 0) or (Piece(MString(wgProbData.itemindex), U, 3) = '') then InfoBox('Select a patient problem from the grid on right', 'Information', MB_OK or MB_ICONINFORMATION) else begin if not EncounterPresent then exit; pProviderID := Encounter.Provider; pProviderName := Encounter.ProviderName ; AllProblemsIndex := 0; repeat begin if wgProbData.Selected[AllProblemsIndex] then begin Line := FAllProblems[AllProblemsIndex]; if CharAt(Piece(Line, U, 2), 1) = 'A' then UpdateProblem('I',Line,AllProblemsIndex) else InfoBox('Problem "' + Trim(UpperCase(Piece(Piece(Line, U, 3), #13, 1))) + '" is already inactive.', 'Problem not updated', MB_ICONINFORMATION or MB_OK); end; inc(AllProblemsIndex); end; until AllProblemsIndex >= wgProbData.Count; RefreshList; end; if (PlUser.usViewAct='A') then begin AList := TStringList.Create ; LoadPatientProblems(Alist,'A',False) ; NoRowSelected ; end; RefreshList; end; 250: {Verify} begin if not PLuser.usVerifyTranscribed then exit ; if PlUser.usViewAct = 'R' then begin InfoBox('Cannot verify a problem on the "Removed Problem List"', 'Information', MB_OK or MB_ICONINFORMATION); exit; end; if (wgProbData.ItemIndex < 0) or (Piece(MString(wgProbData.ItemIndex), U, 3) = '') then InfoBox('Select a patient problem from the grid on right', 'Information', MB_OK or MB_ICONINFORMATION) else begin if not EncounterPresent then exit; pProviderID := Encounter.Provider; pProviderName := Encounter.ProviderName ; AllProblemsIndex := 0; repeat begin if wgProbData.Selected[AllProblemsIndex] then begin Line := FAllProblems[AllProblemsIndex]; if Pos('#',Piece(Line, U, 2)) > 0 then InfoBox('Problem "' + Trim(UpperCase(Piece(Piece(Line, U, 3), #13, 1))) + '" ' + #13#10 + TX_INACTIVE_CODE_V, TC_INACTIVE_CODE, MB_ICONWARNING or MB_OK) else if Pos('(u)',Piece(Line, U, 2)) = 0 then InfoBox('Problem "' + Trim(UpperCase(Piece(Piece(Line, U, 3), #13, 1))) + '" is already verified.', 'Problem not updated', MB_ICONINFORMATION or MB_OK) else UpdateProblem('V',Line,AllProblemsIndex); end; inc(AllProblemsIndex); end; until AllProblemsIndex >= wgProbData.Count; RefreshList; mnuActVerify.Enabled := False; popVerify.Enabled := False; end; end; 300: {detail} with wgProbData do begin if ItemIndex < 0 then InfoBox('Select a problem from the grid for Detail Display', 'Information', MB_OK or MB_ICONINFORMATION) else if StrToIntDef(Piece(MString(ItemIndex), U, 1),0)>0 then ReportBox(DetailProblem(StrToInt(Piece(MString(ItemIndex), U, 1))), Piece(Piece(MString(ItemIndex), U, 3), #13, 1), True); end; 400: {edit} begin if PlUser.usViewAct = 'R' then begin InfoBox('Cannot select a problem to edit from the "Removed Problem List"', 'Information', MB_OK or MB_ICONINFORMATION); exit; end; if wgProbData.ItemIndex < 0 then InfoBox('Select a problem from the grid to Edit', 'Information', MB_OK or MB_ICONINFORMATION) else begin if not EncounterPresent then exit; pProviderID := Encounter.Provider; pProviderName := Encounter.ProviderName ; EditProblem('E'); end end; 500: {Remove} begin if not PlUser.usPrimeUser then exit ; if PlUser.usViewAct = 'R' then begin InfoBox('Cannot remove from the "Removed Problem List"' +#13#10 + 'Use "Restore Problem"', 'Information', MB_OK or MB_ICONINFORMATION); exit; end; if wgProbData.ItemIndex < 0 then InfoBox('Select a problem from the grid to remove', 'Information', MB_OK or MB_ICONINFORMATION) else begin if not EncounterPresent then exit; pProviderID := Encounter.Provider; pProviderName := Encounter.ProviderName ; EditProblem('R'); end; end; 550: {Restore} begin if not PlUser.usPrimeUser then exit ; if PlUser.usViewAct <> 'R' then begin InfoBox('View the Removed Problems Display, and select a record to restore.', 'Information', MB_OK or MB_ICONINFORMATION); exit; end; if wgProbData.ItemIndex < 0 then InfoBox('Select a problem to restore from the grid on right', 'Information', MB_OK or MB_ICONINFORMATION) else begin if not EncounterPresent then exit; pProviderID := Encounter.Provider; pProviderName := Encounter.ProviderName ; RestoreProblem; end; end; 600: {Add Comment} begin if PlUser.usViewAct = 'R' then begin InfoBox('Cannot add a comment to a removed problem', 'Information', MB_OK or MB_ICONINFORMATION); exit; end; if wgProbData.ItemIndex < 0 then InfoBox('Select a problem to annotate from the grid on right', 'Information', MB_OK or MB_ICONINFORMATION) else begin if not EncounterPresent then exit; pProviderID := Encounter.Provider; pProviderName := Encounter.ProviderName ; AList := TStringList.Create; ProblemIFN := Piece(MString(wgProbData.ItemIndex), U, 1); AList.Assign(EditLoad(ProblemIFN, pProviderID, PLPt.ptVAMC)) ; 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} try ProbRec.PIFN := ProblemIFN; if not IsActiveICDCode(ProbRec.Diagnosis.extern) then begin InfoBox(TX_INACTIVE_CODE, TC_INACTIVE_CODE, MB_ICONWARNING or MB_OK); exit; end ; if ProbRec.CmtIsXHTML then begin InfoBox(ProbRec.CmtNoEditReason, 'Unable to add new comment', MB_ICONWARNING or MB_OK); exit; end ; cmt := NewComment ; if (StrToInt(Piece(cmt, U, 1)) > 0) and (Piece(cmt, U, 3) <> '') then begin ProbRec.AddNewComment(Piece(cmt, U, 3)); ut := ''; If PLUser.usPrimeUser then ut := '1'; AList.Assign(EditSave(ProblemIFN,pProviderID,PLPt.ptVAMC,ut,ProbRec.FilerObject)) ; LoadPatientProblems(AList,PlUser.usViewAct[1],true); end ; finally Alist.Free ; ProbRec.Free ; end ; end ; end; 700: {Active only} begin Alist := TstringList.create; try PlUser.usViewAct := 'A'; LoadPatientProblems(Alist,'A',false); SetPiece(FContextString, ';', 3, 'A'); GetRowCount; finally Alist.free; end; end; 800: {inactive Only} begin Alist := TstringList.create; try PlUser.usViewAct := 'I'; LoadPatientProblems(Alist,'I',false); SetPiece(FContextString, ';', 3, 'I'); GetRowCount; finally Alist.free; end; end; 900: {all problems display} begin Alist := TstringList.create; try PlUser.usViewAct := 'B'; LoadPatientProblems(Alist,'B',false); SetPiece(FContextString, ';', 3, 'B'); GetRowCount; finally Alist.free; end; end; 950: {Removed Problems Display} begin Alist := TstringList.create; try PlUser.usViewAct := 'R'; LoadPatientProblems(Alist,'R',false); SetPiece(FContextString, ';', 3, 'R'); GetRowCount; finally Alist.free; end; end; 975: {Select viewing filters} begin lstView.ItemIndex := -1; ContextString := '^;;' + PLUser.usViewAct[1] + ';' + PLUser.usViewComments; GetViewFilters(Font.Size, PLFilters, ContextString, FilterString, FilterChanged); if not FilterChanged then exit; FContextString := ContextString; FFilterString := FilterString; if (Piece(ContextString, ';', 3) <> PLUser.usViewAct[1]) then begin AList := TStringList.Create; try PLUser.usViewAct := Piece(ContextString, ';', 3); LoadPatientProblems(Alist, PLUser.usViewAct[1], False); finally AList.Free; end; end; if (Piece(ContextString, ';', 4) <> PLUser.usViewComments) then with FAllProblems do begin for i := 0 to Count - 1 do begin if Objects[i] = nil then continue; x := Piece(Piece(Strings[i], U, 3), #13, 1); if Piece(ContextString, ';', 4) = '1' then begin comments := ''; for j := 0 to TStringList(Objects[i]).Count - 1 do comments := comments + ' ' + TStringList(Objects[i]).Strings[j] + #13#10; //comments := comments + ' CMT: ' + TStringList(Items.Objects[i]).Strings[j] + #13#10; line := Strings[i]; SetPiece(line, U, 3, x + #13#10 + comments); Strings[i] := line; mnuViewComments.Checked := True; end else begin line := Strings[i]; SetPiece(line, U, 3, x); Strings[i] := line; mnuViewComments.Checked := False; end; end; RefreshList; PLUser.usViewComments := Piece(ContextString, ';', 4); end; pnlRightResize(Self); end ; end; end; procedure TfrmProblems.lstProbPickClick(Sender: TObject); begin if PlUser.usViewAct = 'R' then exit; pProviderID := Encounter.Provider ; AddProblem; TListBox(sender).itemindex := -1; end; procedure TfrmProblems.pnlProbEntResize(Sender: TObject); (*var i:integer;*) begin (* for i := 0 to pred(twincontrol(sender).controlcount) do begin twincontrol(sender).controls[i].width := twincontrol(sender).width - 4; twincontrol(sender).controls[i].left := 2; end;*) end; procedure TfrmProblems.wgProbDataClick(Sender: TObject); var S: string; begin pnlRight.font.color := self.font.color; S := MString(wgProbData.ItemIndex); pnlRight.caption := Piece(Piece(S, U , 3), #13, 1); if (Piece(S, U, 1) = '') or (Pos('No data available', Piece(S, U, 2)) > 0) or (Pos('No problems found.', Piece(S, U, 2)) > 0) then NoRowSelected else RowSelected ; end; procedure TfrmProblems.wgProbDataDblClick(Sender: TObject); begin lstProbActsClick(mnuActDetails); end; procedure TfrmProblems.lstProbPickDblClick(Sender: TObject); begin if PlUser.usViewAct = 'R' then exit; pProviderID := Encounter.Provider ; AddProblem; TListBox(sender).itemindex := -1; end; procedure TfrmProblems.edProbEntKeyPress(Sender: TObject; var Key: Char); begin if key=#13 then lstProbPickDblClick(sender); end; procedure TfrmProblems.bbOtherProbClick(Sender: TObject); var frmPLLex: TfrmPLLex; begin if not PLUser.usUseLexicon then exit; {don't allow lookup} frmPLLex := TFrmPLLex.create(Application); try frmPLLex.showmodal; finally frmPLLex.Free; end; end; procedure TfrmProblems.UMCloseProblem(var Message:TMessage); begin pnlView.BringToFront ; ShowPnlView; bbCancel.Enabled := True ; bbOtherProb.enabled := true; {restore lexicon access} pnlButtons.Visible := False; pnlButtons.SendToBack; pnlProbEnt.Visible := (not PLUser.usUseLexicon) ; if PLuser.usViewAct = 'A' then pnlRight.caption := ACTIVE_LIST_CAP else if PLuser.usViewAct = 'I' then pnlRight.caption := INACTIVE_LIST_CAP else if PLuser.usViewAct = 'B' then pnlRight.caption := BOTH_LIST_CAP else if PLuser.usViewAct = 'R' then pnlRight.caption := REMOVED_LIST_CAP else begin PlUser.usViewAct := 'A'; pnlRight.caption := ACTIVE_LIST_CAP; end; if dlgProbs <> nil then dlgProbs:=nil; end; //procedure TfrmProblems.UMPLFilter(var Message:TMessage); procedure TfrmProblems.ApplyViewFilters; var i: integer; wantnulls: boolean; begin {the following escape is necessitated by change in default row height which corrupts display of hidden rows in wgProbData. Since the default rowheight is changed with each change in screen size, this gets called once before PLFilters is created} if PLFilters = nil then exit; {not initialized} {show all rows} wantnulls := (PLFilters.ProviderList.indexof('-1') > -1); for i := 0 to pred(FProblemsVisible.count) do FProblemsVisible[i] := 'Y'; {filter for provider} if PLFilters.ProviderList.Count > 0 then if PLFilters.ProviderList[0] <> '0' then { 0 signifies all } for i := 0 to pred(FAllProblems.count) do if Piece(FAllProblems[i], U, 1) <> '' then {don't want to disappear empty rows} if (PLFilters.ProviderList.indexof(Piece(FAllProblems[i], U, 10)) < 0) or ((Piece(FAllProblems[i], U, 10) = '') and (not wantnulls)) then FProblemsVisible[i] := 'N'; if PLUser.usCurrentView = PL_UF_VIEW then exit; {Bail out - no filtering by Loc} {conditionally filter for clinic(s) - may be multiple selected} if PLUser.usCurrentView = PL_OP_VIEW then begin wantnulls := (PLFilters.ClinicList.indexof('-1') > -1); if PLFilters.ClinicList.Count = 0 then exit; if PLFilters.ClinicList[0] <> '0' then { 0 signifies all } for i := 0 to pred(FAllProblems.count) do if (Piece(FAllProblems[i], U, 1) <> '') and {don't want to disappear empty rows} (FProblemsVisible[i] = 'Y') then {don't want if already filtered} begin if (Piece(FAllProblems[i], U ,11) <> '') and {clinic not on user list} (PLFilters.ClinicList.indexof(Piece(FAllProblems[i], U, 11)) < 0) then FProblemsVisible[i] := 'N' else if ((Piece(FAllProblems[i], U, 11) = '') and (not wantnulls)) then {no clinic recorded} FProblemsVisible[i] := 'N'; end; end else {conditionally filter for service - may be multiple selected} begin wantnulls := (PLFilters.ServiceList.indexof('-1') > -1); if PLFilters.ServiceList.Count = 0 then exit; if PLFilters.ServiceList[0] <> '0' then { 0 signifies all } for i := 0 to pred(FAllProblems.count) do if (Piece(FAllProblems[i], U, 1) <> '') and {don't want to disappear empty rows} (FProblemsVisible[i] = 'Y') then {don't want if already filtered} begin if (Piece(FAllProblems[i], U, 12) <> '') and {Service not on user list} (PLFilters.ServiceList.indexof(Piece(FAllProblems[i], U, 12)) < 0) then FProblemsVisible[i] := 'N' else if (Piece(FAllProblems[i], U, 12) = '') and (not wantnulls) then {no Service recorded} FProblemsVisible[i] := 'N'; end; end; end; procedure TfrmProblems.GetRowCount; var ShownProbs, TotalProbs: integer; begin if (wgProbData.Items.Count > 0) and (Piece(wgProbData.Items[0], U, 1) <> '') then ShownProbs := wgProbData.Items.Count else ShownProbs := 0; if (FAllProblems.Count > 0) and (Piece(FAllProblems[0], U, 1) <> '') then TotalProbs := FAllProblems.Count else TotalProbs := 0; case PLUser.usViewAct[1] of 'A': lblProbList.Caption := ACTIVE_LIST_CAP ; 'I': lblProbList.Caption := INACTIVE_LIST_CAP ; 'B': lblProbList.Caption := BOTH_LIST_CAP ; 'R': lblProbList.Caption := REMOVED_LIST_CAP ; end; lblProbList.Caption := lblProbList.Caption + ' (' + IntToStr(ShownProbs) + ' of ' + IntToStr(TotalProbs) + ')'; wgProbData.Caption := lblProbList.Caption; end; procedure TfrmProblems.UMPLLexicon(var Message:TMessage); begin if PLProblem = '' then exit; {shouldn't happen but...} if dlgProbs = nil then AddProblem; end; procedure TfrmProblems.SetGridPieces( Pieces: string); var i, AdjustCol, cxUsed: Integer; PieceSet: set of 0..High(GridColWidths); x: string; begin PieceSet := []; x := Pieces; while x <> '' do begin PieceSet := PieceSet + [StrToIntDef(Piece(x, ',', 1), 1)-1]; if Pos(',', x) = 0 then break; x := Copy(x, Pos(',',x)+1, Length(x)); end; AdjustCol := 0; cxUsed := 0; for i := 0 to High(GridColWidths) do if i in PieceSet then begin if GridColWidths[i] > -1 then begin if GridColWidths[i] > 0 then begin HeaderControl.Sections[i].MaxWidth := 10000; HeaderControl.Sections[i].Width := ForChars(GridColWidths[i], gFontWidth); cxUsed := cxUsed + HeaderControl.Sections[i].Width; end else begin HeaderControl.Sections[i].Width := 0; HeaderControl.Sections[i].MaxWidth := 0; end; end else AdjustCol := i; end else begin HeaderControl.Sections[i].Width := 0; HeaderControl.Sections[i].MaxWidth := 0; end; HeaderControl.Sections[AdjustCol].AutoSize := True; HeaderControl.Sections[AdjustCol].Width := HeaderControl.Width - cxUsed; //mnuOptimizeFieldsClick(self); //******** test making compression, proportional, or no spacing on resize end; procedure TfrmProblems.pnlRightResize(Sender: TObject); begin if PLUser = nil then exit; if PLUser.usCurrentView = PL_IP_VIEW then SetGridPieces('2,3,4,5,8,9') else if PLUser.usCurrentView = PL_OP_VIEW then SetGridPieces('2,3,4,5,7'); {have to do this to recover hidden rows} ApplyViewFilters; RefreshList; GetRowCount; //PostMessage(frmProblems.Handle, UM_PLFILTER,0,0); end; procedure TfrmProblems.FormCreate(Sender: TObject); begin inherited; FAllProblems := TStringList.Create; FProblemsVisible := TStringList.Create; FItemData := TStringList.Create; PageID := CT_PROBLEMS; wgProbData.Color := ReadOnlyColor; GetFontInfo(Canvas.Handle, gFontWidth, gFontHeight); end; procedure TfrmProblems.LoadUserParams(Alist:TstringList); var i: integer; begin AList.Assign(InitUser(User.DUZ)) ; //AList.Assign(InitUser(Encounter.Provider)) ; PLUser := TPLUserParams.create(Alist); FContextString := PLUser.usDefaultContext; FFilterString := PLUser.usDefaultView + '/'; if PLFilters <> nil then begin if PLUser.usDefaultView = 'C' then with PLFilters.ClinicList do for i := 0 to Count - 1 do if Piece(Strings[i], U, 1) <> '-1' then FFilterString := FFilterString + Piece(Strings[i], U, 1) + '/'; if PLUser.usDefaultView = 'S' then with PLFilters.ServiceList do for i := 0 to Count - 1 do if Piece(Strings[i], U, 1) <> '-1' then FFilterString := FFilterString + Piece(Strings[i], U, 1) + '/'; end; mnuViewComments.Checked := (PLUser.usViewComments = '1'); if PLUser.usTesting then InfoBox('WARNING - Test User Parameters in Effect', 'Warning', MB_OK or MB_ICONWARNING); pnlRightResize(Self); end; procedure TfrmProblems.LoadPatientParams(AList:TstringList); begin AList.Assign(InitPt(Patient.DFN)) ; PLPt := TPLPt.create(Alist); end; procedure TfrmProblems.ClearGrid; var i:integer; begin with FAllProblems do for i := 0 to Count - 1 do if Objects[i] <> nil then begin TStringList(Objects[i]).Free; Objects[i] := nil; end; wgprobdata.Clear; FAllProblems.Clear; FProblemsVisible.Clear; end; procedure TfrmProblems.LoadPatientProblems(AList:TStringList; const Status:char; init:boolean); var {init should only be true when initializing a list for a new patient} x, line, ver, prio, comments: string; i, j, inact: Integer; st: char; CmtList: TStringList; //SCCond, tmpSCstr: string; procedure ReverseList(Alist:TstringList); var i,j:integer; begin i:=0; j:=pred(Alist.count); while i 1 then Alist.delete(0); {get rid of first element - it is a list count} SortByPiece(AList, u, 6); { Sort by FM date/time } SetListFMDateTime('MMM dd yyyy',AList, u, 6); { Change FM date to MM/DD/YY } SetListFMDateTime('MMM dd yyyy',AList, u, 5); { Change FM date to MM/DD/YY } if PLUser.usReverseChronDisplay then {reverse chron order if required} ReverseList(Alist); {populate the grid} if ((Alist.Count = 1) and (pos('No data available', Alist[0]) > 0))then begin FAllProblems.Add('^^No problems found.'); FProblemsVisible.Add('Y'); RefreshList; Alist.Clear ; NoRowSelected; exit ; end ; for i := 0 to pred(Alist.count) do begin FAllProblems.Add(''); FProblemsVisible.Add('Y'); comments := ''; CmtList.Clear; x := AList[i]; if (Piece(x, U, 18) = '#') and (CharAt(UpperCase(Status), 1) in ['A', 'B', 'I', 'R']) then begin ver := '#'; // inactive ICD code flag takes precedence over unverified flag if (Piece(x, U, 2) = 'A') then inact := inact + 1; end else if (PlUSer.usVerifyTranscribed) and (Piece(x, U, 9) = 'T') then ver := '(u)' else ver := ' '; if Piece(x, U, 14) = 'A' then prio := ' * ' else prio := ' ' ; Line := ''; SetPiece(Line, U, 2, Piece(x, U, 2) + prio + ver); if Piece(x, U, 15) = '1' then //problem has comments begin CmtList.Assign(GetProblemComments(Piece(x, U, 1))); if FAllProblems.Objects[i] = nil then FAllProblems.Objects[i]:= TStringList.Create; TStringList(FAllProblems.Objects[i]).Assign(CmtList); end; SetPiece(Line, U, 3, Piece(x, U, 3)); if PLUser.usViewComments = '1' then begin for j := 0 to CmtList.Count-1 do comments := comments + ' ' + CmtList.Strings[j] + #13#10; SetPiece(Line, U, 3, Piece(Line, U, 3) + #13#10 + comments); end; SetPiece(Line, U, 4, Trim(Piece(x, U, 5))); {onset date} SetPiece(Line, U, 5, Trim(Piece(x, U, 6))); {last updated} SetPiece(Line, U, 7, MixedCase(Piece(Piece(x, U, 10), ';', 2))); {location name} SetPiece(Line, U, 8, MixedCase(Piece(Piece(x, U, 12), ';', 2))); {provider name} SetPiece(Line, U, 9, MixedCase(Piece(Piece(x, U, 13), ';', 2))); {service name} {hidden cells} SetPiece(Line, U, 1, Piece(x, U, 1)); {problem IEN} SetPiece(Line, U, 6, Piece(x, U, 7)); {service connected status} SetPiece(Line, U, 11, Piece(Piece(x, U, 10), ';', 1)); {location IEN} SetPiece(Line, U, 13, Piece(x, U, 11)); {loc type} SetPiece(Line, U, 10, Piece(Piece(x, U, 12), ';', 1)); {responsible provider IEN} SetPiece(Line, U, 12, Piece(Piece(x, U, 13), ';', 1)); {service IEN} SetPiece(Line, U, 14, Piece(x, U, 4)); {code} SetPiece(Line, U, 15, Piece(x, U, 17)); {Service-connected conditions} SetPiece(Line, U, 16, Piece(x, U, 18)); {# = inactive ICD code stored with problem} FAllProblems[i] := Line; end; Alist.clear; if not init then SetViewFilters(Alist) else InitViewFilters(Alist); ApplyViewFilters; RefreshList; lstProbPick.ItemIndex := -1; if (ProbRec <> nil) and (ProbRec.PIFN <> '') then begin for i := 0 to wgProbData.Items.count-1 do if (Piece(MString(i), U, 1) = ProbRec.PIFN) then wgProbData.ItemIndex := i ; wgProbDataClick(Self); end else wgProbData.ItemIndex := -1; if (wgProbData.Items.Count > 0) and (wgProbData.ItemIndex > -1) then RowSelected else NoRowSelected; pnlRightResize(Self); if (not FWarningShown) and (inact > 0) and (CharAt(UpperCase(Status), 1) in ['A', 'B']) then begin InfoBox('There are ' + IntToStr(inact) + ' active problem(s) flagged with a "#" as having' + #13#10 + 'inactive ICD codes as of today''s date. Please correct these' + #13#10 + 'problems using the "Change" option.', 'Inactive ICD Codes Found', MB_ICONWARNING or MB_OK); FWarningShown := True; end; finally CmtList.Free; end; end; procedure TfrmProblems.LoadUserCats(AList:TStringList); begin if not PLUser.usUseLexicon then exit; {Bail out if not to use lexicon} Alist.clear; AList.Assign(UserProblemCategories(Encounter.Provider,Encounter.Location)) ; if Alist.count = 0 then begin lstCatPick.Items.Add('-1^None defined - use OTHER') ; lstProbPick.Visible := False ; lblProblems.Visible := False ; exit ; end ; lstCatPick.Items.assign(AList); lstCatPick.itemindex := 0; lstCatPickClick(frmProblems); end; procedure TfrmProblems.LoadUserProbs(AList:TStringList); var catien: string; begin if not PLUser.usUseLexicon then exit; {Bail out if not to use lexicon} if lstCatPick.itemindex < 0 then exit; {bail out} Alist.clear; catien := IntToStr(lstCatPick.itemIEN); AList.Assign(UserProblemList(catien)) ; {File 125.12, Each line contains: PROBLEM^DISPLAY TEXT^CODE^CODE IFN } {code ifn is derived} lstProbPick.Items.assign(Alist); end; procedure TfrmProblems.LoadProblems; var AList: TStringList; i: integer; begin pProviderID := 0; AList := TStringList.Create; try lstView.ItemIndex := -1; StatusText('Retrieving problem list...') ; if (PLUser = nil) or InitPatient then LoadUserParams(Alist); Alist.clear; if Patient.DFN <> '' then LoadPatientParams(Alist); Alist.clear; LoadPatientProblems(AList,PlUser.usViewAct[1],true); {initialize patient list} lstView.ItemIndex := -1; AList.clear; lstCatPick.Clear ; LoadUserCats(AList); {SET APPLICATION DEFAULTS} if (not PLUser.usPrimeUser) then begin {activities available to GMPLUSER only} mnuActRestore.enabled := False; mnuActRemove.enabled:=false; mnuViewRemoved.Enabled := False; popRemove.enabled:=false; popRestore.enabled := False; i := lstView.Items.IndexOf('Removed'); if i > -1 then lstView.Items.Delete(i); mnuActVerify.enabled:=false; popVerify.enabled:=false; end; if (not PLUser.usVerifyTranscribed) then begin mnuActVerify.enabled:=false; popVerify.enabled:=false; end; finally AList.Free; StatusText('') ; end; end; function TfrmProblems.HighlightDuplicate( NewProb: string; const Msg: string; DlgType: TMsgDlgType; Action: string): boolean; var dup: string; cmplist: TstringList; cmpp, i: integer; collapserow: boolean; begin Result := False; if Piece(newprob, U, 1) = '' then dup := CheckForDuplicateProblem('1', Piece(newprob, U, 2)) else dup := CheckForDuplicateProblem(Piece(newprob,U,1), Piece(newprob, U, 2)); if (Piece(dup, U, 1) <> '0') then // if adding, check all existing problems for duplicates // if changing, exclude curent problem from duplicate check if (Action = 'ADD') or ((Action = 'CHANGE') and (Piece(dup, U, 1) <> ProbRec.PIFN)) then begin if (Piece(dup, U, 2) <> PLUser.usViewAct) and (PLUser.usViewAct <> 'B') then begin lstView.SelectByID(Piece(dup, U, 2)); lstViewClick(Self); end; cmplist:=Tstringlist.create; try {find and highlight duplicate problem - match problem text minus trailing '*'} for i := 0 to FAllProblems.Count - 1 do cmpList.Add(TrimRight(Piece(Piece(Piece(FAllProblems[i], U, 3), #13, 1), '*', 1))); cmpp:=cmpList.indexof(TrimRight(Piece(Piece(newprob, U, 2), '*', 1))); finally cmplist.free; end; if cmpp > -1 then begin collapserow:= (FProblemsVisible[cmpp] <> 'Y'); if CollapseRow then wgProbData.Items.Insert(0, FAllProblems[cmpp]); //translate from FAllProblems index to wgProbData index for i := 0 to wgProbData.Items.Count - 1 do begin if StrToInt(FItemData[i]) = cmpp then with wgProbData do begin TopIndex := i; ItemIndex := i; Selected[i] := True; break; end; end; case DlgType of mtInformation: InfoBox(Msg, 'Information', MB_OK or MB_ICONINFORMATION); mtConfirmation: Result := InfoBox(Msg, 'Confirmation', MB_YESNO or MB_ICONQUESTION) <> IDYES; end; if collapserow then wgProbData.Items.Delete(0); end; end; end; procedure TfrmProblems.AddProblem; const TX799 = '799.9'; var newprob: string; begin if (PLPt.ptDead<>'') then {Check for dead patient} if InfoBox('This Patient has been deceased since ' + PLPt.ptDead + #13#10 + ' Proceed with problem addition?', 'Confirmation', MB_YESNO or MB_ICONQUESTION) = IDNO then exit; {bail out - if don't want to add to dead} {problems are in the form of: ien^.01^icd^icdifn , although only the .01 is required} if PLProblem <> '' then begin newProb:=PLProblem; PLProblem:=''; end else if edProbEnt.text<>'' then begin newprob:= u + edProbEnt.text + u + TX799 + u; {free text problem entry from editbox} edProbEnt.Visible := False; lblProbEnt.Visible := False; edProbEnt.Text := ''; end else if lstProbPick.itemindex > -1 then {problem selected from user list} {Each line contains: PROBLEM^DISPLAY TEXT^CODE^CODE IFN } newprob:=lstProbPick.Items[lstProbPick.itemindex]; if NewProb='' then exit; {should never happen} bbCancel.Enabled := False ; bbOtherProb.enabled:=false; {don't let them invoke lexicon till add completed} // ============= new duplicate checking code =================== if HighlightDuplicate(NewProb, 'This problem is a duplicate of the highlighted problem' + #13#10 + ' Proceed?', mtConfirmation, 'ADD') then begin bbCancel.Enabled := True ; bbOtherProb.enabled:=true; {don't let them invoke lexicon till add completed} exit; {bail out - if don't want dups} end ; //============================== End new code ========================= if ProbRec = nil then begin pnlRight.Caption := lblProbList.caption ; lblProbList.caption:='Add Problem'; wgProbData.Caption := lblProbList.Caption; pnlProbDlg.Visible := True; pnlProbDlg.BringToFront ; dlgProbs:=TFrmDlgProb.create(pnlProbDlg); dlgProbs.HorzScrollBar.Range := dlgProbs.ClientWidth; dlgProbs.VertScrollBar.Range := dlgProbs.ClientHeight; dlgProbs.parent:=pnlProbDlg; dlgProbs.Align := alClient ; dlgProbs.Reason:='A'; dlgProbs.SubjProb:=newprob; dlgProbs.show; PostMessage(dlgProbs.Handle, UM_TAKEFOCUS, 0, 0); end else InfoBox('Current Add/Edit/Display activity must be completed' + #13#10 + 'before another record may be added', 'Information', MB_OK or MB_ICONINFORMATION); end; procedure TfrmProblems.EditProblem(const why: char); var prob: string; reas: string; begin prob := Piece(MString(wgProbData.ItemIndex), U, 1); if (prob <> '') and (ProbRec = nil) then begin StatusText('Retrieving selected problem...') ; bbCancel.Enabled := False ; bbOtherProb.enabled := false; {don't let them invoke lexicon till edit completed} case why of 'E','e','C','c' : reas := 'Edit Problem'; 'D','d' : reas := 'Display Problem'; 'R','r' : reas := 'Remove Problem'; end; pnlRight.Caption := lblProbList.caption ; lblProbList.caption := reas; wgProbData.Caption := lblProbList.Caption; pnlProbDlg.Visible := True; pnlProbDlg.BringToFront ; dlgProbs := TFrmDlgProb.create(pnlProbDlg); dlgProbs.HorzScrollBar.Range := dlgProbs.ClientWidth; dlgProbs.VertScrollBar.Range := dlgProbs.ClientHeight; dlgProbs.parent := pnlProbDlg; dlgProbs.Align := alClient ; dlgProbs.Reason := why; with wgProbData do dlgProbs.subjProb:=prob + u + Piece(Piece(MString(itemindex), U, 3), #13, 1) + u + Piece(MString(itemindex), U, 14); StatusText('') ; dlgProbs.Show; PostMessage(dlgProbs.Handle, UM_TAKEFOCUS, 0, 0); end else begin case why of 'E','e','C','c' : reas := 'Edited'; 'D','d' : reas := 'Displayed'; 'R','r' : reas := 'Removed'; end; InfoBox('Current Add/Edit/Display activity must be completed' + #13#10 + 'before another record may be ' + reas, 'Information', MB_OK or MB_ICONINFORMATION); end; end; procedure TfrmProblems.UpdateProblem(const why:char; Line: string; AllProblemsIndex: integer); var Alist: TstringList; ProblemIFN: string; sv: string; i: integer; begin alist := TstringList.create; try problemIFN := Piece(Line, U, 1); {get the basic info - could shortcut, but try this for now} AList.Assign(EditLoad(ProblemIFN,pProviderID,PLPt.ptVAMC)) ; probRec := TProbrec.create(Alist); probRec.PIFN := problemIFN; ProbRec.RespProvider.DHCPtoKeyVal(inttostr(Encounter.Provider) + u + Encounter.ProviderName); {REV - V13} Alist.clear; case why of 'I': begin ProbRec.status := 'I'; {assume resolution date now with this option. user should do full edit otherwise} ProbRec.DateResStr := 'T'; Probrec.DateModStr := 'T'; AList.Assign(ProblemUpdate(ProbRec.AltFilerObject)) ; end; 'V': begin if not IsActiveICDCode(ProbRec.Diagnosis.extern) then begin InfoBox(TX_INACTIVE_CODE, TC_INACTIVE_CODE, MB_ICONWARNING or MB_OK); exit; end; Probrec.condition := 'P'; Probrec.DateModStr := 'T'; AList.Assign(ProblemVerify(ProbRec.PIFN)) ; end; end; if Alist.count<1 then {show error message} InfoBox('Unable to update record ', 'Information', MB_OK or MB_ICONINFORMATION) else if Alist[0]<'1' then InfoBox('Unable to update record: ' + #13#10 + ' ' + Alist[1] + ' (' + Probrec.PIFN + ')', 'Information', MB_OK or MB_ICONINFORMATION) {show inactivated problem} else if (why='I') then begin if (PlUser.usViewAct='A') then FProblemsVisible[AllProblemsIndex] := 'N' else begin SetPiece(line, U, 2, 'I'); FAllProblems[AllProblemsIndex] := line; end; end else if (why='V') then {show verified problem} begin sv := Piece(Line, U, 2); SetPiece(line, U, 2, Copy(sv,1,4)); //remove (u) FAllProblems[AllProblemsIndex] := line; end; finally 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; alist.free; ProbRec.free; ProbRec := nil; end; end; procedure TfrmProblems.RestoreProblem; const TC_RESTORE_EDIT = 'Unable to restore'; TX_RESTORE_EDIT = 'This problem references an inactive ICD code,' + #13#10 + 'and must be updated using the ''Change'' option' + #13#10 + 'before it can be restored.' + #13#10 + #13#10 + 'Would you like to edit this problem?'; var Alist:TstringList; i: integer; AProbRec: TProbRec; ProblemIFN: string; begin Alist := TStringList.create; ProblemIFN := Piece(MString(wgProbData.ItemIndex), U, 1); AList.Assign(EditLoad(ProblemIFN, pProviderID, PLPt.ptVAMC)) ; AProbRec:=TProbRec.Create(Alist); {create a problem object} try if not IsActiveICDCode(AProbRec.Diagnosis.extern) then begin if InfoBox(TX_RESTORE_EDIT, TC_RESTORE_EDIT, MB_YESNO or MB_ICONWARNING) = IDYES then begin AProbRec.Status := 'A'; EditProblem('C'); end else Exit; end else begin Alist.Assign(ProblemReplace(ProblemIFN)) ; if Alist[0] <> '1' then InfoBox('Unable to restore the problem record: ' + #13#10 + ' (' + AProbrec.PIFN + ')', 'Information', MB_OK or MB_ICONINFORMATION) else LoadPatientProblems(AList, 'R', False); GetRowCount; end; finally 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; AList.free; AProbRec.Free; end; end; procedure TfrmProblems.NoRowSelected; begin mnuActDetails.enabled := false; mnuActChange.enabled := false; mnuActVerify.enabled := false; mnuActInactivate.enabled := false; mnuActRestore.enabled := false; mnuActRemove.enabled := false; mnuActAnnotate.enabled := false; popChange.enabled := false; popVerify.enabled := false; popInactivate.enabled := false; popRestore.enabled := false; popRemove.enabled := false; popAnnotate.enabled := false; popViewDetails.enabled := False; end ; procedure TfrmProblems.RowSelected; var AnyUnver, AnyAct: integer; i: integer; begin if wgProbData.SelCount > 1 then begin mnuActDetails.enabled := false; mnuActChange.enabled := false; mnuActRestore.enabled := false; mnuActRemove.enabled := false; mnuActAnnotate.enabled := false; popChange.enabled := false; popRestore.enabled := false; popRemove.enabled := false; popAnnotate.enabled := false; popViewDetails.enabled := false; AnyUnver := 0; AnyAct := 0; for i := 0 to wgProbData.Count - 1 do begin if wgProbData.Selected[i] and (Copy(Piece(MString(i), U, 2),5,3)='(u)') then AnyUnver := AnyUnVer + 1; if wgProbData.Selected[i] and (Copy(Piece(MString(i), U, 2),1,1) = 'A') then AnyAct := AnyAct + 1; end; mnuActVerify.enabled := PLUser.usVerifyTranscribed and PLUser.usPrimeUser and (AnyUnver > 0); popVerify.enabled := PLUser.usVerifyTranscribed and PLUser.usPrimeUser and (AnyUnver > 0); mnuActInactivate.enabled := (AnyAct > 0); popInactivate.enabled := (AnyAct > 0); end else begin mnuActDetails.enabled := true; mnuActChange.enabled := true; mnuActRestore.enabled := PLUser.usPrimeUser; mnuActRemove.enabled := PLUser.usPrimeUser; mnuActAnnotate.enabled := true; popChange.enabled := true; popRestore.enabled := PLUser.usPrimeUser; popRemove.enabled := PLUser.usPrimeUser; popAnnotate.enabled := true; popViewDetails.enabled := true ; mnuActVerify.enabled := PLUser.usVerifyTranscribed and PLUser.usPrimeUser and (Copy(Piece(MString(wgProbData.ItemIndex), U, 2),5,3)='(u)') ; popVerify.enabled := PLUser.usVerifyTranscribed and PLUser.usPrimeUser and (Copy(Piece(MString(wgProbData.ItemIndex), U, 2),5,3)='(u)') ; mnuActInactivate.enabled := Copy(Piece(MString(wgProbData.ItemIndex), U, 2),1,1) = 'A' ; popInactivate.enabled := Copy(Piece(MString(wgProbData.ItemIndex), U, 2),1,1) = 'A' ; end; //Disable menu actions for REMOVED problems list display if PLUser.usViewAct = 'R' then begin mnuActAnnotate.Enabled := False; mnuActChange.Enabled := False; mnuActInactivate.Enabled := False; mnuActRemove.Enabled := False; mnuActVerify.Enabled := False; popAnnotate.Enabled := False; popChange.Enabled := False; popInactivate.Enabled := False; popRemove.Enabled := False; popVerify.Enabled := False; end; end ; procedure TfrmProblems.bbCancelClick(Sender: TObject); begin inherited; //Hide Panels pnlButtons.Hide; pnlButtons.SendToBack; pnlProbCats.Hide; pnlProbCats.SendToBack; //Show pnlView & Add Back to tab Order ShowPnlView; end; procedure TfrmProblems.lstViewClick(Sender: TObject); begin inherited; case lstView.ItemIndex of 0: tag := 700 ; {Active} 1: tag := 800 ; {Inactive} 2: tag := 900 ; {Both} 3: tag := 950 ; {Removed} { 4: tag := 975 ; {Filters...} end ; lstProbActsClick(Self) ; mnuOptimizeFieldsClick(self); end; function EncounterPresent: Boolean; { make sure a location and provider are selected, returns false if not } begin Result := True; if (Encounter.Provider = 0) or (Encounter.Location = 0) then begin UpdateEncounter(NPF_ALL); {*KCM*} frmFrame.DisplayEncounterText; end; if (Encounter.Provider = 0) or (Encounter.Location = 0) then begin if not frmFrame.CCOWDrivedChange then InfoBox(TX_PROV_LOC, TC_PROV_LOC, MB_OK or MB_ICONWARNING); {!!!} Result := False; end; end; procedure TfrmProblems.FormDestroy(Sender: TObject); begin ClearGrid; FItemData.Free; FAllProblems.Free; FProblemsVisible.Free; inherited; end; procedure TfrmProblems.mnuViewSaveClick(Sender: TObject); begin inherited; if PLPt = nil then begin InfoBox(TX_INVALID_PATIENT, TC_NO_PATIENT, MB_OK or MB_ICONWARNING); Exit; end; if InfoBox('Replace current defaults?','Confirmation', MB_YESNO or MB_ICONQUESTION) = IDYES then begin with PLUser do begin usDefaultContext := FContextString; usDefaultView := Piece(FFilterString, '/', 1); end; SaveViewPreferences(FFilterString + U + FContextString); end; end; procedure TfrmProblems.mnuViewRestoreDefaultClick(Sender: TObject); begin inherited; if PLPt = nil then begin InfoBox(TX_INVALID_PATIENT, TC_NO_PATIENT, MB_OK or MB_ICONWARNING); Exit; end; if PLFilters <> nil then begin PLFilters.Destroy; PLFilters := nil; end; if PLUser <> nil then begin PLUser.Destroy; PLUser := nil; end; ShowPnlView; LoadProblems ; end; procedure TfrmProblems.mnuViewCommentsClick(Sender: TObject); var x, line, comments: string; i, j: integer; begin inherited; if PLPt = nil then begin InfoBox(TX_INVALID_PATIENT, TC_NO_PATIENT, MB_OK or MB_ICONWARNING); Exit; end; mnuViewComments.Checked := not mnuViewComments.Checked; SetPiece(FContextString, ';', 4, BOOLCHAR[mnuViewComments.Checked]); PLUser.usViewComments := BOOLCHAR[mnuViewComments.Checked]; with FAllProblems do begin for i := 0 to Count - 1 do begin if Objects[i] = nil then continue; x := Piece(Piece(Strings[i], U, 3), #13, 1); if PLUser.usViewComments = '1' then begin comments := ''; for j := 0 to TStringList(Objects[i]).Count - 1 do comments := comments + ' ' + TStringList(Objects[i]).Strings[j] + #13#10; //comments := comments + ' CMT: ' + TStringList(Items.Objects[i]).Strings[j] + #13#10; Line := Strings[i]; SetPiece(Line, U, 3, x + #13#10 + comments); Strings[i] := Line; end else begin Line := Strings[i]; SetPiece(Line, U, 3, x); Strings[i] := Line; end; end; end; RefreshList; end; procedure TfrmProblems.RequestPrint; begin inherited; if PLPt = nil then begin InfoBox(TX_INVALID_PATIENT, TC_NO_PATIENT, MB_OK or MB_ICONWARNING); Exit; end; uReportType := ''; PrintReports(IntToStr(RPT_PROBLIST), 'Problem List') end; procedure TfrmProblems.SetFontSize( NewFontSize: integer); var OldParent: TWinControl; begin OldParent := nil; if Assigned(dlgProbs) then begin OldParent := dlgProbs.Parent; dlgProbs.Parent := nil; end; try {These labels are hidden in an ORAutoPanel, so have to be sized manually} lblProbCats.Height := ResizeHeight( Font, MainFont, lblProbCats.Height); lblProblems.Height := ResizeHeight( Font, MainFont, lblProblems.Height); inherited SetFontSize( NewFontSize); finally if Assigned(dlgProbs) then dlgProbs.Parent := OldParent; end; if Assigned(dlgProbs) then dlgProbs.SetFontSize( MainFontSize); mnuOptimizeFieldsClick(self); end; procedure TfrmProblems.RefreshList; var i: integer; begin RedrawSuspend(wgProbData.Handle); wgProbData.Clear; FItemData.Clear; for i := 0 to FAllProblems.Count-1 do if FProblemsVisible[i] = 'Y' then begin FItemData.Add(IntToStr(i)); if Piece(FAllProblems[i], U, 1) <> '' then wgProbData.Items.Add(PlainText(FAllProblems[i])) else wgProbData.Items.Add(FAllProblems[i]); end; wgProbData.Invalidate; RedrawActivate(wgProbData.Handle); end; procedure TfrmProblems.wgProbDataMeasureItem(Control: TWinControl; Index: Integer; var Height: Integer); var ARect: TRect; x: string; NewHeight: Integer; begin inherited; NewHeight := Height; with wgProbData do if Index < Items.Count then begin ARect := ItemRect(Index); ARect.Left := HeaderControl.Sections[0].Width + HeaderControl.Sections[1].Width + 2; ARect.Right := ARect.Left + HeaderControl.Sections[2].Width - 6; x := Piece(MString(Index), U, 3); NewHeight := WrappedTextHeightByFont( Canvas, Font, x, ARect); if NewHeight > 255 then NewHeight := 255; // windows appears to only look at 8 bits *KCM* if NewHeight < 13 then NewHeight := 13; // show at least one line *KCM* end; {if Index} Height := NewHeight; end; procedure TfrmProblems.wgProbDataDrawItem(Control: TWinControl; Index: Integer; Rect: TRect; State: TOwnerDrawState); var i: integer; begin inherited; with wgProbData do if Index < Items.Count then begin ListGridDrawLines(wgProbData, HeaderControl, Index, State); for i := 0 to HeaderControl.Sections.Count -1 do ListGridDrawCell(wgProbData, HeaderControl, Index, i, Piece(MString(Index),U,i+1), i = 2); end; {if Index} end; function TfrmProblems.PlainText(MString: string): string; var i: integer; begin result := ''; with HeaderControl do for i := 0 to Sections.Count -1 do if Sections[i].MaxWidth > 0 then if Trim(Piece(MString, U, i+1)) <> '' then result := result + Sections[i].Text + ': ' + Piece(MString, U, i+1) + CRLF; end; function TfrmProblems.MString(index: integer): string; begin if index = -1 then result := '' else result := FAllProblems[StrToInt(FItemData[index])]; end; procedure TfrmProblems.HeaderControlSectionResize( HeaderControl: THeaderControl; Section: THeaderSection); begin inherited; wgProbData.Invalidate; {FEvtColWidth := HeaderControl.Sections[0].Width; //code from fOrders RedrawSuspend(Self.Handle); //RedrawOrderList; RedrawActivate(Self.Handle); wgProbData.Invalidate; pnlRight.Refresh; pnlLeft.Refresh; } end; {Tab Order tricks. Need to change lstView bbNewProb bbOtherProb bbCancel pnlProbDlg wgProbData to lstView pnlProbDlg wgProbData bbNewProb bbOtherProb bbCancel } procedure TFrmProblems.lstViewExit(Sender: TObject); begin inherited; if IncSecond(FMousing,1) < Now then begin if (Screen.ActiveControl = bbNewProb) or (Screen.ActiveControl = bbOtherProb) or (Screen.ActiveControl = bbCancel) then FindNextControl( bbCancel, True, True, False).SetFocus; end; FMousing := 0; end; procedure TFrmProblems.pnlRightExit(Sender: TObject); begin inherited; if IncSecond(FMousing,1) < Now then begin if (Screen.ActiveControl = frmFrame.pnlPatient) then begin if lstView.Visible then FindNextControl( lstView, True, True, False).SetFocus else FindNextControl( edProbEnt, True, True, False).SetFocus end else if (Screen.ActiveControl = bbNewProb) or (Screen.ActiveControl = bbOtherProb) or (Screen.ActiveControl = bbCancel) then begin if bbNewProb.Visible then FindNextControl( bbNewProb, False, True, False).SetFocus else FindNextControl( bbOtherProb, False, True, False).SetFocus; end; end; FMousing := 0; end; procedure TFrmProblems.bbNewProbExit(Sender: TObject); begin inherited; if IncSecond(FMousing,1) < Now then begin if (Screen.ActiveControl = pnlProbDlg) or (Screen.ActiveControl = wgProbData) then frmFrame.pnlPatient.SetFocus else if (Screen.ActiveControl = lstView) or (Screen.ActiveControl = lstCatPick) then FindNextControl( frmFrame.pnlPatient, False, True, False).SetFocus; end; FMousing := 0; end; procedure TFrmProblems.frmFramePnlPatientExit(Sender: TObject); begin FOldFramePnlPatientExit(Sender); inherited; if IncSecond(FMousing,1) < Now then begin if (Screen.ActiveControl = pnlProbDlg) or (Screen.ActiveControl = wgProbData) then FindNextControl( pnlProbDlg, False, True, False).SetFocus; end; FMousing := 0; end; procedure TFrmProblems.FormHide(Sender: TObject); begin inherited; frmFrame.pnlPatient.OnExit := FOldFramePnlPatientExit; end; procedure TFrmProblems.FormShow(Sender: TObject); begin inherited; FOldFramePnlPatientExit := frmFrame.pnlPatient.OnExit; frmFrame.pnlPatient.OnExit := frmFramePnlPatientExit; end; procedure TfrmProblems.FormMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); begin inherited; FMousing := Now; end; procedure TfrmProblems.ShowPnlView; begin pnlView.BringToFront; pnlView.Show; lstView.TabStop := true; bbNewProb.TabStop := true; end; procedure TfrmProblems.ViewInfo(Sender: TObject); begin inherited; frmFrame.ViewInfo(Sender); end; procedure TfrmProblems.mnuViewInformationClick(Sender: TObject); begin inherited; mnuViewDemo.Enabled := frmFrame.pnlPatient.Enabled; mnuViewVisits.Enabled := frmFrame.pnlVisit.Enabled; mnuViewPrimaryCare.Enabled := frmFrame.pnlPrimaryCare.Enabled; mnuViewMyHealtheVet.Enabled := not (Copy(frmFrame.laMHV.Hint, 1, 2) = 'No'); mnuInsurance.Enabled := not (Copy(frmFrame.laVAA2.Hint, 1, 2) = 'No'); mnuViewFlags.Enabled := frmFrame.lblFlag.Enabled; mnuViewRemoteData.Enabled := frmFrame.lblCirn.Enabled; mnuViewReminders.Enabled := frmFrame.pnlReminders.Enabled; mnuViewPostings.Enabled := frmFrame.pnlPostings.Enabled; end; procedure TfrmProblems.mnuOptimizeFieldsClick(Sender: TObject); var totalSectionsWidth, unitvalue: integer; begin totalSectionsWidth := pnlRight.Width - 3; if totalSectionsWidth < 16 then exit; unitvalue := round(totalSectionsWidth / 16); with HeaderControl do begin if Sections[1].Width > 0 then Sections[1].Width := unitvalue; Sections[2].Width := pnlRight.Width - (unitvalue * 11) - 5; Sections[3].Width := unitvalue * 2; Sections[4].Width := unitvalue * 2; if Sections[6].Width > 0 then Sections[6].Width := unitvalue; if Sections[7].Width > 0 then Sections[7].Width := unitvalue * 2; if Sections[8].Width > 0 then Sections[8].Width := unitvalue * 2; if Sections[15].Width > 0 then Sections[15].Width := unitvalue; end; HeaderControlSectionResize(HeaderControl, HeaderControl.Sections[0]); HeaderControl.Repaint; end; procedure TfrmProblems.HeaderControlSectionClick( HeaderControl: THeaderControl; Section: THeaderSection); begin inherited; //if Section = HeaderControl.Sections[1] then mnuOptimizeFieldsClick(self); end; procedure TfrmProblems.HeaderControlMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); var i: integer; totalSectionsWidth, originalwidth: integer; begin inherited; totalSectionsWidth := getTotalSectionsWidth; if totalSectionsWidth > wgProbData.Width - 5 then begin originalwidth := 0; for i := 0 to HeaderControl.Sections.Count - 1 do originalwidth := originalwidth + origWidths[i]; if originalwidth < totalSectionsWidth then begin for i := 0 to HeaderControl.Sections.Count - 1 do HeaderControl.Sections[i].Width := origWidths[i]; wgProbData.Invalidate; end; end; end; function TfrmProblems.getTotalSectionsWidth : integer; var i: integer; begin Result := 0; for i := 0 to HeaderControl.Sections.Count - 1 do Result := Result + HeaderControl.Sections[i].Width; end; procedure TfrmProblems.HeaderControlMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin inherited; setSectionWidths; end; procedure TfrmProblems.setSectionWidths; var i: integer; begin for i := 0 to 15 do origWidths[i] := HeaderControl.Sections[i].Width; end; procedure TfrmProblems.sptHorzMoved(Sender: TObject); begin inherited; mnuOptimizeFieldsClick(self); end; end.