Module

rReports

Path

C:\CPRS\CPRS30\rReports.pas

Last Modified

7/15/2014 3:26:44 PM

Initialization Code

initialization
  { nothing to initialize }

Finalization Code

finalization
  uTree.Free;
  uReportsList.Free;
  uLabReports.Free;
  uDateRanges.Free;
  uHSTypes.Free;

end.

Units Used in Implementation

Name Comments
fReports -
rCore -
uCore -
uReports -

Procedures

Name Owner Declaration Scope Comments
ColumnHeaders - procedure ColumnHeaders(Dest: TStrings; AReportType: String); Interfaced -
CreatePatientHeader - procedure CreatePatientHeader(var HeaderList: TStringList; PageTitle: string); Interfaced Standard patient header, from HEAD^ORWRPP
DirectQuery - procedure DirectQuery(Dest: TStrings; AReportType: string; AHSType, ADaysback, AExamID: string; Alpha, AOmega: Double; ASite, ARemoteRPC, AHSTag: String); Interfaced -
ExtractSection - procedure ExtractSection(Dest: TStrings; const Section: string; Mixed: Boolean); Global Reports
GetRemoteData - procedure GetRemoteData(Dest: TStrings; aHandle: string; aItem: PChar); Interfaced -
HealthSummaryCheck - procedure HealthSummaryCheck(Dest: TStrings; aQualifier: string); Interfaced -
HSABVComponents - procedure HSABVComponents(Dest: TStrings); Interfaced -
HSComponentFiles - procedure HSComponentFiles(Dest: TStrings; aComponent: String); Interfaced -
HSComponents - procedure HSComponents(Dest: TStrings); Interfaced -
HSComponentSubs - procedure HSComponentSubs(Dest: TStrings; aItem: String); Interfaced -
HSDispComponents - procedure HSDispComponents(Dest: TStrings); Interfaced -
HSReportText - procedure HSReportText(Dest: TStrings; aComponents: TStringlist); Interfaced -
HSSubItems - procedure HSSubItems(Dest: TStrings; aItem: String); Interfaced -
ListConsults - procedure ListConsults(Dest: TStrings); Interfaced
Consults
Consults
ListHealthSummaryTypes - procedure ListHealthSummaryTypes(Dest: TStrings); Interfaced -
ListImagingExams - procedure ListImagingExams(Dest: TStrings); Interfaced -
ListLabReports - procedure ListLabReports(Dest: TStrings); Interfaced -
ListNutrAssessments - procedure ListNutrAssessments(Dest: TStrings); Interfaced -
ListProcedures - procedure ListProcedures(Dest: TStrings); Interfaced -
ListReportDateRanges - procedure ListReportDateRanges(Dest: TStrings); Interfaced -
ListReports - procedure ListReports(Dest: TStrings); Interfaced Reports
ListSurgeryReports - procedure ListSurgeryReports(Dest: TStrings); Interfaced
Returns a list of surgery cases for a patient, without documents
Facility^Case #^Date/Time of Operation^Operative Procedure^Surgeon name)
LoadConsultText - procedure LoadConsultText(Dest: TStrings; IEN: Integer); Interfaced -
LoadLabReportLists - procedure LoadLabReportLists; Global -
LoadReportLists - procedure LoadReportLists; Global -
LoadReportText - procedure LoadReportText(Dest: TStrings; ReportType: string; const Qualifier: string; ARpc, AHSTag: string); Interfaced -
LoadTree - procedure LoadTree(Tab: String); Global -
ModifyHDRData - procedure ModifyHDRData(Dest: string; aHandle: string; aID: string); Interfaced -
PrintBitmap - procedure PrintBitmap(Canvas: TCanvas; DestRect: TRect; Bitmap: TBitmap); Interfaced -
PrintGraph - procedure PrintGraph(GraphImage: TChart; PageTitle: string); Interfaced -
PrintReportsToDevice - procedure PrintReportsToDevice(AReport: string; const Qualifier, Patient, ADevice: string; var ErrMsg: string; aComponents: TStringlist; ARemoteSiteID, ARemoteQuery, AHSTag: string); Interfaced Prints a report on the selected device
PrintVReports - procedure PrintVReports(Dest, ADevice, AHeader: string; AReport: TStringList); Interfaced -
PrintWindowsReport - procedure PrintWindowsReport(ARichEdit: TRichEdit; APageBreak, ATitle: string; var ErrMsg: string; IncludeHeader: Boolean = false); Interfaced -
RemoteQuery - procedure RemoteQuery(Dest: TStrings; AReportType: string; AHSType, ADaysback, AExamID: string; Alpha, AOmega: Double; ASite, ARemoteRPC, AHSTag: String); Interfaced -
RemoteQueryAbortAll - procedure RemoteQueryAbortAll; Interfaced -
SaveColumnSizes - procedure SaveColumnSizes(aColumn: String); Interfaced -
SaveDefaultPrinter - procedure SaveDefaultPrinter(DefPrinter: string) ; Interfaced -
SetAdhocLookup - procedure SetAdhocLookup(aLookup: integer); Interfaced -

Functions

Name Owner Declaration Scope Comments
AutoRDV - function AutoRDV: String; Interfaced -
DefaultToWindowsPrinter - function DefaultToWindowsPrinter: Boolean; Interfaced -
GetAdhocLookup - function GetAdhocLookup: integer; Interfaced -
GetFormattedReport - function GetFormattedReport(AReport: string; const Qualifier, Patient: string; aComponents: TStringlist; ARemoteSiteID, ARemoteQuery, AHSTag: string): TStrings; Interfaced Prints a report on the selected device
GetRemoteStatus - function GetRemoteStatus(aHandle: string): String; Interfaced -
HDRActive - function HDRActive: String; Interfaced -
HSFileLookup - function HSFileLookup(aFile: String; const StartFrom: string; Direction: Integer): TStrings; Interfaced -
ImagingParams - function ImagingParams: String; Interfaced -
ReportQualifierType - function ReportQualifierType(ReportType: Integer): Integer; Interfaced -

Global Variables

Name Type Declaration Comments
uDateRanges TStringList uDateRanges: TStringList; -
uHSTypes TStringList uHSTypes: TStringList; -
uLabReports TStringList uLabReports: TStringList; -
uReportsList TStringList uReportsList: TStringList; -
uTree TStringList uTree: TStringList; -


Module Source

1     unit rReports;
2     
3     interface
4     
5     uses Windows, SysUtils, Classes, ORNet, ORFn, ComCtrls, Chart, graphics;
6     
7     { Consults }
8     procedure ListConsults(Dest: TStrings);
9     procedure LoadConsultText(Dest: TStrings; IEN: Integer);
10    
11    { Reports }
12    procedure ListReports(Dest: TStrings);
13    procedure ListLabReports(Dest: TStrings);
14    procedure ListReportDateRanges(Dest: TStrings);
15    procedure ListHealthSummaryTypes(Dest: TStrings);
16    procedure ListImagingExams(Dest: TStrings);
17    procedure ListProcedures(Dest: TStrings);
18    procedure ListNutrAssessments(Dest: TStrings);
19    procedure ListSurgeryReports(Dest: TStrings);
20    procedure ColumnHeaders(Dest: TStrings; AReportType: String);
21    procedure SaveColumnSizes(aColumn: String);
22    procedure LoadReportText(Dest: TStrings; ReportType: string; const Qualifier: string; ARpc, AHSTag: string);
23    procedure RemoteQueryAbortAll;
24    procedure RemoteQuery(Dest: TStrings; AReportType: string; AHSType, ADaysback,
25                AExamID: string; Alpha, AOmega: Double; ASite, ARemoteRPC, AHSTag: String);
26    procedure DirectQuery(Dest: TStrings; AReportType: string; AHSType, ADaysback,
27                AExamID: string; Alpha, AOmega: Double; ASite, ARemoteRPC, AHSTag: String);
28    function ReportQualifierType(ReportType: Integer): Integer;
29    function ImagingParams: String;
30    function AutoRDV: String;
31    function HDRActive: String;
32    procedure PrintReportsToDevice(AReport: string; const Qualifier, Patient,
33         ADevice: string; var ErrMsg: string; aComponents: TStringlist;
34         ARemoteSiteID, ARemoteQuery, AHSTag: string);
35    function HSFileLookup(aFile: String; const StartFrom: string;
36             Direction: Integer): TStrings;
37    procedure HSComponentFiles(Dest: TStrings; aComponent: String);
38    procedure HSSubItems(Dest: TStrings; aItem: String);
39    procedure HSReportText(Dest: TStrings; aComponents: TStringlist);
40    procedure HSComponents(Dest: TStrings);
41    procedure HSABVComponents(Dest: TStrings);
42    procedure HSDispComponents(Dest: TStrings);
43    procedure HSComponentSubs(Dest: TStrings; aItem: String);
44    procedure HealthSummaryCheck(Dest: TStrings; aQualifier: string);
45    function GetFormattedReport(AReport: string; const Qualifier, Patient: string;
46               aComponents: TStringlist; ARemoteSiteID, ARemoteQuery, AHSTag: string): TStrings;
47    procedure PrintWindowsReport(ARichEdit: TRichEdit; APageBreak, ATitle: string;
48      var ErrMsg: string; IncludeHeader: Boolean = false);
49    function DefaultToWindowsPrinter: Boolean;
50    procedure PrintGraph(GraphImage: TChart; PageTitle: string);
51    procedure PrintBitmap(Canvas: TCanvas; DestRect: TRect; Bitmap: TBitmap);
52    procedure CreatePatientHeader(var HeaderList: TStringList; PageTitle: string);
53    procedure SaveDefaultPrinter(DefPrinter: string) ;
54    function GetRemoteStatus(aHandle: string): String;
55    function GetAdhocLookup: integer;
56    procedure SetAdhocLookup(aLookup: integer);
57    procedure GetRemoteData(Dest: TStrings; aHandle: string; aItem: PChar);
58    procedure ModifyHDRData(Dest: string; aHandle: string; aID: string);
59    procedure PrintVReports(Dest, ADevice, AHeader: string; AReport: TStringList);
60    
61    implementation
62    
63    uses uCore, rCore, Printers, clipbrd, uReports, fReports;
64    
65    var
66      uTree:       TStringList;
67      uReportsList:    TStringList;
68      uLabReports: TStringList;
69      uDateRanges: TStringList;
70      uHSTypes:    TStringList;
71    
72    { Consults }
73    
74    procedure ListConsults(Dest: TStrings);
75    var
76      i: Integer;
77      x: string;
78    begin
79      CallV('ORWCS LIST OF CONSULT REPORTS', [Patient.DFN]);
80      with RPCBrokerV do
81      begin
82        SortByPiece(TStringList(Results), U, 2);
83        InvertStringList(TStringList(Results));
84        SetListFMDateTime('mmm dd,yy', TStringList(Results), U, 2);
85        for i := 0 to Results.Count - 1 do
86        begin
87          x := Results[i];
88          x := Pieces(x, U, 1, 2) + U + Piece(x, U, 3) + '  (' + Piece(x, U, 4) + ')';
89          Results[i] := x;
90        end;
91        FastAssign(Results, Dest);
92      end;
93    end;
94    
95    procedure LoadConsultText(Dest: TStrings; IEN: Integer);
96    begin
97      CallV('ORWCS REPORT TEXT', [Patient.DFN, IEN]);
98      QuickCopy(RPCBrokerV.Results,Dest);
99    end;
100   
101   { Reports }
102   
103   procedure ExtractSection(Dest: TStrings; const Section: string; Mixed: Boolean);
104   var
105     i: Integer;
106   begin
107     with RPCBrokerV do
108     begin
109       i := -1;
110       repeat Inc(i) until (i = Results.Count) or (Results[i] = Section);
111       Inc(i);
112       while (i < Results.Count) and (Results[i] <> '$$END') do
113       begin
114         {if (Pos('OR_ECS',UpperCase(Results[i]))>0) and (not uECSReport.ECSPermit) then
115         begin
116           Inc(i);
117           Continue;
118         end;}
119         if Mixed = true then
120           Dest.Add(MixedCase(Results[i]))
121         else
122           Dest.Add(Results[i]);
123         Inc(i);
124       end;
125     end;
126   end;
127   
128   procedure LoadReportLists;
129   begin
130     CallV('ORWRP REPORT LISTS', [nil]);
131     uDateRanges := TStringList.Create;
132     uHSTypes    := TStringList.Create;
133     uReportsList    := TStringList.Create;
134     ExtractSection(uDateRanges, '[DATE RANGES]', true);
135     ExtractSection(uHSTypes,    '[HEALTH SUMMARY TYPES]', true);
136     ExtractSection(uReportsList,    '[REPORT LIST]', true);
137   end;
138   
139   procedure LoadLabReportLists;
140   begin
141     CallV('ORWRP LAB REPORT LISTS', [nil]);
142     uLabReports  := TStringList.Create;
143     ExtractSection(uLabReports, '[LAB REPORT LIST]', true);
144   end;
145   
146   procedure LoadTree(Tab: String);
147   begin
148     CallV('ORWRP3 EXPAND COLUMNS', [Tab]);
149     uTree    := TStringList.Create;
150     ExtractSection(uTree, '[REPORT LIST]', false);
151   end;
152   
153   procedure ListReports(Dest: TStrings);
154   var
155     i: Integer;
156   begin
157     if uTree = nil
158       then LoadTree('REPORTS')
159     else
160       begin
161         uTree.Clear;
162         LoadTree('REPORTS');
163       end;
164     for i := 0 to uTree.Count - 1 do Dest.Add(Pieces(uTree[i], '^', 1, 20));
165   end;
166   
167   procedure ListLabReports(Dest: TStrings);
168   var
169     i: integer;
170   begin
171     {if uLabreports = nil then LoadLabReportLists;
172     for i := 0 to uLabReports.Count - 1 do Dest.Add(Pieces(uLabReports[i], U, 1, 10)); }
173     if uTree = nil
174       then LoadTree('LABS')
175     else
176       begin
177         uTree.Clear;
178         LoadTree('LABS');
179       end;
180     for i := 0 to uTree.Count - 1 do Dest.Add(Pieces(uTree[i], '^', 1, 20));
181   end;
182   
183   procedure ListReportDateRanges(Dest: TStrings);
184   begin
185     if uDateRanges = nil then LoadReportLists;
186     FastAssign(uDateRanges, Dest);
187   end;
188   
189   procedure ListHealthSummaryTypes(Dest: TStrings);
190   begin
191     if uHSTypes = nil then LoadReportLists;
192     MixedCaseList(uHSTypes);
193     FastAssign(uHSTypes, Dest);
194   end;
195   
196   procedure HealthSummaryCheck(Dest: TStrings; aQualifier: string);
197   
198   begin
199     if aQualifier = '1' then
200       begin
201         ListHealthSummaryTypes(Dest);
202       end;
203   end;
204   
205   procedure ColumnHeaders(Dest: TStrings; AReportType: String);
206   begin
207     CallV('ORWRP COLUMN HEADERS',[AReportType]);
208     FastAssign(RPCBrokerV.Results, Dest);
209   end;
210   
211   procedure SaveColumnSizes(aColumn: String);
212   begin
213     CallV('ORWCH SAVECOL', [aColumn]);
214   end;
215   
216   procedure ListImagingExams(Dest: TStrings);
217   var
218     x: string;
219     i: Integer;
220   begin
221     CallV('ORWRA IMAGING EXAMS1', [Patient.DFN]);
222     with RPCBrokerV do
223     begin
224       SetListFMDateTime('mm/dd/yyyy hh:nn', TStringList(Results), U, 3);
225       for i := 0 to Results.Count - 1 do
226       begin
227         x := Results[i];
228         if Piece(x,U,7) = 'Y' then SetPiece(x,U,7, ' - Abnormal');
229           x := Piece(x,U,1) + U + 'i' + Pieces(x,U,2,3)+ U + Piece(x,U,4)
230                + U + Piece(x,U,6)  + Piece(x,U,7) + U
231                + MixedCase(Piece(Piece(x,U,9),'~',2)) + U + Piece(x,U,5) +  U + '[+]'
232                + U + Pieces(x, U, 15,17);                                                 
233   (*      x := Piece(x,U,1) + U + 'i' + Pieces(x,U,2,3)+ U + Piece(x,U,4)
234           + U + Piece(x,U,6) + Piece(x,U,7) + U + Piece(x,U,5) +  U + '[+]' + U + Piece(x, U, 15);*)
235         Results[i] := x;
236       end;
237       FastAssign(Results, Dest);
238     end;
239   end;
240   
241   procedure ListProcedures(Dest: TStrings);
242   var
243     x,sdate: string;
244     i: Integer;
245   begin
246     CallV('ORWMC PATIENT PROCEDURES1', [Patient.DFN]);
247     with RPCBrokerV do
248     begin
249       for i := 0 to Results.Count - 1 do
250       begin
251         x := Results[i];
252         if length(piece(x, U, 8)) > 0 then
253           begin
254             sdate := ShortDateStrToDate(piece(piece(x, U, 8),'@',1)) + ' ' + piece(piece(x, U, 8),'@',2);
255           end;
256         x := Piece(x, U, 1) + U + 'i' + Piece(x, U, 2) + U + sdate + U + Piece(x, U, 3) + U + Piece(x, U, 9) + '^[+]';
257         Results[i] := x;
258       end;
259       FastAssign(Results, Dest);
260     end;
261   end;
262   
263   procedure ListNutrAssessments(Dest: TStrings);
264   var
265     x: string;
266     i: Integer;
267   begin
268     CallV('ORWRP1 LISTNUTR', [Patient.DFN]);
269     with RPCBrokerV do
270     begin
271       for i := 0 to Results.Count - 1 do
272         begin
273           x := Results[i];
274           x := Piece(x, U, 1) + U + 'i' + Piece(x, U, 3) + U + Piece(x, U, 3);
275           Results[i] := x;
276         end;
277       FastAssign(Results, Dest);
278     end;
279   end;
280   
281   procedure ListSurgeryReports(Dest: TStrings);
282   { returns a list of surgery cases for a patient, without documents}
283   //Facility^Case #^Date/Time of Operation^Operative Procedure^Surgeon name)
284   var
285     i: integer;
286     x, AFormat: string;
287   begin
288     CallV('ORWSR RPTLIST', [Patient.DFN]);
289     with RPCBrokerV do
290      begin
291       for i := 0 to Results.Count - 1 do
292         begin
293           x := Results[i];
294           if Piece(Piece(x, U, 3), '.', 2) = '' then AFormat := 'mm/dd/yyyy' else AFormat := 'mm/dd/yyyy hh:nn';
295           x := Piece(x, U, 1) + U + 'i' + Piece(x, U, 2) + U + FormatFMDateTimeStr(AFormat, Piece(x, U, 3))+ U +
296                Piece(x, U, 4)+ U + Piece(x, U, 5);
297           if Piece(Results[i], U, 6) = '+' then x := x + '^[+]';
298           Results[i] := x;
299         end;
300       FastAssign(Results, Dest);
301     end;
302   end;
303   
304   procedure LoadReportText(Dest: TStrings; ReportType: string; const Qualifier: string; ARpc, AHSTag: string);
305   var
306     HSType, DaysBack, ExamID, MaxOcc, AReport, x: string;
307     Alpha, Omega, Trans: double;
308   begin
309     HSType := '';
310     DaysBack := '';
311     ExamID := '';
312     Alpha := 0;
313     Omega := 0;
314     if CharAt(Qualifier, 1) = 'T' then
315       begin
316         Alpha := StrToFMDateTime(Piece(Qualifier,';',1));
317         Omega := StrToFMDateTime(Piece(Qualifier,';',2));
318         if Alpha > Omega then
319           begin
320             Trans := Omega;
321             Omega := Alpha;
322             Alpha := Trans;
323           end;
324         MaxOcc := Piece(Qualifier,';',3);
325         SetPiece(AHSTag,';',4,MaxOcc);
326       end;
327     if CharAt(Qualifier, 1) = 'd' then
328       begin
329         MaxOcc := Piece(Qualifier,';',2);
330         SetPiece(AHSTag,';',4,MaxOcc);
331         x := Piece(Qualifier,';',1);
332         DaysBack := Copy(x, 2, Length(x));
333       end;
334     if CharAt(Qualifier, 1) = 'h' then HSType   := Copy(Qualifier, 2, Length(Qualifier));
335     if CharAt(Qualifier, 1) = 'i' then ExamID   := Copy(Qualifier, 2, Length(Qualifier));
336     AReport := ReportType + '~' + AHSTag;
337     if Length(ARpc) > 0 then
338       begin
339         CallV(ARpc, [Patient.DFN, AReport, HSType, DaysBack, ExamID, Alpha, Omega]);
340         QuickCopy(RPCBrokerV.Results,Dest);
341       end
342     else
343       begin
344         Dest.Add('RPC is missing from report definition (file 101.24).');
345         Dest.Add('Please contact Technical Support.');
346       end;
347   end;
348   
349   procedure RemoteQueryAbortAll;
350   begin
351     CallV('XWB DEFERRED CLEARALL',[nil]);
352   end;
353   
354   procedure RemoteQuery(Dest: TStrings; AReportType: string; AHSType, ADaysback,
355               AExamID: string; Alpha, AOmega: Double; ASite, ARemoteRPC, AHSTag: String);
356   var
357     AReport: string;
358   begin
359     AReport := AReportType + ';1' + '~' + AHSTag;
360     if length(AHSType) > 0 then
361       AHSType := piece(AHSType,':',1) + ';' + piece(AHSType,':',2);  //format for backward compatibility
362     CallV('XWB REMOTE RPC', [ASite, ARemoteRPC, 0, Patient.DFN + ';' + Patient.ICN,
363               AReport, AHSType, ADaysBack, AExamID, Alpha, AOmega]);
364     QuickCopy(RPCBrokerV.Results,Dest);
365   end;
366   
367   procedure DirectQuery(Dest: TStrings; AReportType: string; AHSType, ADaysback,
368               AExamID: string; Alpha, AOmega: Double; ASite, ARemoteRPC, AHSTag: String);
369   var
370     AReport: string;
371   begin
372     AReport := AReportType + ';1' + '~' + AHSTag;
373     if length(AHSType) > 0 then
374       AHSType := piece(AHSType,':',1) + ';' + piece(AHSType,':',2);  //format for backward compatibility
375     CallV('XWB DIRECT RPC', [ASite, ARemoteRPC, 0, Patient.DFN + ';' + Patient.ICN,
376               AReport, AHSType, ADaysBack, AExamID, Alpha, AOmega]);
377     QuickCopy(RPCBrokerV.Results,Dest);
378   end;
379   
380   function ReportQualifierType(ReportType: Integer): Integer;
381   var
382     i: Integer;
383   begin
384     Result := 0;
385     for i := 0 to uReportsList.Count - 1 do
386       if StrToIntDef(Piece(uReportsList[i], U, 1), 0) = ReportType
387         then Result := StrToIntDef(Piece(uReportsList[i], U, 3), 0);
388   end;
389   
390   function ImagingParams: String;
391   begin
392     Result := sCallV('ORWTPD GETIMG',[nil]);
393   end;
394   
395   function AutoRDV: String;
396   begin
397     Result := sCallV('ORWCIRN AUTORDV', [nil]);
398   end;
399   
400   function HDRActive: String;
401   begin
402     Result := sCallV('ORWCIRN HDRON', [nil]);
403   end;
404   
405   procedure PrintVReports(Dest, ADevice, AHeader: string; AReport: TStringList);
406   begin
407     CallV('ORWRP PRINT V REPORT', [ADevice, Patient.DFN, AHeader, AReport]);
408   end;
409   
410   procedure PrintReportsToDevice(AReport: string; const Qualifier, Patient, ADevice: string;
411    var ErrMsg: string; aComponents: TStringlist; ARemoteSiteID, ARemoteQuery, AHSTag: string);
412   { prints a report on the selected device }
413   var
414     HSType, DaysBack, ExamID, MaxOcc, ARpt, x: string;
415     Alpha, Omega: double;
416     j: integer;
417     RemoteHandle,Report: string;
418     aHandles: TStringlist;
419   begin
420     HSType := '';
421     DaysBack := '';
422     ExamID := '';
423     Alpha := 0;
424     Omega := 0;
425     aHandles := TStringList.Create;
426     if CharAt(Qualifier, 1) = 'T' then
427       begin
428         Alpha := StrToFMDateTime(Piece(Qualifier,';',1));
429         Omega := StrToFMDateTime(Piece(Qualifier,';',2));
430         MaxOcc := Piece(Qualifier,';',3);
431         SetPiece(AHSTag,';',4,MaxOcc);
432       end;
433     if CharAt(Qualifier, 1) = 'd' then
434       begin
435         MaxOcc := Piece(Qualifier,';',2);
436         SetPiece(AHSTag,';',4,MaxOcc);
437         x := Piece(Qualifier,';',1);
438         DaysBack := Copy(x, 2, Length(x));
439       end;
440     if CharAt(Qualifier, 1) = 'h' then HSType   := Copy(Qualifier, 2, Length(Qualifier));
441     if CharAt(Qualifier, 1) = 'i' then ExamID   := Copy(Qualifier, 2, Length(Qualifier));
442     if Length(ARemoteSiteID) > 0 then
443       begin
444         RemoteHandle := '';
445         for j := 0 to RemoteReports.Count - 1 do
446           begin
447             Report := TRemoteReport(RemoteReports.ReportList.Items[j]).Report;
448             if Report = ARemoteQuery then
449               begin
450                 RemoteHandle := TRemoteReport(RemoteReports.ReportList.Items[j]).Handle
451                   + '^' + Pieces(Report,'^',9,10);
452                 break;
453               end;
454           end;
455         if Length(RemoteHandle) > 1 then
456           with RemoteSites.SiteList do
457               aHandles.Add(ARemoteSiteID + '^' + RemoteHandle);
458       end;
459     ARpt := AReport + '~' + AHSTag;
460     if aHandles.Count > 0 then
461       begin
462         ErrMsg := sCallV('ORWRP PRINT REMOTE REPORT',[ADevice, Patient, ARpt, aHandles]);
463         if Piece(ErrMsg, U, 1) = '0' then ErrMsg := '' else ErrMsg := Piece(ErrMsg, U, 2);
464       end
465     else
466       begin
467         ErrMsg := sCallV('ORWRP PRINT REPORT',[ADevice, Patient, ARpt, HSType,
468           DaysBack, ExamID, aComponents, Alpha, Omega]);
469         if Piece(ErrMsg, U, 1) = '0' then ErrMsg := '' else ErrMsg := Piece(ErrMsg, U, 2);
470       end;
471     aHandles.Clear;
472     aHandles.Free;
473   end;
474   
475   function GetFormattedReport(AReport: string; const Qualifier, Patient: string;
476            aComponents: TStringlist; ARemoteSiteID, ARemoteQuery, AHSTag: string): TStrings;
477   { prints a report on the selected device }
478   var
479     HSType, DaysBack, ExamID, MaxOcc, ARpt, x: string;
480     Alpha, Omega: double;
481     j: integer;
482     RemoteHandle,Report: string;
483     aHandles: TStringlist;
484   begin
485     HSType := '';
486     DaysBack := '';
487     ExamID := '';
488     Alpha := 0;
489     Omega := 0;
490     aHandles := TStringList.Create;
491     if CharAt(Qualifier, 1) = 'T' then
492       begin
493         Alpha := StrToFMDateTime(Piece(Qualifier,';',1));
494         Omega := StrToFMDateTime(Piece(Qualifier,';',2));
495         MaxOcc := Piece(Qualifier,';',3);
496         SetPiece(AHSTag,';',4,MaxOcc);
497       end;
498     if CharAt(Qualifier, 1) = 'd' then
499       begin
500         MaxOcc := Piece(Qualifier,';',2);
501         SetPiece(AHSTag,';',4,MaxOcc);
502         x := Piece(Qualifier,';',1);
503         DaysBack := Copy(x, 2, Length(x));
504       end;
505     if CharAt(Qualifier, 1) = 'h' then HSType   := Copy(Qualifier, 2, Length(Qualifier));
506     if CharAt(Qualifier, 1) = 'i' then ExamID   := Copy(Qualifier, 2, Length(Qualifier));
507     if Length(ARemoteSiteID) > 0 then
508       begin
509         RemoteHandle := '';
510         for j := 0 to RemoteReports.Count - 1 do
511           begin
512             Report := TRemoteReport(RemoteReports.ReportList.Items[j]).Report;
513             if Report = ARemoteQuery then
514               begin
515                 RemoteHandle := TRemoteReport(RemoteReports.ReportList.Items[j]).Handle
516                   + '^' + Pieces(Report,'^',9,10);
517                 break;
518               end;
519           end;
520         if Length(RemoteHandle) > 1 then
521           with RemoteSites.SiteList do
522               aHandles.Add(ARemoteSiteID + '^' + RemoteHandle);
523       end;
524     ARpt := AReport + '~' + AHSTag;
525     if aHandles.Count > 0 then
526       begin
527         CallV('ORWRP PRINT WINDOWS REMOTE',[Patient, ARpt, aHandles]);
528         Result := RPCBrokerV.Results;
529       end
530     else
531       begin
532         CallV('ORWRP PRINT WINDOWS REPORT',[Patient, ARpt, HSType,
533           DaysBack, ExamID, aComponents, Alpha, Omega]);
534         Result := RPCBrokerV.Results;
535       end;
536     aHandles.Clear;
537     aHandles.Free;
538   end;
539   
540   function DefaultToWindowsPrinter: Boolean;
541   begin
542     Result := (StrToIntDef(sCallV('ORWRP WINPRINT DEFAULT',[]), 0) > 0);
543   end;
544   
545   procedure PrintWindowsReport(ARichEdit: TRichEdit; APageBreak, Atitle: string; var ErrMsg: string; IncludeHeader: Boolean = false);
546   var
547     i, j, x, y, LineHeight: integer;
548     aGoHead: string;
549     aHeader: TStringList;
550   const
551     TX_ERR_CAP = 'Print Error';
552     TX_FONT_SIZE = 10;
553     TX_FONT_NAME = 'Courier New';
554   begin
555     aHeader := TStringList.Create;
556     aGoHead := '';
557     if piece(Atitle,';',2) = '1' then
558       begin
559         Atitle := piece(Atitle,';',1);
560         aGoHead := '1';
561       end;
562     CreatePatientHeader(aHeader ,ATitle);
563     with ARichEdit do
564       begin
565   (*      if Lines[Lines.Count - 1] = APageBreak then      //  remove trailing form feed
566           Lines.Delete(Lines.Count - 1);
567         while (Lines[0] = '') or (Lines[0] = APageBreak) do
568           Lines.Delete(0);                               //  remove leading blank lines and form feeds*)
569   
570           {v20.4 - SFC-0602-62899 - RV}
571           while (Lines.Count > 0) and ((Lines[Lines.Count - 1] = '') or (Lines[Lines.Count - 1] = APageBreak)) do
572             Lines.Delete(Lines.Count - 1);                 //  remove trailing blank lines and form feeds
573           while (Lines.Count > 0) and ((Lines[0] = '') or (Lines[0] = APageBreak)) do
574             Lines.Delete(0);                               //  remove leading blank lines and form feeds
575   
576         if Lines.Count > 1 then
577           begin
578   (*          i := Lines.IndexOf(APageBreak);
579             if ((i >= 0 ) and (i < Lines.Count - 1)) then        // removed in v15.9 (RV)
580               begin*)
581                 Printer.Canvas.Font.Size := TX_FONT_SIZE;
582                 Printer.Canvas.Font.Name := TX_FONT_NAME;
583                 Printer.Title := ATitle;
584                 x := Trunc(Printer.Canvas.TextWidth(StringOfChar('=', TX_FONT_SIZE)) * 0.75);
585                 LineHeight := Printer.Canvas.TextHeight(TX_FONT_NAME);
586                 y := LineHeight * 5;            // 5 lines = .83" top margin   v15.9 (RV)
587                 Printer.BeginDoc;
588   
589                 //Do we need to add the header?
590                 IF IncludeHeader then begin
591                  for j := 0 to aHeader.Count - 1 do
592                   begin
593                    Printer.Canvas.TextOut(x, y, aHeader[j]);
594                    y := y + LineHeight;
595                   end;
596                 end;
597   
598                 for i := 0 to Lines.Count - 1 do
599                   begin
600                     if Lines[i] = APageBreak then
601                       begin
602                         Printer.NewPage;
603                         y := LineHeight * 5;   // 5 lines = .83" top margin    v15.9 (RV)
604                         if (IncludeHeader) then
605                           begin
606                             for j := 0 to aHeader.Count - 1 do
607                               begin
608                                 Printer.Canvas.TextOut(x, y, aHeader[j]);
609                                 y := y + LineHeight;
610                               end;
611                           end;
612                       end
613                     else
614                       begin
615                         Printer.Canvas.TextOut(x, y, Lines[i]);
616                         y := y + LineHeight;
617                       end;
618                   end;
619                 Printer.EndDoc;
620   (*            end
621             else                               // removed in v15.9 (RV)  TRichEdit.Print no longer used.
622               try
623                 Font.Size := TX_FONT_SIZE;
624                 Font.Name := TX_FONT_NAME;
625                 Print(ATitle);
626               except
627                 ErrMsg := TX_ERR_CAP;
628               end;*)
629           end
630         else if ARichEdit.Lines.Count = 1 then
631           if Piece(ARichEdit.Lines[0], U, 1) <> '0' then
632             ErrMsg := Piece(ARichEdit.Lines[0], U, 2);
633       end;
634     aHeader.Free;
635   end;
636   
637   procedure CreatePatientHeader(var HeaderList: TStringList; PageTitle: string);
638   // standard patient header, from HEAD^ORWRPP
639   var
640     tmpStr, tmpItem: string;
641   begin
642     with HeaderList do
643       begin
644         Add(' ');
645         Add(StringOfChar(' ', (74 - Length(PageTitle)) div 2) + PageTitle);
646         Add(' ');
647         tmpStr := Patient.Name + '   ' + Patient.SSN;
648         tmpItem := tmpStr + StringOfChar(' ', 39 - Length(tmpStr)) + Encounter.LocationName;
649         tmpStr := FormatFMDateTime('mmm dd, yyyy', Patient.DOB) + ' (' + IntToStr(Patient.Age) + ')';
650         tmpItem := tmpItem + StringOfChar(' ', 74 - (Length(tmpItem) + Length(tmpStr))) + tmpStr;
651         Add(tmpItem);
652         Add(StringOfChar('=', 74));
653         Add('*** WORK COPY ONLY ***' + StringOfChar(' ', 24) + 'Printed: ' + FormatFMDateTime('mmm dd, yyyy  hh:nn', FMNow));
654         Add(' ');
655         Add(' ');
656       end;
657   end;
658   
659   procedure PrintGraph(GraphImage: TChart; PageTitle: string);
660   var
661     AHeader: TStringList;
662     i, y, LineHeight: integer;
663     GraphPic: TBitMap;
664     Magnif: integer;
665   const
666     TX_FONT_SIZE = 12;
667     TX_FONT_NAME = 'Courier New';
668     CF_BITMAP = 2;      // from Windows.pas
669   begin
670     ClipBoard;
671     AHeader := TStringList.Create;
672     CreatePatientHeader(AHeader, PageTitle);
673     GraphPic := TBitMap.Create;
674     try
675       GraphImage.CopyToClipboardBitMap;
676       GraphPic.LoadFromClipBoardFormat(CF_BITMAP, ClipBoard.GetAsHandle(CF_BITMAP), 0);
677       with Printer do
678         begin
679           Canvas.Font.Size := TX_FONT_SIZE;
680           Canvas.Font.Name := TX_FONT_NAME;
681           Title := PageTitle;
682           Magnif := (Canvas.TextWidth(StringOfChar('=', 74)) div GraphImage.Width);
683           LineHeight := Printer.Canvas.TextHeight(TX_FONT_NAME);
684           y := LineHeight;
685           BeginDoc;
686           try
687             for i := 0 to AHeader.Count - 1 do
688               begin
689                 Canvas.TextOut(0, y, AHeader[i]);
690                 y := y + LineHeight;
691               end;
692             y := y + (4 * LineHeight);
693             //GraphImage.PrintPartial(Rect(0, y, Canvas.TextWidth(StringOfChar('=', 74)), y + (Magnif * GraphImage.Height)));
694             PrintBitmap(Canvas, Rect(0, y, Canvas.TextWidth(StringOfChar('=', 74)), y + (Magnif * GraphImage.Height)), GraphPic);
695           finally
696             EndDoc;
697           end;
698         end;
699     finally
700       ClipBoard.Clear;
701       GraphPic.Free;
702       AHeader.Free;
703     end;
704   end;
705   
706   procedure SaveDefaultPrinter(DefPrinter: string) ;
707   begin
708     CallV('ORWRP SAVE DEFAULT PRINTER', [DefPrinter]);
709   end;
710   
711   function HSFileLookup(aFile: String; const StartFrom: string;
712             Direction:Integer): TStrings;
713   begin
714     CallV('ORWRP2 HS FILE LOOKUP', [aFile, StartFrom, Direction]);
715     MixedCaseList(RPCBrokerV.Results);
716     Result := RPCBrokerV.Results;
717   end;
718   
719   procedure HSComponentFiles(Dest: TStrings; aComponent: String);
720   begin
721     CallV('ORWRP2 HS COMP FILES', [aComponent]);
722     QuickCopy(RPCBrokerV.Results,Dest);
723   end;
724   
725   procedure HSSubItems(Dest: TStrings; aItem: String);
726   begin
727     CallV('ORWRP2 HS SUBITEMS', [aItem]);
728     MixedCaseList(RPCBrokerV.Results);
729     QuickCopy(RPCBrokerV.Results,Dest);
730   end;
731   
732   procedure HSReportText(Dest: TStrings; aComponents: TStringlist);
733   begin
734     CallV('ORWRP2 HS REPORT TEXT', [aComponents, Patient.DFN]);
735     QuickCopy(RPCBrokerV.Results,Dest);
736   end;
737   
738   procedure HSComponents(Dest: TStrings);
739   begin
740     CallV('ORWRP2 HS COMPONENTS', [nil]);
741     QuickCopy(RPCBrokerV.Results,Dest);
742   end;
743   
744   procedure HSABVComponents(Dest: TStrings);
745   begin
746     CallV('ORWRP2 COMPABV', [nil]);
747     QuickCopy(RPCBrokerV.Results,Dest);
748   end;
749   
750   procedure HSDispComponents(Dest: TStrings);
751   begin
752     CallV('ORWRP2 COMPDISP', [nil]);
753     QuickCopy(RPCBrokerV.Results,Dest);
754   end;
755   
756   procedure HSComponentSubs(Dest: TStrings; aItem: String);
757   begin
758     CallV('ORWRP2 HS COMPONENT SUBS',[aItem]);
759     MixedCaseList(RPCBrokerV.Results);
760     QuickCopy(RPCBrokerV.Results,Dest);
761   end;
762   
763   function GetRemoteStatus(aHandle: string): String;
764   begin
765     CallV('XWB REMOTE STATUS CHECK', [aHandle]);
766     Result := RPCBrokerV.Results[0];
767   end;
768   
769   function GetAdhocLookup: integer;
770   begin
771     CallV('ORWRP2 GETLKUP', [nil]);
772     if RPCBrokerV.Results.Count > 0 then
773       Result := StrToInt(RPCBrokerV.Results[0])
774     else
775       Result := 0;
776   end;
777   
778   procedure SetAdhocLookup(aLookup: integer);
779   
780   begin
781     CallV('ORWRP2 SAVLKUP', [IntToStr(aLookup)]);
782   end;
783   
784   procedure GetRemoteData(Dest: TStrings; aHandle: string; aItem: PChar);
785   begin
786     CallV('XWB REMOTE GETDATA', [aHandle]);
787     if RPCBrokerV.Results.Count < 1 then
788       RPCBrokerV.Results[0] := 'No data found.';
789     if (RPCBrokerV.Results.Count < 2) and (RPCBrokerV.Results[0] = '') then
790       RPCBrokerV.Results[0] := 'No data found.';
791     QuickCopy(RPCBrokerV.Results,Dest);
792   end;
793   
794   procedure ModifyHDRData(Dest: string; aHandle: string; aID: string);
795   begin
796     CallV('ORWRP4 HDR MODIFY', [aHandle, aID]);
797   end;
798   
799   procedure PrintBitmap(Canvas:  TCanvas; DestRect:  TRect;  Bitmap:  TBitmap);
800   var
801     BitmapHeader:  pBitmapInfo;
802     BitmapImage :  POINTER;
803     HeaderSize  :  DWORD;    // Use DWORD for D3-D5 compatibility
804     ImageSize   :  DWORD;
805   begin
806     GetDIBSizes(Bitmap.Handle, HeaderSize, ImageSize);
807     GetMem(BitmapHeader, HeaderSize);
808     GetMem(BitmapImage,  ImageSize);
809     try
810       GetDIB(Bitmap.Handle, Bitmap.Palette, BitmapHeader^, BitmapImage^);
811       StretchDIBits(Canvas.Handle,
812                     DestRect.Left, DestRect.Top,     // Destination Origin
813                     DestRect.Right  - DestRect.Left, // Destination Width
814                     DestRect.Bottom - DestRect.Top,  // Destination Height
815                     0, 0,                            // Source Origin
816                     Bitmap.Width, Bitmap.Height,     // Source Width & Height
817                     BitmapImage,
818                     TBitmapInfo(BitmapHeader^),
819                     DIB_RGB_COLORS,
820                     SRCCOPY)
821     finally
822       FreeMem(BitmapHeader);
823       FreeMem(BitmapImage)
824     end
825   end {PrintBitmap};
826   
827   initialization
828     { nothing to initialize }
829   
830   finalization
831     uTree.Free;
832     uReportsList.Free;
833     uLabReports.Free;
834     uDateRanges.Free;
835     uHSTypes.Free;
836   
837   end.

Module Calls (2 levels)


rReports
 ├uCore
 │ ├rCore
 │ ├uConst
 │ ├uCombatVet
 │ ├rTIU
 │ ├rOrders
 │ ├rConsults
 │ └uOrders
 ├rCore...
 └uReports

Module Called-By (2 levels)


                   rReports
                   fFrame┤ 
              CPRSChart┤ │ 
                  fPage┤ │ 
                uOrders┤ │ 
                fODBase┤ │ 
                UBACore┤ │ 
                fOrders┤ │ 
                   uPCE┤ │ 
      fBALocalDiagnoses┤ │ 
             fEncVitals┤ │ 
                fVitals┤ │ 
                 fCover┤ │ 
                 rCover┤ │ 
              fPtSelMsg┤ │ 
                 fPtSel┤ │ 
            fOrdersSign┤ │ 
         fPrintLocation┤ │ 
                  fMeds┤ │ 
                fRptBox┤ │ 
                 fNotes┤ │ 
               fReports┤ │ 
                 fEncnt┤ │ 
                 fProbs┤ │ 
          fReportsPrint┤ │ 
                fGraphs┤ │ 
              fConsults┤ │ 
                fDCSumm┤ │ 
        fReminderDialog┤ │ 
                  fLabs┤ │ 
              fLabPrint┤ │ 
                fReview┤ │ 
            fIconLegend┤ │ 
           fOrdersPrint┤ │ 
               fSurgery┤ │ 
uVA508CPRSCompatibility┤ │ 
           fOrdersRenew┤ │ 
             fODConsult┤ │ 
                fODProc┤ │ 
                 fODRad┤ │ 
                 fODLab┤ │ 
                fODMeds┤ │ 
               fODMedIV┤ │ 
              fODVitals┤ │ 
                fODAuto┤ │ 
                 fOMSet┤ │ 
         fOrdersRelease┤ │ 
              fODMedNVA┤ │ 
         fOrdersOnChart┤ │ 
             fOCSession┤ │ 
              fODActive┤ │ 
               fPCEEdit┘ │ 
               fVitals...┤ 
               fRptBox...┤ 
           fConsult513Prt┤ 
           fConsults...┘ │ 
              fReports...┤ 
         fReportsPrint...┤ 
  fReportsAdhocComponent1┤ 
            fReports...┤ │ 
  fReportsAdhocSubItem1┘ │ 
 fReportsAdhocSubItem1...┤ 
            fDeviceSelect┤ 
              fFrame...┤ │ 
             uReminders┤ │ 
        fOrdersPrint...┘ │ 
                 fLabs...┤ 
             fLabPrint...┤ 
                  fPtDemo┤ 
              fFrame...┘ │ 
                 fNotePrt┤ 
              fNotes...┤ │ 
           fConsults...┤ │ 
             fDCSumm...┤ │ 
            fSurgery...┘ │ 
                  fPreReq┘ 
          fODConsult...┤   
             fODProc...┘