Module

fLabTestGroups

Path

C:\CPRS\CPRS30\fLabTestGroups.pas

Last Modified

7/15/2014 3:26:38 PM

Units Used in Interface

Name Comments
fBase508Form -

Units Used in Implementation

Name Comments
fLabs -
rLabs -
uCore -

Classes

Name Comments
TfrmLabTestGroups -

Procedures

Name Owner Declaration Scope Comments
AddTests TfrmLabTestGroups procedure AddTests(tests: TStrings); Private Private declarations
cboSpecimenNeedData TfrmLabTestGroups procedure cboSpecimenNeedData(Sender: TObject; const StartFrom: string; Direction, InsertAt: Integer); Public/Published -
cboTestsChange TfrmLabTestGroups procedure cboTestsChange(Sender: TObject); Public/Published -
cboTestsEnter TfrmLabTestGroups procedure cboTestsEnter(Sender: TObject); Public/Published -
cboTestsExit TfrmLabTestGroups procedure cboTestsExit(Sender: TObject); Public/Published -
cboTestsNeedData TfrmLabTestGroups procedure cboTestsNeedData(Sender: TObject; const StartFrom: string; Direction, InsertAt: Integer); Public/Published -
cboUsersClick TfrmLabTestGroups procedure cboUsersClick(Sender: TObject); Public/Published -
cboUsersNeedData TfrmLabTestGroups procedure cboUsersNeedData(Sender: TObject; const StartFrom: string; Direction, InsertAt: Integer); Public/Published -
cmdAddClick TfrmLabTestGroups procedure cmdAddClick(Sender: TObject); Public/Published -
cmdAddTestClick TfrmLabTestGroups procedure cmdAddTestClick(Sender: TObject); Public/Published -
cmdClearClick TfrmLabTestGroups procedure cmdClearClick(Sender: TObject); Public/Published
Var
i: integer;
cmdDeleteClick TfrmLabTestGroups procedure cmdDeleteClick(Sender: TObject); Public/Published -
cmdDownClick TfrmLabTestGroups procedure cmdDownClick(Sender: TObject); Public/Published -
cmdOKClick TfrmLabTestGroups procedure cmdOKClick(Sender: TObject); Public/Published -
cmdRemoveClick TfrmLabTestGroups procedure cmdRemoveClick(Sender: TObject); Public/Published -
cmdReplaceClick TfrmLabTestGroups procedure cmdReplaceClick(Sender: TObject); Public/Published -
cmdUpClick TfrmLabTestGroups procedure cmdUpClick(Sender: TObject); Public/Published -
FormCreate TfrmLabTestGroups procedure FormCreate(Sender: TObject); Public/Published -
lstListClick TfrmLabTestGroups procedure lstListClick(Sender: TObject); Public/Published -
lstTestGroupsChange TfrmLabTestGroups procedure lstTestGroupsChange(Sender: TObject); Public/Published -
pnlDownButtonEnter TfrmLabTestGroups procedure pnlDownButtonEnter(Sender: TObject); Public/Published -
pnlDownButtonExit TfrmLabTestGroups procedure pnlDownButtonExit(Sender: TObject); Public/Published -
pnlDownButtonResize TfrmLabTestGroups procedure pnlDownButtonResize(Sender: TObject); Public/Published -
pnlUpButtonEnter TfrmLabTestGroups procedure pnlUpButtonEnter(Sender: TObject); Public/Published -
pnlUpButtonExit TfrmLabTestGroups procedure pnlUpButtonExit(Sender: TObject); Public/Published -
pnlUpButtonResize TfrmLabTestGroups procedure pnlUpButtonResize(Sender: TObject); Public/Published -
SelectTestGroups - procedure SelectTestGroups(FontSize: Integer); Interfaced -
TestGroupEnable TfrmLabTestGroups procedure TestGroupEnable; Private -


Module Source

1     unit fLabTestGroups;
2     
3     interface
4     
5     uses
6       Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
7       ExtCtrls, Buttons, ORCtrls, StdCtrls, fBase508Form, VA508AccessibilityManager;
8     
9     type
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    
74    procedure SelectTestGroups(FontSize: Integer);
75    
76    implementation
77    
78    uses fLabs, ORFn, rLabs, uCore, VAUtils, VA508AccessibilityRouter;
79    
80    {$R *.DFM}
81    
82    procedure SelectTestGroups(FontSize: Integer);
83    var
84      frmLabTestGroups: TfrmLabTestGroups;
85      W, H: integer;
86    begin
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;
117   end;
118   
119   procedure TfrmLabTestGroups.FormCreate(Sender: TObject);
120   var
121     i: integer;
122     blood, urine, serum, plasma: string;
123   begin
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;
154   end;
155   
156   procedure TfrmLabTestGroups.cboTestsNeedData(Sender: TObject;
157     const StartFrom: string; Direction, InsertAt: Integer);
158   begin
159     cboTests.ForDataUse(ChemTest(StartFrom, Direction));
160   end;
161   
162   procedure TfrmLabTestGroups.cmdOKClick(Sender: TObject);
163   begin
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;
172   end;
173   
174   procedure TfrmLabTestGroups.cmdClearClick(Sender: TObject);
175   //var
176     //i: integer;
177   begin
178     lstList.Clear;
179     lstListClick(self);
180     lstTestGroups.ClearSelection;
181     //for i := 0 to lstTestGroups.Count - 1 do
182     //  lstTestGroups.Selected[i] := false;
183   end;
184   
185   procedure TfrmLabTestGroups.cmdRemoveClick(Sender: TObject);
186   var
187     newindex: integer;
188   begin
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;
200   end;
201   
202   procedure TfrmLabTestGroups.cmdUpClick(Sender: TObject);
203   var
204     newindex: integer;
205     templine: string;
206   begin
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;
217   end;
218   
219   procedure TfrmLabTestGroups.cmdDownClick(Sender: TObject);
220   var
221     newindex: integer;
222     templine: string;
223   begin
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;
234   end;
235   
236   procedure TfrmLabTestGroups.lstListClick(Sender: TObject);
237   begin
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;
257   end;
258   
259   procedure TfrmLabTestGroups.cboUsersNeedData(Sender: TObject;
260     const StartFrom: string; Direction, InsertAt: Integer);
261   begin
262     cboUsers.ForDataUse(Users(StartFrom, Direction));
263   end;
264   
265   procedure TfrmLabTestGroups.cboSpecimenNeedData(Sender: TObject;
266     const StartFrom: string; Direction, InsertAt: Integer);
267   begin
268     cboSpecimen.ForDataUse(Specimens(StartFrom, Direction));
269   end;
270   
271   procedure TfrmLabTestGroups.cboUsersClick(Sender: TObject);
272   begin
273     FastAssign(TestGroups(cboUsers.ItemIEN), lstTestGroups.Items);
274     TestGroupEnable;
275   end;
276   
277   procedure TfrmLabTestGroups.AddTests(tests: TStrings);
278   var
279     i, j, textindex: integer;
280     ok: boolean;
281   begin
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);
300   end;
301   
302   procedure TfrmLabTestGroups.lstTestGroupsChange(Sender: TObject);
303   begin
304     if lstTestGroups.ItemIEN > 0 then
305     begin
306       AddTests(ATestGroup(lstTestGroups.ItemIEN, cboUsers.ItemIEN));
307     end;
308   end;
309   
310   procedure TfrmLabTestGroups.TestGroupEnable;
311   begin
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;
315   end;
316   
317   procedure TfrmLabTestGroups.cmdReplaceClick(Sender: TObject);
318   var
319     text: string;
320     i: integer;
321   begin
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;  
335   end;
336   
337   procedure TfrmLabTestGroups.cmdAddClick(Sender: TObject);
338   var
339     text: string;
340     i: integer;
341   begin
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;  
360   end;
361   
362   procedure TfrmLabTestGroups.cmdDeleteClick(Sender: TObject);
363   var
364     text: string;
365     i: integer;
366   begin
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;
386   end;
387   
388   procedure TfrmLabTestGroups.cboTestsChange(Sender: TObject);
389   begin
390     cmdAddTest.Enabled := cboTests.ItemIndex > -1;
391   end;
392   
393   procedure TfrmLabTestGroups.cboTestsEnter(Sender: TObject);
394   begin
395     cmdAddTest.Default := true;
396   end;
397   
398   procedure TfrmLabTestGroups.cboTestsExit(Sender: TObject);
399   begin
400     cmdAddTest.Default := false;
401   end;
402   
403   procedure TfrmLabTestGroups.cmdAddTestClick(Sender: TObject);
404   begin
405     AddTests(ATest(cboTests.ItemIEN));
406   end;
407   
408   procedure TfrmLabTestGroups.pnlUpButtonEnter(Sender: TObject);
409   begin
410     pnlUpButton.BevelOuter := bvLowered;
411   end;
412   
413   procedure TfrmLabTestGroups.pnlUpButtonExit(Sender: TObject);
414   begin
415     pnlUpButton.BevelOuter := bvNone;
416   end;
417   
418   procedure TfrmLabTestGroups.pnlDownButtonEnter(Sender: TObject);
419   begin
420     pnlDownButton.BevelOuter := bvLowered;
421   end;
422   
423   procedure TfrmLabTestGroups.pnlDownButtonExit(Sender: TObject);
424   begin
425     pnlDownButton.BevelOuter := bvNone;
426   end;
427   
428   procedure TfrmLabTestGroups.pnlUpButtonResize(Sender: TObject);
429   begin
430     cmdUp.Width := pnlUpButton.Width;
431   end;
432   
433   procedure TfrmLabTestGroups.pnlDownButtonResize(Sender: TObject);
434   begin
435     cmdDown.Width := pnlDownButton.Width;
436   end;
437   
438   end.

Module Calls (2 levels)


fLabTestGroups
 ├fBase508Form
 │ ├uConst
 │ └uHelpManager
 ├fLabs
 │ ├fHSplit
 │ ├fLabTest
 │ ├fLabTests
 │ ├fLabTestGroups...
 │ ├uConst
 │ ├fBase508Form...
 │ ├uCore
 │ ├rLabs
 │ ├rCore
 │ ├rOrders
 │ ├fLabPrint
 │ ├fFrame
 │ ├fRptBox
 │ ├fReportsPrint
 │ ├rReports
 │ ├rGraphs
 │ └uReports
 ├rLabs...
 └uCore...

Module Called-By (2 levels)


           fLabTestGroups
                  fLabs┘ 
               fFrame┤   
             fLabTest┤   
            fLabTests┤   
    fLabTestGroups...┤   
            fLabPrint┤   
fOptionsReportsCustom┘