source: cprs/trunk/CPRS-Chart/fLabTestGroups.pas@ 808

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

Initial Upload of Official WV CPRS 1.0.26.76
File size: 12.0 KB
Line 
1unit fLabTestGroups;
2
3interface
4
5uses
6 Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
7 ExtCtrls, Buttons, ORCtrls, StdCtrls;
8
9type
10 TfrmLabTestGroups = class(TForm)
11 pnlLabTestGroups: TORAutoPanel;
12 cmdOK: TButton;
13 cmdCancel: TButton;
14 cmdClear: TButton;
15 cmdRemove: TButton;
16 lstList: TORListBox;
17 cboTests: TORComboBox;
18 cmdUp: TSpeedButton;
19 pnlUpButton: TKeyClickPanel;
20 cmdDown: TSpeedButton;
21 pnlDownButton: TKeyClickPanel;
22 bvlTestGroups: TBevel;
23 cboUsers: TORComboBox;
24 lstTestGroups: TORListBox;
25 cmdReplace: TButton;
26 lblTests: TLabel;
27 lblList: TLabel;
28 cboSpecimen: TORComboBox;
29 lblSpecimen: TLabel;
30 lblTestGroups: TLabel;
31 lblUsers: TLabel;
32 lblOrder: TLabel;
33 cmdDelete: TButton;
34 cmdAdd: TButton;
35 cmdAddTest: TButton;
36 lblDefine: TLabel;
37 lblTestGroup: TLabel;
38 procedure FormCreate(Sender: TObject);
39 procedure cboTestsNeedData(Sender: TObject; const StartFrom: string;
40 Direction, InsertAt: Integer);
41 procedure cmdOKClick(Sender: TObject);
42 procedure cmdClearClick(Sender: TObject);
43 procedure cmdRemoveClick(Sender: TObject);
44 procedure cmdUpClick(Sender: TObject);
45 procedure cmdDownClick(Sender: TObject);
46 procedure lstListClick(Sender: TObject);
47 procedure cboUsersNeedData(Sender: TObject; const StartFrom: string;
48 Direction, InsertAt: Integer);
49 procedure cboSpecimenNeedData(Sender: TObject; const StartFrom: string;
50 Direction, InsertAt: Integer);
51 procedure cboUsersClick(Sender: TObject);
52 procedure lstTestGroupsClick(Sender: TObject);
53 procedure cmdReplaceClick(Sender: TObject);
54 procedure cmdAddClick(Sender: TObject);
55 procedure cmdDeleteClick(Sender: TObject);
56 procedure cboTestsChange(Sender: TObject);
57 procedure cboTestsEnter(Sender: TObject);
58 procedure cboTestsExit(Sender: TObject);
59 procedure cmdAddTestClick(Sender: TObject);
60 procedure pnlUpButtonEnter(Sender: TObject);
61 procedure pnlUpButtonExit(Sender: TObject);
62 procedure pnlDownButtonEnter(Sender: TObject);
63 procedure pnlDownButtonExit(Sender: TObject);
64 procedure pnlUpButtonResize(Sender: TObject);
65 procedure pnlDownButtonResize(Sender: TObject);
66 private
67 { Private declarations }
68 procedure AddTests(tests: TStrings);
69 procedure TestGroupEnable;
70 public
71 { Public declarations }
72 end;
73
74procedure SelectTestGroups(FontSize: Integer);
75
76implementation
77
78uses fLabs, ORFn, rLabs, uCore;
79
80{$R *.DFM}
81
82procedure SelectTestGroups(FontSize: Integer);
83var
84 frmLabTestGroups: TfrmLabTestGroups;
85 W, H: integer;
86begin
87 frmLabTestGroups := TfrmLabTestGroups.Create(Application);
88 try
89 with frmLabTestGroups do
90 begin
91 Font.Size := FontSize;
92 W := ClientWidth;
93 H := ClientHeight;
94 ResizeToFont(FontSize, W, H);
95 ClientWidth := W; pnlLabTestGroups.Width := W;
96 ClientHeight := H; pnlLabTestGroups.Height := H;
97 with lblTestGroup do begin
98 AutoSize := False;
99 Height := lstList.Height div 3;
100 Width := cmdAddTest.Width * 4 div 3;
101 AutoSize := True;
102 end;
103 with lblOrder do begin
104 AutoSize := False;
105 Height := lstList.Height div 3;
106 Width := cmdAddTest.Width div 2 + 10;
107 AutoSize := True;
108 end;
109 lstList.Items.Assign(frmLabs.lstTests.Items);
110 if lstList.Items.Count > 0 then lstList.ItemIndex := 0;
111 lstListClick(frmLabTestGroups);
112 ShowModal;
113 end;
114 finally
115 frmLabTestGroups.Release;
116 end;
117end;
118
119procedure TfrmLabTestGroups.FormCreate(Sender: TObject);
120var
121 i: integer;
122 blood, urine, serum, plasma: string;
123begin
124 RedrawSuspend(cboTests.Handle);
125 cboTests.InitLongList('');
126 RedrawActivate(cboTests.Handle);
127 RedrawSuspend(cboSpecimen.Handle);
128 cboSpecimen.InitLongList('');
129 SpecimenDefaults(blood, urine, serum, plasma);
130 cboSpecimen.Items.Add('0^Any');
131 cboSpecimen.Items.Add(serum + '^Serum');
132 cboSpecimen.Items.Add(blood + '^Blood');
133 cboSpecimen.Items.Add(plasma + '^Plasma');
134 cboSpecimen.Items.Add(urine + '^Urine');
135 cboSpecimen.Items.Add(LLS_LINE);
136 cboSpecimen.Items.Add(LLS_SPACE);
137 cboSpecimen.ItemIndex := 0;
138 RedrawActivate(cboSpecimen.Handle);
139 RedrawSuspend(cboTests.Handle);
140 cboUsers.InitLongList(User.Name);
141 for i := 0 to cboUsers.Items.Count - 1 do
142 if StrToInt64Def(Piece(cboUsers.Items[i], '^', 1), 0) = User.DUZ then
143 begin
144 cboUsers.ItemIndex := i;
145 break;
146 end;
147 if cboUsers.ItemIndex > -1 then cboUsersClick(self);
148 RedrawActivate(cboTests.Handle);
149 cmdUp.Enabled := false;
150 pnlUpButton.TabStop := false;
151 cmdDown.Enabled := false;
152 pnlDownButton.TabStop := false;
153 lstList.Clear;
154end;
155
156procedure TfrmLabTestGroups.cboTestsNeedData(Sender: TObject;
157 const StartFrom: string; Direction, InsertAt: Integer);
158begin
159 cboTests.ForDataUse(ChemTest(StartFrom, Direction));
160end;
161
162procedure TfrmLabTestGroups.cmdOKClick(Sender: TObject);
163begin
164 if lstList.Items.Count = 0 then
165 ShowMessage('No tests were selected.')
166 else
167 begin
168 frmLabs.lstTests.Items.Assign(lstList.Items);
169 frmLabs.lblSpecimen.Caption := cboSpecimen.Items[cboSpecimen.ItemIndex];
170 Close;
171 end;
172end;
173
174procedure TfrmLabTestGroups.cmdClearClick(Sender: TObject);
175begin
176 lstList.Clear;
177 lstListClick(self);
178end;
179
180procedure TfrmLabTestGroups.cmdRemoveClick(Sender: TObject);
181var
182 newindex: integer;
183begin
184 if lstList.Items.Count > 0 then
185 begin
186 if lstList.ItemIndex = (lstList.Items.Count -1 ) then
187 newindex := lstList.ItemIndex - 1
188 else
189 newindex := lstList.ItemIndex;
190 lstList.Items.Delete(lstList.ItemIndex);
191 if lstList.Items.Count > 0 then lstList.ItemIndex := newindex;
192 end;
193 lstListClick(self);
194end;
195
196procedure TfrmLabTestGroups.cmdUpClick(Sender: TObject);
197var
198 newindex: integer;
199 templine: string;
200begin
201 if cmdUp.Enabled then begin
202 newindex := lstList.ItemIndex - 1;
203 templine := lstList.Items[lstList.ItemIndex - 1];
204 lstList.Items[lstList.ItemIndex - 1] := lstList.Items[lstList.ItemIndex];
205 lstList.Items[lstList.ItemIndex] := templine;
206 lstList.ItemIndex := newindex;
207 lstListClick(self);
208 end;
209end;
210
211procedure TfrmLabTestGroups.cmdDownClick(Sender: TObject);
212var
213 newindex: integer;
214 templine: string;
215begin
216 if cmdDown.Enabled then begin
217 newindex := lstList.ItemIndex + 1;
218 templine := lstList.Items[lstList.ItemIndex + 1];
219 lstList.Items[lstList.ItemIndex + 1] := lstList.Items[lstList.ItemIndex];
220 lstList.Items[lstList.ItemIndex] := templine;
221 lstList.ItemIndex := newindex;
222 lstListClick(self);
223 end;
224end;
225
226procedure TfrmLabTestGroups.lstListClick(Sender: TObject);
227begin
228 cmdUp.Enabled := not (lstList.ItemIndex = 0);
229 pnlUpButton.TabStop := not (lstList.ItemIndex = 0);
230 cmdDown.Enabled := not (lstList.ItemIndex = lstList.Items.Count - 1);
231 pnlDownButton.TabStop := not (lstList.ItemIndex = lstList.Items.Count - 1);
232 if lstList.Items.Count = 0 then
233 begin
234 cmdUp.Enabled := false;
235 pnlUpButton.TabStop := false;
236 cmdDown.Enabled := false;
237 pnlDownButton.TabStop := false;
238 cmdClear.Enabled := false;
239 cmdRemove.Enabled := false;
240 end
241 else
242 begin
243 cmdClear.Enabled := true;
244 cmdRemove.Enabled := true;
245 end;
246 TestGroupEnable;
247end;
248
249procedure TfrmLabTestGroups.cboUsersNeedData(Sender: TObject;
250 const StartFrom: string; Direction, InsertAt: Integer);
251begin
252 cboUsers.ForDataUse(Users(StartFrom, Direction));
253end;
254
255procedure TfrmLabTestGroups.cboSpecimenNeedData(Sender: TObject;
256 const StartFrom: string; Direction, InsertAt: Integer);
257begin
258 cboSpecimen.ForDataUse(Specimens(StartFrom, Direction));
259end;
260
261procedure TfrmLabTestGroups.cboUsersClick(Sender: TObject);
262begin
263 lstTestGroups.Items.Assign(TestGroups(cboUsers.ItemIEN));
264 TestGroupEnable;
265end;
266
267procedure TfrmLabTestGroups.AddTests(tests: TStrings);
268var
269 i, j, textindex: integer;
270 ok: boolean;
271begin
272 textindex := lstList.Items.Count;
273 for i := 0 to tests.Count - 1 do
274 begin
275 ok := true;
276 for j := 0 to lstList.Items.Count - 1 do
277 if lstList.Items[j] = tests[i] then
278 begin
279 ok := false;
280 textindex := j;
281 end;
282 if ok then
283 begin
284 lstList.Items.Add(tests[i]);
285 textindex := lstList.Items.Count - 1;
286 end;
287 end;
288 lstList.ItemIndex := textindex;
289 lstListClick(self);
290end;
291
292procedure TfrmLabTestGroups.lstTestGroupsClick(Sender: TObject);
293begin
294 AddTests(ATestGroup(lstTestGroups.ItemIEN, cboUsers.ItemIEN));
295end;
296
297procedure TfrmLabTestGroups.TestGroupEnable;
298begin
299 cmdAdd.Enabled := (lstList.Items.Count > 0) and (lstList.Items.Count < 8);
300 cmdDelete.Enabled := (cboUsers.ItemIEN = User.DUZ) and (lstTestGroups.ItemIndex > -1);
301 cmdReplace.Enabled := cmdAdd.Enabled and cmdDelete.Enabled;
302end;
303
304procedure TfrmLabTestGroups.cmdReplaceClick(Sender: TObject);
305var
306 text: string;
307 i: integer;
308begin
309 text := 'Do you want to REPLACE your test group -' + #13 + ' ';
310 text := text + lstTestGroups.DisplayText[lstTestGroups.ItemIndex] + #13;
311 text := text + ' with:' + #13 + ' ';
312 for i := 0 to lstList.Items.Count -1 do
313 text := text + lstList.DisplayText[i] + #13 + ' ';
314 if InfoBox(text,'Confirmation', MB_YESNO or MB_ICONQUESTION) = IDYES then
315 UTGReplace(lstList.Items, lstTestGroups.ItemIEN); //ShowMessage('Replace'); //Replace
316 cboUsersClick(self);
317end;
318
319procedure TfrmLabTestGroups.cmdAddClick(Sender: TObject);
320var
321 text: string;
322 i: integer;
323begin
324 text := 'Do you wish to create a NEW test group with these tests: ' + #13 + ' ';
325 for i := 0 to lstList.Items.Count -1 do
326 text := text + lstList.DisplayText[i] + #13 + ' ';
327 if InfoBox(text,'Confirmation', MB_YESNO or MB_ICONQUESTION) = IDYES then
328 begin
329 UTGAdd(lstList.Items);
330 cboUsers.InitLongList(User.Name);
331 for i := 0 to cboUsers.Items.Count - 1 do
332 if StrToInt64Def(Piece(cboUsers.Items[i], '^', 1), 0) = User.DUZ then
333 begin
334 cboUsers.ItemIndex := i;
335 break;
336 end;
337 end;
338 if cboUsers.ItemIndex > -1 then cboUsersClick(self);
339end;
340
341procedure TfrmLabTestGroups.cmdDeleteClick(Sender: TObject);
342var
343 text: string;
344 i: integer;
345begin
346 text := 'Do you wish to DELETE your test group:' + #13 + ' ';
347 text := text + lstTestGroups.DisplayText[lstTestGroups.ItemIndex] + #13 + ' ';
348 if InfoBox(text,'Confirmation', MB_YESNO or MB_ICONQUESTION) = IDYES then
349 begin
350 UTGDelete(lstTestGroups.ItemIEN);
351 cboUsers.Text := '';
352 lstTestGroups.Clear;
353 cboUsers.InitLongList(User.Name);
354 for i := 0 to cboUsers.Items.Count - 1 do
355 if StrToInt64Def(Piece(cboUsers.Items[i], '^', 1), 0) = User.DUZ then
356 begin
357 cboUsers.ItemIndex := i;
358 break;
359 end;
360 end;
361 if cboUsers.ItemIndex > -1 then cboUsersClick(self);
362end;
363
364procedure TfrmLabTestGroups.cboTestsChange(Sender: TObject);
365begin
366 cmdAddTest.Enabled := cboTests.ItemIndex > -1;
367end;
368
369procedure TfrmLabTestGroups.cboTestsEnter(Sender: TObject);
370begin
371 cmdAddTest.Default := true;
372end;
373
374procedure TfrmLabTestGroups.cboTestsExit(Sender: TObject);
375begin
376 cmdAddTest.Default := false;
377end;
378
379procedure TfrmLabTestGroups.cmdAddTestClick(Sender: TObject);
380begin
381 AddTests(ATest(cboTests.ItemIEN));
382end;
383
384procedure TfrmLabTestGroups.pnlUpButtonEnter(Sender: TObject);
385begin
386 pnlUpButton.BevelOuter := bvRaised;
387end;
388
389procedure TfrmLabTestGroups.pnlUpButtonExit(Sender: TObject);
390begin
391 pnlUpButton.BevelOuter := bvNone;
392end;
393
394procedure TfrmLabTestGroups.pnlDownButtonEnter(Sender: TObject);
395begin
396 pnlDownButton.BevelOuter := bvRaised;
397end;
398
399procedure TfrmLabTestGroups.pnlDownButtonExit(Sender: TObject);
400begin
401 pnlDownButton.BevelOuter := bvNone;
402end;
403
404procedure TfrmLabTestGroups.pnlUpButtonResize(Sender: TObject);
405begin
406 cmdUp.Width := pnlUpButton.Width;
407end;
408
409procedure TfrmLabTestGroups.pnlDownButtonResize(Sender: TObject);
410begin
411 cmdDown.Width := pnlDownButton.Width;
412end;
413
414end.
Note: See TracBrowser for help on using the repository browser.