Module

uOptions

Path

C:\CPRS\CPRS30\Options\uOptions.pas

Last Modified

7/15/2014 3:26:40 PM

Units Used in Implementation

Name Comments
fRptBox -
rCore -

Classes

Name Comments
TSurrogate -

Procedures

Name Owner Declaration Scope Comments
DateLimits - procedure DateLimits(const limit: integer; var value: integer); Interfaced Check if date is within valid limit
DisplayPtInfo - procedure DisplayPtInfo(PtID: string); Interfaced -
GetMultiplier - procedure GetMultiplier(var entry: string; var multiplier: integer); Local -
LabelSurrogate - procedure LabelSurrogate(surrogateinfo: string; alabel: TStaticText); Interfaced Surrogateinfo = surrogateIEN^surrogate name^surrogate start date/time^surrogate stop date/time
ShowDisplay - procedure ShowDisplay(editbox: TEdit); Interfaced Displays the relative date (uses tag of editbox to hold # of days
TextExit - procedure TextExit(editbox: TEdit; var entrycheck: boolean; limitcheck: integer); Interfaced Checks entry in editbx if date is valid

Functions

Name Owner Declaration Scope Comments
OKToday - function OKToday(value: string): boolean; Local Return the number of days for the entry (e.g. -3 for T - 3)
RelativeDate - function RelativeDate(entry: string): integer; Interfaced Return the number of days for the entry (e.g. -3 for T - 3)

Constants

Name Declaration Scope Comments
DAYS_LIMIT 999 Interfaced -
INVALID_DAYS -99999 Interfaced -
SELECTION_LIMIT 999 Interfaced -


Module Source

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.

Module Calls (2 levels)


uOptions
 ├rCore
 │ └uCore
 └fRptBox
   ├fFrame
   ├fBase508Form
   ├uReports
   └rReports

Module Called-By (2 levels)


                  uOptions
                fOptions┤ 
                fFrame┘ │ 
            fOptionsDays┤ 
           fOptions...┘ │ 
       fOptionsSurrogate┤ 
           fOptions...┘ │ 
fOptionsPatientSelection┤ 
           fOptions...┘ │ 
           fOptionsLists┤ 
           fOptions...┘ │ 
           fOptionsTeams┘ 
           fOptions...┘