source: cprs/trunk/CPRS-Chart/fPtSelMsg.pas@ 722

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

Initial Upload of Official WV CPRS 1.0.26.76

File size: 3.5 KB
RevLine 
[456]1unit fPtSelMsg;
2
3interface
4
5uses
6 Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
7 ExtCtrls, StdCtrls, ComCtrls;
8
9type
10 TfrmPtSelMsg = class(TForm)
11 cmdClose: TButton;
12 timClose: TTimer;
13 memMessages: TRichEdit;
14 procedure FormClose(Sender: TObject; var Action: TCloseAction);
15 procedure cmdCloseClick(Sender: TObject);
16 procedure timCloseTimer(Sender: TObject);
17 procedure FormCreate(Sender: TObject);
18 procedure FormDestroy(Sender: TObject);
19 private
20 FSeconds: Integer;
21 FChanging: boolean;
22 FEventsActive: boolean;
23 FOldActiveFormChanged: TNotifyEvent;
24 FOldTabChanged: TNotifyEvent;
25 procedure ClearEvents;
26 procedure TabChanged(Sender: TObject);
27 procedure ActiveFormChanged(Sender: TObject);
28 public
29 { Public declarations }
30 end;
31
32procedure ShowPatientSelectMessages(const AMsg: string);
33procedure HidePatientSelectMessages;
34
35implementation
36
37{$R *.DFM}
38
39uses ORFn, uCore, fFrame;
40
41var
42 frmPtSelMsg: TfrmPtSelMsg = nil;
43
44procedure ShowPatientSelectMessages(const AMsg: string);
45begin
46 if assigned(frmPtSelMsg) then
47 begin
48 frmPtSelMsg.Free;
49 frmPtSelMsg := nil;
50 end;
51 if Length(AMsg) = 0 then Exit;
52 frmPtSelMsg := TfrmPtSelMsg.Create(Application);
53 ResizeAnchoredFormToFont(frmPtSelMsg);
54 frmPtSelMsg.memMessages.Lines.SetText(PChar(AMsg)); // Text := AMsg doesn't seem to work
55 frmPtSelMsg.memMessages.SelStart := 0;
56 if User.PtMsgHang = 0
57 then frmPtSelMsg.timClose.Enabled := False
58 else
59 begin
60 //frmPtSelMsg.timClose.Interval := User.PtMsgHang * 1000;
61 frmPtSelMsg.FSeconds := User.PtMsgHang;
62 frmPtSelMsg.timClose.Enabled := True;
63 end;
64 frmPtSelMsg.Show;
65end;
66
67procedure HidePatientSelectMessages;
68begin
69 if assigned(frmPtSelMsg) then
70 begin
71 frmPtSelMsg.Free;
72 frmPtSelMsg := nil;
73 end;
74end;
75
76procedure TfrmPtSelMsg.timCloseTimer(Sender: TObject);
77begin
78 Dec(FSeconds);
79 if FSeconds > 0
80 then Caption := 'Patient Lookup Messages (Auto-Close in ' + IntToStr(FSeconds) + ' seconds)'
81 else Close;
82end;
83
84procedure TfrmPtSelMsg.cmdCloseClick(Sender: TObject);
85begin
86 Close;
87end;
88
89procedure TfrmPtSelMsg.FormClose(Sender: TObject; var Action: TCloseAction);
90begin
91 Action := caFree;
92end;
93
94procedure TfrmPtSelMsg.FormCreate(Sender: TObject);
95begin
96 memMessages.Color := ReadOnlyColor;
97 FOldActiveFormChanged := Screen.OnActiveFormChange;
98 Screen.OnActiveFormChange := ActiveFormChanged;
99 FOldTabChanged := frmFrame.OnTabChanged;
100 frmFrame.OnTabChanged := TabChanged;
101 FEventsActive := TRUE;
102end;
103
104procedure TfrmPtSelMsg.FormDestroy(Sender: TObject);
105begin
106 ClearEvents;
107 frmPtSelMsg := nil;
108end;
109
110procedure TfrmPtSelMsg.ActiveFormChanged(Sender: TObject);
111begin
112 if assigned(FOldActiveFormChanged) then
113 FOldActiveFormChanged(Sender);
114 if (not FChanging) and (Screen.ActiveForm <> Self) and
115 (not (csDestroying in Self.ComponentState)) then
116 begin
117 FChanging := TRUE;
118 try
119 SetFocus;
120 finally
121 FChanging := FALSE;
122 end;
123 end;
124end;
125
126procedure TfrmPtSelMsg.ClearEvents;
127begin
128 if FEventsActive then
129 begin
130 Screen.OnActiveFormChange := FOldActiveFormChanged;
131 frmFrame.OnTabChanged := FOldTabChanged;
132 FEventsActive := FALSE;
133 end;
134end;
135
136procedure TfrmPtSelMsg.TabChanged(Sender: TObject);
137begin
138 if assigned(FOldTabChanged) then
139 FOldTabChanged(Sender);
140 ClearEvents;
141end;
142
143end.
Note: See TracBrowser for help on using the repository browser.