iSharkFly-Open
/
VistA-cprs
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
VistA-cprs/CPRS-Chart/fReports.pas

3074 lines
116 KiB
Plaintext
Raw Blame History

unit fReports;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
fHSplit, StdCtrls, ExtCtrls, ORCtrls, ComCtrls, Menus, uConst, ORDtTmRng,
OleCtrls, SHDocVw, Buttons, ClipBrd, rECS, Variants, StrUtils;
type
TfrmReports = class(TfrmHSplit)
PopupMenu1: TPopupMenu;
GotoTop1: TMenuItem;
GotoBottom1: TMenuItem;
FreezeText1: TMenuItem;
UnFreezeText1: TMenuItem;
calApptRng: TORDateRangeDlg;
Timer1: TTimer;
pnlLefTop: TPanel;
lblTypes: TOROffsetLabel;
Splitter1: TSplitter;
pnlLeftBottom: TPanel;
lblQualifier: TOROffsetLabel;
lblHeaders: TLabel;
lstHeaders: TORListBox;
lstQualifier: TORListBox;
pnlRightTop: TPanel;
pnlRightBottom: TPanel;
pnlRightMiddle: TPanel;
lblTitle: TOROffsetLabel;
TabControl1: TTabControl;
lvReports: TCaptionListView;
Memo1: TMemo;
WebBrowser1: TWebBrowser;
memText: TRichEdit;
sptHorzRight: TSplitter;
tvReports: TORTreeView;
PopupMenu2: TPopupMenu;
Print1: TMenuItem;
Copy1: TMenuItem;
Print2: TMenuItem;
Copy2: TMenuItem;
SelectAll1: TMenuItem;
SelectAll2: TMenuItem;
pnlProcedures: TPanel;
lblProcedures: TOROffsetLabel;
tvProcedures: TORTreeView;
lblProcTypeMsg: TOROffsetLabel;
pnlViews: TORAutoPanel;
chkDualViews: TCheckBox;
btnChangeView: TORAlignButton;
btnGraphSelections: TORAlignButton;
lblDateRange: TLabel;
lstDateRange: TORListBox;
pnlTopViews: TPanel;
procedure lstQualifierClick(Sender: TObject);
procedure GotoTop1Click(Sender: TObject);
procedure GotoBottom1Click(Sender: TObject);
procedure FreezeText1Click(Sender: TObject);
procedure UnFreezeText1Click(Sender: TObject);
procedure PopupMenu1Popup(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure DisplayHeading(aRanges: string);
procedure FormShow(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
procedure TabControl1Change(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure GoRemote(Dest: TStringList; AItem: string; AQualifier, ARpc: string; AHSTag: string; AHDR: string);
procedure lstHeadersClick(Sender: TObject);
procedure Splitter1CanResize(Sender: TObject; var NewSize: Integer;
var Accept: Boolean);
procedure WebBrowser1DocumentComplete(Sender: TObject;
const pDisp: IDispatch; var URL: OleVariant);
procedure sptHorzRightCanResize(Sender: TObject; var NewSize: Integer;
var Accept: Boolean);
procedure lstQualifierDrawItem(Control: TWinControl; Index: Integer;
Rect: TRect; State: TOwnerDrawState);
procedure tvReportsClick(Sender: TObject);
procedure lvReportsColumnClick(Sender: TObject; Column: TListColumn);
procedure lvReportsCompare(Sender: TObject; Item1, Item2: TListItem;
Data: Integer; var Compare: Integer);
procedure lvReportsSelectItem(Sender: TObject; Item: TListItem;
Selected: Boolean);
procedure LoadListView(aReportData: TStringList);
procedure LoadTreeView;
procedure tvReportsExpanding(Sender: TObject; Node: TTreeNode;
var AllowExpansion: Boolean);
procedure tvReportsCollapsing(Sender: TObject; Node: TTreeNode;
var AllowCollapse: Boolean);
procedure Print1Click(Sender: TObject);
procedure Copy1Click(Sender: TObject);
procedure Copy2Click(Sender: TObject);
procedure Print2Click(Sender: TObject);
procedure UpdateRemoteStatus(aSiteID, aStatus: string);
procedure lvReportsKeyUp(Sender: TObject; var Key: Word;
Shift: TShiftState);
procedure SelectAll1Click(Sender: TObject);
procedure SelectAll2Click(Sender: TObject);
procedure tvReportsKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
procedure Memo1KeyUp(Sender: TObject; var Key: Word;
Shift: TShiftState);
procedure LoadProceduresTreeView(x: string; var CurrentParentNode: TTreeNode;
var CurrentNode: TTreeNode);
procedure tvProceduresCollapsing(Sender: TObject; Node: TTreeNode;
var AllowCollapse: Boolean);
procedure tvProceduresExpanding(Sender: TObject; Node: TTreeNode;
var AllowExpansion: Boolean);
procedure tvProceduresClick(Sender: TObject);
procedure tvProceduresChange(Sender: TObject; Node: TTreeNode);
procedure tvProceduresKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
procedure chkDualViewsClick(Sender: TObject);
procedure btnChangeViewClick(Sender: TObject);
procedure btnGraphSelectionsClick(Sender: TObject);
procedure lstDateRangeClick(Sender: TObject);
procedure sptHorzMoved(Sender: TObject);
private
SortIdx1, SortIdx2, SortIdx3: Integer;
procedure ProcessNotifications;
procedure ShowTabControl;
procedure Graph(reportien: integer);
procedure GraphPanel(active: boolean);
public
procedure ClearPtData; override;
function AllowContextChange(var WhyNot: string): Boolean; override;
procedure DisplayPage; override;
procedure SetFontSize(NewFontSize: Integer); override;
procedure RequestPrint; override;
end;
var
frmReports: TfrmReports;
uHSComponents: TStringList; //components selected
//segment^OccuranceLimit^TimeLimit^Header...
//^(value of uComponents...)
uHSAll: TStringList; //List of all displayable Health Summaries
uLocalReportData: TStringList; //Storage for Local report data
uRemoteReportData: TStringList; //Storage for status of Remote data
uReportInstruction: String; //User Instructions
uNewColumn: TListColumn;
uListItem: TListItem;
uColumns: TStringList;
uTreeStrings: TStrings;
uMaxOcc: string;
uHState: string;
uQualifier: string;
uReportType: string;
uSortOrder: string;
uQualifierType: Integer;
uFirstSort: Integer;
uSecondSort: Integer;
uThirdSort: Integer;
uColChange: string; //determines when column widths have changed
uUpdateStat: boolean; //flag turned on when remote status is being updated
ulvSelectOn: boolean; //flag turned on when multiple items in lvReports control have been selected
uListState: Integer; //Checked state of list of Adhoc components Checked: Abbreviation, UnChecked: Name
uECSReport: TECSReport; //Event Capture Report, initiated in fFrame when Click Event Capture under Tools
UpdatingLvReports: Boolean; //Currently updating lvReports
UpdatingTvProcedures: Boolean; //Currently updating tvProcedures
implementation
{$R *.DFM}
uses ORFn, rCore, rReports, fFrame, uCore, uReports, fReportsPrint,
fReportsAdhocComponent1, activex, mshtml, dShared, fGraphs, rGraphs; //*****
const
CT_REPORTS =10; // ID for REPORTS tab used by frmFrame
QT_OTHER = 0;
QT_HSTYPE = 1;
QT_DATERANGE = 2;
QT_IMAGING = 3;
QT_NUTR = 4;
QT_PROCEDURES = 19;
QT_SURGERY = 28;
QT_HSCOMPONENT = 5;
QT_HSWPCOMPONENT = 6;
TX_NOREPORT = 'No report is currently selected.';
TX_NOREPORT_CAP = 'No Report Selected';
HTML_PRE = '<html><head><style>' + CRLF +
'PRE {font-size:8pt;font-family: "Courier New", "monospace"}' + CRLF +
'</style></head><body><pre>';
HTML_POST = CRLF + '</pre></body></html>';
var
uRemoteCount: Integer;
uFrozen: Boolean;
uHTMLDoc: string;
uReportRPC: string;
uHTMLPatient: ANSIstring;
uRptID: String;
uDirect: String;
uEmptyImageList: TImageList;
ColumnToSort: Integer;
ColumnSortForward: Boolean;
GraphForm: TfrmGraphs;
GraphFormActive: boolean;
procedure TfrmReports.ClearPtData;
begin
inherited ClearPtData;
Timer1.Enabled := False;
memText.Clear;
tvProcedures.Items.Clear;
lblProcTypeMsg.Visible := FALSE;
lvReports.SmallImages := uEmptyImageList;
lvReports.Items.Clear;
uLocalReportData.Clear;
uRemoteReportData.Clear;
TabControl1.Tabs.Clear;
TabControl1.Visible := false;
TabControl1.TabStop := false;
if (GraphForm <> nil) and GraphFormActive then
with GraphForm do
begin
GraphForm.SendToBack;
Initialize;
DisplayData('top');
DisplayData('bottom');
lstCheck.Items.Clear;
GraphFormActive := false;
end;
begin
end;
end;
procedure TfrmReports.Graph(reportien: integer);
begin
if GraphForm = nil then
begin
GraphForm := TfrmGraphs.Create(self);
try
with GraphForm do
begin
if btnClose.Tag = 1 then
Exit;
Parent := pnlRight;
Align := alClient;
pnlFooter.Tag := 1; //suppresses bottom of graph form
pnlBottom.Height := 1;
pnlMain.BevelInner := bvLowered;
pnlMain.BevelOuter := bvRaised;
pnlMain.Tag := reportien;
Initialize;
ResizeAnchoredFormToFont(GraphForm);
Show;
DisplayData('top');
DisplayData('bottom');
lstCheck.Items.Clear;
GraphPanel(true);
lstTypes.Hint := Patient.DFN;
BringToFront;
end;
finally
if GraphForm.btnClose.Tag = 1 then
begin
GraphFormActive := false;
GraphForm.Free;
GraphForm := nil;
end
else
GraphFormActive := true;
end;
end
else if GraphForm.btnClose.Tag = 1 then
Exit
else if GraphFormActive and (GraphForm.lstTypes.Hint = Patient.DFN) then
begin // displaying same patient
if Tag <> reportien then
with GraphForm do
begin // new report
pnlMain.Tag := reportien;
Initialize;
//DisplayData('top');
//DisplayData('bottom');
lstCheck.Items.Clear;
GraphPanel(true);
BringToFront;
end;
//no action
end
else if GraphForm.lstTypes.Hint = Patient.DFN then
begin // same patient, bring back graph
GraphPanel(true);
BringToFront;
GraphFormActive := true;
end
else
with GraphForm do
begin // new patient
pnlMain.Tag := reportien;
Initialize;
DisplayData('top');
DisplayData('bottom');
lstCheck.Items.Clear;
lstTypes.Hint := Patient.DFN;
GraphPanel(true);
BringToFront;
GraphFormActive := true;
end;
end;
procedure TfrmReports.GraphPanel(active: boolean);
var
aQualifier, aStartTime, aStopTime: string;
begin
if active then
begin
pnlLeftBottom.Height := pnlLeft.Height div 2;
pnlViews.Height := pnlLeftBottom.Height;
if pnlLeft.Height < 200 then
pnlTopViews.Height := 3
else
pnlTopViews.Height := 80;
lblQualifier.Visible := false;
lstQualifier.Visible := false;
pnlViews.Visible := true;
if lstDateRange.Tag = 0 then
begin
lstDateRange.Tag := 1;
aQualifier := PReportTreeObject(tvReports.Selected.Data)^.Qualifier;
aStartTime := Piece(aQualifier,';',1);
aStopTime := Piece(aQualifier,';',2);
GraphForm.cboDateRange.Items.Add(
'^' + aStartTime + ' to ' + aStopTime +'^^^' + aStartTime + ';' + aStopTime +
'^' + floattostr(strtofmdatetime(aStartTime)) + '^' + floattostr(strtofmdatetime(aStopTime)));
lstDateRange.Items := GraphForm.cboDateRange.Items;
//lstDateRange.ItemIndex := lstDateRange.Items.Count - 1;
lstDateRange.ItemIndex := lstDateRange.Items.Count - 2; //set to all results till fixed
lstDateRangeClick(self);
end;
pnlLeftBottom.Visible := true;
splitter1.Visible := true;
end
else
begin
lblQualifier.Visible := true;
lstQualifier.Visible := true;
pnlViews.Visible := false;
pnlLeftBottom.Height := lblHeaders.Height + lblQualifier.Height + 90;
end;
end;
function TfrmReports.AllowContextChange(var WhyNot: string): Boolean;
var
i: integer;
begin
Result := inherited AllowContextChange(WhyNot); // sets result = true
if Timer1.Enabled = true then
case BOOLCHAR[frmFrame.CCOWContextChanging] of
'1': begin
WhyNot := 'A remote data query in progress will be aborted.';
Result := False;
end;
'0': if WhyNot = 'COMMIT' then
begin
with RemoteSites.SiteList do for i := 0 to Count - 1 do
if TRemoteSite(Items[i]).Selected then
if Length(TRemoteSite(Items[i]).RemoteHandle) > 0 then
begin
TRemoteSite(Items[i]).ReportClear;
TRemoteSite(Items[i]).QueryStatus := '-1^Aborted';
UpdateRemoteStatus(TRemoteSite(Items[i]).SiteID, 'Query Aborted');
end;
Timer1.Enabled := false;
Result := True;
end;
end;
end;
procedure TfrmReports.RequestPrint;
begin
if uReportType = 'M' then
begin
InfoBox(TX_NOREPORT, TX_NOREPORT_CAP, MB_OK);
Exit;
end;
if (uReportType = 'V') and (length(piece(uHState,';',2)) > 0) then
begin
if lvReports.Items.Count < 1 then
begin
InfoBox('There are no items to be printed.', 'No Items to Print', MB_OK);
Exit;
end;
if lvReports.SelCount < 1 then
begin
InfoBox('Please select one or more items from the list to be printed.', 'No Items Selected', MB_OK);
Exit;
end;
end;
if (uReportType = 'G') and GraphFormActive then
with GraphForm do
begin
if (lvwItemsTop.SelCount < 1) and (lvwItemsBottom.SelCount < 1) then
begin
InfoBox('There are no items graphed.', 'No Items to Print', MB_OK);
Exit;
end
else
begin
mnuPopGraphPrintClick(mnuPopGraphPrint);
Exit;
end;
end;
if uQualifierType = QT_DATERANGE then
begin // = 2
if lstQualifier.ItemIndex < 0 then
begin
InfoBox('Please select from one of the Date Range items before printing', 'Incomplete Information', MB_OK);
end
else
PrintReports(uRptID, piece(uRemoteType,'^',4));
end
else
PrintReports(uRptID, piece(uRemoteType,'^',4));
end;
procedure TfrmReports.DisplayPage;
var
i: integer;
begin
inherited DisplayPage;
frmFrame.mnuFilePrint.Tag := CT_REPORTS;
frmFrame.mnuFilePrint.Enabled := True;
frmFrame.mnuFilePrintSetup.Enabled := True;
uUpdateStat := false;
ulvSelectOn := false;
uListState := GetAdhocLookup();
memText.SelStart := 0;
FormShow(self);
uHTMLPatient := '<DIV align left>'
+ '<TABLE width="75%" border="0" cellspacing="0" cellpadding="1">'
+ '<TR valign="bottom" align="left">'
+ '<TD nowrap><B>Patient: ' + Patient.Name + '</B></TD>'
+ '<TD nowrap><B>' + Patient.SSN + '</B></TD>'
+ '<TD nowrap><B>Age: ' + IntToStr(Patient.Age) + '</B></TD>'
+ '</TR></TABLE></DIV><HR>';
//the preferred method would be to use headers and footers
//so this is just an interim solution.
if not GraphFormActive then
pnlLeftBottom.Visible := False;
if InitPage then
begin
Splitter1.Visible := false;
pnlLeftBottom.Visible := false;
uMaxOcc := '';
uColChange := '';
LoadTreeView;
end;
if InitPatient and not (CallingContext = CC_NOTIFICATION) then
begin
lstQualifier.Clear;
tvProcedures.Items.Clear;
lblProcTypeMsg.Visible := FALSE;
lvReports.SmallImages := uEmptyImageList;
lvReports.Items.Clear;
lvReports.Columns.Clear;
lblTitle.Caption := '';
lvReports.Caption := '';
Splitter1.Visible := false;
pnlLeftBottom.Visible := false;
memText.Parent := pnlRightBottom;
memText.Align := alClient;
memText.Clear;
uReportInstruction := '';
uLocalReportData.Clear;
for i := 0 to RemoteSites.SiteList.Count - 1 do
TRemoteSite(RemoteSites.SiteList.Items[i]).ReportClear;
pnlRightTop.Height := lblTitle.Height + TabControl1.Height;
StatusText('');
with tvReports do
if Items.Count > 0 then
begin
tvReports.Selected := tvReports.Items.GetFirstNode;
end;
end;
case CallingContext of
CC_INIT_PATIENT: if not InitPatient then
begin
lstQualifier.Clear;
tvProcedures.Items.Clear;
lblProcTypeMsg.Visible := FALSE;
lvReports.SmallImages := uEmptyImageList;
lvReports.Items.Clear;
Splitter1.Visible := false;
pnlLeftBottom.Visible := false;
with tvReports do
if Items.Count > 0 then
begin
tvReports.Selected := tvReports.Items.GetFirstNode;
end;
end;
CC_NOTIFICATION: ProcessNotifications;
end;
end;
procedure TfrmReports.UpdateRemoteStatus(aSiteID, aStatus: string);
var
j: integer;
s: string;
c: boolean;
begin
if uUpdateStat = true then exit; //uUpdateStat also looked at in fFrame
uUpdateStat := true;
for j := 0 to frmFrame.lstCIRNLocations.Items.Count - 1 do
begin
s := frmFrame.lstCIRNLocations.Items[j];
c := frmFrame.lstCIRNLocations.checked[j];
if piece(s, '^', 1) = aSiteID then
begin
frmFrame.lstCIRNLocations.Items[j] := pieces(s, '^', 1, 3) + '^' + aStatus;
frmFrame.lstCIRNLocations.checked[j] := c;
end;
end;
uUpdateStat := false;
end;
procedure TfrmReports.LoadTreeView;
var
i,j: integer;
currentNode, parentNode, grandParentNode: TTreeNode;
x: string;
addchild, addgrandchild: boolean;
begin
tvReports.Items.Clear;
memText.Clear;
uHTMLDoc := '';
WebBrowser1.Navigate('about:blank');
tvProcedures.Items.Clear;
lblProcTypeMsg.Visible := FALSE;
lvReports.SmallImages := uEmptyImageList;
lvReports.Items.Clear;
uTreeStrings.Clear;
lblTitle.Caption := '';
lvReports.Caption := '';
ListReports(uTreeStrings);
addchild := false;
addgrandchild := false;
parentNode := nil;
grandParentNode := nil;
currentNode := nil;
for i := 0 to uTreeStrings.Count - 1 do
begin
x := uTreeStrings[i];
if UpperCase(Piece(x,'^',1))='[PARENT END]' then
begin
if addgrandchild = true then
begin
currentNode := grandParentNode;
addgrandchild := false;
end
else
begin
currentNode := parentNode;
addchild := false;
end;
continue;
end;
if UpperCase(Piece(x,'^',1))='[PARENT START]' then
begin
if addgrandchild = true then
currentNode := tvReports.Items.AddChildObject(grandParentNode,Piece(x,'^',3),MakeReportTreeObject(Pieces(x,'^',2,15)))
else
if addchild = true then
begin
currentNode := tvReports.Items.AddChildObject(parentNode,Piece(x,'^',3),MakeReportTreeObject(Pieces(x,'^',2,15)));
addgrandchild := true;
grandParentNode := currentNode;
end
else
begin
currentNode := tvReports.Items.AddObject(currentNode,Piece(x,'^',3),MakeReportTreeObject(Pieces(x,'^',2,15)));
parentNode := currentNode;
addchild := true;
end;
end
else
if addchild = false then
begin
currentNode := tvReports.Items.AddObject(currentNode,Piece(x,'^',2),MakeReportTreeObject(x));
parentNode := currentNode;
end
else
begin
if addgrandchild = true then
currentNode := tvReports.Items.AddChildObject(grandParentNode,Piece(x,'^',2),MakeReportTreeObject(x))
else
currentNode := tvReports.Items.AddChildObject(parentNode,Piece(x,'^',2),MakeReportTreeObject(x));
end;
end;
for i := 0 to tvReports.Items.Count - 1 do
if Piece(PReportTreeObject(tvReports.Items[i].Data)^.Qualifier,';',4) = '1' then
begin
HealthSummaryCheck(uHSAll,'1');
for j := 0 to uHSAll.Count - 1 do
tvReports.Items.AddChildObject(tvReports.Items[i],Piece(uHSAll[j],'^',2),MakeReportTreeObject(uHSAll[j]));
end;
if tvReports.Items.Count > 0 then begin
tvReports.Selected := tvReports.Items.GetFirstNode;
tvReportsClick(self);
end;
end;
procedure TfrmReports.SetFontSize(NewFontSize: Integer);
begin
inherited SetFontSize(NewFontSize);
memText.Font.Size := NewFontSize;
end;
procedure TfrmReports.LoadListView(aReportData: TStringList);
var
i,j,k,aErr: integer;
aTmpAray: TStringList;
aColCtr, aCurCol, aCurRow, aColID: integer;
x,y,z,c,aSite: string;
ListItem: TListItem;
begin
aSite := '';
aErr := 0;
ListItem := nil;
case uQualifierType of
QT_HSCOMPONENT:
begin // = 5
if (length(piece(uHState,';',2)) > 0) then //and (chkText.Checked = false) then
begin
with lvReports do
begin
ViewStyle := vsReport;
for j := 0 to aReportData.Count - 1 do
begin
if piece(aReportData[j],'^',1) = '-1' then //error condition, most likely remote call
continue;
ListItem := Items.Add;
aSite := piece(aReportData[j],'^',1);
ListItem.Caption := piece(aSite,';',1);
for k := 2 to uColumns.Count do
begin
ListItem.SubItems.Add(piece(aReportData[j],'^',k));
end;
end;
if aReportData.Count = 0 then
begin
uReportInstruction := '<No Data Available>';
memText.Lines.Clear;
memText.Lines.Add(uReportInstruction);
end
else
memText.Lines.Clear;
end;
end;
end;
QT_HSWPCOMPONENT:
begin // = 6
if (length(piece(uHState,';',2)) > 0) then //and (chkText.Checked = false) then
begin
aTmpAray := TStringList.Create;
aCurRow := 0;
aCurCol := 0;
aColCtr := 9;
aTmpAray.Clear;
with lvReports do
begin
for j := 0 to aReportData.Count - 1 do
begin
x := aReportData[j];
aColID := StrToIntDef(piece(x,'^',1),-1);
if aColID < 0 then //this is an error condition most likely an incompatible remote call
continue;
if aColID > (uColumns.Count - 1) then
begin
aErr := 1;
continue; //extract is out of sync with columns defined in 101.24
end;
if aColID < aColCtr then
begin
if aTmpAray.Count > 0 then
begin
if aColCtr = 1 then
begin
ListItem := Items.Add;
aSite := piece(aTmpAray[j],'^',1);
ListItem.Caption := piece(aSite,';',1);
ListItem.SubItems.Add(IntToStr(aCurRow) + ':' + IntToStr(aCurCol));
end
else
begin
c := aTmpAray[0];
if piece(uColumns.Strings[aCurCol],'^',4) = '1' then
c := c + '...';
z := piece(c,'^',1);
y := copy(c, (pos('^', c)), 9999);
if pos('^',y) > 0 then
begin
while pos('^',y) > 0 do
begin
y := copy(y, (pos('^', y)+1), 9999);
z := z + '^' + y;
end;
ListItem.SubItems.Add(z);
end
else
begin
ListItem.SubItems.Add(y);
end;
end;
RowObjects.Add(aSite, IntToStr(aCurRow) + ':' + IntToStr(aCurCol), uColumns.Strings[aCurCol], aTmpAray);
aTmpAray.Clear;
end;
aColCtr := 0;
aCurCol := aColID;
aCurRow := aCurRow + 1;
end
else
if aColID = aCurCol then
begin
z := '';
y := piece(x,'^',2);
if length(y) > 0 then z := y;
y := copy(x, (pos('^', x)+1), 9999);
if pos('^',y) > 0 then
begin
while pos('^',y) > 0 do
begin
y := copy(y, (pos('^', y)+1), 9999);
z := z + '^' + y;
end;
aTmpAray.Add(z);
end
else
begin
aTmpAray.Add(y);
end;
continue;
end;
if aTmpAray.Count > 0 then
begin
if aColCtr = 1 then
begin
ListItem := Items.Add;
aSite := piece(aTmpAray[0],'^',1);
ListItem.Caption := piece(aSite,';',1);
ListItem.SubItems.Add(IntToStr(aCurRow) + ':' + IntToStr(aCurCol));
end
else
begin
c := aTmpAray[0];
if piece(uColumns.Strings[aCurCol],'^',4) = '1' then
c := c + '...';
ListItem.SubItems.Add(c);
end;
RowObjects.Add(aSite, IntToStr(aCurRow) + ':' + IntToStr(aCurCol), uColumns.Strings[aCurCol], aTmpAray);
aTmpAray.Clear;
end;
aCurCol := aColID;
Inc(aColCtr);
y := '';
for k := 2 to 10 do
if length(piece(x,'^',k)) > 0 then
begin
if length(y) > 0 then y := y + '^' + piece(x,'^',k)
else y := y + piece(x,'^',k);
end;
aTmpAray.Add(y);
if aColCtr > 0 then
while aColCtr < aCurCol do
begin
ListItem.SubItems.Add('');
Inc(aColCtr);
end;
end;
if aTmpAray.Count > 0 then
begin
if aColCtr = 1 then
begin
ListItem := Items.Add;
aSite := piece(aTmpAray[0],'^',1);
ListItem.Caption := piece(aSite,';',1);
ListItem.SubItems.Add(IntToStr(aCurRow) + ':' + IntToStr(aCurCol));
end
else
begin
c := aTmpAray[0];
if piece(uColumns.Strings[aCurCol],'^',4) = '1' then
c := c + '...';
ListItem.SubItems.Add(c);
end;
RowObjects.Add(aSite, IntToStr(aCurRow) + ':' + IntToStr(aCurCol), uColumns.Strings[aCurCol], aTmpAray);
aTmpAray.Clear;
end;
end;
aTmpAray.Free;
end;
if uRptID = 'OR_R18:IMAGING' then with lvReports do //set image indicator for "Imaging" report
begin
SmallImages := dmodShared.imgImages;
for i := 0 to Items.Count - 1 do
if Items[i].SubItems[7] = 'Y' then
Items[i].SubItemImages[1] := IMG_1_IMAGE
else
Items[i].SubItemImages[1] := IMG_NO_IMAGES;
end
else lvReports.SmallImages := uEmptyImageList;
if uRptID = 'OR_PN:PROGRESS NOTES' then with lvReports do //set image indicator for "Progress Notes" report
begin
SmallImages := dmodShared.imgImages;
for i := 0 to Items.Count - 1 do
if StrToInt(Items[i].SubItems[7]) > 0 then
Items[i].SubItemImages[2] := IMG_1_IMAGE
else
Items[i].SubItemImages[2] := IMG_NO_IMAGES;
end
else lvReports.SmallImages := uEmptyImageList;
end;
end;
if aErr = 1 then
if User.HasKey('XUPROGMODE') then
ShowMessage('Programmer message: One or more Column ID''s in file 101.24 do not match ID''s coded in extract routine');
end;
procedure TfrmReports.lstQualifierClick(Sender: TObject);
var
MoreID: String; //Restores MaxOcc value
aRemote, aHDR: string;
i: integer;
begin
inherited;
if uFrozen = True then
begin
memo1.visible := False;
memo1.TabStop := False;
end;
MoreID := ';' + Piece(uQualifier,';',3);
aRemote := piece(uRemoteType,'^',1);
aHDR := piece(uRemoteType,'^',7);
SetPiece(uRemoteType,'^',5,lstQualifier.ItemID);
uHSComponents.Clear;
uHSAll.Clear;
tvProcedures.Items.Clear;
lblProcTypeMsg.Visible := FALSE;
uHTMLDoc := '';
if uReportType = 'H' then
begin
WebBrowser1.Visible := true;
WebBrowser1.TabStop := true;
WebBrowser1.Navigate('about:blank');
WebBrowser1.BringToFront;
memText.Visible := false;
memText.TabStop := false;
end
else
begin
WebBrowser1.Visible := false;
WebBrowser1.TabStop := false;
memText.Visible := true;
memText.TabStop := true;
memText.BringToFront;
RedrawActivate(memText.Handle);
end;
uLocalReportData.Clear;
uRemoteReportData.Clear;
for i := 0 to RemoteSites.SiteList.Count - 1 do
TRemoteSite(RemoteSites.SiteList.Items[i]).ReportClear;
uRemoteCount := 0;
if aHDR = '1' then
DisplayHeading(lstQualifier.ItemID)
else
DisplayHeading(lstQualifier.ItemID + MoreID);
if lstQualifier.ItemID = 'ds' then
begin
with calApptRng do
if Not (Execute) then
begin
lstQualifier.ItemIndex := -1;
Exit;
end
else if (Length(TextOfStart) > 0) and (Length(TextOfStop) > 0) then
begin
if (Length(piece(uRemoteType,'^',6)) > 0) and (StrToInt(piece(uRemoteType,'^',6)) > 0) then
if abs(FMDateTimeToDateTime(FMDateStart) - FMDateTimeToDateTime(FMDateStop)) > StrToInt(piece(uRemoteType,'^',6)) then
begin
InfoBox('The Date Range selected is greater than the' + CRLF + 'Maximum Days Allowed of ' + piece(uRemoteType,'^',6)
+ ' for this report.', 'No Report Generated',MB_OK);
lstQualifier.ItemIndex := -1;
exit;
end;
lstQualifier.ItemIndex := lstQualifier.Items.Add(RelativeStart +
';' + RelativeStop + U + TextOfStart + ' to ' + TextOfStop);
DisplayHeading(lstQualifier.ItemID + MoreID);
SetPiece(uRemoteType,'^',5,lstQualifier.ItemID);
end
else
begin
lstQualifier.ItemIndex := -1;
InfoBox('Invalid Date Range entered. Please try again','Invalid Date/time entry',MB_OK);
if (Execute) and (Length(TextOfStart) > 0) and (Length(TextOfStop) > 0) then
begin
lstQualifier.ItemIndex := lstQualifier.Items.Add(RelativeStart +
';' + RelativeStop + U + TextOfStart + ' to ' + TextOfStop);
DisplayHeading(lstQualifier.ItemID + MoreID);
SetPiece(uRemoteType,'^',5,lstQualifier.ItemID);
end
else
begin
lstQualifier.ItemIndex := -1;
InfoBox('No Report Generated!','Invalid Date/time entry',MB_OK);
exit;
end;
end;
end;
if (CharAt(lstQualifier.ItemID,1) = 'd') and (Length(piece(uRemoteType,'^',6)) > 0) and (StrToInt(piece(uRemoteType,'^',6)) > 0) then
if ExtractInteger(lstQualifier.ItemID) > (StrToInt(piece(uRemoteType,'^',6))) then
begin
InfoBox('The Date Range selected is greater than the' + CRLF + 'Maximum Days Allowed of ' + piece(uRemoteType,'^',6)
+ ' for this report.', 'No Report Generated',MB_OK);
lstQualifier.ItemIndex := -1;
exit;
end;
StatusText('Retrieving ' + lblTitle.Caption + '...');
Screen.Cursor := crHourGlass;
uReportInstruction := #13#10 + 'Retrieving data...';
memText.Lines.Add(uReportInstruction);
if WebBrowser1.Visible = true then
begin
uHTMLDoc := HTML_PRE + uReportInstruction + HTML_POST;
WebBrowser1.Navigate('about:blank');
end;
case uQualifierType of
QT_HSCOMPONENT:
begin // = 5
lvReports.SmallImages := uEmptyImageList;
lvReports.Items.Clear;
memText.Lines.Clear;
RowObjects.Clear;
if ((aRemote = '1') or (aRemote = '2')) then
GoRemote(uRemoteReportData, uRptID, lstQualifier.ItemID + MoreID, uReportRPC, uHState, aHDR);
if (length(piece(uHState,';',2)) > 0) then
begin
if not(aRemote = '2') then
LoadReportText(uLocalReportData, uRptID, lstQualifier.ItemID + MoreID, uReportRPC, uHState);
LoadListView(uLocalReportData);
end
else
begin
if ((aRemote = '1') or (aRemote = '2')) then
ShowTabControl;
pnlRightMiddle.Visible := false;
LoadReportText(uLocalReportData, uRptID, lstQualifier.ItemID + MoreID, uReportRPC, uHState);
if uLocalReportData.Count < 1 then
begin
uReportInstruction := '<No Report Available>';
memText.Lines.Add(uReportInstruction);
end
else
begin
QuickCopy(uLocalReportData,memText);
TabControl1.OnChange(nil);
end;
end;
end;
QT_HSWPCOMPONENT:
begin // = 6
lvReports.SmallImages := uEmptyImageList;
lvReports.Items.Clear;
RowObjects.Clear;
memText.Lines.Clear;
if ((aRemote = '1') or (aRemote = '2')) then
begin
Screen.Cursor := crDefault;
GoRemote(uRemoteReportData, uRptID, lstQualifier.ItemID + MoreID, uReportRPC, uHState, aHDR);
end;
if (length(piece(uHState,';',2)) > 0) then
begin
if not(aRemote = '2') then
LoadReportText(uLocalReportData, uRptID, lstQualifier.ItemID + MoreID, uReportRPC, uHState);
LoadListView(uLocalReportData);
end
else
begin
if ((aRemote = '1') or (aRemote = '2')) then
ShowTabControl;
pnlRightMiddle.Visible := false;
if not (aRemote = '2') then
begin
LoadReportText(uLocalReportData, uRptID, lstQualifier.ItemID + MoreID, uReportRPC, uHState);
if uLocalReportData.Count < 1 then
begin
uReportInstruction := '<No Report Available>';
memText.Lines.Add(uReportInstruction);
end
else
QuickCopy(uLocalReportData,memText);
end;
end;
end
else
begin
Screen.Cursor := crDefault;
GoRemote(uRemoteReportData, uRptID, lstQualifier.ItemID + MoreID, uReportRPC, uHState, aHDR);
if Pos('ECS',Piece(uRptID,':',1))>0 then
begin
if Pos('OR_ECS1',uRptID)>0 then
uECSReport.ReportHandle := 'ECPCER';
if Pos('OR_ECS2',uRptID)>0 then
uECSReport.ReportHandle := 'ECPAT';
uECSReport.ReportType := 'D';
if uECSReport.ReportHandle = 'ECPAT' then
begin
if InfoBox('Would you like the procedure reason be included in the report?', 'Confirmation', MB_YESNO or MB_ICONQUESTION) = IDYES then
uECSReport.NeedReason := 'Y'
else
uECSReport.NeedReason := 'N';
end;
FormatECSDate(lstQualifier.ItemID, uECSReport);
LoadECSReportText(uLocalReportData, uECSReport);
end else
LoadReportText(uLocalReportData, uRptID, lstQualifier.ItemID + MoreID, uReportRPC, uHState);
if TabControl1.TabIndex < 1 then
QuickCopy(uLocalReportData,memText);
end;
end;
Screen.Cursor := crDefault;
StatusText('');
memText.Lines.Insert(0,' ');
memText.Lines.Delete(0);
if WebBrowser1.Visible = true then
begin
if uReportType = 'R' then
uHTMLDoc := HTML_PRE + uLocalReportData.Text + HTML_POST
else
uHTMLDoc := uHTMLPatient + uLocalReportData.Text;
WebBrowser1.Navigate('about:blank');
end;
end;
procedure TfrmReports.GotoTop1Click(Sender: TObject);
var
Current, Desired : Longint;
begin
inherited;
with memText do
begin
SetFocus;
SelStart :=0;
SelLength :=0;
Current := SendMessage(memText.handle, EM_GETFIRSTVISIBLELINE, 0, 0);
Desired := SendMessage(memText.handle, EM_LINEFROMCHAR,
memText.SelStart + memText.SelLength ,0) - 1;
SendMessage(memText.Handle,EM_LINESCROLL, 0, Desired - Current);
end;
end;
procedure TfrmReports.GotoBottom1Click(Sender: TObject);
var
Current, Desired : Longint;
I,LineCount : Integer;
begin
Inherited;
LineCount :=0;
with memText do
begin
for I := 0 to lines.count-1 do
LineCount := LineCount + Length(Lines[I]) + 2;
SetFocus;
SelStart := LineCount;
SelLength :=0;
end;
Current := SendMessage(memText.handle, EM_GETFIRSTVISIBLELINE, 0, 0);
Desired := SendMessage(memText.handle, EM_LINEFROMCHAR,
memText.SelStart + memText.SelLength ,0);
SendMessage(memText.Handle,EM_LINESCROLL, 0, Desired - Current - 5);
end;
procedure TfrmReports.FreezeText1Click(Sender: TObject);
var
Current, Desired : Longint;
LineCount : Integer;
begin
Inherited;
If memText.SelLength > 0 then begin
Memo1.visible := true;
Memo1.TabStop := true;
Memo1.Text := memText.SelText;
If Memo1.Lines.Count <6 then
LineCount := Memo1.Lines.Count + 1
Else
LineCount := 5;
Memo1.Height := LineCount * frmReports.Canvas.TextHeight(memText.SelText);
Current := SendMessage(memText.handle, EM_GETFIRSTVISIBLELINE, 0, 0);
Desired := SendMessage(memText.handle, EM_LINEFROMCHAR,
memText.SelStart + memText.SelLength ,0);
SendMessage(memText.Handle,EM_LINESCROLL, 0, Desired - Current);
uFrozen := True;
end;
end;
procedure TfrmReports.UnFreezeText1Click(Sender: TObject);
begin
Inherited;
If uFrozen = True Then begin
uFrozen := False;
UnFreezeText1.Enabled := False;
Memo1.Visible := False;
Memo1.TabStop := False;
Memo1.Text := '';
end;
end;
procedure TfrmReports.PopupMenu1Popup(Sender: TObject);
begin
inherited;
If Screen.ActiveControl.Name <> memText.Name then
begin
memText.SetFocus;
memText.SelStart := 0;
end;
If memText.SelLength > 0 Then
FreezeText1.Enabled := True
Else
FreezeText1.Enabled := False;
If Memo1.Visible Then
UnFreezeText1.Enabled := True;
If memText.SelStart > 0 then
GotoTop1.Enabled := True
Else
GotoTop1.Enabled := False;
If SendMessage(memText.handle, EM_LINEFROMCHAR,
memText.SelStart,0) < memText.Lines.Count then
GotoBottom1.Enabled := True
Else
GotoBottom1.Enabled := False;
end;
procedure TfrmReports.FormCreate(Sender: TObject);
begin
inherited;
PageID := CT_REPORTS;
memText.Color := ReadOnlyColor;
uFrozen := False;
uHSComponents := TStringList.Create;
uHSAll := TStringList.Create;
uLocalReportData := TStringList.Create;
uRemoteReportData := TStringList.Create;
uColumns := TStringList.Create;
uTreeStrings := TStringList.Create;
uEmptyImageList := TImageList.Create(Self);
uEmptyImageList.Width := 0;
RowObjects := TRowObject.Create;
uRemoteCount := 0;
GraphFormActive := false;
end;
procedure TfrmReports.ProcessNotifications;
var
i: integer;
SelectID: string;
Found: boolean;
ListItem: TListItem;
begin
Found := False;
with tvReports do
begin
for i := 0 to Items.Count -1 do
if StrToIntDef(Piece(PReportTreeObject(tvReports.Items[i].Data)^.Qualifier,';',4),0) = QT_IMAGING then
begin
Found := True;
break;
end;
end;
if not Found then exit; // no imaging entry in treeview would result in error below, and loss of alert
case Notifications.Followup of
NF_IMAGING_RESULTS, NF_ABNORMAL_IMAGING_RESULTS, NF_IMAGING_RESULTS_AMENDED:
begin
tvReports.Selected := tvReports.Items[i];
SelectID := 'i' + Piece(Notifications.AlertData, '~', 1) +
'-' + Piece(Notifications.AlertData, '~', 2);
if tvReports.Selected <> tvReports.Items[i] then
tvReports.Selected := tvReports.Items[i];
end;
NF_IMAGING_REQUEST_CHANGED:
begin
tvReports.Selected := tvReports.Items[i];
SelectID := 'i' + Piece(Notifications.AlertData, '/', 2) +
'-' + Piece(Notifications.AlertData, '/', 3);
if tvReports.Selected <> tvReports.Items[i] then
tvReports.Selected := tvReports.Items[i];
end;
NF_STAT_RESULTS :
begin
tvReports.Selected := tvReports.Items[i];
SelectID := 'i' + Piece(Notifications.AlertData, '~', 2) +
'-' + Piece(Piece(Notifications.AlertData, '~', 3), '@', 1);
if tvReports.Selected <> tvReports.Items[i] then
tvReports.Selected := tvReports.Items[i];
end;
else with tvReports do if Items.Count > 0 then Selected := Items[0];
end;
if tvReports.Selected <> nil then
begin
tvReportsClick(Self);
for i := 0 to lvReports.Items.Count - 1 do
begin
ListItem := lvReports.Items[i];
if ListItem.Subitems[0] = SelectID then
begin
lvReports.Selected := lvReports.Items[i];
break;
end;
end;
Notifications.Delete;
end;
end;
procedure TfrmReports.DisplayHeading(aRanges: string);
var
x,x1,x2,y,z,DaysBack: string;
d1,d2: TFMDateTime;
begin
with lblTitle do
begin
x := '';
if tvReports.Selected = nil then
tvReports.Selected := tvReports.Items.GetFirstNode;
if tvReports.Selected.Parent <> nil then
x := tvReports.Selected.Parent.Text + ' ' + tvReports.Selected.Text
else
x := tvReports.Selected.Text;
x1 := '';
x2 := '';
if uReportType <> 'M' then
begin
if CharAt(aRanges, 1) = 'd' then
begin
if length(piece(aRanges,';',2)) > 0 then
begin
x2 := ' Max/site:' + piece(aRanges,';',2);
aRanges := piece(aRanges,';',1);
end;
DaysBack := Copy(aRanges, 2, Length(aRanges));
if DaysBack = '0' then
aRanges := 'T' + ';T'
else
aRanges := 'T-' + DaysBack + ';T';
end;
if length(piece(aRanges,';',1)) > 0 then
begin
d1 := ValidDateTimeStr(piece(aRanges,';',1),'');
d2 := ValidDateTimeStr(piece(aRanges,';',2),'');
y := FormatFMDateTime('mmm dd,yyyy',d1);
z := FormatFMDateTime('mmm dd,yyyy',d2);
x1 := ' [From: ' + y + ' to ' + z + ']';
end;
if length(piece(aRanges,';',3)) > 0 then
x2 := ' Max/site:' + piece(aRanges,';',3);
case uQualifierType of
QT_DATERANGE:
x := x + x1;
QT_HSCOMPONENT:
x := x + x1 + x2;
QT_HSWPCOMPONENT:
x := x + x1 + x2;
QT_IMAGING:
x := x + x1 + x2;
end;
end;
Caption := x;
end;
lvReports.Caption := x;
end;
procedure TfrmReports.FormShow(Sender: TObject);
begin
inherited;
if RemoteSites.SiteList.Count > 0 then
begin
case uQualifierType of
QT_HSWPCOMPONENT:;
QT_HSCOMPONENT:;
QT_IMAGING:;
QT_PROCEDURES:;
QT_NUTR:;
else
ShowTabControl;
end;
end;
end;
procedure TfrmReports.Timer1Timer(Sender: TObject);
var
i,j,fail: integer;
r0,aSite: String;
aHDR, aID, aRet: String;
begin
inherited;
with RemoteSites.SiteList do
begin
for i := 0 to Count - 1 do
if TRemoteSite(Items[i]).Selected then
begin
if Length(TRemoteSite(Items[i]).RemoteHandle) > 0 then
begin
r0 := GetRemoteStatus(TRemoteSite(Items[i]).RemoteHandle);
aSite := TRemoteSite(Items[i]).SiteName;
TRemoteSite(Items[i]).QueryStatus := r0; //r0='1^Done' if no errors
UpdateRemoteStatus(TRemoteSite(Items[i]).SiteID, piece(r0,'^',2));
if piece(r0,'^',1) = '1' then
begin
aHDR := piece(TRemoteSite(Items[i]).CurrentReportQuery, '^', 13);
aID := piece(piece(TRemoteSite(Items[i]).CurrentReportQuery, '^', 2),':',1);
if aHDR = '1' then
begin
ModifyHDRData(aRet, TRemoteSite(Items[i]).RemoteHandle ,aID);
end;
GetRemoteData(TRemoteSite(Items[i]).Data, TRemoteSite(Items[i]).RemoteHandle,Items[i]);
RemoteReports.Add(TRemoteSite(Items[i]).CurrentReportQuery,
TRemoteSite(Items[i]).RemoteHandle);
TRemoteSite(Items[i]).RemoteHandle := '';
TabControl1.OnChange(nil);
if (length(piece(uHState,';',2)) > 0) then
begin
uRemoteReportData.Clear;
QuickCopy(TRemoteSite(Items[i]).Data,uRemoteReportData);
fail := 0;
if uRemoteReportData.Count > 0 then
begin
if uRemoteReportData[0] = 'Report not available at this time.' then
begin
fail := 1;
UpdateRemoteStatus(TRemoteSite(Items[i]).SiteID,'Report not available');
end;
if piece(uRemoteReportData[0],'^',1) = '-1' then
begin
fail := 1;
UpdateRemoteStatus(TRemoteSite(Items[i]).SiteID,'Communication failure');
end;
if fail = 0 then
LoadListView(uRemoteReportData);
end;
end;
end
else
begin
uRemoteCount := uRemoteCount + 1;
if uRemoteCount > 90 then
begin
TRemoteSite(Items[i]).RemoteHandle := '';
TRemoteSite(Items[i]).QueryStatus := '-1^Timed out';
UpdateRemoteStatus(TRemoteSite(Items[i]).SiteID,'Timed out');
StatusText('');
TabControl1.OnChange(nil);
end
else
StatusText('Retrieving reports from '
+ TRemoteSite(Items[i]).SiteName + '...');
end;
Timer1.Interval := 10000;
end;
end;
if Timer1.Enabled = True then
begin
j := 0;
for i := 0 to Count -1 do
begin
if Length(TRemoteSite(Items[i]).RemoteHandle) > 0 then
begin
j := 1;
break;
end;
end;
if j = 0 then //Shutdown timer if all sites have been processed
begin
Timer1.Enabled := False;
StatusText('');
end;
j := 0;
for i := 0 to Count -1 do
if TRemoteSite(Items[i]).Selected = true then
begin
j := 1;
break;
end;
if j = 0 then //Shutdown timer if user has de-selected all sites
begin
Timer1.Enabled := False;
StatusText('');
TabControl1.OnChange(nil);
end;
end;
end;
end;
procedure TfrmReports.TabControl1Change(Sender: TObject);
var
aStatus,aSite: string;
hook: Boolean;
i: integer;
begin
inherited;
if (uQualifiertype <> 6) or (length(piece(uHState,';',2)) < 1) then
memText.Lines.Clear;
lstHeaders.Items.Clear;
uHTMLDoc := '';
if WebBrowser1.visible = true then WebBrowser1.Navigate('about:blank');
if (length(piece(uHState,';',2)) = 0) then with TabControl1 do
begin
memText.Lines.BeginUpdate;
if TabIndex > 0 then
begin
aStatus := TRemoteSite(Tabs.Objects[TabIndex]).QueryStatus;
aSite := TRemoteSite(Tabs.Objects[TabIndex]).SiteName;
if aStatus = '1^Done' then
begin
if Piece(TRemoteSite(Tabs.Objects[TabIndex]).Data[0],'^',1) = '[HIDDEN TEXT]' then
begin
lstHeaders.Clear;
hook := false;
for i := 1 to TRemoteSite(Tabs.Objects[TabIndex]).Data.Count - 1 do
if hook = true then
memText.Lines.Add(TRemoteSite(Tabs.Objects[TabIndex]).Data[i])
else
begin
lstHeaders.Items.Add(MixedCase(TRemoteSite(Tabs.Objects[TabIndex]).Data[i]));
if Piece(TRemoteSite(Tabs.Objects[TabIndex]).Data[i],'^',1) = '[REPORT TEXT]' then
hook := true;
end;
end
else
QuickCopy(TRemoteSite(Tabs.Objects[TabIndex]).Data,memText);
memText.Lines.Insert(0,' ');
memText.Lines.Delete(0);
end;
if Piece(aStatus,'^',1) = '-1' then
begin
memText.Lines.Add('Remote data transmission error: ' + Piece(aStatus,'^',2));
end;
if Piece(aStatus,'^',1) = '0' then
memText.Lines.Add('Retrieving data... ' + Piece(aStatus,'^',2));
if Piece(aStatus,'^',1) = '' then
memText.Lines.Add(uReportInstruction);
end
else
if uLocalReportData.Count > 0 then
begin
if Piece(uLocalReportData[0],'^',1) = '[HIDDEN TEXT]' then
begin
lstHeaders.Clear;
hook := false;
for i := 1 to uLocalReportData.Count - 1 do
if hook = true then
memText.Lines.Add(uLocalReportData[i])
else
begin
lstHeaders.Items.Add(MixedCase(uLocalReportData[i]));
if Piece(uLocalReportData[i],'^',1) = '[REPORT TEXT]' then
hook := true;
end;
end
else
if tvReports.Selected.Text = 'Imaging (local only)' then
memText.Lines.clear
else
QuickCopy(uLocalReportData,memText);
memText.Lines.Insert(0,' ');
memText.Lines.Delete(0);
end
else
memText.Lines.Add(uReportInstruction);
if WebBrowser1.Visible = true then
begin
if uReportType = 'R' then
uHTMLDoc := HTML_PRE + memText.Lines.Text + HTML_POST
else
uHTMLDoc := uHTMLPatient + memText.Lines.Text;
WebBrowser1.Navigate('about:blank');
end;
memText.Lines.EndUpdate;
end;
end;
procedure TfrmReports.GoRemote(Dest: TStringList; AItem: string; AQualifier, ARpc: string; AHSTag: string; AHDR: string);
var
i, j: integer;
LocalHandle, Query, Report: string;
HSType, DaysBack, ExamID, MaxOcc: string;
Alpha, Omega, Trans: double;
begin
HSType := '';
DaysBack := '';
ExamID := '';
Alpha := 0;
Omega := 0;
if UseVistaWeb then
begin
if AHDR = '1' then
InfoBox('You must use VistaWeb to view this report. To use RDV Classic, change your default setting.',
'Use VistaWeb for HDR data', MB_OK);
Exit;
end;
if AHDR = '1' then
begin
if HDRActive = '0' then
begin
InfoBox('The HDR is currently inactive.' + CRLF + 'Unable to retrieve HDR data at this time.', 'HDR Error', MB_OK);
Exit;
end;
if (Piece(AItem, ':', 1) = 'OR_VWAL') or (Piece(AItem, ':', 1) = 'OR_VWRX') then
AQualifier := 'T-75000;T+75000;99999';
if (Piece(AItem, ':', 1) = 'OR_VWVS') and (CharAt(AQualifier, 1) = ';') then
AQualifier := 'T-75000;T+75000;99999';
end;
if CharAt(AQualifier, 1) = 'd' then
begin
DaysBack := Copy(AQualifier, 2, Length(AQualifier));
AQualifier := ('T-' + Piece(DaysBack,';',1) + ';T;' + Pieces(AQualifier,';',2,3));
DaysBack := '';
end;
if CharAt(AQualifier, 1) = 'T' then
begin
if Piece(AQualifier,';',1) = 'T-0' then SetPiece(AQualifier,';',1,'T');
if (Piece(Aqualifier,';',1) = 'T') and (Piece(Aqualifier,';',2) = 'T')
then SetPiece(AQualifier,';',2,'T+1');
Alpha := StrToFMDateTime(Piece(AQualifier,';',1));
Omega := StrToFMDateTime(Piece(AQualifier,';',2));
if Alpha > Omega then
begin
Trans := Omega;
Omega := Alpha;
Alpha := Trans;
end;
MaxOcc := Piece(AQualifier,';',3);
SetPiece(AHSTag,';',4,MaxOcc);
end;
if CharAt(AQualifier, 1) = 'h' then HSType := Copy(AQualifier, 2, Length(AQualifier));
if CharAt(AQualifier, 1) = 'i' then ExamID := Copy(AQualifier, 2, Length(AQualifier));
with RemoteSites.SiteList do for i := 0 to Count - 1 do
begin
if (AHDR='1') and (LeftStr(TRemoteSite(Items[i]).SiteID, 5) = '200HD') then
begin
TRemoteSite(Items[i]).Selected := true;
frmFrame.lstCIRNLocations.Checked[i+2] := true;
end;
if TRemoteSite(Items[i]).Selected then
begin
TRemoteSite(Items[i]).ReportClear;
if (LeftStr(TRemoteSite(Items[i]).SiteID, 5) = '200HD') and not(AHDR = '1') then
begin
TRemoteSite(Items[i]).QueryStatus := '1^Not Included';
UpdateRemoteStatus(TRemoteSite(Items[i]).SiteID, 'NOT INCLUDED');
TabControl1.OnChange(nil);
continue;
end;
if (AHDR = '1') and not(LeftStr(TRemoteSite(Items[i]).SiteID, 5) = '200HD') then
begin
TRemoteSite(Items[i]).QueryStatus := '1^Not Included';
UpdateRemoteStatus(TRemoteSite(Items[i]).SiteID, 'NOT INCLUDED');
TabControl1.OnChange(nil);
continue;
end;
TRemoteSite(Items[i]).CurrentReportQuery := 'Report' + Patient.DFN + ';'
+ Patient.ICN + '^' + AItem + '^^^' + ARpc + '^' + HSType +
'^' + DaysBack + '^' + ExamID + '^' + FloatToStr(Alpha) + '^' +
FloatToStr(Omega) + '^' + TRemoteSite(Items[i]).SiteID + '^' + AHSTag + '^' + AHDR;
LocalHandle := '';
Query := TRemoteSite(Items[i]).CurrentReportQuery;
for j := 0 to RemoteReports.Count - 1 do
begin
Report := TRemoteReport(RemoteReports.ReportList.Items[j]).Report;
if Report = Query then
begin
LocalHandle := TRemoteReport(RemoteReports.ReportList.Items[j]).Handle;
break;
end;
end;
if Length(LocalHandle) > 1 then
with RemoteSites.SiteList do
begin
GetRemoteData(TRemoteSite(Items[i]).Data,LocalHandle,Items[i]);
TRemoteSite(Items[i]).RemoteHandle := '';
TRemoteSite(Items[i]).QueryStatus := '1^Done';
UpdateRemoteStatus(TRemoteSite(Items[i]).SiteID, 'Done');
TabControl1.OnChange(nil);
if (length(piece(uHState,';',2)) > 0) then //and (chkText.Checked = false) then
LoadListView(TRemoteSite(Items[i]).Data);
end
else
begin
if uDirect = '1' then
begin
StatusText('Retrieving reports from ' + TRemoteSite(Items[i]).SiteName + '...');
TRemoteSite(Items[i]).QueryStatus := '1^Direct Call';
UpdateRemoteStatus(TRemoteSite(Items[i]).SiteID, 'Direct Call');
DirectQuery(Dest, AItem, HSType, Daysback, ExamID, Alpha, Omega, TRemoteSite(Items[i]).SiteID, ARpc, AHSTag);
if Copy(Dest[0],1,2) = '-1' then
begin
TRemoteSite(Items[i]).QueryStatus := '-1^Communication error';
UpdateRemoteStatus(TRemoteSite(Items[i]).SiteID,'Communication error');
end
else
begin
QuickCopy(Dest,TRemoteSite(Items[i]).Data);
TRemoteSite(Items[i]).RemoteHandle := '';
TRemoteSite(Items[i]).QueryStatus := '1^Done';
UpdateRemoteStatus(TRemoteSite(Items[i]).SiteID, 'Done');
TabControl1.OnChange(nil);
if (length(piece(uHState,';',2)) > 0) then
LoadListView(TRemoteSite(Items[i]).Data);
end;
StatusText('');
end
else
begin
RemoteQuery(Dest, AItem, HSType, Daysback, ExamID, Alpha, Omega, TRemoteSite(Items[i]).SiteID, ARpc, AHSTag);
if Dest[0] = '' then
begin
TRemoteSite(Items[i]).QueryStatus := '-1^Communication error';
UpdateRemoteStatus(TRemoteSite(Items[i]).SiteID,'Communication error');
end
else
begin
TRemoteSite(Items[i]).RemoteHandle := Dest[0];
TRemoteSite(Items[i]).QueryStatus := '0^initialization...';
UpdateRemoteStatus(TRemoteSite(Items[i]).SiteID, 'initialization');
Timer1.Enabled := True;
StatusText('Retrieving reports from ' + TRemoteSite(Items[i]).SiteName + '...');
end;
end;
end;
end;
end;
end;
procedure TfrmReports.FormDestroy(Sender: TObject);
var
i: integer;
aColChange: string;
begin
inherited;
if length(uColChange) > 0 then
begin
aColChange := '';
for i := 0 to lvReports.Columns.Count - 1 do
aColChange := aColChange + IntToStr(lvReports.Column[i].width) + ',';
if aColChange <> piece(uColchange,'^',2) then
SaveColumnSizes(piece(uColChange,'^',1) + '^' + aColChange);
uColChange := '';
end;
RemoteQueryAbortAll;
RowObjects.Free;
uHSComponents.Free;
uHSAll.Free;
uLocalReportData.Free;
uRemoteReportData.Free;
uColumns.Free;
uTreeStrings.Free;
uEmptyImageList.Free;
uECSReport.Free;
if GraphForm <> nil then GraphForm.Release;
end;
procedure TfrmReports.lstHeadersClick(Sender: TObject);
var
Current, Desired: integer;
begin
inherited;
if uFrozen = True then
begin
memo1.visible := False;
memo1.TabStop := False;
end;
Current := SendMessage(memText.Handle, EM_GETFIRSTVISIBLELINE, 0, 0);
Desired := lstHeaders.ItemIEN;
SendMessage(memText.Handle, EM_LINESCROLL, 0, Desired - Current - 1);
end;
procedure TfrmReports.Splitter1CanResize(Sender: TObject;
var NewSize: Integer; var Accept: Boolean);
begin
inherited;
if NewSize < 50 then
Newsize := 50;
end;
procedure TfrmReports.WebBrowser1DocumentComplete(Sender: TObject;
const pDisp: IDispatch; var URL: OleVariant);
var
WebDoc: IHtmlDocument2;
v: variant;
begin
inherited;
if uHTMLDoc = '' then Exit;
if not(uReportType = 'H') then Exit; //this can be removed if & when browser replaces memtext control
if not Assigned(WebBrowser1.Document) then Exit;
WebDoc := WebBrowser1.Document as IHtmlDocument2;
v := VarArrayCreate([0, 0], varVariant);
v[0] := uHTMLDoc;
WebDoc.write(PSafeArray(TVarData(v).VArray));
WebDoc.close;
//uHTMLDoc := '';
end;
procedure TfrmReports.sptHorzRightCanResize(Sender: TObject;
var NewSize: Integer; var Accept: Boolean);
begin
inherited;
if NewSize < 50 then
Newsize := 50;
end;
procedure TfrmReports.lstQualifierDrawItem(Control: TWinControl;
Index: Integer; Rect: TRect; State: TOwnerDrawState);
var
x: string;
AnImage: TBitMap;
const
STD_DATE = 'MMM DD,YY@HH:NN';
begin
inherited;
AnImage := TBitMap.Create;
try
with (Control as TORListBox).Canvas do { draw on control canvas, not on the form }
begin
x := (Control as TORListBox).Items[Index];
FillRect(Rect); { clear the rectangle }
if uQualifierType = QT_IMAGING then // moved position of assignment in all case branches
begin
AnImage.LoadFromResourceName(hInstance, 'BMP_IMAGEFLAG_1');
if Piece(x, U, 4) = 'Y' then
begin
BrushCopy(Bounds(Rect.Left, Rect.Top, AnImage.Width, AnImage.Height),
AnImage, Bounds(0, 0, AnImage.Width, AnImage.Height), clRed); {render ImageFlag}
end;
TextOut(Rect.Left + AnImage.Width, Rect.Top, Piece(x, U, 2));
TextOut(Rect.Left + AnImage.Width + TextWidth(STD_DATE), Rect.Top, Piece(x, U, 3));
end
else
begin
TextOut(Rect.Left, Rect.Top, Piece(x, U, 2));
TextOut(Rect.Left + TextWidth(STD_DATE), Rect.Top, Piece(x, U, 3));
end;
end;
finally
AnImage.Free;
end;
end;
procedure TfrmReports.tvReportsClick(Sender: TObject);
var
i,j: integer;
ListItem: TListItem;
aHeading, aReportType, aRPC, aQualifier, aStartTime, aStopTime, aMax, aRptCode, aRemote, aCategory, aSortOrder, aDaysBack, x: string;
aIFN: integer;
aID, aHSTag, aRadParam, aColChange, aDirect, aHDR, aQualifierID: string;
CurrentParentNode, CurrentNode: TTreeNode;
begin
inherited;
lvReports.Hint := 'To sort, click on column headers|';
tvReports.TopItem := tvReports.Selected;
uRemoteCount := 0;
uReportInstruction := '';
aHeading := PReportTreeObject(tvReports.Selected.Data)^.Heading;
aRemote := PReportTreeObject(tvReports.Selected.Data)^.Remote;
aReportType := PReportTreeObject(tvReports.Selected.Data)^.RptType;
aQualifier := PReportTreeObject(tvReports.Selected.Data)^.Qualifier;
aID := PReportTreeObject(tvReports.Selected.Data)^.ID;
aRPC := PReportTreeObject(tvReports.Selected.Data)^.RPCName;
aHSTag := PReportTreeObject(tvReports.Selected.Data)^.HSTag;
aCategory := PReportTreeObject(tvReports.Selected.Data)^.Category;
aSortOrder := PReportTreeObject(tvReports.Selected.Data)^.SortOrder;
aDaysBack := PReportTreeObject(tvReports.Selected.Data)^.MaxDaysBack;
aIFN := StrToIntDef(PReportTreeObject(tvReports.Selected.Data)^.IFN,0);
aDirect := PReportTreeObject(tvReports.Selected.Data)^.Direct;
aHDR := PReportTreeObject(tvReports.Selected.Data)^.HDR;
aStartTime := Piece(aQualifier,';',1);
aStopTime := Piece(aQualifier,';',2);
aMax := Piece(aQualifier,';',3);
aRptCode := Piece(aQualifier,';',4);
aQualifierID:= '';
if length(uColChange) > 0 then
begin
aColChange := '';
for i := 0 to lvReports.Columns.Count - 1 do
aColChange := aColChange + IntToStr(lvReports.Column[i].width) + ',';
if aColChange <> piece(uColchange,'^',2) then
SaveColumnSizes(piece(uColChange,'^',1) + '^' + aColChange);
uColChange := '';
end;
if (aReportType <> 'M') and (aRPC = '') and (CharAt(aID,1) = 'H') then
begin
aReportType := 'R';
aRptCode := LowerCase(CharAt(aID,1)) + Copy(aID, 2, Length(aID));
aID := '1';
aRPC := 'ORWRP REPORT TEXT';
aHSTag := '';
end;
if aReportType = '' then aReportType := 'R';
uReportRPC := aRPC;
uRptID := aID;
uDirect := aDirect;
uReportType := aReportType;
uQualifier := aQualifier;
uSortOrder := aSortOrder;
uRemoteType := aRemote + '^' + aReportType + '^' + IntToStr(aIFN) + '^' + aHeading + '^' + aRptCode + '^' + aDaysBack + '^' + aHDR;
pnlRightTop.Height := lblTitle.Height; // see below
RedrawSuspend(tvReports.Handle);
RedrawSuspend(memText.Handle);
uHState := aHSTag;
Timer1.Enabled := False;
TabControl1.Visible := false;
TabControl1.TabStop := false;
sptHorzRight.Visible := false;
lblProcTypeMsg.Visible := FALSE;
pnlRightMiddle.Visible := false;
pnlProcedures.Visible := FALSE;
if (aRemote = '1') or (aRemote = '2') then
if not(uReportType = 'V') then
if TabControl1.Tabs.Count > 1 then
begin
TabControl1.Visible := true;
TabControl1.TabStop := true;
pnlRightTop.Height := lblTitle.Height + TabControl1.Height;
end;
StatusText('');
uHTMLDoc := '';
WebBrowser1.Navigate('about:blank');
memText.Lines.Clear;
memText.Parent := pnlRightBottom;
memText.Align := alClient;
UpdatingLvReports := TRUE; {lw added}
tvProcedures.Items.Clear;
UpdatingLvReports := FALSE; {lw added}
lblProcTypeMsg.Visible := FALSE;
lvReports.SmallImages := uEmptyImageList;
lvReports.Items.Clear;
lvReports.Columns.Clear;
uHSComponents.Clear;
DisplayHeading('');
if uReportType = 'H' then
begin
pnlRightMiddle.Visible := false;
pnlRightBottom.Visible := true;
WebBrowser1.Visible := true;
WebBrowser1.TabStop := true;
WebBrowser1.Navigate('about:blank');
WebBrowser1.BringToFront;
memText.Visible := false;
memText.TabStop := false;
end
else
if uReportType = 'V' then
begin
with lvReports do
begin
RedrawSuspend(lvReports.Handle);
Items.BeginUpdate;
ViewStyle := vsReport;
ColumnHeaders(uColumns, IntToStr(aIFN));
for i := 0 to uColumns.Count -1 do
begin
uNewColumn := Columns.Add;
uNewColumn.Caption := piece(uColumns.Strings[i],'^',1);
if length(uColChange) < 1 then uColChange := IntToStr(aIFN) + '^';
if piece(uColumns.Strings[i],'^',2) = '1' then
begin
uNewColumn.Width := 0;
uColChange := uColChange + '0,';
end
else
if length(piece(uColumns.Strings[i],'^',10)) > 0 then
begin
uColChange := uColChange + piece(uColumns.Strings[i],'^',10) + ',';
uNewColumn.Width := StrToInt(piece(uColumns.Strings[i],'^',10))
end
else
uNewColumn.Width := ColumnHeaderWidth; //ColumnTextWidth for width of text
if (i = 0) and (((aRemote <> '2') and (aRemote <> '1')) or ((TabControl1.Tabs.Count < 2) and (not (aHDR = '1')))) then
uNewColumn.Width := 0;
end;
Items.EndUpdate;
RedrawActivate(lvReports.Handle);
end;
pnlRightMiddle.Visible := true;
sptHorzRight.Visible := true;
WebBrowser1.Visible := false;
WebBrowser1.TabStop := false;
pnlRightBottom.Visible := true;
memText.Visible := true;
memText.TabStop := true;
memText.BringToFront;
RedrawActivate(memText.Handle);
end
else
begin
pnlRightMiddle.Visible := false;
sptHorzRight.Visible := false;
WebBrowser1.Visible := false;
WebBrowser1.TabStop := false;
pnlRightBottom.Visible := True;
memText.Visible := true;
memText.TabStop := true;
memText.BringToFront;
RedrawActivate(memText.Handle);
end;
uLocalReportData.Clear;
RowObjects.Clear;
uRemoteReportData.Clear;
lstHeaders.Visible := false;
lstHeaders.TabStop := false;
lblHeaders.Visible := false;
lstHeaders.Clear;
for i := 0 to RemoteSites.SiteList.Count - 1 do
TRemoteSite(RemoteSites.SiteList.Items[i]).ReportClear;
if uFrozen = True then
begin
memo1.visible := False;
memo1.TabStop := False;
end;
Screen.Cursor := crHourGlass;
if (GraphForm <> nil) and (aReportType <> 'G') then
begin
GraphForm.SendToBack;
GraphPanel(false);
GraphFormActive := false;
end;
if aReportType = 'G' then
Graph(aIFN)
else
if aReportType = 'M' then
begin
pnlLeftBottom.Visible := false;
splitter1.Visible := false;
end
else
begin
uQualifierType := StrToIntDef(aRptCode,0);
case uQualifierType of
QT_OTHER:
begin // = 0
memText.Lines.Clear;
If copy(aRptCode,1,2) = 'h0' then //HS Adhoc
begin
if TabControl1.TabIndex > 0 then
begin
InfoBox('Adhoc report is not available for remote sites',
'Information', MB_OK);
TabControl1.TabIndex := 0;
end;
with RemoteSites.SiteList do
for j := 0 to Count - 1 do
begin
TRemoteSite(RemoteSites.SiteList[j]).ReportClear;
TRemoteSite(RemoteSites.SiteList[j]).LabClear;
end;
uHTMLDoc := '';
if WebBrowser1.Visible = true then WebBrowser1.Navigate('about:blank');
ExecuteAdhoc1; //Calls Adhoc form
if uLocalReportData.Count < 1 then
uReportInstruction := '<No Report Available>'
else
begin
if TabControl1.TabIndex < 1 then
QuickCopy(uLocalReportData,memText);
if WebBrowser1.Visible = true then
begin
if uReportType = 'R' then
uHTMLDoc := HTML_PRE + uLocalReportData.Text + HTML_POST
else
uHTMLDoc := uHTMLPatient + uLocalReportData.Text;
WebBrowser1.Navigate('about:blank');
end;
end;
TabControl1.OnChange(nil);
end
else
begin
pnlLeftBottom.Visible := false;
splitter1.Visible := false;
StatusText('Retrieving ' + tvReports.Selected.Text + '...');
GoRemote(uRemoteReportData, aID, aRptCode, aRPC, uHState, aHDR);
uReportInstruction := #13#10 + 'Retrieving data...';
TabControl1.OnChange(nil);
LoadReportText(uLocalReportData, aID, aRptCode, aRPC, uHState);
memText.Lines.Assign(uLocalReportData);
if uLocalReportData.Count > 0 then
TabControl1.OnChange(nil);
StatusText('');
end;
end;
QT_HSTYPE:
begin // = 1
pnlLeftBottom.Visible := false;
splitter1.Visible := false;
end;
QT_DATERANGE:
begin // = 2
ListReportDateRanges(lstQualifier.Items);
if lstQualifier.ItemID = '' then
begin
lstQualifier.ItemIndex := lstQualifier.Items.Add(aStartTime + ';' + aStopTime + '^' + aStartTime + ' to ' + aStopTime);
lvReports.SmallImages := uEmptyImageList;
lvReports.Items.Clear;
lstQualifierClick(self);
end
else
lstQualifier.Items.Add(aStartTime + ';' + aStopTime + '^' + aStartTime + ' to ' + aStopTime);
lblQualifier.Caption := 'Date Range';
pnlLeftBottom.Visible := true;
splitter1.Visible := true;
end;
QT_IMAGING:
begin // = 3
pnlLeftBottom.Visible := false;
splitter1.Visible := false;
ListImagingExams(uLocalReportData);
aRadParam := ImagingParams;
uQualifier := StringReplace(aRadParam, '^', ';', [rfReplaceAll]);
with lvReports do
begin
RedrawSuspend(lvReports.Handle);
Items.BeginUpdate;
ViewStyle := vsReport;
SmallImages := dmodShared.imgImages;
CurrentParentNode := nil;
CurrentNode := nil;
for i := 0 to uLocalReportData.Count - 1 do
begin
ListItem := Items.Add;
ListItem.Caption := piece(piece(uLocalReportData[i],'^',1),';',1);
if uColumns.Count > 1 then
begin
for j := 2 to uColumns.Count do
ListItem.SubItems.Add(piece(uLocalReportData[i],'^',j));
// if pieces are (added to/removed from) return string, PLEASE UPDATE THIS!! (RV)
if Piece(uLocalReportData[i], U, 9) = 'Y' then
ListItem.SubItemImages[1] := IMG_1_IMAGE
else
ListItem.SubItemImages[1] := IMG_NO_IMAGES;
end;
LoadProceduresTreeView(uLocalReportData[i], CurrentParentNode, CurrentNode);
if CurrentNode <> nil then
PProcTreeObj(CurrentNode.Data)^.Associate := lvReports.Items.IndexOf(ListItem);
end;
if tvProcedures.Items.Count > 0 then
tvProcedures.Selected := tvProcedures.Items.GetFirstNode;
lblProcTypeMsg.Visible := TRUE;
pnlRightTop.Height := lblTitle.Height + lblProcTypeMsg.Height;
pnlLeftBottom.Visible := FALSE;
pnlProcedures.Visible := TRUE;
Splitter1.Visible := True;
if lvReports.Columns.Count > 0 then lvReports.Columns[1].Width := 0;
Items.EndUpdate;
RedrawActivate(lvReports.Handle);
tvProcedures.TopItem := tvProcedures.Selected;
end;
if TabControl1.TabIndex > 0 then TabControl1.TabIndex := 0;
if uLocalReportData.Count > 0
then x := #13#10 + 'Select an imaging exam...'
else x := #13#10 + 'No imaging reports found...';
uReportInstruction := PChar(x);
memText.Lines.Add(uReportInstruction);
if WebBrowser1.Visible = true then
begin
uHTMLDoc := HTML_PRE + uReportInstruction + HTML_POST;
WebBrowser1.Navigate('about:blank');
end;
end;
QT_NUTR:
begin // = 4
lblQualifier.Caption := 'Nutritional Assessments';
pnlLeftBottom.Visible := false;
splitter1.Visible := false;
ListNutrAssessments(uLocalReportData);
with lvReports do
begin
RedrawSuspend(lvReports.Handle);
Items.BeginUpdate;
ViewStyle := vsReport;
for i := 0 to uLocalReportData.Count - 1 do
begin
ListItem := Items.Add;
ListItem.Caption := piece(piece(uLocalReportData[i],'^',1),';',1);
if uColumns.Count > 1 then
for j := 2 to uColumns.Count do
ListItem.SubItems.Add(piece(uLocalReportData[i],'^',j));
end;
if lvReports.Columns.Count > 0 then lvReports.Columns[1].Width := 0;
Items.EndUpdate;
RedrawActivate(lvReports.Handle);
end;
if TabControl1.TabIndex > 0 then TabControl1.TabIndex := 0;
if uLocalReportData.Count > 0
then x := #13#10 + 'Select an assessment date...'
else x := #13#10 + 'No nutritional assessments found...';
uReportInstruction := PChar(x);
memText.Lines.Add(uReportInstruction);
if WebBrowser1.Visible = true then
begin
uHTMLDoc := HTML_PRE + uReportInstruction + HTML_POST;
WebBrowser1.Navigate('about:blank');
end;
end;
QT_HSCOMPONENT:
begin // = 5
pnlRightMiddle.Height := pnlRight.Height - (pnlRight.Height div 2);
pnlLeftBottom.Visible := false;
splitter1.Visible := false;
StatusText('Retrieving ' + tvReports.Selected.Text + '...');
uReportInstruction := #13#10 + 'Retrieving data...';
lvReports.SmallImages := uEmptyImageList;
lvReports.Items.Clear;
RowObjects.Clear;
memText.Lines.Clear;
if (length(piece(aHSTag,';',2)) > 0) then
begin
if aCategory <> '0' then
begin
ListReportDateRanges(lstQualifier.Items);
aQualifierID := lstQualifier.ItemID;
if aQualifierID = '' then
begin
if aHDR = '1' then
lstQualifier.ItemIndex := lstQualifier.Items.Add('T-75000' + ';' + 'T+75000' + '^' + 'T-75000' + ' to ' + 'T+75000')
else
if length(aStartTime) > 0 then lstQualifier.ItemIndex := lstQualifier.Items.Add(aStartTime + ';' + aStopTime + '^' + aStartTime + ' to ' + aStopTime);
lstQualifierClick(self);
end
else
begin
GoRemote(uRemoteReportData, aID, aQualifier, aRPC, uHState, aHDR);
if aHDR = '1' then
lstQualifier.ItemIndex := lstQualifier.Items.Add('T-75000' + ';' + 'T+75000' + '^' + 'T-75000' + ' to ' + 'T+75000')
else
if length(aStartTime) > 0 then lstQualifier.ItemIndex := lstQualifier.Items.Add(aStartTime + ';' + aStopTime + '^' + aStartTime + ' to ' + aStopTime);
end;
lblQualifier.Caption := 'Date Range';
pnlLeftBottom.Visible := true;
splitter1.Visible := true;
end
else
begin
if not (aRemote = '2' ) then
GoRemote(uRemoteReportData, aID, aQualifier, aRPC, uHState, aHDR);
begin
LoadReportText(uLocalReportData, aID, aQualifier, aRPC, uHState);
LoadListView(uLocalReportData);
end;
end;
end
else
begin
if (aRemote = '1') or (aRemote = '2') then
if TabControl1.Tabs.Count > 1 then
ShowTabControl;
sptHorzRight.Visible := false;
pnlRightMiddle.Visible := false;
GoRemote(uRemoteReportData, aID, aQualifier, aRPC, uHState, aHDR);
LoadReportText(uLocalReportData, aID, aQualifier, aRPC, uHState);
if uLocalReportData.Count < 1 then
uReportInstruction := '<No Report Available>'
else
begin
if TabControl1.TabIndex < 1 then
QuickCopy(uLocalReportData,memText);
end;
TabControl1.OnChange(nil);
if aCategory <> '0' then
begin
ListReportDateRanges(lstQualifier.Items);
if lstQualifier.ItemID = '' then
begin
lstQualifier.ItemIndex := lstQualifier.Items.Add(aStartTime + ';' + aStopTime + '^' + aStartTime + ' to ' + aStopTime);
lstQualifierClick(self);
end
else
lstQualifier.Items.Add(aStartTime + ';' + aStopTime + '^' + aStartTime + ' to ' + aStopTime);
lblQualifier.Caption := 'Date Range';
pnlLeftBottom.Visible := true;
splitter1.Visible := true;
end
else
begin
if uLocalReportData.Count < 1 then
begin
uReportInstruction := '<No Report Available>';
memText.Lines.Add(uReportInstruction);
end
else
begin
QuickCopy(uLocalReportData,memText);
TabControl1.OnChange(nil);
end;
end;
end;
StatusText('');
end;
QT_HSWPCOMPONENT:
begin // = 6
pnlRightMiddle.Height := pnlRight.Height - (pnlRight.Height div 2);
pnlLeftBottom.Visible := false;
splitter1.Visible := false;
StatusText('Retrieving ' + tvReports.Selected.Text + '...');
uReportInstruction := #13#10 + 'Retrieving data...';
TabControl1.OnChange(nil);
RowObjects.Clear;
memText.Lines.Clear;
lvReports.SmallImages := uEmptyImageList;
lvReports.Items.Clear;
if (length(piece(aHSTag,';',2)) > 0) then
begin
if aCategory <> '0' then
begin
ListReportDateRanges(lstQualifier.Items);
aQualifierID := lstQualifier.ItemID;
if aQualifierID = '' then
begin
if aHDR = '1' then
lstQualifier.ItemIndex := lstQualifier.Items.Add('T-75000' + ';' + 'T+75000' + '^' + 'T-75000' + ' to ' + 'T+75000')
else
if length(aStartTime) > 0 then lstQualifier.ItemIndex := lstQualifier.Items.Add(aStartTime + ';' + aStopTime + '^' + aStartTime + ' to ' + aStopTime);
lstQualifierClick(self);
end
else
begin
GoRemote(uRemoteReportData, aID, aQualifier, aRPC, uHState, aHDR);
if aHDR = '1' then
lstQualifier.ItemIndex := lstQualifier.Items.Add('T-75000' + ';' + 'T+75000' + '^' + 'T-75000' + ' to ' + 'T+75000')
else
if length(aStartTime) > 0 then lstQualifier.ItemIndex := lstQualifier.Items.Add(aStartTime + ';' + aStopTime + '^' + aStartTime + ' to ' + aStopTime);
end;
lblQualifier.Caption := 'Date Range';
pnlLeftBottom.Visible := true;
splitter1.Visible := true;
end
else
begin
GoRemote(uRemoteReportData, aID, aQualifier, aRPC, uHState, aHDR);
if not (aRemote = '2' ) then
begin
LoadReportText(uLocalReportData, aID, aQualifier, aRPC, uHState);
LoadListView(uLocalReportData);
end;
end;
end
else
begin
if (aRemote = '1') or (aRemote = '2') then
ShowTabControl;
sptHorzRight.Visible := false;
pnlRightMiddle.Visible := false;
GoRemote(uRemoteReportData, aID, aQualifier, aRPC, uHState, aHDR);
LoadReportText(uLocalReportData, aID, aQualifier, aRPC, uHState);
if uLocalReportData.Count < 1 then
uReportInstruction := '<No Report Available>'
else
begin
if TabControl1.TabIndex < 1 then
QuickCopy(uLocalReportData,memText);
end;
TabControl1.OnChange(nil);
if aCategory <> '0' then
begin
ListReportDateRanges(lstQualifier.Items);
if lstQualifier.ItemID = '' then
begin
lstQualifier.ItemIndex := lstQualifier.Items.Add(aStartTime + ';' + aStopTime + '^' + aStartTime + ' to ' + aStopTime);
lstQualifierClick(self);
end
else
lstQualifier.Items.Add(aStartTime + ';' + aStopTime + '^' + aStartTime + ' to ' + aStopTime);
lblQualifier.Caption := 'Date Range';
pnlLeftBottom.Visible := true;
splitter1.Visible := true;
end
else
begin
LoadListView(uLocalReportData);
end;
end;
StatusText('');
end;
QT_PROCEDURES:
begin // = 19
pnlLeftBottom.Visible := false;
splitter1.Visible := false;
ListProcedures(uLocalReportData);
with lvReports do
begin
RedrawSuspend(lvReports.Handle);
Items.BeginUpdate;
ViewStyle := vsReport;
for i := 0 to uLocalReportData.Count - 1 do
begin
ListItem := Items.Add;
ListItem.Caption := piece(piece(uLocalReportData[i],'^',1),';',1);
if uColumns.Count > 1 then
for j := 2 to uColumns.Count do
ListItem.SubItems.Add(piece(uLocalReportData[i],'^',j));
end;
if lvReports.Columns.Count > 0 then lvReports.Columns[1].Width := 0;
Items.EndUpdate;
RedrawActivate(lvReports.Handle);
end;
if uLocalReportData.Count > 0
then x := #13#10 + 'Select a procedure...'
else x := #13#10 + 'No procedures found...';
uReportInstruction := PChar(x);
if WebBrowser1.Visible = true then
begin
uHTMLDoc := HTML_PRE + uReportInstruction + HTML_POST;
WebBrowser1.Navigate('about:blank');
end;
if WebBrowser1.Visible = true then WebBrowser1.Navigate('about:blank');
end;
QT_SURGERY:
begin // = 28
pnlLeftBottom.Visible := false;
splitter1.Visible := false;
ListSurgeryReports(uLocalReportData);
with lvReports do
begin
RedrawSuspend(lvReports.Handle);
Items.BeginUpdate;
ViewStyle := vsReport;
for i := 0 to uLocalReportData.Count - 1 do
begin
ListItem := Items.Add;
ListItem.Caption := piece(piece(uLocalReportData[i],'^',1),';',1);
if uColumns.Count > 1 then
for j := 2 to uColumns.Count do
ListItem.SubItems.Add(piece(uLocalReportData[i],'^',j));
end;
if lvReports.Columns.Count > 0 then lvReports.Columns[1].Width := 0;
Items.EndUpdate;
RedrawActivate(lvReports.Handle);
end;
if uLocalReportData.Count > 0
then x := #13#10 + 'Select a surgery case...'
else x := #13#10 + 'No surgery cases found...';
uReportInstruction := PChar(x);
memText.Lines.Add(uReportInstruction);
uHTMLDoc := HTML_PRE + uReportInstruction + HTML_POST;
if WebBrowser1.Visible = true then WebBrowser1.Navigate('about:blank');
end;
else
begin // = ?
uQualifierType := QT_OTHER;
pnlLeftBottom.Visible := false;
splitter1.Visible := false;
StatusText('Retrieving ' + tvReports.Selected.Text + '...');
GoRemote(uRemoteReportData, aID, aRptCode, aRPC, uHState, aHDR);
uReportInstruction := #13#10 + 'Retrieving data...';
TabControl1.OnChange(nil);
LoadReportText(uLocalReportData, aID, aRptCode, aRPC, uHState);
LoadReportText(uLocalReportData, aID, '', aRPC, uHState);
if uLocalReportData.Count < 1 then
uReportInstruction := '<No Report Available>'
else
begin
if TabControl1.TabIndex < 1 then
QuickCopy(uLocalReportData,memText);
end;
TabControl1.OnChange(nil);
StatusText('');
end;
lstQualifier.Caption := lblQualifier.Caption;
end;
end;
if not (aHDR = '1') then
if aCategory <> '0' then
DisplayHeading(uQualifier)
else
DisplayHeading('');
SendMessage(tvReports.Handle, WM_HSCROLL, SB_THUMBTRACK, 0);
RedrawActivate(tvReports.Handle);
if WebBrowser1.Visible = true then
begin
WebBrowser1.Navigate('about:blank');
WebBrowser1.BringToFront;
end
else if not GraphFormActive then
begin
memText.Visible := true;
memText.TabStop := true;
memText.BringToFront;
RedrawActivate(memText.Handle);
end
else
begin
GraphPanel(true);
with GraphForm do
begin
lstDateRange.Items := cboDateRange.Items;
lstDateRange.ItemIndex := cboDateRange.ItemIndex;
ViewSelections;
BringToFront;
end;
end;
Screen.Cursor := crDefault;
end;
procedure TfrmReports.lvReportsColumnClick(Sender: TObject;
Column: TListColumn);
var
ClickedColumn: Integer;
a1, a2: integer;
s,s1,s2: string;
begin
inherited;
a1 := StrToIntDef(piece(uSortOrder,':',1),0) - 1;
a2 := StrToIntDef(piece(uSortOrder,':',2),0) - 1;
ClickedColumn := Column.Index;
ColumnToSort := Column.Index;
SortIdx1 := StrToIntDef(piece(uColumns[ColumnToSort],'^',9),0);
SortIdx2 := 0;
SortIdx3 := 0;
if a1 > -1 then SortIdx2 := StrToIntDef(piece(uColumns[a1],'^',9),0);
if a2 > -1 then SortIdx3 := StrToIntDef(piece(uColumns[a2],'^',9),0);
if a1 = ColumnToSort then
begin
SortIdx2 := SortIdx3;
SortIdx3 := 0;
end;
if a2 = ColumnToSort then
SortIdx3 := 0;
if ClickedColumn = ColumnToSort then
ColumnSortForward := not ColumnSortForward
else
ColumnSortForward := true;
ColumnToSort := ClickedColumn;
uFirstSort := ColumnToSort;
uSecondSort := a1;
uThirdSort := a2;
lvReports.Hint := '';
if ColumnSortForward = true then
s := 'Sorted forward'
else
s := 'Sorted reverse';
s1 := piece(uColumns[uFirstSort],'^',1);
s2 := '';
if length(piece(s1,' ',2)) > 0 then
s2 := pieces(s1,' ',2,99);
if length(s2) > 0 then s2 := StripSpace(s2);
s := s + ' by ' + piece(s1,' ',1) + ' ' + s2;
if (a1 <> uFirstSort) and (a1 > -1) then
begin
s1 := piece(uColumns[a1], '^', 1);
s2 := '';
if length(piece(s1,' ',2)) > 0 then
s2 := pieces(s1,' ',2,99);
if length(s2) > 0 then s2 := StripSpace(s2);
s := s + ' then by ' + piece(s1,' ',1) + ' ' + s2;
end;
if (a2 <> uFirstSort) and (a2 > -1) then
begin
s1 := piece(uColumns[a2], '^', 1);
s2 := '';
if length(piece(s1,' ',2)) > 0 then
s2 := pieces(s1,' ',2,99);
if length(s2) > 0 then s2 := StripSpace(s2);
s := s + ' then by ' + piece(s1,' ',1) + ' ' + s2;
end;
lvReports.Hint := s;
lvReports.CustomSort(nil, 0);
end;
procedure TfrmReports.lvReportsCompare(Sender: TObject; Item1,
Item2: TListItem; Data: Integer; var Compare: Integer);
function CompareValues(Col: Integer): integer;
var
ix: Integer;
s1, s2: string;
v1, v2: extended;
d1, d2: TFMDateTime;
begin
inherited;
if ColumnToSort = 0 then
Result := CompareText(Item1.Caption,Item2.Caption)
else
begin
ix := ColumnToSort - 1;
case Col of
0: //strings
begin
if(Item1.SubItems.Count > 0) and (ix < Item1.SubItems.Count) then
s1 := Item1.SubItems[ix]
else
s1 := '0';
if(Item2.SubItems.Count > 0) and (ix < Item2.SubItems.Count) then
s2 := Item2.SubItems[ix]
else
s2 := '0';
Result := CompareText(s1,s2);
end;
1: //integers
begin
if(Item1.SubItems.Count > 0) and (ix < Item1.SubItems.Count) then
s1 := Item1.SubItems[ix]
else
s1 := '0';
if(Item2.SubItems.Count > 0) and (ix < Item2.SubItems.Count) then
s2 := Item2.SubItems[ix]
else
s2 := '0';
IsValidNumber(s1, v1);
IsValidNumber(s2, v2);
if v1 > v2 then
Result := 1
else
if v1 < v2 then
Result := -1
else
Result := 0;
end;
2: //date/times
begin
if(Item1.SubItems.Count > 1) and (ix < Item1.SubItems.Count) then
s1 := Item1.SubItems[ix]
else
s1 := '1/1/1700';
if(Item2.SubItems.Count > 1) and (ix < Item2.SubItems.Count) then
s2 := Item2.SubItems[ix]
else
s2 := '1/1/1700';
d1 := StringToFMDateTime(s1);
d2 := StringToFMDateTime(s2);
if d1 > d2 then
Result := 1
else
if d1 < d2 then
Result := -1
else
Result := 0;
end;
else
Result := 0; // to make the compiler happy
end;
end;
end;
begin
ColumnToSort := uFirstSort;
Compare := CompareValues(SortIdx1);
if Compare = 0 then
begin
if (uSecondSort > -1) and (uFirstSort <> uSecondSort) then
begin
ColumnToSort := uSecondSort;
Compare := CompareValues(SortIdx2);
end;
if Compare = 0 then
if (uThirdSort > -1) and (uFirstSort <> uThirdSort) and (uSecondSort <> uThirdSort) then
begin
ColumnToSort := uThirdSort;
Compare := CompareValues(SortIdx3);
end;
end;
if not ColumnSortForward then Compare := -Compare;
end;
procedure TfrmReports.lvReportsSelectItem(Sender: TObject; Item: TListItem;
Selected: Boolean);
var
aID, aMoreID, aSID: string;
i,j,k: integer;
aBasket: TStringList;
aWPFlag: Boolean;
begin
inherited;
if not selected then Exit;
aBasket := TStringList.Create;
uLocalReportData.Clear;
aWPFlag := false;
with lvReports do
begin
aID := Item.SubItems[0];
case uQualifierType of
QT_OTHER:
begin // = 0
end;
QT_HSTYPE:
begin // = 1
aMoreID := ';' + Item.SubItems[2];
end;
QT_DATERANGE:
begin // = 2
end;
QT_IMAGING:
begin // = 3
if lvReports.SelCount = 1 then
begin
memText.Lines.Clear;
if not UpdatingTvProcedures then
begin
UpdatingLvReports := TRUE;
for i := 0 to (tvProcedures.Items.Count - 1) do
if PProcTreeObj(tvProcedures.Items[i].Data)^.ExamDtTm = Item.SubItems[0] then
if PProcTreeObj(tvProcedures.Items[i].Data)^.ProcedureName = Item.SubItems[2] then
begin
if tvProcedures.Items[i].Parent <> nil then
begin
tvProcedures.Items[i].Parent.Expanded := True;
if PProcTreeObj(tvProcedures.Items[i].Data)^.MemberOfSet = '1' then
lblProcTypeMsg.Caption := 'Descendent Procedure'
else if PProcTreeObj(tvProcedures.Items[i].Data)^.MemberOfSet = '2' then
lblProcTypeMsg.Caption := 'Descendent Procedure with shared report';
end
else
lblProcTypeMsg.Caption := 'Standalone (single) procedure';
tvProcedures.Items[i].Selected := TRUE;
end;
UpdatingLvReports := False;
end;
end
else
if not UpdatingTvProcedures then
tvProcedures.Selected := nil;
if MemText.Lines.Count > 0 then
memText.Lines.Add('===============================================================================');
aMoreID := '#' + Item.SubItems[5];
SetPiece(uRemoteType,'^',5,aID + aMoreID);
LoadReportText(uLocalReportData, uRptID, aID + aMoreID, uReportRPC, '');
for i := 0 to uLocalReportData.Count - 1 do
MemText.Lines.Add(uLocalReportData[i]);
if Item.SubItems.Count > 5 then
NotifyOtherApps(NAE_REPORT, 'RA^' + aID + U + Item.SubItems[5])
else
NotifyOtherApps(NAE_REPORT, 'RA^' + aID);
end;
QT_NUTR:
begin // = 4
if lvReports.SelCount = 1 then
memText.Lines.Clear;
if MemText.Lines.Count > 0 then
memText.Lines.Add('===============================================================================');
SetPiece(uRemoteType,'^',5,aID);
LoadReportText(uLocalReportData, uRptID, aID, uReportRPC, '');
for i := 0 to uLocalReportData.Count - 1 do
MemText.Lines.Add(uLocalReportData[i]);
end;
QT_HSWPCOMPONENT:
begin // = 6
if lvReports.SelCount < 3 then
begin
memText.Lines.Clear;
ulvSelectOn := false;
end;
aBasket.Clear;
if (SelCount = 2) and (ulvSelectOn = false) then
begin
ulvSelectOn := true;
for i := 0 to Items.Count - 1 do
if (Items[i].Selected) and (aID <> Items[i].SubItems[0]) then
begin
aSID := Items[i].SubItems[0];
for j := 0 to RowObjects.ColumnList.Count - 1 do
if piece(aSID,':',1) = piece(TCellObject(RowObjects.ColumnList[j]).Handle,':',1) then
if Item.Caption = (piece(TCellObject(RowObjects.ColumnList[j]).Site,';',1)) then
if (TCellObject(RowObjects.ColumnList[j]).Data.Count > 0) and
(TCellObject(RowObjects.ColumnList[j]).Include = '1') then
begin
aWPFlag := true;
MemText.Lines.Add(TCellObject(RowObjects.ColumnList[j]).Name);
aBasket.Assign(TCellObject(RowObjects.ColumnList[j]).Data);
for k := 0 to aBasket.Count - 1 do
MemText.Lines.Add(' ' + aBasket[k]);
end;
if aWPFlag = true then
begin
memText.Lines.Add('Facility: ' + Item.Caption);
memText.Lines.Add('===============================================================================');
end;
end;
end;
aBasket.Clear;
aWPFlag := false;
for i := 0 to RowObjects.ColumnList.Count - 1 do
if piece(aID,':',1) = piece(TCellObject(RowObjects.ColumnList[i]).Handle,':',1) then
if Item.Caption = (piece(TCellObject(RowObjects.ColumnList[i]).Site,';',1)) then
if (TCellObject(RowObjects.ColumnList[i]).Data.Count > 0) and
(TCellObject(RowObjects.ColumnList[i]).Include = '1') then
begin
aWPFlag := true;
MemText.Lines.Add(TCellObject(RowObjects.ColumnList[i]).Name);
aBasket.Assign(TCellObject(RowObjects.ColumnList[i]).Data);
for j := 0 to aBasket.Count - 1 do
MemText.Lines.Add(' ' + aBasket[j]);
end;
if aWPFlag = true then
begin
memText.Lines.Add('Facility: ' + Item.Caption);
memText.Lines.Add('===============================================================================');
end;
if uRptID = 'OR_R18:IMAGING' then
if (Item.SubItems.Count > 4) and (Item.SubItems.Count > 8) then
NotifyOtherApps(NAE_REPORT, 'RA^' + Item.SubItems[8] + U + Item.SubItems[4] + U + Item.Caption)
else
if Item.SubItems.Count > 8 then
NotifyOtherApps(NAE_REPORT, 'RA^' + Item.SubItems[8] + U + U + Item.Caption)
else if Item.SubItemImages[1] = 1 then
begin
memText.Lines.Insert(0,'<Imaging links not active at this site>');
memText.Lines.Insert(1,' ');
end;
if uRptID = 'OR_PN:PROGRESS NOTES' then
if (Item.SubItems.Count > 7) then
NotifyOtherApps(NAE_REPORT, 'PN^' + Item.SubItems[7] + U + Item.SubItems[1] + U + Item.Caption);
end;
QT_PROCEDURES:
begin // = 19
if lvReports.SelCount = 1 then
memText.Lines.Clear;
if MemText.Lines.Count > 0 then
memText.Lines.Add('===============================================================================');
SetPiece(uRemoteType,'^',5,aID);
LoadReportText(uLocalReportData, uRptID, aID + aMoreID, uReportRPC, '');
for i := 0 to uLocalReportData.Count - 1 do
MemText.Lines.Add(uLocalReportData[i]);
end;
QT_SURGERY:
begin // = 28
if lvReports.SelCount = 1 then
memText.Lines.Clear;
if MemText.Lines.Count > 0 then
memText.Lines.Add('===============================================================================');
SetPiece(uRemoteType,'^',5,aID);
LoadReportText(uLocalReportData, uRptID, aID + aMoreID, uReportRPC, '');
for i := 0 to uLocalReportData.Count - 1 do
MemText.Lines.Add(uLocalReportData[i]);
NotifyOtherApps(NAE_REPORT, 'SUR^' + aID);
end;
end;
memText.Lines.Insert(0,' ');
memText.Lines.Delete(0);
end;
aBasket.Free;
end;
procedure TfrmReports.tvReportsExpanding(Sender: TObject; Node: TTreeNode;
var AllowExpansion: Boolean);
begin
inherited;
tvReports.Selected := Node;
end;
procedure TfrmReports.tvReportsCollapsing(Sender: TObject; Node: TTreeNode;
var AllowCollapse: Boolean);
begin
inherited;
tvReports.Selected := Node;
end;
procedure TfrmReports.Print1Click(Sender: TObject);
begin
inherited;
RequestPrint;
end;
procedure TfrmReports.Copy1Click(Sender: TObject);
var
i,j: integer;
line: string;
ListItem: TListItem;
aText: String;
begin
inherited;
ClipBoard;
aText := '';
for i := 0 to lvReports.Items.Count - 1 do
if lvReports.Items[i].Selected then
begin
ListItem := lvReports.Items[i];
line := '';
for j := 1 to lvReports.Columns.Count - 1 do
begin
if (lvReports.Column[j].Width <> 0) and (j < (ListItem.SubItems.Count + 1)) then
line := line + ' ' + ListItem.SubItems[j-1];
end;
if (length(line) > 0) and (lvReports.Column[0].Width <> 0) then
line := ListItem.Caption + ' ' + line;
if length(aText) > 0 then
aText := aText + CRLF + line
else aText := line;
end;
ClipBoard.Clear;
ClipBoard.AsText := aText;
end;
procedure TfrmReports.Copy2Click(Sender: TObject);
begin
inherited;
memText.CopyToClipboard;
end;
procedure TfrmReports.Print2Click(Sender: TObject);
begin
inherited;
RequestPrint;
end;
procedure TfrmReports.lvReportsKeyUp(Sender: TObject; var Key: Word;
Shift: TShiftState);
begin
inherited;
if (Key = 67) and (ssCtrl in Shift) then
Copy1Click(Self);
if (Key = 65) and (ssCtrl in Shift) then
SelectAll1Click(Self);
end;
procedure TfrmReports.SelectAll1Click(Sender: TObject);
var
i: integer;
begin
inherited;
for i := 0 to lvReports.Items.Count - 1 do
lvReports.Items[i].Selected := true;
end;
procedure TfrmReports.SelectAll2Click(Sender: TObject);
begin
inherited;
memText.SelectAll;
end;
procedure TfrmReports.tvReportsKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
begin
inherited;
case Key of
VK_LBUTTON, VK_RETURN, VK_SPACE:
begin
tvReportsClick(Sender);
Key := 0;
end;
end;
end;
procedure TfrmReports.ShowTabControl;
begin
if TabControl1.Tabs.Count > 1 then
begin
TabControl1.Visible := true;
TabControl1.TabStop := true;
pnlRightTop.Height := lblTitle.Height + TabControl1.Height;
end;
end;
procedure TfrmReports.Memo1KeyUp(Sender: TObject; var Key: Word;
Shift: TShiftState);
begin
inherited;
if (Key = VK_TAB) then
begin
if ssShift in Shift then
begin
FindNextControl(Sender as TWinControl, False, True, False).SetFocus; //previous control
Key := 0;
end
else if ssCtrl in Shift then
begin
FindNextControl(Sender as TWinControl, True, True, False).SetFocus; //next control
Key := 0;
end;
end;
if (key = VK_ESCAPE) then begin
FindNextControl(Sender as TWinControl, False, True, False).SetFocus; //previous control
key := 0;
end;
end;
procedure TfrmReports.LoadProceduresTreeView(x: string; var CurrentParentNode: TTreeNode; var CurrentNode: TTreeNode);
var
PTO, PTO2: PProcTreeObj;
begin
PTO := MakeProcedureTreeObject(x);
PTO2 := MakeProcedureTreeObject(x);
PTO2.ProcedureName := '';
if PTO^.ParentName = '' then
begin // New stand-alone
CurrentParentNode := tvProcedures.Items.AddObject(CurrentParentNode,PTO^.ProcedureName,PTO);
CurrentNode := CurrentParentNode;
end
else
if (CurrentParentNode <> nil) and (PTO^.ParentName = PProcTreeObj(CurrentParentNode.Data)^.ParentName) then
// another child for same parent
CurrentNode := tvProcedures.Items.AddChildObject(CurrentParentNode,PTO^.ProcedureName,PTO)
else
begin //New child and parent
CurrentParentNode := tvProcedures.Items.AddObject(CurrentParentNode,PTO2^.ParentName,PTO2);
CurrentNode := tvProcedures.Items.AddChildObjectFirst(CurrentParentNode,PTO^.ProcedureName,PTO);
end;
end;
procedure TfrmReports.tvProceduresCollapsing(Sender: TObject;
Node: TTreeNode; var AllowCollapse: Boolean);
begin
inherited;
tvReports.Selected := Node;
end;
procedure TfrmReports.tvProceduresExpanding(Sender: TObject;
Node: TTreeNode; var AllowExpansion: Boolean);
begin
inherited;
tvReports.Selected := Node;
end;
procedure TfrmReports.tvProceduresClick(Sender: TObject);
var
Associate: Integer;
SelNode: TTreeNode;
begin
inherited;
SelNode := TTreeView(Sender).Selected;
if not assigned(SelNode) then Exit;
Associate := PProcTreeObj(SelNode.Data)^.Associate;
lvReports.Selected := nil;
if PProcTreeObj(SelNode.Data)^.ProcedureName <> '' then //if it is a descendent or a stand-alone
begin
memText.Lines.Clear;
lvReports.Selected := lvReports.Items[Associate];
if PProcTreeObj(SelNode.Data)^.MemberOfSet = '1' then
lblProcTypeMsg.Caption := 'Descendent Procedure'
else
if PProcTreeObj(SelNode.Data)^.MemberOfSet = '2' then
lblProcTypeMsg.Caption := 'Descendent Procedure with shared report';
end
else //if it is a parent with descendents
if PProcTreeObj(SelNode.Data)^.MemberOfSet = '2' then //printset = shared report
lblProcTypeMsg.Caption := 'Descendent Procedures with shared report'
else if PProcTreeObj(SelNode.Data)^.MemberOfSet = '1' then //examset - individual reports
begin
memText.Lines.Clear;
lblProcTypeMsg.Caption := 'Descendent Procedures - Select to view individual reports';
memText.Lines.Add('Descendent Procedures - Select to view individual reports...')
end;
end;
procedure TfrmReports.tvProceduresChange(Sender: TObject; Node: TTreeNode);
var
Associate, i: Integer;
FirstChild: TTreeNode;
aID, aMoreID: string;
begin
inherited;
if UpdatingLvReports or not assigned(Node) then Exit;
UpdatingTVProcedures := TRUE;
Associate := PProcTreeObj(Node.Data)^.Associate;
lvReports.Selected := nil;
if PProcTreeObj(Node.Data)^.ProcedureName <> '' then //if it is a descendent or a stand-alone
if (Associate >= 0) and (Associate < (lvReports.Items.Count)) then // if valid associate in lvReports
if lvReports.Items[Associate].Selected = FALSE then // if not already selected
begin
lvReports.Selected := lvReports.Items[Associate];
if PProcTreeObj(Node.Data)^.MemberOfSet = '1' then
begin
lblProcTypeMsg.Caption := 'Descendent Procedure';
end
else if PProcTreeObj(Node.Data)^.MemberOfSet = '2' then
lblProcTypeMsg.Caption := 'Descendent Procedures with shared report'
else if PProcTreeObj(Node.Data)^.MemberOfSet = '' then
lblProcTypeMsg.Caption := 'Standalone (single) procedure';
end;
UpdatingTvProcedures := FALSE;
if PProcTreeObj(Node.Data)^.ProcedureName = '' then //Parent with descendents
if PProcTreeObj(Node.Data)^.MemberOfSet = '2' then //printset = shared report
begin
lblProcTypeMsg.Caption := 'Descendent Procedures with shared report';
FirstChild := Node.GetFirstChild;
Associate := PProcTreeObj(FirstChild.Data)^.Associate;
aID := lvReports.Items[Associate].SubItems[0];
aMoreID := '#' + lvReports.Items[Associate].SubItems[5];
SetPiece(uRemoteType,'^',5,aID + aMoreID);
uLocalReportData.Clear;
MemText.Lines.Clear;
LoadReportText(uLocalReportData, uRptID, aID + aMoreID, uReportRPC, '');
for i := 0 to uLocalReportData.Count - 1 do
MemText.Lines.Add(uLocalReportData[i]);
memText.SelStart := 0;
if lvReports.Items[Associate].SubItems.Count > 5 then
NotifyOtherApps(NAE_REPORT, 'RA^' + aID + U + lvReports.Items[Associate].SubItems[5])
else
NotifyOtherApps(NAE_REPORT, 'RA^' + aID);
end
else if PProcTreeObj(Node.Data)^.MemberOfSet = '1' then //examset - individual reports
begin
memText.Lines.Clear;
lblProcTypeMsg.Caption := 'Descendent Procedures - Select to view individual reports';
memText.Lines.Add('Descendent Procedures - Select to view individual reports...');
end;
end;
procedure TfrmReports.tvProceduresKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
begin
inherited;
case Key of
VK_LBUTTON, VK_RETURN, VK_SPACE:
begin
tvReportsClick(Sender);
Key := 0;
end;
end;
end;
procedure TfrmReports.chkDualViewsClick(Sender: TObject);
begin
inherited;
if (GraphForm <> nil) and GraphFormActive then
GraphForm.chkDualViews.Checked := chkDualViews.Checked;
end;
procedure TfrmReports.btnChangeViewClick(Sender: TObject);
begin
inherited;
if (GraphForm <> nil) and GraphFormActive then
begin
GraphForm.btnChangeSettingsClick(GraphForm);
chkDualViews.Checked := GraphForm.chkDualViews.Checked;
end;
end;
procedure TfrmReports.btnGraphSelectionsClick(Sender: TObject);
begin
inherited;
if (GraphForm <> nil) and GraphFormActive then
begin
GraphForm.btnGraphSelectionsClick(GraphForm);
chkDualViews.Checked := GraphForm.chkDualViews.Checked;
end;
end;
procedure TfrmReports.lstDateRangeClick(Sender: TObject);
begin
inherited;
if (GraphForm <> nil) then
begin
GraphForm.cboDateRange.ItemIndex := lstDateRange.ItemIndex;
GraphForm.cboDateRangeChange(self);
lstDateRange.Items.Assign(GraphForm.cboDateRange.Items);
lstDateRange.ItemIndex := GraphForm.cboDateRange.ItemIndex;
//Exit;
end;
end;
procedure TfrmReports.sptHorzMoved(Sender: TObject);
begin
inherited;
pnlTopViews.Height := 80;
end;
end.
Reference in New Issue View Git Blame Copy Permalink