source: cprs/trunk/CPRS-Chart/Options/uOptions.pas@ 1094

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

Upgrade to version 27
File size: 8.2 KB
Line 
1unit uOptions;
2
3interface
4
5uses
6 Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
7 StdCtrls, ExtCtrls, ComCtrls, ORFn;
8
9type
10 TSurrogate = class
11 private
12 FIEN: Int64;
13 FName: string;
14 FStart: TFMDateTime;
15 FStop: TFMDateTime;
16 public
17 property IEN: Int64 read FIEN write FIEN;
18 property Name: string read FName write FName;
19 property Start: TFMDateTime read FStart write FStart;
20 property Stop: TFMDateTime read FStop write FStop;
21 end;
22
23function RelativeDate(entry: string): integer;
24procedure DateLimits(const limit: integer; var value: integer);
25procedure ShowDisplay(editbox: TEdit);
26procedure TextExit(editbox: TEdit; var entrycheck: boolean; limitcheck: integer);
27procedure LabelSurrogate(surrogateinfo: string; alabel: TStaticText);
28procedure DisplayPtInfo(PtID: string);
29
30const
31 INVALID_DAYS = -99999;
32 DAYS_LIMIT = 999;
33 SELECTION_LIMIT = 999;
34
35implementation
36
37uses rCore, fRptBox;
38
39function RelativeDate(entry: string): integer;
40// return the number of days for the entry (e.g. -3 for T - 3)
41
42 function OKToday(value: string): boolean;
43 // check if value is used as the current date
44 begin
45 Result := false;
46 if value = 'T' then Result := true
47 else if value = 'TODAY' then Result := true
48 else if value = 'N' then Result := true
49 else if value = 'NOW' then Result := true;
50 end;
51
52 procedure GetMultiplier(var entry: string; var multiplier: integer);
53 // check if entry has a multiplier on today's date (days, weeks, months, years)
54 var
55 lastchar: char;
56 begin
57 if (entry = 'NOW') or (entry = 'TODAY') then
58 begin
59 multiplier := 1;
60 exit;
61 end;
62 lastchar := entry[length(entry)];
63 case lastchar of
64 'D': multiplier := 1;
65 'W': multiplier := 7;
66 'M': multiplier := 30;
67 'Y': multiplier := 365;
68 else multiplier := 0;
69 end;
70 if multiplier > 0 then
71 entry := copy(entry, 0, length(entry) - 1)
72 else
73 multiplier := 1;
74 end;
75
76var
77 firstpart, operator: string;
78 lenfirstpart, multiplier: integer;
79begin // begin function RelativeDate
80 Result := INVALID_DAYS;
81 entry := Uppercase(entry);
82 GetMultiplier(entry, multiplier);
83 if strtointdef(entry, INVALID_DAYS) <> INVALID_DAYS then
84 begin
85 Result := strtointdef(entry, INVALID_DAYS);
86 if Result <> INVALID_DAYS then
87 Result := Result * multiplier;
88 exit;
89 end;
90 if OKToday(entry) then // process today only
91 begin
92 Result := 0;
93 exit;
94 end;
95 firstpart := Piece(entry, ' ', 1);
96 lenfirstpart := length(firstpart);
97 if OKToday(firstpart) then // process space
98 begin
99 operator := Copy(entry, lenfirstpart + 2, 1);
100 if (operator = '+') or (operator = '-') then
101 begin
102 if Copy(entry, lenfirstpart + 3, 1) = ' ' then
103 Result := strtointdef(Copy(entry, lenfirstpart + 4, length(entry)), INVALID_DAYS)
104 else
105 Result := strtointdef(Copy(entry, lenfirstpart + 3, length(entry)), INVALID_DAYS);
106 if Result <> INVALID_DAYS then
107 if Result < 0 then
108 Result := INVALID_DAYS
109 else if operator = '-' then
110 Result := -Result;
111 end;
112 if Result <> INVALID_DAYS then
113 Result := Result * multiplier;
114 end
115 else
116 begin
117 firstpart := Piece(entry, '+', 1);
118 lenfirstpart := length(firstpart);
119 if OKToday(firstpart) then // process +
120 begin
121 if Copy(entry, lenfirstpart + 2, 1) = ' ' then
122 Result := strtointdef(Copy(entry, lenfirstpart + 3, length(entry)), INVALID_DAYS)
123 else
124 Result := strtointdef(Copy(entry, lenfirstpart + 2, length(entry)), INVALID_DAYS);
125 if Result <> INVALID_DAYS then
126 if Result < 0 then
127 Result := INVALID_DAYS
128 end
129 else
130 begin
131 firstpart := Piece(entry, '-', 1);
132 lenfirstpart := length(firstpart);
133 if OKToday(firstpart) then // process -
134 begin
135 if Copy(entry, lenfirstpart + 2, 1) = ' ' then
136 Result := strtointdef(Copy(entry, lenfirstpart + 3, length(entry)), INVALID_DAYS)
137 else
138 Result := strtointdef(Copy(entry, lenfirstpart + 2, length(entry)), INVALID_DAYS);
139 if Result <> INVALID_DAYS then
140 Result := -Result;
141 end;
142 end;
143 if Result <> INVALID_DAYS then
144 Result := Result * multiplier;
145 end;
146end;
147
148procedure DateLimits(const limit: integer; var value: integer);
149// check if date is within valid limit
150begin
151 if value > limit then
152 begin
153 beep;
154 InfoBox('Date cannot be greater than Today + ' + inttostr(limit), 'Warning', MB_OK or MB_ICONWARNING);
155 value := INVALID_DAYS;
156 end
157 else if value < -limit then
158 begin
159 beep;
160 InfoBox('Date cannot be less than Today - ' + inttostr(limit), 'Warning', MB_OK or MB_ICONWARNING);
161 value := INVALID_DAYS;
162 end;
163end;
164
165procedure ShowDisplay(editbox: TEdit);
166// displays the relative date (uses tag of editbox to hold # of days
167begin
168 with editbox do
169 begin
170 if Tag > 0 then
171 Text := 'Today + ' + inttostr(Tag)
172 else if Tag < 0 then
173 Text := 'Today - ' + inttostr(-Tag)
174 else
175 Text := 'Today';
176 Hint := Text;
177 end;
178end;
179
180procedure TextExit(editbox: TEdit; var entrycheck: boolean; limitcheck: integer);
181// checks entry in editbx if date is valid
182var
183 tagnum: integer;
184begin
185 with editbox do
186 begin
187 if entrycheck then
188 begin
189 tagnum := RelativeDate(Hint);
190 if tagnum = INVALID_DAYS then
191 begin
192 beep;
193 InfoBox('Date entry was invalid', 'Warning', MB_OK or MB_ICONWARNING);
194 SetFocus;
195 end
196 else
197 begin
198 DateLimits(limitcheck, tagnum);
199 if tagnum = INVALID_DAYS then
200 SetFocus
201 else
202 Tag := tagnum;
203 end;
204 ShowDisplay(editbox);
205 if Focused then SelectAll;
206 end;
207 entrycheck := false;
208 end;
209end;
210
211procedure LabelSurrogate(surrogateinfo: string; alabel: TStaticText);
212// surrogateinfo = surrogateIEN^surrogate name^surrogate start date/time^surrogate stop date/time
213var
214 surrogatename, surrogatestart, surrogatestop: string;
215 surrogateien: Int64;
216begin
217 surrogateien := strtoint64def(Piece(surrogateinfo, '^', 1), -1);
218 if surrogateien > 1 then
219 begin
220 surrogatename := Piece(surrogateinfo, '^', 2);
221 surrogatestart := Piece(surrogateinfo, '^', 3);
222 if surrogatestart = '-1' then surrogatestart := '0';
223 if surrogatestart = '' then surrogatestart := '0';
224 surrogatestop := Piece(surrogateinfo, '^', 4);
225 if surrogatestop = '-1' then surrogatestop := '0';
226 if surrogatestop = '' then surrogatestop := '0';
227 alabel.Caption := surrogatename;
228 if (surrogatestart <> '0') and (surrogatestop <> '0') then
229 alabel.Caption := surrogatename +
230 ' (from ' + FormatFMDateTimeStr('mmm d,yyyy@hh:nn', surrogatestart) +
231 ' until ' + FormatFMDateTimeStr('mmm d,yyyy@hh:nn', surrogatestop) + ')'
232 else if surrogatestart <> '0' then
233 alabel.Caption := surrogatename +
234 ' (from ' + FormatFMDateTimeStr('mmm d,yyyy@hh:nn', surrogatestart) + ')'
235 else if surrogatestop <> '0' then
236 alabel.Caption := surrogatename +
237 ' (until ' + FormatFMDateTimeStr('mmm d,yyyy@hh:nn', surrogatestop) + ')'
238 else
239 alabel.Caption := surrogatename;
240 end
241 else
242 alabel.Caption := '<no surrogate designated>';
243end;
244
245procedure DisplayPtInfo(PtID: string);
246var
247 PtRec: TPtIDInfo;
248 rpttext: TStringList;
249begin
250 if strtointdef(PtID, -1) < 0 then exit;
251 PtRec := GetPtIDInfo(PtID);
252 rpttext := TStringList.Create;
253 try
254 with PtRec do
255 begin
256 rpttext.Add(' ' + Name);
257 rpttext.Add('SSN: ' + SSN);
258 rpttext.Add('DOB: ' + DOB);
259 rpttext.Add('');
260 rpttext.Add(Sex);
261 rpttext.Add(SCSts);
262 rpttext.Add(Vet);
263 rpttext.Add('');
264 if length(Location) > 0 then rpttext.Add('Location: ' + Location);
265 if length(RoomBed) > 0 then rpttext.Add('Room/Bed: ' + RoomBed);
266 end;
267 ReportBox(rpttext, 'Patient ID', false);
268 finally
269 rpttext.free
270 end;
271end;
272
273end.
Note: See TracBrowser for help on using the repository browser.