source: cprs/branches/HealthSevak-CPRS/CPRS-Chart/fPtDemo.pas@ 1703

Last change on this file since 1703 was 1693, checked in by healthsevak, 9 years ago

Committing the files for first time to this new branch

File size: 4.7 KB
RevLine 
[456]1unit fPtDemo;
2
3interface
4
5uses
6 Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
[830]7 StdCtrls, ExtCtrls, ORCtrls, ORFn, ComCtrls, fBase508Form,
8 VA508AccessibilityManager, uReports;
[456]9
10type
[830]11 TfrmPtDemo = class(TfrmBase508Form)
[456]12 lblFontTest: TLabel;
13 memPtDemo: TRichEdit;
14 pnlTop: TORAutoPanel;
15 cmdNewPt: TButton;
16 cmdClose: TButton;
17 cmdPrint: TButton;
18 dlgPrintReport: TPrintDialog;
19 procedure cmdCloseClick(Sender: TObject);
20 procedure cmdNewPtClick(Sender: TObject);
21 procedure FormCreate(Sender: TObject);
22 procedure cmdPrintClick(Sender: TObject);
23 private
24 { Private declarations }
25 FNewPt: Boolean;
26 public
27 { Public declarations }
28 end;
29
30procedure PatientInquiry(var NewPt: Boolean);
31
32implementation
33
34{$R *.DFM}
35
36uses rCover, rReports, Printers, uCore;
37
38procedure PatientInquiry(var NewPt: Boolean);
39{ displays patient demographics, returns true in NewPt if the user pressed 'Select New' btn }
40var
41 frmPtDemo: TfrmPtDemo;
42begin
43 if StrToInt64Def(Patient.DFN, 0) <= 0 then exit;
44 frmPtDemo := TfrmPtDemo.Create(Application);
45 try
46 with frmPtDemo do
47 begin
48 frmPtDemo.ShowModal;
49 NewPt := FNewPt;
50 end; {with frmPtDemo}
51 finally
52 frmPtDemo.Release;
53 end;
54end;
55
56procedure TfrmPtDemo.FormCreate(Sender: TObject);
57var
58 i, MaxWidth, AWidth, AHeight: Integer;
59 Rect: TRect;
60begin
61 FNewPt := False;
62 LoadDemographics(memPtDemo.Lines);
63 memPtDemo.SelStart := 0;
64 ResizeAnchoredFormToFont(self);
65 MaxWidth := 350; // make sure at least 350 wide
66 for i := 0 to memPtDemo.Lines.Count - 1 do
67 begin
68 AWidth := lblFontTest.Canvas.TextWidth(memPtDemo.Lines[i]);
69 if AWidth > MaxWidth then MaxWidth := AWidth;
70 end;
71 { width = borders + inset of memo box (left=8) }
72 MaxWidth := MaxWidth + (GetSystemMetrics(SM_CXFRAME) * 2)
73 + GetSystemMetrics(SM_CXVSCROLL) + 16;
74 { height = height of lines + title bar + borders + 4 lines (room for buttons) }
75 AHeight := ((memPtDemo.Lines.Count + 4) * (lblFontTest.Height + 1))
76 + (GetSystemMetrics(SM_CYFRAME) * 3) + GetSystemMetrics(SM_CYCAPTION);
77 AHeight := HigherOf(AHeight, 250); // make sure at least 250 high
78 if AHeight > (Screen.Height - 120) then AHeight := Screen.Height - 120;
79 if MaxWidth > Screen.Width then MaxWidth := Screen.Width;
80 Width := MaxWidth;
81 Height := AHeight;
[1693]82 Constraints.MinHeight := pnlTop.Height + GetSystemMetrics(SM_CYCAPTION) + GetSystemMetrics(SM_CYHSCROLL) + 7;
[456]83 Rect := BoundsRect;
84 ForceInsideWorkArea(Rect);
85 BoundsRect := Rect;
86end;
87
88procedure TfrmPtDemo.cmdNewPtClick(Sender: TObject);
89begin
90 FNewPt := True;
91 Close;
92end;
93
94procedure TfrmPtDemo.cmdCloseClick(Sender: TObject);
95begin
96 Close;
97end;
98
99procedure TfrmPtDemo.cmdPrintClick(Sender: TObject);
100var
101 AHeader: TStringList;
102 memPrintReport: TRichEdit;
103 StartLine, MaxLines, LastLine, ThisPage, i: integer;
104 ErrMsg: string;
105 RemoteSiteID: string; //for Remote site printing
106 RemoteQuery: string; //for Remote site printing
107const
108 PAGE_BREAK = '**PAGE BREAK**';
109begin
110 RemoteSiteID := '';
111 RemoteQuery := '';
112 if dlgPrintReport.Execute then
113 begin
114 AHeader := TStringList.Create;
115 CreatePatientHeader(AHeader, Self.Caption);
[830]116 memPrintReport := CreateReportTextComponent(Self);
[456]117 try
118 MaxLines := 60 - AHeader.Count;
119 LastLine := 0;
120 ThisPage := 0;
121 with memPrintReport do
122 begin
123 StartLine := 4;
124 repeat
125 with Lines do
126 begin
127 for i := StartLine to MaxLines do
128 //if i < memPtDemo.Lines.Count - 1 then
129 if i < memPtDemo.Lines.Count then
130 Add(memPtDemo.Lines[LastLine + i])
131 else
132 Break;
133 LastLine := LastLine + i;
134 Add(' ');
[830]135 Add(' ');
[456]136 Add(StringOfChar('-', 74));
137 if LastLine >= memPtDemo.Lines.Count - 1 then
138 Add('End of report')
139 else
140 begin
141 ThisPage := ThisPage + 1;
142 Add('Page ' + IntToStr(ThisPage));
143 Add(PAGE_BREAK);
144 StartLine := 0;
145 end;
146 end;
147 until LastLine >= memPtDemo.Lines.Count - 1;
[1693]148 PrintWindowsReport(memPrintReport, PAGE_BREAK, Self.Caption, ErrMsg, True);
[456]149 end;
150 finally
151 memPrintReport.Free;
152 AHeader.Free;
153 end;
154 end;
155 memPtDemo.SelStart := 0;
156 memPtDemo.Invalidate;
157end;
158
159end.
Note: See TracBrowser for help on using the repository browser.