source: cprs/branches/foia-cprs/CPRS-Chart/fPtDemo.pas@ 1705

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

Adding foia-cprs branch

File size: 4.9 KB
Line 
1unit fPtDemo;
2
3interface
4
5uses
6 Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
7 StdCtrls, ExtCtrls, ORCtrls, ORFn, ComCtrls;
8
9type
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
29procedure PatientInquiry(var NewPt: Boolean);
30
31implementation
32
33{$R *.DFM}
34
35uses rCover, rReports, Printers, uCore;
36
37procedure PatientInquiry(var NewPt: Boolean);
38{ displays patient demographics, returns true in NewPt if the user pressed 'Select New' btn }
39var
40 frmPtDemo: TfrmPtDemo;
41begin
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;
53end;
54
55procedure TfrmPtDemo.FormCreate(Sender: TObject);
56var
57 i, MaxWidth, AWidth, AHeight: Integer;
58 Rect: TRect;
59begin
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;
85end;
86
87procedure TfrmPtDemo.cmdNewPtClick(Sender: TObject);
88begin
89 FNewPt := True;
90 Close;
91end;
92
93procedure TfrmPtDemo.cmdCloseClick(Sender: TObject);
94begin
95 Close;
96end;
97
98procedure TfrmPtDemo.cmdPrintClick(Sender: TObject);
99var
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
106const
107 PAGE_BREAK = '**PAGE BREAK**';
108begin
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;
162end;
163
164end.
Note: See TracBrowser for help on using the repository browser.