source: cprs/branches/tmg-cprs/CPRS-Chart/Options/fOptionsTeams.pas@ 1619

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

Initial upload of TMG-CPRS 1.0.26.69

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