source: cprs/trunk/CPRS-Chart/Options/fOptionsTeams.pas@ 912

Last change on this file since 912 was 829, checked in by Kevin Toppenberg, 14 years ago

Upgrade to version 27

File size: 8.1 KB
Line 
1unit fOptionsTeams;
2
3interface
4
5uses
6 Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
7 StdCtrls, ExtCtrls, ORCtrls, OrFn, Menus, fBase508Form,
8 VA508AccessibilityManager;
9
10type
11 TfrmOptionsTeams = class(TfrmBase508Form)
12 pnlBottom: TPanel;
13 btnClose: TButton;
14 lstPatients: TORListBox;
15 lstTeams: TORListBox;
16 lblTeams: TLabel;
17 lblPatients: TLabel;
18 lstUsers: TORListBox;
19 lblTeamMembers: TLabel;
20 btnRemove: TButton;
21 chkPersonal: TCheckBox;
22 chkRestrict: TCheckBox;
23 bvlBottom: TBevel;
24 lblInfo: TMemo;
25 lblSubscribe: TLabel;
26 cboSubscribe: TORComboBox;
27 mnuPopPatient: TPopupMenu;
28 mnuPatientID: TMenuItem;
29 procedure FormCreate(Sender: TObject);
30 procedure chkPersonalClick(Sender: TObject);
31 procedure lstTeamsClick(Sender: TObject);
32 procedure chkRestrictClick(Sender: TObject);
33 procedure cboSubscribeClick(Sender: TObject);
34 procedure btnRemoveClick(Sender: TObject);
35 procedure mnuPatientIDClick(Sender: TObject);
36 procedure lstPatientsMouseDown(Sender: TObject; Button: TMouseButton;
37 Shift: TShiftState; X, Y: Integer);
38 procedure cboSubscribeKeyDown(Sender: TObject; var Key: Word;
39 Shift: TShiftState);
40 procedure cboSubscribeMouseClick(Sender: TObject);
41 private
42 FKeyBoarding: boolean;
43 { Private declarations }
44 procedure FillATeams;
45 procedure FillList(alist: TORListBox; members: TStrings);
46 procedure MergeList(alist: TORListBox; members: TStrings);
47 function ItemNotAMember(alist: TStrings; listnum: string): boolean;
48 function MemberNotOnList(alist: TStrings; listnum: string): boolean;
49 public
50 { Public declarations }
51 end;
52
53var
54 frmOptionsTeams: TfrmOptionsTeams;
55
56procedure DialogOptionsTeams(topvalue, leftvalue, fontsize: integer; var actiontype: Integer);
57
58implementation
59
60uses rOptions, uOptions, rCore, fOptions;
61
62{$R *.DFM}
63
64procedure DialogOptionsTeams(topvalue, leftvalue, fontsize: integer; var actiontype: Integer);
65// create the form and make it modal, return an action
66var
67 frmOptionsTeams: TfrmOptionsTeams;
68begin
69 frmOptionsTeams := TfrmOptionsTeams.Create(Application);
70 actiontype := 0;
71 try
72 with frmOptionsTeams do
73 begin
74 if (topvalue < 0) or (leftvalue < 0) then
75 Position := poScreenCenter
76 else
77 begin
78 Position := poDesigned;
79 Top := topvalue;
80 Left := leftvalue;
81 end;
82 ResizeAnchoredFormToFont(frmOptionsTeams);
83 ShowModal;
84 end;
85 finally
86 frmOptionsTeams.Release;
87 end;
88end;
89
90procedure TfrmOptionsTeams.FormCreate(Sender: TObject);
91begin
92 rpcGetTeams(lstTeams.Items);
93 lstTeams.ItemIndex := -1;
94 FillATeams;
95end;
96
97procedure TfrmOptionsTeams.FillATeams;
98var
99 i: integer;
100 alist: TStringList;
101begin
102 cboSubscribe.Items.Clear;
103 alist := TStringList.Create;
104 rpcGetAteams(alist);
105 for i := 0 to alist.Count - 1 do
106 if MemberNotOnList(lstTeams.Items, Piece(alist[i], '^', 1)) then
107 cboSubscribe.Items.Add(alist[i]);
108 cboSubscribe.Enabled := cboSubscribe.Items.Count > 0;
109 lblSubscribe.Enabled := cboSubscribe.Items.Count > 0;
110 alist.Free;
111end;
112
113procedure TfrmOptionsTeams.FillList(alist: TORListBox; members: TStrings);
114var
115 i: integer;
116begin
117 for i := 0 to members.Count - 1 do
118 if MemberNotOnList(alist.Items, Piece(members[i], '^', 1)) then
119 alist.Items.Add(members[i]);
120end;
121
122procedure TfrmOptionsTeams.MergeList(alist: TORListBox; members: TStrings);
123var
124 i: integer;
125begin
126 for i := alist.Items.Count - 1 downto 0 do
127 if ItemNotAMember(members, Piece(alist.Items[i], '^', 1)) then
128 alist.Items.Delete(i);
129end;
130
131function TfrmOptionsTeams.ItemNotAMember(alist: TStrings; listnum: string): boolean;
132var
133 i: integer;
134begin
135 result := true;
136 for i := 0 to alist.Count - 1 do
137 if listnum = Piece(alist[i], '^', 1) then
138 begin
139 result := false;
140 break;
141 end;
142end;
143
144function TfrmOptionsTeams.MemberNotOnList(alist: TStrings; listnum: string): boolean;
145var
146 i: integer;
147begin
148 result := true;
149 with alist do
150 for i := 0 to Count - 1 do
151 if listnum = Piece(alist[i], '^', 1) then
152 begin
153 result := false;
154 break;
155 end;
156end;
157
158procedure TfrmOptionsTeams.chkPersonalClick(Sender: TObject);
159begin
160 lstTeams.Items.Clear;
161 if chkPersonal.Checked then
162 rpcGetAllTeams(lstTeams.Items)
163 else
164 rpcGetTeams(lstTeams.Items);
165 lstTeams.ItemIndex := -1;
166 lstTeamsClick(self);
167end;
168
169procedure TfrmOptionsTeams.lstTeamsClick(Sender: TObject);
170var
171 i, teamid, cnt: integer;
172 astrings: TStringList;
173begin
174 lstPatients.Items.Clear;
175 lstUsers.Items.Clear;
176 chkRestrict.Enabled := lstTeams.SelCount > 1;
177 astrings := TStringList.Create;
178 cnt := 0;
179 with lstTeams do
180 begin
181 for i := 0 to Items.Count - 1 do
182 if Selected[i] then
183 begin
184 inc(cnt);
185 teamid := strtointdef(Piece(Items[i], '^', 1), 0);
186 if (cnt > 1) and chkRestrict.Checked then
187 begin
188 ListPtByTeam(astrings, teamid);
189 MergeList(lstPatients, astrings);
190 rpcListUsersByTeam(astrings, teamid);
191 MergeList(lstUsers, astrings);
192 end
193 else
194 begin
195 ListPtByTeam(astrings, teamid);
196 if astrings.Count = 1 then // don't fill the '^No patients found.' msg
197 begin
198 if Piece(astrings[0], '^', 1) <> '' then
199 FillList(lstPatients, astrings);
200 end
201 else
202 FillList(lstPatients, astrings);
203 rpcListUsersByTeam(astrings, teamid);
204 FillList(lstUsers, astrings);
205 end;
206 end;
207 btnRemove.Enabled := (SelCount = 1)
208 and (Piece(Items[ItemIndex], '^', 3) <> 'P')
209 and (Piece(Items[ItemIndex], '^', 7) = 'Y');
210 if SelCount > 0 then
211 begin
212 if lstPatients.Items.Count = 0 then
213 lstPatients.Items.Add('^No patients found.');
214 if lstUsers.Items.Count = 0 then
215 lstUsers.Items.Add('^No team members found.');
216 end;
217 end;
218 astrings.Free;
219end;
220
221procedure TfrmOptionsTeams.chkRestrictClick(Sender: TObject);
222begin
223 lstTeamsClick(self);
224end;
225
226procedure TfrmOptionsTeams.cboSubscribeClick(Sender: TObject);
227begin
228 FKeyBoarding := False
229end;
230
231procedure TfrmOptionsTeams.btnRemoveClick(Sender: TObject);
232begin
233 with lstTeams do
234 if InfoBox('Do you want to remove yourself from '
235 + Piece(Items[ItemIndex], '^', 2) + '?',
236 'Confirmation', MB_YESNO or MB_ICONQUESTION) = IDYES then
237 begin
238 rpcRemoveList(ItemIEN);
239 Items.Delete(ItemIndex);
240 lstTeamsClick(self);
241 FillATeams;
242 end;
243end;
244
245procedure TfrmOptionsTeams.mnuPatientIDClick(Sender: TObject);
246begin
247 DisplayPtInfo(lstPatients.ItemID);
248end;
249
250procedure TfrmOptionsTeams.lstPatientsMouseDown(Sender: TObject;
251 Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
252begin
253 mnuPopPatient.AutoPopup := (lstPatients.Items.Count > 0)
254 and (lstPatients.ItemIndex > -1)
255 and (Button = mbRight);
256end;
257
258procedure TfrmOptionsTeams.cboSubscribeKeyDown(Sender: TObject;
259 var Key: Word; Shift: TShiftState);
260begin
261 case Key of VK_RETURN:
262 if (cboSubscribe.ItemIndex > -1) then
263 begin
264 FKeyBoarding := False;
265 cboSubscribeMouseClick(self); // Provide onmouseclick behavior.
266 end;
267 else
268 FKeyBoarding := True; // Suppress onmouseclick behavior.
269 end;
270end;
271
272procedure TfrmOptionsTeams.cboSubscribeMouseClick(Sender: TObject);
273begin
274 if FKeyBoarding then
275 FKeyBoarding := False
276 else
277 begin
278 with cboSubscribe do
279 if ItemIndex < 0 then
280 exit
281 else if InfoBox('Do you want to join '
282 + Piece(Items[ItemIndex], '^', 2) + '?',
283 'Confirmation', MB_YESNO or MB_ICONQUESTION) = IDYES then
284 begin
285 rpcAddList(ItemIEN);
286 lstTeams.Items.Add(Items[ItemIndex]);
287 Items.Delete(ItemIndex);
288 ItemIndex := -1;
289 Text := '';
290 Enabled := Items.Count > 0;
291 lblSubscribe.Enabled := Items.Count > 0;
292 end
293 else
294 begin
295 ItemIndex := -1;
296 Text := '';
297 end;
298 end;
299end;
300
301end.
Note: See TracBrowser for help on using the repository browser.