source: cprs/trunk/CPRS-Chart/Consults/fConsultBSt.pas@ 1806

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

Upgrade to version 27

File size: 3.3 KB
Line 
1unit fConsultBSt;
2
3interface
4
5uses
6 Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
7 ExtCtrls, ORCtrls, StdCtrls, ORFn, uConsults, fBase508Form,
8 VA508AccessibilityManager;
9
10type
11 TfrmConsultsByStatus = class(TfrmBase508Form)
12 pnlBase: TORAutoPanel;
13 lblStatus: TLabel;
14 radSort: TRadioGroup;
15 lstStatus: TORListBox;
16 cmdOK: TButton;
17 cmdCancel: TButton;
18 procedure cmdCancelClick(Sender: TObject);
19 procedure cmdOKClick(Sender: TObject);
20 private
21 FChanged: Boolean;
22 FStatus: string;
23 FStatusName: string;
24 FAscending: Boolean;
25 end;
26
27 TStatusContext = record
28 Changed: Boolean;
29 Status: string;
30 StatusName: string;
31 Ascending: Boolean;
32 end;
33
34function SelectStatus(FontSize: Integer; CurrentContext: TSelectContext; var StatusContext: TStatusContext): boolean ;
35
36implementation
37
38{$R *.DFM}
39
40uses rConsults, rCore, uCore;
41
42const
43 TX_STAT_TEXT = 'Select a consult status or press Cancel.';
44 TX_STAT_CAP = 'Missing Status';
45
46function SelectStatus(FontSize: Integer; CurrentContext: TSelectContext; var StatusContext: TStatusContext): boolean ;
47{ displays Status select form for consults and returns a record of the selection }
48var
49 frmConsultsByStatus: TfrmConsultsByStatus;
50 W, H, i, j: Integer;
51 CurrentStatus: string;
52begin
53 frmConsultsByStatus := TfrmConsultsByStatus.Create(Application);
54 try
55 with frmConsultsByStatus do
56 begin
57 Font.Size := FontSize;
58 W := ClientWidth;
59 H := ClientHeight;
60 ResizeToFont(FontSize, W, H);
61 ClientWidth := W; pnlBase.Width := W;
62 ClientHeight := H; pnlBase.Height := H;
63 FChanged := False;
64 with radSort do {if SortConsultsAscending then ItemIndex := 0 else} ItemIndex := 1;
65 FastAssign(SubSetOfStatus, lstStatus.Items);
66 CurrentStatus := CurrentContext.Status;
67 if CurrentStatus <> '' then with lstStatus do
68 begin
69 i := 1;
70 while Piece(CurrentStatus, ',', i) <> '' do
71 begin
72 j := SelectByID(Piece(CurrentStatus, ',', i));
73 if j > -1 then Selected[j] := True;
74 Inc(i);
75 end;
76 end;
77 ShowModal;
78 with StatusContext do
79 begin
80 Changed := FChanged;
81 Status := FStatus;
82 StatusName := FStatusName;
83 Ascending := FAscending;
84 Result := Changed ;
85 end; {with StatusContext}
86 end; {with frmConsultsByStatus}
87 finally
88 frmConsultsByStatus.Release;
89 end;
90end;
91
92procedure TfrmConsultsByStatus.cmdCancelClick(Sender: TObject);
93begin
94 Close;
95end;
96
97procedure TfrmConsultsByStatus.cmdOKClick(Sender: TObject);
98var
99 i: integer;
100begin
101 if lstStatus.SelCount = 0 then
102 begin
103 InfoBox(TX_STAT_TEXT, TX_STAT_CAP, MB_OK or MB_ICONWARNING);
104 Exit;
105 end;
106 FChanged := True;
107 with lstStatus do for i := 0 to Items.Count-1 do if Selected[i] then
108 begin
109 if Piece(Items[i], U, 1) <> '999' then
110 FStatus := FStatus + Piece(Items[i], U, 1) + ','
111 else
112 FStatus := FStatus + Piece(Items[i],U,3) ;
113 FStatusName := FStatusName + DisplayText[i] + ',' ;
114 end;
115 FStatus := Copy(FStatus, 1, Length(FStatus)-1);
116 FStatusName := Copy(FStatusName, 1, Length(FStatusName)-1);
117 FAscending := radSort.ItemIndex = 0;
118 Close;
119end;
120
121end.
Note: See TracBrowser for help on using the repository browser.