| 1 | //kt -- Modified with SourceScanner on 8/8/2007
|
|---|
| 2 | unit uOptions;
|
|---|
| 3 |
|
|---|
| 4 | interface
|
|---|
| 5 |
|
|---|
| 6 | uses
|
|---|
| 7 | Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
|
|---|
| 8 | StdCtrls, ExtCtrls, ComCtrls, ORFn;
|
|---|
| 9 |
|
|---|
| 10 | type
|
|---|
| 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 |
|
|---|
| 24 | function RelativeDate(entry: string): integer;
|
|---|
| 25 | procedure DateLimits(const limit: integer; var value: integer);
|
|---|
| 26 | procedure ShowDisplay(editbox: TEdit);
|
|---|
| 27 | procedure TextExit(editbox: TEdit; var entrycheck: boolean; limitcheck: integer);
|
|---|
| 28 | procedure LabelSurrogate(surrogateinfo: string; alabel: TStaticText);
|
|---|
| 29 | procedure DisplayPtInfo(PtID: string);
|
|---|
| 30 |
|
|---|
| 31 | const
|
|---|
| 32 | INVALID_DAYS = -99999;
|
|---|
| 33 | DAYS_LIMIT = 999;
|
|---|
| 34 | SELECTION_LIMIT = 999;
|
|---|
| 35 |
|
|---|
| 36 | implementation
|
|---|
| 37 |
|
|---|
| 38 | uses rCore, fRptBox
|
|---|
| 39 | ,DKLang //kt
|
|---|
| 40 | ;
|
|---|
| 41 |
|
|---|
| 42 | function 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 |
|
|---|
| 79 | var
|
|---|
| 80 | firstpart, operator: string;
|
|---|
| 81 | lenfirstpart, multiplier: integer;
|
|---|
| 82 | begin // 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;
|
|---|
| 149 | end;
|
|---|
| 150 |
|
|---|
| 151 | procedure DateLimits(const limit: integer; var value: integer);
|
|---|
| 152 | // check if date is within valid limit
|
|---|
| 153 | begin
|
|---|
| 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;
|
|---|
| 168 | end;
|
|---|
| 169 |
|
|---|
| 170 | procedure ShowDisplay(editbox: TEdit);
|
|---|
| 171 | // displays the relative date (uses tag of editbox to hold # of days
|
|---|
| 172 | begin
|
|---|
| 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;
|
|---|
| 186 | end;
|
|---|
| 187 |
|
|---|
| 188 | procedure TextExit(editbox: TEdit; var entrycheck: boolean; limitcheck: integer);
|
|---|
| 189 | // checks entry in editbx if date is valid
|
|---|
| 190 | var
|
|---|
| 191 | tagnum: integer;
|
|---|
| 192 | begin
|
|---|
| 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;
|
|---|
| 218 | end;
|
|---|
| 219 |
|
|---|
| 220 | procedure LabelSurrogate(surrogateinfo: string; alabel: TStaticText);
|
|---|
| 221 | // surrogateinfo = surrogateIEN^surrogate name^surrogate start date/time^surrogate stop date/time
|
|---|
| 222 | var
|
|---|
| 223 | surrogatename, surrogatestart, surrogatestop: string;
|
|---|
| 224 | surrogateien: Int64;
|
|---|
| 225 | begin
|
|---|
| 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
|
|---|
| 257 | end;
|
|---|
| 258 |
|
|---|
| 259 | procedure DisplayPtInfo(PtID: string);
|
|---|
| 260 | var
|
|---|
| 261 | PtRec: TPtIDInfo;
|
|---|
| 262 | rpttext: TStringList;
|
|---|
| 263 | begin
|
|---|
| 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;
|
|---|
| 288 | end;
|
|---|
| 289 |
|
|---|
| 290 | end.
|
|---|
