source: cprs/branches/tmg-cprs/CPRS-Chart/fLabTestGroups.pas@ 697

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

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