source: cprs/branches/tmg-cprs/CPRS-Chart/rReports.pas@ 498

Last change on this file since 498 was 453, checked in by Kevin Toppenberg, 16 years ago

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