source: cprs/trunk/CPRS-Chart/fLabPrint.pas@ 908

Last change on this file since 908 was 830, checked in by Kevin Toppenberg, 14 years ago

Upgrading to version 27
File size: 19.9 KB
Line 
1unit fLabPrint;
2
3interface
4
5uses
6 Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
7 StdCtrls, ORCtrls, ORNet, Mask, ComCtrls, fBase508Form,
8 VA508AccessibilityManager;
9
10type
11 TfrmLabPrint = class(TfrmBase508Form)
12 lblLabTitle: TMemo;
13 lblPrintTo: TLabel;
14 grpDevice: TGroupBox;
15 lblMargin: TLabel;
16 lblLength: TLabel;
17 txtRightMargin: TMaskEdit;
18 txtPageLength: TMaskEdit;
19 cboDevice: TORComboBox;
20 cmdOK: TButton;
21 cmdCancel: TButton;
22 dlgWinPrinter: TPrintDialog;
23 chkDefault: TCheckBox;
24 procedure cboDeviceChange(Sender: TObject);
25 procedure cboDeviceNeedData(Sender: TObject; const StartFrom: String;
26 Direction, InsertAt: Integer);
27 procedure cmdOKClick(Sender: TObject);
28 procedure cmdCancelClick(Sender: TObject);
29 procedure FindVType;
30 private
31 { Private declarations }
32 FReports: String;
33 FDaysBack: Integer;
34 FReportText: TRichEdit;
35 procedure DisplaySelectDevice;
36 public
37 { Public declarations }
38 end;
39
40var
41 frmLabPrint: TfrmLabPrint;
42
43procedure PrintLabs(AReports: String; const ALabTitle: string; ADaysBack: Integer); //Lontint
44function StringPad(aString: string; aStringCount, aPadCount: integer): String;
45
46implementation
47
48{$R *.DFM}
49
50uses ORFn, rCore, uCore, fLabs, rLabs, Printers, rReports, fFrame, uReports;
51
52const
53 TX_NODEVICE = 'A device must be selected to print, or press ''Cancel'' to not print.';
54 TX_NODEVICE_CAP = 'Device Not Selected';
55 TX_ERR_CAP = 'Print Error';
56 PAGE_BREAK = '**PAGE BREAK**';
57 QT_OTHER = 0;
58 QT_HSTYPE = 1;
59 QT_DATERANGE = 2;
60 QT_IMAGING = 3;
61 QT_NUTR = 4;
62 QT_PROCEDURES = 19;
63 QT_SURGERY = 28;
64 QT_HSCOMPONENT = 5;
65 QT_HSWPCOMPONENT = 6;
66
67procedure PrintLabs(AReports: String; const ALabTitle: string; ADaysBack: Integer);
68{ displays a form that prompts for a device and then prints the report }
69var
70 frmLabPrint: TfrmLabPrint;
71 DefPrt: string;
72begin
73 frmLabPrint := TfrmLabPrint.Create(Application);
74 try
75 ResizeAnchoredFormToFont(frmLabPrint);
76 with frmLabPrint do
77 begin
78 lblLabTitle.Text := ALabTitle;
79 FReports := AReports;
80 FDaysBack := ADaysBack;
81 DefPrt := GetDefaultPrinter(User.Duz, Encounter.Location);
82 if User.CurrentPrinter = '' then User.CurrentPrinter := DefPrt;
83 with cboDevice do
84 begin
85 if Printer.Printers.Count > 0 then
86 begin
87 Items.Add('WIN;Windows Printer^Windows Printer');
88 Items.Add('^--------------------VistA Printers----------------------');
89 end;
90 if User.CurrentPrinter <> '' then
91 begin
92 InitLongList(Piece(User.CurrentPrinter, ';', 2));
93 SelectByID(User.CurrentPrinter);
94 end
95 else
96 InitLongList('');
97 end;
98 if (DefPrt = 'WIN;Windows Printer') and
99 (User.CurrentPrinter = DefPrt) then
100 cmdOKClick(frmLabPrint)
101 else
102 ShowModal;
103 end;
104 finally
105 frmLabPrint.Release;
106 end;
107end;
108
109procedure TfrmLabPrint.DisplaySelectDevice;
110begin
111 with cboDevice, lblPrintTo do
112 begin
113 Caption := 'Print Report on: ' + Piece(ItemID, ';', 2);
114 end;
115end;
116
117procedure TfrmLabPrint.cboDeviceChange(Sender: TObject);
118begin
119 inherited;
120 with cboDevice do if ItemIndex > -1 then
121 begin
122 txtRightMargin.Text := Piece(Items[ItemIndex], '^', 4);
123 txtPageLength.Text := Piece(Items[ItemIndex], '^', 5);
124 DisplaySelectDevice;
125 end;
126end;
127
128procedure TfrmLabPrint.cboDeviceNeedData(Sender: TObject;
129 const StartFrom: String; Direction, InsertAt: Integer);
130begin
131inherited;
132 cboDevice.ForDataUse(SubsetOfDevices(StartFrom, Direction));
133end;
134
135function StringPad(aString: string; aStringCount, aPadCount: integer): String;
136var
137 s: integer;
138begin
139 if aStringCount >= aPadCount then
140 aStringCount := aPadCount - 1;
141 Result := copy(aString, 1, aStringCount);
142 s := aPadCount - length(Result);
143 if s < 0 then s := 0;
144 Result := Result + StringOfChar(' ', s);
145end;
146
147procedure TfrmLabPrint.cmdOKClick(Sender: TObject);
148var
149 ADevice, ErrMsg: string;
150 daysback: integer;
151 date1, date2: TFMDateTime;
152 today: TDateTime;
153 RemoteSiteID: string; //for Remote site printing
154 RemoteQuery: string; //for Remote site printing
155 ListItem: TListItem;
156 aReport: TStringList;
157 aQualifier: string;
158 i: integer;
159 MoreID: String; //Restores MaxOcc value
160 aCaption: string;
161begin
162 inherited;
163 FReportText := CreateReportTextComponent(Self);
164 RemoteSiteID := '';
165 RemoteQuery := '';
166 MoreID := '';
167 aReport := TStringList.Create;
168 if uQualifier = '' then
169 aQualifier := piece(uRemoteType,'^',5) //Health Summary Type Report
170 else
171 begin
172 MoreID := ';' + Piece(uQualifier,';',3);
173 aQualifier := piece(uRemoteType,'^',5);
174 end;
175 with frmLabs.TabControl1 do
176 if TabIndex > 0 then
177 begin
178 RemoteSiteID := TRemoteSite(Tabs.Objects[TabIndex]).SiteID;
179 RemoteQuery := TRemoteSite(Tabs.Objects[TabIndex]).CurrentLabQuery;
180 end;
181 if cboDevice.ItemID = '' then
182 begin
183 InfoBox(TX_NODEVICE, TX_NODEVICE_CAP, MB_OK);
184 Exit;
185 end;
186 today := frmLabs.FMToDateTime(floattostr(FMToday));
187 if frmLabs.lstDates.ItemIEN > 0 then
188 begin
189 daysback := frmLabs.lstDates.ItemIEN;
190 date1 := FMToday;
191 If daysback = 1 then
192 date2 := DateTimeToFMDateTime(today)
193 Else
194 date2 := DateTimeToFMDateTime(today - daysback);
195 end
196 else
197 frmLabs.BeginEndDates(date1,date2,daysback);
198 date1 := date1 + 0.2359;
199 if Piece(cboDevice.ItemID, ';', 1) = 'WIN' then
200 begin
201 if dlgWinPrinter.Execute then with FReportText do
202 begin
203 if uReportType = 'V' then
204 begin
205 case uQualifierType of
206 QT_IMAGING:
207 begin
208 for i := 0 to frmLabs.lvReports.Items.Count - 1 do
209 if frmLabs.lvReports.Items[i].Selected then
210 begin
211 ListItem := frmLabs.lvReports.Items[i];
212 aQualifier := ListItem.SubItems[0];
213 ADevice := Piece(cboDevice.ItemID, ';', 2);
214 QuickCopy(GetFormattedReport(FReports, aQualifier,
215 Patient.DFN, nil , RemoteSiteID, RemoteQuery, uHState), FReportText);
216 aCaption := piece(uRemoteType,'^',4); //nil used to be uHSComponents
217 PrintWindowsReport(FReportText, PAGE_BREAK, aCaption, ErrMsg);
218 if Length(ErrMsg) > 0 then InfoBox(ErrMsg, TX_ERR_CAP, MB_OK);
219 end;
220 end;
221 QT_NUTR:
222 begin
223 for i := 0 to frmLabs.lvReports.Items.Count - 1 do
224 if frmLabs.lvReports.Items[i].Selected then
225 begin
226 ListItem := frmLabs.lvReports.Items[i];
227 aQualifier := ListItem.SubItems[0];
228 ADevice := Piece(cboDevice.ItemID, ';', 2);
229 QuickCopy(GetFormattedReport(FReports, aQualifier + MoreID,
230 Patient.DFN, nil, RemoteSiteID, RemoteQuery, uHState), FReportText);
231 aCaption := piece(uRemoteType,'^',4);
232 PrintWindowsReport(FReportText, PAGE_BREAK, aCaption, ErrMsg);
233 if Length(ErrMsg) > 0 then InfoBox(ErrMsg, TX_ERR_CAP, MB_OK);
234 end;
235 end;
236 QT_HSCOMPONENT:
237 begin
238 if (length(piece(uHState,';',2)) > 0) then
239 begin
240 FReportText.Clear;
241 aReport.Clear;
242 CreatePatientHeader(aReport,piece(uRemoteType,'^',4));
243 QuickCopy(aReport, FReportText);
244 FindVType;
245 aCaption := piece(uRemoteType,'^',4) + ';1';
246 PrintWindowsReport(FReportText, PAGE_BREAK, aCaption, ErrMsg);
247 if Length(ErrMsg) > 0 then InfoBox(ErrMsg, TX_ERR_CAP, MB_OK);
248 end
249 else
250 begin
251 QuickCopy(GetFormattedReport(FReports, aQualifier + MoreID,
252 Patient.DFN, nil, RemoteSiteID, RemoteQuery, uHState), FReportText);
253 aCaption := piece(uRemoteType,'^',4);
254 PrintWindowsReport(FReportText, PAGE_BREAK, aCaption, ErrMsg);
255 if Length(ErrMsg) > 0 then InfoBox(ErrMsg, TX_ERR_CAP, MB_OK);
256 end;
257 end;
258 QT_HSWPCOMPONENT:
259 begin
260 if (length(piece(uHState,';',2)) > 0) then
261 begin
262 FReportText.Clear;
263 aReport.Clear;
264 CreatePatientHeader(aReport,piece(uRemoteType,'^',4));
265 QuickCopy(aReport, FReportText);
266 FindVType;
267 aCaption := piece(uRemoteType,'^',4) + ';1';
268 PrintWindowsReport(FReportText, PAGE_BREAK, aCaption, ErrMsg);
269 if Length(ErrMsg) > 0 then InfoBox(ErrMsg, TX_ERR_CAP, MB_OK);
270 end
271 else
272 begin
273 QuickCopy(GetFormattedReport(FReports, aQualifier + MoreID,
274 Patient.DFN, nil, RemoteSiteID, RemoteQuery, uHState), FReportText);
275 aCaption := piece(uRemoteType,'^',4);
276 PrintWindowsReport(FReportText, PAGE_BREAK, aCaption, ErrMsg);
277 if Length(ErrMsg) > 0 then InfoBox(ErrMsg, TX_ERR_CAP, MB_OK);
278 end;
279 end;
280 QT_PROCEDURES:
281 begin
282 for i := 0 to frmLabs.lvReports.Items.Count - 1 do
283 if frmLabs.lvReports.Items[i].Selected then
284 begin
285 ListItem := frmLabs.lvReports.Items[i];
286 aQualifier := ListItem.SubItems[0];
287 ADevice := Piece(cboDevice.ItemID, ';', 2);
288 QuickCopy(GetFormattedReport(FReports, aQualifier,
289 Patient.DFN, nil, RemoteSiteID, RemoteQuery, uHState), FReportText);
290 aCaption := piece(uRemoteType,'^',4);
291 PrintWindowsReport(FReportText, PAGE_BREAK, aCaption, ErrMsg);
292 if Length(ErrMsg) > 0 then InfoBox(ErrMsg, TX_ERR_CAP, MB_OK);
293 end;
294 end;
295 QT_SURGERY:
296 begin
297 for i := 0 to frmLabs.lvReports.Items.Count - 1 do
298 if frmLabs.lvReports.Items[i].Selected then
299 begin
300 ListItem := frmLabs.lvReports.Items[i];
301 aQualifier := ListItem.SubItems[0];
302 ADevice := Piece(cboDevice.ItemID, ';', 2);
303 QuickCopy(GetFormattedReport(FReports, aQualifier,
304 Patient.DFN, nil, RemoteSiteID, RemoteQuery, uHState), FReportText);
305 aCaption := piece(uRemoteType,'^',4);
306 PrintWindowsReport(FReportText, PAGE_BREAK, aCaption, ErrMsg);
307 if Length(ErrMsg) > 0 then InfoBox(ErrMsg, TX_ERR_CAP, MB_OK);
308 end;
309 end;
310 end;
311 end
312 else
313 begin
314 QuickCopy(GetFormattedLabReport(FReports, FDaysBack, Patient.DFN,
315 frmLabs.lstTests.Items, date1, date2, RemoteSiteID, RemoteQuery), FReportText);
316 PrintWindowsReport(FReportText, PAGE_BREAK, Self.Caption, ErrMsg);
317 if Length(ErrMsg) > 0 then InfoBox(ErrMsg, TX_ERR_CAP, MB_OK);
318 end;
319 end;
320 end
321 else // if it's not a Win printer
322 begin
323 if uReportType = 'V' then
324 begin
325 case uQualifierType of
326 QT_HSCOMPONENT:
327 begin
328 if (length(piece(uHState,';',2)) > 0) then
329 begin
330 FindVType;
331 aReport.Clear;
332 QuickCopy(FReportText.Lines, aReport);
333 ADevice := Piece(cboDevice.ItemID, ';', 2);
334 PrintVReports(ErrMsg, ADevice, piece(uRemoteType,'^',4),aReport);
335 if Length(ErrMsg) > 0 then InfoBox(ErrMsg, TX_ERR_CAP, MB_OK);
336 end
337 else
338 begin
339 ADevice := Piece(cboDevice.ItemID, ';', 2);
340 PrintReportsToDevice(FReports, aQualifier + MoreID,
341 Patient.DFN, ADevice, ErrMsg, nil, RemoteSiteID, RemoteQuery, uHState);
342 ErrMsg := Piece(FReportText.Lines[0], U, 2);
343 if Length(ErrMsg) > 0 then InfoBox(ErrMsg, TX_ERR_CAP, MB_OK);
344 end;
345 end;
346 QT_HSWPCOMPONENT:
347 begin
348 if (length(piece(uHState,';',2)) > 0) then
349 begin
350 FindVType;
351 aReport.Clear;
352 QuickCopy(FReportText, aReport);
353 ADevice := Piece(cboDevice.ItemID, ';', 2);
354 PrintVReports(ErrMsg, ADevice, piece(uRemoteType,'^',4),aReport);
355 if Length(ErrMsg) > 0 then InfoBox(ErrMsg, TX_ERR_CAP, MB_OK);
356 end
357 else
358 begin
359 ADevice := Piece(cboDevice.ItemID, ';', 2);
360 PrintReportsToDevice(FReports, aQualifier + MoreID,
361 Patient.DFN, ADevice, ErrMsg, nil, RemoteSiteID, RemoteQuery, uHState);
362 ErrMsg := Piece(FReportText.Lines[0], U, 2);
363 if Length(ErrMsg) > 0 then InfoBox(ErrMsg, TX_ERR_CAP, MB_OK);
364 end;
365 end;
366 end;
367 end
368 else
369 begin
370 ADevice := Piece(cboDevice.ItemID, ';', 2);
371 PrintLabsToDevice(FReports, FDaysBack, Patient.DFN, ADevice,
372 frmLabs.lstTests.Items, ErrMsg, date1, date2, RemoteSiteID, RemoteQuery);
373 ErrMsg := Piece(FReportText.Lines[0], U, 2);
374 if Length(ErrMsg) > 0 then InfoBox(ErrMsg, TX_ERR_CAP, MB_OK);
375 end;
376 end;
377 if chkDefault.Checked then SaveDefaultPrinter(Piece(cboDevice.ItemID, ';', 1));
378 User.CurrentPrinter := cboDevice.ItemID;
379 aReport.Free;
380 FReportText.Free;
381 Close;
382end;
383procedure TfrmLabPrint.FindVType;
384var
385 i,j,k,L,cnt: integer;
386 aBasket: TStringList;
387 aID, aHead, aData, aCol, x: string;
388 ListItem: TListItem;
389 aWPFlag: Boolean;
390begin
391 aBasket := TStringList.Create;
392 aBasket.Clear;
393 //frmReports.MemText.Clear;
394 aHead := '';
395 cnt := 2;
396 //aWPFlag := false;
397 for i := 0 to uColumns.Count - 1 do
398 begin
399 if (piece(uColumns[i],'^',7) = '1') and (not(piece(uColumns[i],'^',4) = '1')) then
400 begin
401 L := StrToIntDef(piece(uColumns[i],'^',6),15);
402 if length(piece(uColumns[i],'^',8)) > 0 then
403 x := piece(uColumns[i],'^',8)
404 else
405 x := piece(uColumns[i],'^',1);
406 x := StringPad(x, L, L+1);
407 if frmLabs.TabControl1.Tabs.Count > 1 then
408 aHead := aHead + x
409 else
410 if i = 0 then
411 continue
412 else
413 aHead := aHead + x;
414 end;
415 end;
416 if length(aHead) > 0 then
417 begin
418 FReportText.Lines.Add(aHead);
419 FReportText.Lines.Add('-------------------------------------------------------------------------------');
420 //frmReports.memText.Lines.Add(aHead);
421 //frmReports.MemText.Lines.Add('-------------------------------------------------------------------------------');
422 end;
423 for i := 0 to frmLabs.lvReports.Items.Count - 1 do
424 if frmLabs.lvReports.Items[i].Selected then
425 begin
426 aData := '';
427 aWPFlag := false;
428 ListItem := frmLabs.lvReports.Items[i];
429 aID := ListItem.SubItems[0];
430 if frmLabs.TabControl1.Tabs.Count > 1 then
431 begin
432 L := StrToIntDef(piece(uColumns[0],'^',6),10);
433 x := StringPad(ListItem.Caption, L, L+1);
434 aData := x;
435 end;
436 for j := 0 to RowObjects.ColumnList.Count - 1 do
437 begin
438 aCol := TCellObject(RowObjects.ColumnList[j]).Handle;
439 if piece(aID,':',1) = piece(TCellObject(RowObjects.ColumnList[j]).Handle,':',1) then
440 if ListItem.Caption = (piece(TCellObject(RowObjects.ColumnList[j]).Site,';',1)) then
441 begin
442 if (piece(uColumns[StrToInt(piece(aCol,':',2))],'^',7) = '1') and
443 (not (piece(uColumns[StrToInt(piece(aCol,':',2))],'^',4) = '1')) then
444 begin
445 FastAssign(TCellObject(RowObjects.ColumnList[j]).Data, aBasket);
446 for k := 0 to aBasket.Count - 1 do
447 begin
448 L := StrToIntDef(piece(uColumns[StrToInt(piece(aCol,':',2))],'^',6),15);
449 x := StringPad(aBasket[k], L, L+1);
450 aData := aData + x;
451 end;
452 end;
453 end;
454 end;
455 //frmReports.memText.Lines.Add(aData);
456 FReportText.Lines.Add(aData);
457 cnt := cnt + 1;
458 if cnt > 40 then
459 begin
460 cnt := 0;
461 //frmReports.memText.Lines.Add('**PAGE BREAK**');
462 FReportText.Lines.Add('**PAGE BREAK**');
463 end;
464 for j := 0 to RowObjects.ColumnList.Count - 1 do
465 begin
466 aCol := TCellObject(RowObjects.ColumnList[j]).Handle;
467 if piece(aID,':',1) = piece(TCellObject(RowObjects.ColumnList[j]).Handle,':',1) then
468 if ListItem.Caption = (piece(TCellObject(RowObjects.ColumnList[j]).Site,';',1)) then
469 begin
470 if (piece(uColumns[StrToInt(piece(aCol,':',2))],'^',7) = '1') and
471 (piece(uColumns[StrToInt(piece(aCol,':',2))],'^',4) = '1') then
472 begin
473 aWPFlag := true;
474 FastAssign(TCellObject(RowObjects.ColumnList[j]).Data, aBasket);
475 //frmReports.MemText.Lines.Add(TCellObject(RowObjects.ColumnList[j]).Name);
476 FReportText.Lines.Add(TCellObject(RowObjects.ColumnList[j]).Name);
477 cnt := cnt + 1;
478 for k := 0 to aBasket.Count - 1 do
479 begin
480 //frmReports.memText.Lines.Add(' ' + aBasket[k]);
481 FReportText.Lines.Add(' ' + aBasket[k]);
482 cnt := cnt + 1;
483 if cnt > 40 then
484 begin
485 cnt := 0;
486 //frmReports.memText.Lines.Add('**PAGE BREAK**');
487 FReportText.Lines.Add('**PAGE BREAK**');
488 end;
489 end;
490 end;
491 end;
492 end;
493 if aWPFlag = true then
494 begin
495 //frmReports.MemText.Lines.Add('===============================================================================');
496 FReportText.Lines.Add('===============================================================================');
497 end;
498 end;
499 aBasket.Free;
500end;
501
502procedure TfrmLabPrint.cmdCancelClick(Sender: TObject);
503begin
504inherited;
505 Close;
506end;
507
508end.
Note: See TracBrowser for help on using the repository browser.