source: cprs/trunk/CPRS-Chart/Options/fOptionsLists.pas@ 1443

Last change on this file since 1443 was 829, checked in by Kevin Toppenberg, 15 years ago

Upgrade to version 27
File size: 17.6 KB
Line 
1unit fOptionsLists;
2
3interface
4
5uses
6 Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
7 StdCtrls, ExtCtrls, ORCtrls, OrFn, Menus, fBase508Form,
8 VA508AccessibilityManager;
9
10type
11 TfrmOptionsLists = class(TfrmBase508Form)
12 pnlBottom: TPanel;
13 btnOK: TButton;
14 btnCancel: TButton;
15 lblAddby: TLabel;
16 lblPatientsAdd: TLabel;
17 lblPersonalPatientList: TLabel;
18 lblPersonalLists: TLabel;
19 lstAddBy: TORComboBox;
20 btnPersonalPatientRA: TButton;
21 btnPersonalPatientR: TButton;
22 lstListPats: TORListBox;
23 lstPersonalPatients: TORListBox;
24 btnListAddAll: TButton;
25 btnNewList: TButton;
26 btnDeleteList: TButton;
27 lstPersonalLists: TORListBox;
28 radAddByType: TRadioGroup;
29 btnListSaveChanges: TButton;
30 btnListAdd: TButton;
31 lblInfo: TMemo;
32 bvlBottom: TBevel;
33 mnuPopPatient: TPopupMenu;
34 mnuPatientID: TMenuItem;
35 grpVisibility: TRadioGroup;
36 procedure FormCreate(Sender: TObject);
37 procedure btnNewListClick(Sender: TObject);
38 procedure radAddByTypeClick(Sender: TObject);
39 procedure lstPersonalListsChange(Sender: TObject);
40 procedure lstAddByClick(Sender: TObject);
41 procedure btnDeleteListClick(Sender: TObject);
42 procedure btnListSaveChangesClick(Sender: TObject);
43 procedure btnPersonalPatientRAClick(Sender: TObject);
44 procedure btnListAddAllClick(Sender: TObject);
45 procedure btnPersonalPatientRClick(Sender: TObject);
46 procedure lstPersonalPatientsChange(Sender: TObject);
47 procedure btnListAddClick(Sender: TObject);
48 procedure lstListPatsChange(Sender: TObject);
49 procedure FormShow(Sender: TObject);
50 procedure lstAddByNeedData(Sender: TObject; const StartFrom: String;
51 Direction, InsertAt: Integer);
52 procedure btnOKClick(Sender: TObject);
53 procedure mnuPatientIDClick(Sender: TObject);
54 procedure lstListPatsMouseDown(Sender: TObject; Button: TMouseButton;
55 Shift: TShiftState; X, Y: Integer);
56 procedure lstPersonalPatientsMouseDown(Sender: TObject;
57 Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
58 procedure lstAddByKeyPress(Sender: TObject; var Key: Char);
59 procedure grpVisibilityClick(Sender: TObject);
60 private
61 { Private declarations }
62 FLastList: integer;
63 FChanging: boolean;
64 procedure AddIfUnique(entry: string; aList: TORListBox);
65 public
66 { Public declarations }
67 end;
68
69var
70 frmOptionsLists: TfrmOptionsLists;
71
72procedure DialogOptionsLists(topvalue, leftvalue, fontsize: integer; var actiontype: Integer);
73
74implementation
75
76uses fOptionsNewList, rOptions, uOptions, rCore, fPtSelOptns, VAUtils;
77
78{$R *.DFM}
79
80const
81 LIST_ADD = 1;
82 LIST_PERSONAL = 2;
83
84procedure DialogOptionsLists(topvalue, leftvalue, fontsize: integer; var actiontype: Integer);
85// create the form and make it modal, return an action
86var
87 frmOptionsLists: TfrmOptionsLists;
88begin
89 frmOptionsLists := TfrmOptionsLists.Create(Application);
90 actiontype := 0;
91 try
92 with frmOptionsLists do
93 begin
94 if (topvalue < 0) or (leftvalue < 0) then
95 Position := poScreenCenter
96 else
97 begin
98 Position := poDesigned;
99 Top := topvalue;
100 Left := leftvalue;
101 end;
102 ResizeAnchoredFormToFont(frmOptionsLists);
103 ShowModal;
104 actiontype := btnOK.Tag;
105 end;
106 finally
107 frmOptionsLists.Release;
108 end;
109end;
110
111procedure TfrmOptionsLists.FormCreate(Sender: TObject);
112begin
113 rpcGetPersonalLists(lstPersonalLists.Items);
114 grpVisibility.ItemIndex := 1;
115 grpVisibility.Enabled := FALSE;
116 radAddByType.ItemIndex := 0;
117 radAddByTypeClick(self);
118 FLastList := 0;
119end;
120
121procedure TfrmOptionsLists.btnNewListClick(Sender: TObject);
122var
123 newlist: string;
124 newlistnum: integer;
125begin
126 newlist := '';
127 DialogOptionsNewList(Font.Size, newlist);
128 newlistnum := strtointdef(Piece(newlist, '^', 1), 0);
129 if newlistnum > 0 then
130 begin
131 with lstPersonalLists do
132 begin
133 Items.Add(newlist);
134 SelectByIEN(newlistnum);
135 end;
136 lstPersonalListsChange(self);
137 lstPersonalPatients.Items.Clear;
138 lstPersonalPatientsChange(self);
139 end;
140end;
141
142procedure TfrmOptionsLists.radAddByTypeClick(Sender: TObject);
143begin
144 with lstAddBy do
145 begin
146 case radAddByType.ItemIndex of
147 0: begin
148 ListItemsOnly := true;
149 LongList := true;
150 InitLongList('');
151 lblAddby.Caption := 'Patient:';
152 end;
153 1: begin
154 ListItemsOnly := false;
155 LongList := false;
156 ListWardAll(lstAddBy.Items);
157 lblAddby.Caption := 'Ward:';
158 end;
159 2: begin
160 ListItemsOnly := true;
161 LongList := true;
162 InitLongList('');
163 lblAddby.Caption := 'Clinic:';
164 end;
165 3: begin
166 ListItemsOnly := true;
167 LongList := true;
168 InitLongList('');
169 lblAddby.Caption := 'Provider:';
170 end;
171 4: begin
172 ListItemsOnly := false;
173 LongList := false;
174 ListSpecialtyAll(lstAddBy.Items);
175 lblAddby.Caption := 'Specialty:';
176 end;
177 5: begin
178 ListItemsOnly := false;
179 LongList := false;
180 ListTeamAll(lstAddBy.Items);
181 lblAddby.Caption := 'List:';
182 end;
183 end;
184 lstAddby.Caption := lblAddby.Caption;
185 ItemIndex := -1;
186 Text := '';
187 end;
188 lstListPats.Items.Clear;
189 lstListPatsChange(self);
190end;
191
192procedure TfrmOptionsLists.AddIfUnique(entry: string; aList: TORListBox);
193var
194 i: integer;
195 ien: string;
196 inlist: boolean;
197begin
198 ien := Piece(entry, '^', 1);
199 inlist := false;
200 with aList do
201 for i := 0 to Items.Count - 1 do
202 if ien = Piece(Items[i], '^', 1) then
203 begin
204 inlist := true;
205 break;
206 end;
207 if not inlist then
208 aList.Items.Add(entry);
209end;
210
211procedure TfrmOptionsLists.lstPersonalListsChange(Sender: TObject);
212var
213 x: integer;
214begin
215 if (btnListSaveChanges.Enabled) and (not FChanging) then
216 begin
217 if InfoBox('Do you want to save changes to '
218 + Piece(lstPersonalLists.Items[FLastList], '^', 2) + '?',
219 'Confirmation', MB_YESNO or MB_ICONQUESTION) = IDYES then
220 btnListSaveChangesClick(self);
221 end;
222 if lstPersonalLists.ItemIndex > -1 then FLastList := lstPersonalLists.ItemIndex;
223 lstPersonalPatients.Items.Clear;
224 btnDeleteList.Enabled := lstPersonalLists.ItemIndex > -1;
225 with lstPersonalLists do
226 begin
227 if (ItemIndex < 0) or (Items.Count <1) then
228 begin
229 btnListAdd.Enabled := false;
230 btnListAddAll.Enabled := false;
231 btnPersonalPatientR.Enabled := false;
232 btnPersonalPatientRA.Enabled := false;
233 btnListSaveChanges.Enabled := false;
234 grpVisibility.Enabled := False;
235 exit;
236 end;
237 ListPtByTeam(lstPersonalPatients.Items, strtointdef(Piece(Items[ItemIndex], '^', 1), 0));
238 grpVisibility.Enabled := TRUE;
239 FChanging := True;
240 x := StrToIntDef(Piece(Items[ItemIndex], '^', 9), 1);
241 if x = 2 then x := 1;
242 grpVisibility.ItemIndex := x;
243 FChanging := False;
244 btnDeleteList.Enabled := true;
245 end;
246 if lstPersonalPatients.Items.Count = 1 then // avoid selecting '^No patients found.' msg
247 if Piece(lstPersonalPatients.Items[0], '^', 1) = '' then
248 begin
249 btnPersonalPatientR.Enabled := false;
250 btnPersonalPatientRA.Enabled := false;
251 exit;
252 end;
253 btnPersonalPatientR.Enabled := lstPersonalPatients.SelCount > 0;
254 btnPersonalPatientRA.Enabled := lstPersonalPatients.Items.Count > 0;
255 btnListSaveChanges.Enabled := false;
256end;
257
258procedure TfrmOptionsLists.lstAddByClick(Sender: TObject);
259var
260 ien: string;
261 visitstart, visitstop, i: integer;
262 visittoday, visitbegin, visitend: TFMDateTime;
263 aList: TStringList;
264 PtRec: TPtIDInfo;
265begin
266 if lstAddBy.ItemIndex < 0 then exit;
267 ien := Piece(lstAddBy.Items[lstAddBy.ItemIndex], '^', 1);
268 case radAddByType.ItemIndex of
269 0:
270 begin
271 PtRec := GetPtIDInfo(ien);
272 lblAddBy.Caption := 'Patient: SSN: ' + PtRec.SSN;
273 lstAddby.Caption := lblAddby.Caption;
274 AddIfUnique(lstAddBy.Items[lstAddBy.ItemIndex], lstListPats);
275 end;
276 1:
277 begin
278 ListPtByWard(lstListPats.Items, strtointdef(ien,0));
279 end;
280 2:
281 begin
282 rpcGetApptUserDays(visitstart, visitstop); // use user's date range for appointments
283 visittoday := FMToday;
284 visitbegin := FMDateTimeOffsetBy(visittoday, LowerOf(visitstart, visitstop));
285 visitend := FMDateTimeOffsetBy(visittoday, HigherOf(visitstart, visitstop));
286 aList := TStringList.Create;
287 ListPtByClinic(lstListPats.Items, strtointdef(ien, 0), floattostr(visitbegin), floattostr(visitend));
288 for i := 0 to aList.Count - 1 do
289 AddIfUnique(aList[i], lstListPats);
290 aList.Free;
291 end;
292 3:
293 begin
294 ListPtByProvider(lstListPats.Items, strtoint64def(ien,0));
295 end;
296 4:
297 begin
298 ListPtBySpecialty(lstListPats.Items, strtointdef(ien,0));
299 end;
300 5:
301 begin
302 ListPtByTeam(lstListPats.Items, strtointdef(ien,0));
303 end;
304 end;
305 if lstListPats.Items.Count = 1 then // avoid selecting '^No patients found.' msg
306 if Piece(lstListPats.Items[0], '^', 1) = '' then
307 begin
308 btnListAddAll.Enabled := false;
309 btnListAdd.Enabled := false;
310 exit;
311 end;
312 btnListAddAll.Enabled := (lstListPats.Items.Count > 0) and (lstPersonalLists.ItemIndex > -1);
313 btnListAdd.Enabled := (lstListPats.SelCount > 0) and (lstPersonalLists.ItemIndex > -1);
314end;
315
316procedure TfrmOptionsLists.btnDeleteListClick(Sender: TObject);
317var
318 oldindex: integer;
319 deletemsg: string;
320begin
321 with lstPersonalLists do
322 deletemsg := 'You have selected "' + DisplayText[ItemIndex]
323 + '" to be deleted.' + CRLF + 'Are you sure you want to delete this list?';
324 if InfoBox(deletemsg, 'Confirmation', MB_YESNO or MB_ICONQUESTION) = IDYES then
325 begin
326 btnListSaveChanges.Enabled := false;
327 with lstPersonalLists do
328 begin
329 oldindex := ItemIndex;
330 if oldindex > -1 then
331 begin
332 rpcDeleteList(Piece(Items[oldindex], '^', 1));
333 Items.Delete(oldindex);
334 btnPersonalPatientRAClick(self);
335 btnListSaveChanges.Enabled := false;
336 end;
337 if Items.Count > 0 then
338 begin
339 if oldindex = 0 then
340 ItemIndex := 0
341 else if oldindex > (Items.Count - 1) then
342 ItemIndex := Items.Count - 1
343 else
344 ItemIndex := oldindex;
345 btnListSaveChanges.Enabled := false;
346 lstPersonalListsChange(self);
347 end;
348 end;
349 end;
350end;
351
352procedure TfrmOptionsLists.btnListSaveChangesClick(Sender: TObject);
353var
354 listien: integer;
355begin
356 listien := strtointdef(Piece(lstPersonalLists.Items[FLastList], '^', 1), 0);
357 rpcSaveListChanges(lstPersonalPatients.Items, listien, grpVisibility.ItemIndex);
358 btnListSaveChanges.Enabled := false;
359 rpcGetPersonalLists(lstPersonalLists.Items);
360 lstPersonalLists.ItemIndex := FLastList;
361 lstPersonalListsChange(Self);
362 if lstPersonalPatients.CanFocus then
363 lstPersonalPatients.SetFocus;
364end;
365
366procedure TfrmOptionsLists.btnPersonalPatientRAClick(Sender: TObject);
367begin
368 lstPersonalPatients.Items.Clear;
369 btnPersonalPatientR.Enabled := lstPersonalPatients.SelCount > 0;
370 btnPersonalPatientRA.Enabled := lstPersonalPatients.Items.Count > 0;
371 btnListSaveChanges.Enabled := true;
372end;
373
374procedure TfrmOptionsLists.btnListAddAllClick(Sender: TObject);
375var
376 i: integer;
377begin
378 with lstPersonalPatients do
379 begin
380 if Items.Count = 1 then
381 if Piece(Items[0], '^', 1) = '' then
382 Items.Clear;
383 end;
384 with lstListPats do
385 begin
386 for i := 0 to Items.Count - 1 do
387 AddIfUnique(Items[i], lstPersonalPatients);
388 Items.Clear;
389 lstPersonalPatientsChange(self);
390 lstAddBy.ItemIndex := -1;
391 btnListAddAll.Enabled := false;
392 lstPersonalPatientsChange(self);
393 end;
394 btnListSaveChanges.Enabled := true;
395end;
396
397procedure TfrmOptionsLists.btnPersonalPatientRClick(Sender: TObject);
398var
399 i: integer;
400begin
401 if not btnPersonalPatientR.Enabled then exit;
402 with lstPersonalPatients do
403 for i := Items.Count - 1 downto 0 do
404 if Selected[i] then
405 Items.Delete(i);
406 btnPersonalPatientR.Enabled := lstPersonalPatients.SelCount > 0;
407 btnPersonalPatientRA.Enabled := lstPersonalPatients.Items.Count > 0;
408 btnListSaveChanges.Enabled := true;
409end;
410
411procedure TfrmOptionsLists.lstPersonalPatientsChange(Sender: TObject);
412begin
413 if lstPersonalPatients.SelCount = 1 then // avoid selecting '^No patients found.' msg
414 if Piece(lstPersonalPatients.Items[0], '^', 1) = '' then
415 begin
416 btnPersonalPatientR.Enabled := false;
417 btnPersonalPatientRA.Enabled := false;
418 exit;
419 end;
420 btnPersonalPatientR.Enabled := lstPersonalPatients.SelCount > 0;
421 btnPersonalPatientRA.Enabled := lstPersonalPatients.Items.Count > 0;
422end;
423
424procedure TfrmOptionsLists.btnListAddClick(Sender: TObject);
425var
426 i: integer;
427begin
428 if not btnListAdd.Enabled then exit;
429 with lstPersonalPatients do
430 begin
431 if Items.Count = 1 then
432 if Piece(Items[0], '^', 1) = '' then
433 Items.Clear;
434 end;
435 with lstListPats do
436 for i := Items.Count - 1 downto 0 do
437 if Selected[i] then
438 begin
439 AddIfUnique(Items[i], lstPersonalPatients);
440 Items.Delete(i);
441 end;
442 lstListPatsChange(self);
443 lstPersonalPatientsChange(self);
444 btnListSaveChanges.Enabled := true;
445end;
446
447procedure TfrmOptionsLists.lstListPatsChange(Sender: TObject);
448begin
449 if lstListPats.SelCount = 1 then // avoid selecting '^No patients found.' msg
450 if Piece(lstListPats.Items[0], '^', 1) = '' then
451 exit;
452 btnListAdd.Enabled := (lstListPats.SelCount > 0) and (lstPersonalLists.ItemIndex > -1);
453 btnListAddAll.Enabled := (lstListPats.Items.Count > 0) and (lstPersonalLists.ItemIndex > -1);
454end;
455
456procedure TfrmOptionsLists.FormShow(Sender: TObject);
457begin
458 with lstPersonalLists do
459 if Items.Count < 1 then
460 ShowMsg('You have no personal lists. Use "New List..." to create one.')
461 else
462 begin
463 ItemIndex := 0;
464 lstPersonalListsChange(self);
465 end;
466end;
467
468procedure TfrmOptionsLists.grpVisibilityClick(Sender: TObject);
469begin
470 inherited;
471 if not FChanging then btnListSaveChanges.Enabled := True;
472end;
473
474procedure TfrmOptionsLists.lstAddByNeedData(Sender: TObject;
475 const StartFrom: String; Direction, InsertAt: Integer);
476begin
477 with lstAddBy do
478 begin
479 case radAddByType.ItemIndex of
480 0: begin
481 Pieces := '2';
482 ForDataUse(SubSetOfPatients(StartFrom, Direction));
483 end;
484 1: begin
485 Pieces := '2';
486 end;
487 2: begin
488 Pieces := '2';
489 ForDataUse(SubSetOfClinics(StartFrom, Direction));
490 end;
491 3: begin
492 Pieces := '2,3';
493 ForDataUse(SubSetOfProviders(StartFrom, Direction));
494 end;
495 4: begin
496 Pieces := '2';
497 end;
498 5: begin
499 Pieces := '2';
500 end;
501 end;
502 end;
503end;
504
505procedure TfrmOptionsLists.btnOKClick(Sender: TObject);
506begin
507 if btnListSaveChanges.Enabled then
508 begin
509 if InfoBox('Do you want to save changes to '
510 + Piece(lstPersonalLists.Items[FLastList], '^', 2) + '?',
511 'Confirmation', MB_YESNO or MB_ICONQUESTION) = IDYES then
512 btnListSaveChangesClick(self);
513 end;
514end;
515
516procedure TfrmOptionsLists.mnuPatientIDClick(Sender: TObject);
517begin
518 case mnuPopPatient.Tag of
519 LIST_PERSONAL: DisplayPtInfo(lstPersonalPatients.ItemID);
520 LIST_ADD: DisplayPtInfo(lstListPats.ItemID);
521 end;
522end;
523
524procedure TfrmOptionsLists.lstListPatsMouseDown(Sender: TObject;
525 Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
526begin
527 mnuPopPatient.AutoPopup := (lstListPats.Items.Count > 0)
528 and (lstListPats.ItemIndex > -1)
529 and (lstListPats.SelCount = 1)
530 and (Button = mbRight)
531 and (btnListAdd.Enabled);
532 mnuPopPatient.Tag := LIST_ADD;
533end;
534
535procedure TfrmOptionsLists.lstPersonalPatientsMouseDown(Sender: TObject;
536 Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
537begin
538 mnuPopPatient.AutoPopup := (lstPersonalPatients.Items.Count > 0)
539 and (lstPersonalPatients.ItemIndex > -1)
540 and (lstPersonalPatients.SelCount = 1)
541 and (Button = mbRight)
542 and (btnPersonalPatientR.Enabled);
543 mnuPopPatient.Tag := LIST_PERSONAL;
544end;
545
546procedure TfrmOptionsLists.lstAddByKeyPress(Sender: TObject;
547 var Key: Char);
548
549 procedure ShowMatchingPatients;
550 begin
551 with lstAddBy do
552 begin
553 if ShortCount > 0 then
554 begin
555 if ShortCount = 1 then
556 begin
557 ItemIndex := 0;
558 end;
559 Items.Add(LLS_LINE);
560 Items.Add(LLS_SPACE);
561 end;
562 InitLongList('');
563 end;
564 Key := #0; //Now that we've selected it, don't process the last keystroke!
565 end;
566
567var
568 FutureText: string;
569begin
570 if radAddByType.ItemIndex = 0 {patient} then
571 begin
572 with lstAddBy do
573 begin
574 FutureText := Text + Key;
575 if frmPtSelOptns.IsLast5(FutureText) then
576 begin
577 ListPtByLast5(Items, FutureText);
578 ShowMatchingPatients;
579 end
580 else if frmPtSelOptns.IsFullSSN(FutureText) then
581 begin
582 ListPtByFullSSN(Items, FutureText);
583 ShowMatchingPatients;
584 end;
585 end;
586 end;
587end;
588
589end.
Note: See TracBrowser for help on using the repository browser.