Module

fOptionsTeams

Path

C:\CPRS\CPRS30\Options\fOptionsTeams.pas

Last Modified

7/15/2014 3:26:40 PM

Units Used in Interface

Name Comments
fBase508Form -

Units Used in Implementation

Name Comments
fOptions -
rCore -
rOptions -
uOptions -

Classes

Name Comments
TfrmOptionsTeams -

Procedures

Name Owner Declaration Scope Comments
btnRemoveClick TfrmOptionsTeams procedure btnRemoveClick(Sender: TObject); Public/Published -
cboSubscribeClick TfrmOptionsTeams procedure cboSubscribeClick(Sender: TObject); Public/Published -
cboSubscribeKeyDown TfrmOptionsTeams procedure cboSubscribeKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); Public/Published -
cboSubscribeMouseClick TfrmOptionsTeams procedure cboSubscribeMouseClick(Sender: TObject); Public/Published -
chkPersonalClick TfrmOptionsTeams procedure chkPersonalClick(Sender: TObject); Public/Published -
chkRestrictClick TfrmOptionsTeams procedure chkRestrictClick(Sender: TObject); Public/Published -
DialogOptionsTeams - procedure DialogOptionsTeams(topvalue, leftvalue, fontsize: integer; var actiontype: Integer); Interfaced Create the form and make it modal, return an action
FillATeams TfrmOptionsTeams procedure FillATeams; Private Private declarations
FillList TfrmOptionsTeams procedure FillList(alist: TORListBox; members: TStrings); Private -
FormCreate TfrmOptionsTeams procedure FormCreate(Sender: TObject); Public/Published -
lstPatientsMouseDown TfrmOptionsTeams procedure lstPatientsMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); Public/Published -
lstTeamsClick TfrmOptionsTeams procedure lstTeamsClick(Sender: TObject); Public/Published -
MergeList TfrmOptionsTeams procedure MergeList(alist: TORListBox; members: TStrings); Private -
mnuPatientIDClick TfrmOptionsTeams procedure mnuPatientIDClick(Sender: TObject); Public/Published -

Functions

Name Owner Declaration Scope Comments
ItemNotAMember TfrmOptionsTeams function ItemNotAMember(alist: TStrings; listnum: string): boolean; Private -
MemberNotOnList TfrmOptionsTeams function MemberNotOnList(alist: TStrings; listnum: string): boolean; Private -

Global Variables

Name Type Declaration Comments
frmOptionsTeams TfrmOptionsTeams frmOptionsTeams: TfrmOptionsTeams; -


Module Source

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

Module Calls (2 levels)


fOptionsTeams
 ├fBase508Form
 │ ├uConst
 │ └uHelpManager
 ├rOptions
 │ └rCore
 ├uOptions
 │ ├rCore...
 │ └fRptBox
 └rCore...

Module Called-By (2 levels)


fOptionsTeams
   fOptions┘ 
   fFrame┘