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

Last change on this file was 1679, checked in by healthsevak, 9 years ago

Updating the working copy to CPRS version 28
File size: 12.9 KB
Line 
1unit fLabTestGroups;
2
3interface
4
5uses
6 Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
7 ExtCtrls, Buttons, ORCtrls, StdCtrls, fBase508Form, VA508AccessibilityManager;
8
9type
10 TfrmLabTestGroups = class(TfrmBase508Form)
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: TVA508StaticText;
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 cmdReplaceClick(Sender: TObject);
53 procedure cmdAddClick(Sender: TObject);
54 procedure cmdDeleteClick(Sender: TObject);
55 procedure cboTestsChange(Sender: TObject);
56 procedure cboTestsEnter(Sender: TObject);
57 procedure cboTestsExit(Sender: TObject);
58 procedure cmdAddTestClick(Sender: TObject);
59 procedure pnlUpButtonEnter(Sender: TObject);
60 procedure pnlUpButtonExit(Sender: TObject);
61 procedure pnlDownButtonEnter(Sender: TObject);
62 procedure pnlDownButtonExit(Sender: TObject);
63 procedure pnlUpButtonResize(Sender: TObject);
64 procedure pnlDownButtonResize(Sender: TObject);
65 procedure lstTestGroupsChange(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, VAUtils, VA508AccessibilityRouter;
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 FastAssign(frmLabs.lstTests.Items, lstList.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 ShowMsg('No tests were selected.')
166 else
167 begin
168 FastAssign(lstList.Items, frmLabs.lstTests.Items);
169 frmLabs.lblSpecimen.Caption := cboSpecimen.Items[cboSpecimen.ItemIndex];
170 Close;
171 end;
172end;
173
174procedure TfrmLabTestGroups.cmdClearClick(Sender: TObject);
175//var
176 //i: integer;
177begin
178 lstList.Clear;
179 lstListClick(self);
180 lstTestGroups.ClearSelection;
181 //for i := 0 to lstTestGroups.Count - 1 do
182 // lstTestGroups.Selected[i] := false;
183end;
184
185procedure TfrmLabTestGroups.cmdRemoveClick(Sender: TObject);
186var
187 newindex: integer;
188begin
189 if lstList.Items.Count > 0 then
190 begin
191 if lstList.ItemIndex = (lstList.Items.Count -1 ) then
192 newindex := lstList.ItemIndex - 1
193 else
194 newindex := lstList.ItemIndex;
195 lstList.Items.Delete(lstList.ItemIndex);
196 if lstList.Items.Count > 0 then lstList.ItemIndex := newindex;
197 end;
198 lstListClick(self);
199 lstTestGroups.ClearSelection;
200end;
201
202procedure TfrmLabTestGroups.cmdUpClick(Sender: TObject);
203var
204 newindex: integer;
205 templine: string;
206begin
207 if cmdUp.Enabled then begin
208 newindex := lstList.ItemIndex - 1;
209 templine := lstList.Items[lstList.ItemIndex - 1];
210 lstList.Items[lstList.ItemIndex - 1] := lstList.Items[lstList.ItemIndex];
211 lstList.Items[lstList.ItemIndex] := templine;
212 lstList.ItemIndex := newindex;
213 lstListClick(self);
214 if ScreenReaderSystemActive then
215 GetScreenReader.Speak('Test Moved Up');
216 end;
217end;
218
219procedure TfrmLabTestGroups.cmdDownClick(Sender: TObject);
220var
221 newindex: integer;
222 templine: string;
223begin
224 if cmdDown.Enabled then begin
225 newindex := lstList.ItemIndex + 1;
226 templine := lstList.Items[lstList.ItemIndex + 1];
227 lstList.Items[lstList.ItemIndex + 1] := lstList.Items[lstList.ItemIndex];
228 lstList.Items[lstList.ItemIndex] := templine;
229 lstList.ItemIndex := newindex;
230 lstListClick(self);
231 if ScreenReaderSystemActive then
232 GetScreenReader.Speak('Test Moved Down');
233 end;
234end;
235
236procedure TfrmLabTestGroups.lstListClick(Sender: TObject);
237begin
238 cmdUp.Enabled := not (lstList.ItemIndex = 0);
239 pnlUpButton.TabStop := not (lstList.ItemIndex = 0);
240 cmdDown.Enabled := not (lstList.ItemIndex = lstList.Items.Count - 1);
241 pnlDownButton.TabStop := not (lstList.ItemIndex = lstList.Items.Count - 1);
242 if lstList.Items.Count = 0 then
243 begin
244 cmdUp.Enabled := false;
245 pnlUpButton.TabStop := false;
246 cmdDown.Enabled := false;
247 pnlDownButton.TabStop := false;
248 cmdClear.Enabled := false;
249 cmdRemove.Enabled := false;
250 end
251 else
252 begin
253 cmdClear.Enabled := true;
254 cmdRemove.Enabled := true;
255 end;
256 TestGroupEnable;
257end;
258
259procedure TfrmLabTestGroups.cboUsersNeedData(Sender: TObject;
260 const StartFrom: string; Direction, InsertAt: Integer);
261begin
262 cboUsers.ForDataUse(Users(StartFrom, Direction));
263end;
264
265procedure TfrmLabTestGroups.cboSpecimenNeedData(Sender: TObject;
266 const StartFrom: string; Direction, InsertAt: Integer);
267begin
268 cboSpecimen.ForDataUse(Specimens(StartFrom, Direction));
269end;
270
271procedure TfrmLabTestGroups.cboUsersClick(Sender: TObject);
272begin
273 FastAssign(TestGroups(cboUsers.ItemIEN), lstTestGroups.Items);
274 TestGroupEnable;
275end;
276
277procedure TfrmLabTestGroups.AddTests(tests: TStrings);
278var
279 i, j, textindex: integer;
280 ok: boolean;
281begin
282 textindex := lstList.Items.Count;
283 for i := 0 to tests.Count - 1 do
284 begin
285 ok := true;
286 for j := 0 to lstList.Items.Count - 1 do
287 if lstList.Items[j] = tests[i] then
288 begin
289 ok := false;
290 textindex := j;
291 end;
292 if ok then
293 begin
294 lstList.Items.Add(tests[i]);
295 textindex := lstList.Items.Count - 1;
296 end;
297 end;
298 lstList.ItemIndex := textindex;
299 lstListClick(self);
300end;
301
302procedure TfrmLabTestGroups.lstTestGroupsChange(Sender: TObject);
303begin
304 if lstTestGroups.ItemIEN > 0 then
305 begin
306 AddTests(ATestGroup(lstTestGroups.ItemIEN, cboUsers.ItemIEN));
307 end;
308end;
309
310procedure TfrmLabTestGroups.TestGroupEnable;
311begin
312 cmdAdd.Enabled := (lstList.Items.Count > 0) and (lstList.Items.Count < 8);
313 cmdDelete.Enabled := (cboUsers.ItemIEN = User.DUZ) and (lstTestGroups.ItemIndex > -1);
314 cmdReplace.Enabled := cmdAdd.Enabled and cmdDelete.Enabled;
315end;
316
317procedure TfrmLabTestGroups.cmdReplaceClick(Sender: TObject);
318var
319 text: string;
320 i: integer;
321begin
322 text := 'Do you want to REPLACE your test group -' + #13 + ' ';
323 text := text + lstTestGroups.DisplayText[lstTestGroups.ItemIndex] + #13;
324 text := text + ' with:' + #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 UTGReplace(lstList.Items, lstTestGroups.ItemIEN); //Show508Message('Replace'); //Replace
330 if ScreenReaderSystemActive then
331 GetScreenReader.Speak('test group replaced');
332 end;
333 cboUsersClick(self);
334 lstTestGroups.SetFocus;
335end;
336
337procedure TfrmLabTestGroups.cmdAddClick(Sender: TObject);
338var
339 text: string;
340 i: integer;
341begin
342 text := 'Do you wish to create a NEW test group with these tests: ' + #13 + ' ';
343 for i := 0 to lstList.Items.Count -1 do
344 text := text + lstList.DisplayText[i] + #13 + ' ';
345 if InfoBox(text,'Confirmation', MB_YESNO or MB_ICONQUESTION) = IDYES then
346 begin
347 UTGAdd(lstList.Items);
348 if ScreenReaderSystemActive then
349 GetScreenReader.Speak('New test group created');
350 cboUsers.InitLongList(User.Name);
351 for i := 0 to cboUsers.Items.Count - 1 do
352 if StrToInt64Def(Piece(cboUsers.Items[i], '^', 1), 0) = User.DUZ then
353 begin
354 cboUsers.ItemIndex := i;
355 break;
356 end;
357 end;
358 if cboUsers.ItemIndex > -1 then cboUsersClick(self);
359 lstTestGroups.SetFocus;
360end;
361
362procedure TfrmLabTestGroups.cmdDeleteClick(Sender: TObject);
363var
364 text: string;
365 i: integer;
366begin
367 text := 'Do you wish to DELETE your test group:' + #13 + ' ';
368 text := text + lstTestGroups.DisplayText[lstTestGroups.ItemIndex] + #13 + ' ';
369 if InfoBox(text,'Confirmation', MB_YESNO or MB_ICONQUESTION) = IDYES then
370 begin
371 UTGDelete(lstTestGroups.ItemIEN);
372 if ScreenReaderSystemActive then
373 GetScreenReader.Speak('Test group deleted');
374 cboUsers.Text := '';
375 lstTestGroups.Clear;
376 cboUsers.InitLongList(User.Name);
377 for i := 0 to cboUsers.Items.Count - 1 do
378 if StrToInt64Def(Piece(cboUsers.Items[i], '^', 1), 0) = User.DUZ then
379 begin
380 cboUsers.ItemIndex := i;
381 break;
382 end;
383 end;
384 if cboUsers.ItemIndex > -1 then cboUsersClick(self);
385 lstTestGroups.SetFocus;
386end;
387
388procedure TfrmLabTestGroups.cboTestsChange(Sender: TObject);
389begin
390 cmdAddTest.Enabled := cboTests.ItemIndex > -1;
391end;
392
393procedure TfrmLabTestGroups.cboTestsEnter(Sender: TObject);
394begin
395 cmdAddTest.Default := true;
396end;
397
398procedure TfrmLabTestGroups.cboTestsExit(Sender: TObject);
399begin
400 cmdAddTest.Default := false;
401end;
402
403procedure TfrmLabTestGroups.cmdAddTestClick(Sender: TObject);
404begin
405 AddTests(ATest(cboTests.ItemIEN));
406end;
407
408procedure TfrmLabTestGroups.pnlUpButtonEnter(Sender: TObject);
409begin
410 pnlUpButton.BevelOuter := bvLowered;
411end;
412
413procedure TfrmLabTestGroups.pnlUpButtonExit(Sender: TObject);
414begin
415 pnlUpButton.BevelOuter := bvNone;
416end;
417
418procedure TfrmLabTestGroups.pnlDownButtonEnter(Sender: TObject);
419begin
420 pnlDownButton.BevelOuter := bvLowered;
421end;
422
423procedure TfrmLabTestGroups.pnlDownButtonExit(Sender: TObject);
424begin
425 pnlDownButton.BevelOuter := bvNone;
426end;
427
428procedure TfrmLabTestGroups.pnlUpButtonResize(Sender: TObject);
429begin
430 cmdUp.Width := pnlUpButton.Width;
431end;
432
433procedure TfrmLabTestGroups.pnlDownButtonResize(Sender: TObject);
434begin
435 cmdDown.Width := pnlDownButton.Width;
436end;
437
438end.
Note: See TracBrowser for help on using the repository browser.