| 1 | unit uOptions;
|
|---|
| 2 |
|
|---|
| 3 | interface
|
|---|
| 4 |
|
|---|
| 5 | uses
|
|---|
| 6 | Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
|
|---|
| 7 | StdCtrls, ExtCtrls, ComCtrls, ORFn;
|
|---|
| 8 |
|
|---|
| 9 | type
|
|---|
| 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 |
|
|---|
| 23 | function RelativeDate(entry: string): integer;
|
|---|
| 24 | procedure DateLimits(const limit: integer; var value: integer);
|
|---|
| 25 | procedure ShowDisplay(editbox: TEdit);
|
|---|
| 26 | procedure TextExit(editbox: TEdit; var entrycheck: boolean; limitcheck: integer);
|
|---|
| 27 | procedure LabelSurrogate(surrogateinfo: string; alabel: TStaticText);
|
|---|
| 28 | procedure DisplayPtInfo(PtID: string);
|
|---|
| 29 |
|
|---|
| 30 | const
|
|---|
| 31 | INVALID_DAYS = -99999;
|
|---|
| 32 | DAYS_LIMIT = 999;
|
|---|
| 33 | SELECTION_LIMIT = 999;
|
|---|
| 34 |
|
|---|
| 35 | implementation
|
|---|
| 36 |
|
|---|
| 37 | uses rCore, fRptBox;
|
|---|
| 38 |
|
|---|
| 39 | function 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 |
|
|---|
| 76 | var
|
|---|
| 77 | firstpart, operator: string;
|
|---|
| 78 | lenfirstpart, multiplier: integer;
|
|---|
| 79 | begin // 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;
|
|---|
| 146 | end;
|
|---|
| 147 |
|
|---|
| 148 | procedure DateLimits(const limit: integer; var value: integer);
|
|---|
| 149 | // check if date is within valid limit
|
|---|
| 150 | begin
|
|---|
| 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;
|
|---|
| 163 | end;
|
|---|
| 164 |
|
|---|
| 165 | procedure ShowDisplay(editbox: TEdit);
|
|---|
| 166 | // displays the relative date (uses tag of editbox to hold # of days
|
|---|
| 167 | begin
|
|---|
| 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;
|
|---|
| 178 | end;
|
|---|
| 179 |
|
|---|
| 180 | procedure TextExit(editbox: TEdit; var entrycheck: boolean; limitcheck: integer);
|
|---|
| 181 | // checks entry in editbx if date is valid
|
|---|
| 182 | var
|
|---|
| 183 | tagnum: integer;
|
|---|
| 184 | begin
|
|---|
| 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;
|
|---|
| 209 | end;
|
|---|
| 210 |
|
|---|
| 211 | procedure LabelSurrogate(surrogateinfo: string; alabel: TStaticText);
|
|---|
| 212 | // surrogateinfo = surrogateIEN^surrogate name^surrogate start date/time^surrogate stop date/time
|
|---|
| 213 | var
|
|---|
| 214 | surrogatename, surrogatestart, surrogatestop: string;
|
|---|
| 215 | surrogateien: Int64;
|
|---|
| 216 | begin
|
|---|
| 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>';
|
|---|
| 243 | end;
|
|---|
| 244 |
|
|---|
| 245 | procedure DisplayPtInfo(PtID: string);
|
|---|
| 246 | var
|
|---|
| 247 | PtRec: TPtIDInfo;
|
|---|
| 248 | rpttext: TStringList;
|
|---|
| 249 | begin
|
|---|
| 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;
|
|---|
| 271 | end;
|
|---|
| 272 |
|
|---|
| 273 | end.
|
|---|
