Module

fLabPrint

Path

C:\CPRS\CPRS30\fLabPrint.pas

Last Modified

7/15/2014 3:26:38 PM

Units Used in Interface

Name Comments
fBase508Form -

Units Used in Implementation

Name Comments
fFrame -
fLabs -
rCore -
rLabs -
rReports -
uCore -
uReports -

Classes

Name Comments
TfrmLabPrint -

Procedures

Name Owner Declaration Scope Comments
cboDeviceChange TfrmLabPrint procedure cboDeviceChange(Sender: TObject); Public/Published -
cboDeviceNeedData TfrmLabPrint procedure cboDeviceNeedData(Sender: TObject; const StartFrom: String; Direction, InsertAt: Integer); Public/Published -
cmdCancelClick TfrmLabPrint procedure cmdCancelClick(Sender: TObject); Public/Published -
cmdOKClick TfrmLabPrint procedure cmdOKClick(Sender: TObject); Public/Published -
DisplaySelectDevice TfrmLabPrint procedure DisplaySelectDevice; Private -
FindVType TfrmLabPrint procedure FindVType; Public/Published -
PrintLabs - procedure PrintLabs(AReports: String; const ALabTitle: string; ADaysBack: Integer); Interfaced
Lontint
displays a form that prompts for a device and then prints the report

Functions

Name Owner Declaration Scope Comments
StringPad - function StringPad(aString: string; aStringCount, aPadCount: integer): String; Interfaced -

Global Variables

Name Type Declaration Comments
frmLabPrint TfrmLabPrint frmLabPrint: TfrmLabPrint; -

Constants

Name Declaration Scope Comments
PAGE_BREAK '**PAGE BREAK**' Global -
QT_DATERANGE 2 Global -
QT_HSCOMPONENT 5 Global -
QT_HSTYPE 1 Global -
QT_HSWPCOMPONENT 6 Global -
QT_IMAGING 3 Global -
QT_NUTR 4 Global -
QT_OTHER 0 Global -
QT_PROCEDURES 19 Global -
QT_SURGERY 28 Global -
TX_ERR_CAP 'Print Error' Global -
TX_NODEVICE 'A device must be selected to print, or press ''Cancel'' to not print.' Global -
TX_NODEVICE_CAP 'Device Not Selected' Global -


Module Source

1     unit fLabPrint;
2     
3     interface
4     
5     uses
6       Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
7       StdCtrls, ORCtrls, ORNet, Mask, ComCtrls, fBase508Form,
8       VA508AccessibilityManager;
9     
10    type
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    
40    var
41      frmLabPrint: TfrmLabPrint;
42    
43    procedure PrintLabs(AReports: String; const ALabTitle: string; ADaysBack: Integer);  //Lontint
44    function StringPad(aString: string; aStringCount, aPadCount: integer): String;
45    
46    implementation
47    
48    {$R *.DFM}
49    
50    uses ORFn, rCore, uCore, fLabs, rLabs, Printers, rReports, fFrame, uReports;
51    
52    const
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    
67    procedure PrintLabs(AReports: String; const ALabTitle: string; ADaysBack: Integer);
68    { displays a form that prompts for a device and then prints the report }
69    var
70      frmLabPrint: TfrmLabPrint;
71      DefPrt: string;
72    begin
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;
107   end;
108   
109   procedure TfrmLabPrint.DisplaySelectDevice;
110   begin
111     with cboDevice, lblPrintTo do
112     begin
113      Caption := 'Print Report on:  ' + Piece(ItemID, ';', 2);
114     end;
115   end;
116   
117   procedure TfrmLabPrint.cboDeviceChange(Sender: TObject);
118   begin
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;
126   end;
127   
128   procedure TfrmLabPrint.cboDeviceNeedData(Sender: TObject;
129     const StartFrom: String; Direction, InsertAt: Integer);
130   begin
131   inherited;
132     cboDevice.ForDataUse(SubsetOfDevices(StartFrom, Direction));
133   end;
134   
135   function StringPad(aString: string; aStringCount, aPadCount: integer): String;
136   var
137     s: integer;
138   begin
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);
145   end;
146   
147   procedure TfrmLabPrint.cmdOKClick(Sender: TObject);
148   var
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;
161   begin
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;
382   end;
383   procedure TfrmLabPrint.FindVType;
384   var
385     i,j,k,L,cnt: integer;
386     aBasket: TStringList;
387     aID, aHead, aData, aCol, x: string;
388     ListItem: TListItem;
389     aWPFlag: Boolean;
390   begin
391     aBasket := TStringList.Create;
392     aBasket.Clear;
393     aHead := '';
394     cnt := 2;
395     for i := 0 to uColumns.Count - 1 do
396       begin
397         if (piece(uColumns[i],'^',7) = '1') and (not(piece(uColumns[i],'^',4) = '1')) then
398           begin
399             L := StrToIntDef(piece(uColumns[i],'^',6),15);
400             if length(piece(uColumns[i],'^',8)) > 0 then
401               x := piece(uColumns[i],'^',8)
402             else
403               x := piece(uColumns[i],'^',1);
404             x := StringPad(x, L, L+1);
405             if frmLabs.TabControl1.Tabs.Count > 1  then
406               aHead := aHead + x
407             else
408               if i = 0 then
409                 continue
410               else
411                 aHead := aHead + x;
412           end;
413       end;
414     if length(aHead) > 0 then
415       begin
416         FReportText.Lines.Add(aHead);
417         FReportText.Lines.Add('-------------------------------------------------------------------------------');
418       end;
419     for i := 0 to frmLabs.lvReports.Items.Count - 1 do
420       if frmLabs.lvReports.Items[i].Selected then
421         begin
422           aData := '';
423           aWPFlag := false;
424           ListItem := frmLabs.lvReports.Items[i];
425           aID := ListItem.SubItems[0];
426          if frmLabs.TabControl1.Tabs.Count > 1 then
427             begin
428               L := StrToIntDef(piece(uColumns[0],'^',6),10);
429               x := StringPad(ListItem.Caption, L, L+1);
430               aData := x;
431             end;
432           for j := 0 to LabRowObjects.ColumnList.Count - 1 do
433             begin
434               aCol := TCellObject(LabRowObjects.ColumnList[j]).Handle;
435               if piece(aID,':',1) = piece(TCellObject(LabRowObjects.ColumnList[j]).Handle,':',1) then
436                 if ListItem.Caption = (piece(TCellObject(LabRowObjects.ColumnList[j]).Site,';',1)) then
437                   begin
438                     if (piece(uColumns[StrToInt(piece(aCol,':',2))],'^',7) = '1') and
439                      (not (piece(uColumns[StrToInt(piece(aCol,':',2))],'^',4) = '1')) then
440                       begin
441                         FastAssign(TCellObject(LabRowObjects.ColumnList[j]).Data, aBasket);
442                         for k := 0 to aBasket.Count - 1 do
443                           begin
444                             L := StrToIntDef(piece(uColumns[StrToInt(piece(aCol,':',2))],'^',6),15);
445                             x := StringPad(aBasket[k], L, L+1);
446                             aData := aData + x;
447                           end;
448                       end;
449                   end;
450             end;
451           FReportText.Lines.Add(aData);
452           cnt := cnt + 1;
453           if cnt > 40 then
454             begin
455               cnt := 0;
456               FReportText.Lines.Add('**PAGE BREAK**');
457             end;
458           for j := 0 to LabRowObjects.ColumnList.Count - 1 do
459             begin
460               aCol := TCellObject(LabRowObjects.ColumnList[j]).Handle;
461               if piece(aID,':',1) = piece(TCellObject(LabRowObjects.ColumnList[j]).Handle,':',1) then
462                 if ListItem.Caption = (piece(TCellObject(LabRowObjects.ColumnList[j]).Site,';',1)) then
463                   begin
464                     if (piece(uColumns[StrToInt(piece(aCol,':',2))],'^',7) = '1') and
465                        (piece(uColumns[StrToInt(piece(aCol,':',2))],'^',4) = '1') then
466                       begin
467                         aWPFlag := true;
468                         FastAssign(TCellObject(LabRowObjects.ColumnList[j]).Data, aBasket);
469                         FReportText.Lines.Add(TCellObject(LabRowObjects.ColumnList[j]).Name);
470                         cnt := cnt + 1;
471                         for k := 0 to aBasket.Count - 1 do
472                           begin
473                             FReportText.Lines.Add('' + aBasket[k]);
474                             cnt := cnt + 1;
475                             if cnt > 40 then
476                               begin
477                                 cnt := 0;
478                                 FReportText.Lines.Add('**PAGE BREAK**');
479                               end;
480                           end;
481                       end;
482                   end;
483             end;
484           if aWPFlag = true then
485             begin
486               FReportText.Lines.Add('===============================================================================');
487             end;
488         end;
489     aBasket.Free;
490   end;
491   
492   procedure TfrmLabPrint.cmdCancelClick(Sender: TObject);
493   begin
494   inherited;
495     Close;
496   end;
497   
498   end.

Module Calls (2 levels)


fLabPrint
 ├fBase508Form
 │ ├uConst
 │ └uHelpManager
 ├rCore
 │ └uCore
 ├uCore...
 ├fLabs
 │ ├fHSplit
 │ ├fLabTest
 │ ├fLabTests
 │ ├fLabTestGroups
 │ ├uConst
 │ ├fBase508Form...
 │ ├uCore...
 │ ├rLabs
 │ ├rCore...
 │ ├rOrders
 │ ├fLabPrint...
 │ ├fFrame
 │ ├fRptBox
 │ ├fReportsPrint
 │ ├rReports
 │ ├rGraphs
 │ └uReports
 ├rLabs...
 ├rReports...
 ├fFrame...
 └uReports

Module Called-By (2 levels)


                fLabPrint
                  fLabs┘ 
               fFrame┤   
             fLabTest┤   
            fLabTests┤   
       fLabTestGroups┤   
         fLabPrint...┤   
fOptionsReportsCustom┘