source: cprs/branches/tmg-cprs/CPRS-Chart/Options/uOptions.pas@ 973

Last change on this file since 973 was 453, checked in by Kevin Toppenberg, 16 years ago

Initial upload of TMG-CPRS 1.0.26.69

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