1 | unit fPtDemo;
|
---|
2 |
|
---|
3 | interface
|
---|
4 |
|
---|
5 | uses
|
---|
6 | Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
|
---|
7 | StdCtrls, ExtCtrls, ORCtrls, ORFn, ComCtrls;
|
---|
8 |
|
---|
9 | type
|
---|
10 | TfrmPtDemo = class(TForm)
|
---|
11 | lblFontTest: TLabel;
|
---|
12 | memPtDemo: TRichEdit;
|
---|
13 | pnlTop: TORAutoPanel;
|
---|
14 | cmdNewPt: TButton;
|
---|
15 | cmdClose: TButton;
|
---|
16 | cmdPrint: TButton;
|
---|
17 | dlgPrintReport: TPrintDialog;
|
---|
18 | procedure cmdCloseClick(Sender: TObject);
|
---|
19 | procedure cmdNewPtClick(Sender: TObject);
|
---|
20 | procedure FormCreate(Sender: TObject);
|
---|
21 | procedure cmdPrintClick(Sender: TObject);
|
---|
22 | private
|
---|
23 | { Private declarations }
|
---|
24 | FNewPt: Boolean;
|
---|
25 | public
|
---|
26 | { Public declarations }
|
---|
27 | end;
|
---|
28 |
|
---|
29 | procedure PatientInquiry(var NewPt: Boolean);
|
---|
30 |
|
---|
31 | implementation
|
---|
32 |
|
---|
33 | {$R *.DFM}
|
---|
34 |
|
---|
35 | uses rCover, rReports, Printers, uCore;
|
---|
36 |
|
---|
37 | procedure PatientInquiry(var NewPt: Boolean);
|
---|
38 | { displays patient demographics, returns true in NewPt if the user pressed 'Select New' btn }
|
---|
39 | var
|
---|
40 | frmPtDemo: TfrmPtDemo;
|
---|
41 | begin
|
---|
42 | if StrToInt64Def(Patient.DFN, 0) <= 0 then exit;
|
---|
43 | frmPtDemo := TfrmPtDemo.Create(Application);
|
---|
44 | try
|
---|
45 | with frmPtDemo do
|
---|
46 | begin
|
---|
47 | frmPtDemo.ShowModal;
|
---|
48 | NewPt := FNewPt;
|
---|
49 | end; {with frmPtDemo}
|
---|
50 | finally
|
---|
51 | frmPtDemo.Release;
|
---|
52 | end;
|
---|
53 | end;
|
---|
54 |
|
---|
55 | procedure TfrmPtDemo.FormCreate(Sender: TObject);
|
---|
56 | var
|
---|
57 | i, MaxWidth, AWidth, AHeight: Integer;
|
---|
58 | Rect: TRect;
|
---|
59 | begin
|
---|
60 | memPtDemo.Color := ReadOnlyColor;
|
---|
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;
|
---|
82 | Rect := BoundsRect;
|
---|
83 | ForceInsideWorkArea(Rect);
|
---|
84 | BoundsRect := Rect;
|
---|
85 | end;
|
---|
86 |
|
---|
87 | procedure TfrmPtDemo.cmdNewPtClick(Sender: TObject);
|
---|
88 | begin
|
---|
89 | FNewPt := True;
|
---|
90 | Close;
|
---|
91 | end;
|
---|
92 |
|
---|
93 | procedure TfrmPtDemo.cmdCloseClick(Sender: TObject);
|
---|
94 | begin
|
---|
95 | Close;
|
---|
96 | end;
|
---|
97 |
|
---|
98 | procedure TfrmPtDemo.cmdPrintClick(Sender: TObject);
|
---|
99 | var
|
---|
100 | AHeader: TStringList;
|
---|
101 | memPrintReport: TRichEdit;
|
---|
102 | StartLine, MaxLines, LastLine, ThisPage, i: integer;
|
---|
103 | ErrMsg: string;
|
---|
104 | RemoteSiteID: string; //for Remote site printing
|
---|
105 | RemoteQuery: string; //for Remote site printing
|
---|
106 | const
|
---|
107 | PAGE_BREAK = '**PAGE BREAK**';
|
---|
108 | begin
|
---|
109 | RemoteSiteID := '';
|
---|
110 | RemoteQuery := '';
|
---|
111 | if dlgPrintReport.Execute then
|
---|
112 | begin
|
---|
113 | AHeader := TStringList.Create;
|
---|
114 | CreatePatientHeader(AHeader, Self.Caption);
|
---|
115 | memPrintReport := TRichEdit.Create(Self);
|
---|
116 | try
|
---|
117 | MaxLines := 60 - AHeader.Count;
|
---|
118 | LastLine := 0;
|
---|
119 | ThisPage := 0;
|
---|
120 | with memPrintReport do
|
---|
121 | begin
|
---|
122 | Visible := False;
|
---|
123 | Parent := Self;
|
---|
124 | Width := Printer.Canvas.TextWidth(StringOfChar('-', 74));
|
---|
125 | Font.Name := 'Courier New';
|
---|
126 | Font.Size := MainFontSize;
|
---|
127 | StartLine := 4;
|
---|
128 | repeat
|
---|
129 | with Lines do
|
---|
130 | begin
|
---|
131 | AddStrings(AHeader);
|
---|
132 | for i := StartLine to MaxLines do
|
---|
133 | //if i < memPtDemo.Lines.Count - 1 then
|
---|
134 | if i < memPtDemo.Lines.Count then
|
---|
135 | Add(memPtDemo.Lines[LastLine + i])
|
---|
136 | else
|
---|
137 | Break;
|
---|
138 | LastLine := LastLine + i;
|
---|
139 | Add(' ');
|
---|
140 | Add(' ');
|
---|
141 | Add(StringOfChar('-', 74));
|
---|
142 | if LastLine >= memPtDemo.Lines.Count - 1 then
|
---|
143 | Add('End of report')
|
---|
144 | else
|
---|
145 | begin
|
---|
146 | ThisPage := ThisPage + 1;
|
---|
147 | Add('Page ' + IntToStr(ThisPage));
|
---|
148 | Add(PAGE_BREAK);
|
---|
149 | StartLine := 0;
|
---|
150 | end;
|
---|
151 | end;
|
---|
152 | until LastLine >= memPtDemo.Lines.Count - 1;
|
---|
153 | PrintWindowsReport(memPrintReport, PAGE_BREAK, Self.Caption, ErrMsg);
|
---|
154 | end;
|
---|
155 | finally
|
---|
156 | memPrintReport.Free;
|
---|
157 | AHeader.Free;
|
---|
158 | end;
|
---|
159 | end;
|
---|
160 | memPtDemo.SelStart := 0;
|
---|
161 | memPtDemo.Invalidate;
|
---|
162 | end;
|
---|
163 |
|
---|
164 | end.
|
---|