source: cprs/branches/foia-cprs/CPRS-Chart/Options/fOptionsTeams.pas@ 1742

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

Uploading from OR_30_258

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