//kt -- Modified with SourceScanner on 8/8/2007
unit uOptions;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, ExtCtrls, ComCtrls, ORFn;

type
  TSurrogate = class
  private
    FIEN:        Int64;
    FName:       string;
    FStart:      TFMDateTime;
    FStop:       TFMDateTime;
  public
    property IEN:        Int64          read FIEN       write FIEN;
    property Name:       string         read FName      write FName;
    property Start:      TFMDateTime    read FStart     write FStart;
    property Stop:       TFMDateTime    read FStop      write FStop;
  end;

function RelativeDate(entry: string): integer;
procedure DateLimits(const limit: integer; var value: integer);
procedure ShowDisplay(editbox: TEdit);
procedure TextExit(editbox: TEdit; var entrycheck: boolean; limitcheck: integer);
procedure LabelSurrogate(surrogateinfo: string; alabel: TStaticText);
procedure DisplayPtInfo(PtID: string);

const
  INVALID_DAYS = -99999;
  DAYS_LIMIT = 999;
  SELECTION_LIMIT = 999;

implementation

uses rCore, fRptBox
     ,DKLang  //kt
       ;

function RelativeDate(entry: string): integer;
// return the number of days for the entry  (e.g. -3 for T - 3)

  function OKToday(value: string): boolean;
  // check if value is used as the current date
  begin
    Result := false;
    if value = 'T' then Result := true
    else if value = 'TODAY' then Result := true
    else if value = 'N' then Result := true
    else if value = 'NOW' then Result := true;
  end;

  procedure GetMultiplier(var entry: string; var multiplier: integer);
  // check if entry has a multiplier on today's date (days, weeks, months, years)
  var
    lastchar: char;
  begin
    if (entry = 'NOW') or (entry = 'TODAY') then
    begin
      multiplier := 1;
      exit;
    end;
    lastchar := entry[length(entry)];
    case lastchar of
      'D': multiplier := 1;
      'W': multiplier := 7;
      'M': multiplier := 30;
      'Y': multiplier := 365;
      else multiplier := 0;
    end;
    if multiplier > 0 then
      entry := copy(entry, 0, length(entry) - 1)
    else
      multiplier := 1;
  end;

var
  firstpart, operator: string;
  lenfirstpart, multiplier: integer;
begin                                  // begin function RelativeDate
  Result := INVALID_DAYS;
  entry := Uppercase(entry);
  GetMultiplier(entry, multiplier);
  if strtointdef(entry, INVALID_DAYS) <> INVALID_DAYS then
  begin
    Result := strtointdef(entry, INVALID_DAYS);
    if Result <> INVALID_DAYS then
      Result := Result * multiplier;
    exit;
  end;
  if OKToday(entry) then                      // process today only
  begin
    Result := 0;
    exit;
  end;
  firstpart := Piece(entry, ' ', 1);
  lenfirstpart := length(firstpart);
  if OKToday(firstpart) then                  // process space
  begin
    operator := Copy(entry, lenfirstpart + 2, 1);
    if (operator = '+') or (operator = '-') then
    begin
      if Copy(entry, lenfirstpart + 3, 1) = ' ' then
        Result := strtointdef(Copy(entry, lenfirstpart + 4, length(entry)), INVALID_DAYS)
      else
        Result := strtointdef(Copy(entry, lenfirstpart + 3, length(entry)), INVALID_DAYS);
      if Result <> INVALID_DAYS then
        if Result < 0 then
          Result := INVALID_DAYS
        else if operator = '-' then
          Result := -Result;
    end;
    if Result <> INVALID_DAYS then
      Result := Result * multiplier;
  end
  else
  begin
    firstpart := Piece(entry, '+', 1);
    lenfirstpart := length(firstpart);
    if OKToday(firstpart) then                // process +
    begin
      if Copy(entry, lenfirstpart + 2, 1) = ' ' then
        Result := strtointdef(Copy(entry, lenfirstpart + 3, length(entry)), INVALID_DAYS)
      else
        Result := strtointdef(Copy(entry, lenfirstpart + 2, length(entry)), INVALID_DAYS);
      if Result <> INVALID_DAYS then
        if Result < 0 then
          Result := INVALID_DAYS
    end
    else
    begin
      firstpart := Piece(entry, '-', 1);
      lenfirstpart := length(firstpart);
      if OKToday(firstpart) then              // process -
      begin
        if Copy(entry, lenfirstpart + 2, 1) = ' ' then
          Result := strtointdef(Copy(entry, lenfirstpart + 3, length(entry)), INVALID_DAYS)
        else
          Result := strtointdef(Copy(entry, lenfirstpart + 2, length(entry)), INVALID_DAYS);
        if Result <> INVALID_DAYS then
          Result := -Result;
      end;
    end;
    if Result <> INVALID_DAYS then
      Result := Result * multiplier;
  end;
end;

procedure DateLimits(const limit: integer; var value: integer);
// check if date is within valid limit
begin
  if value > limit then
  begin
    beep;
//  InfoBox('Date cannot be greater than Today + ' + inttostr(limit), 'Warning', MB_OK or MB_ICONWARNING);  <-- original line.  //kt 8/8/2007
    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
    value := INVALID_DAYS;
  end
  else if value < -limit then
  begin
    beep;
//  InfoBox('Date cannot be less than Today - ' + inttostr(limit), 'Warning', MB_OK or MB_ICONWARNING);  <-- original line.  //kt 8/8/2007
    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
    value := INVALID_DAYS;
  end;
end;

procedure ShowDisplay(editbox: TEdit);
// displays the relative date (uses tag of editbox to hold # of days
begin
  with editbox do
  begin
    if Tag > 0 then
//    Text := 'Today + ' + inttostr(Tag)  <-- original line.  //kt 8/8/2007
      Text := DKLangConstW('uOptions_Today_xP') + inttostr(Tag) //kt added 8/8/2007
    else if Tag < 0 then
//    Text := 'Today - ' + inttostr(-Tag)  <-- original line.  //kt 8/8/2007
      Text := DKLangConstW('uOptions_Today_xM') + inttostr(-Tag) //kt added 8/8/2007
    else
//    Text := 'Today';  <-- original line.  //kt 8/8/2007
      Text := DKLangConstW('uOptions_Today'); //kt added 8/8/2007
    Hint := Text;
  end;
end;

procedure TextExit(editbox: TEdit; var entrycheck: boolean; limitcheck: integer);
// checks entry in editbx if date is valid
var
  tagnum: integer;
begin
  with editbox do
  begin
    if entrycheck then
    begin
      tagnum := RelativeDate(Hint);
      if tagnum = INVALID_DAYS then
      begin
        beep;
//      InfoBox('Date entry was invalid', 'Warning', MB_OK or MB_ICONWARNING);  <-- original line.  //kt 8/8/2007
        InfoBox(DKLangConstW('uOptions_Date_entry_was_invalid'), DKLangConstW('uOptions_Warning'), MB_OK or MB_ICONWARNING); //kt added 8/8/2007
        SetFocus;
      end
      else
      begin
        DateLimits(limitcheck, tagnum);
        if tagnum = INVALID_DAYS then
          SetFocus
        else
          Tag := tagnum;
      end;
      ShowDisplay(editbox);
      if Focused then SelectAll;
    end;
    entrycheck := false;
  end;
end;

procedure LabelSurrogate(surrogateinfo: string; alabel: TStaticText);
// surrogateinfo = surrogateIEN^surrogate name^surrogate start date/time^surrogate stop date/time
var
  surrogatename, surrogatestart, surrogatestop: string;
  surrogateien: Int64;
begin
  surrogateien := strtoint64def(Piece(surrogateinfo, '^', 1), -1);
  if surrogateien > 1 then
  begin
    surrogatename := Piece(surrogateinfo, '^', 2);
    surrogatestart := Piece(surrogateinfo, '^', 3);
    if surrogatestart = '-1' then surrogatestart := '0';
    if surrogatestart = '' then surrogatestart := '0';
    surrogatestop := Piece(surrogateinfo, '^', 4);
    if surrogatestop = '-1' then surrogatestop := '0';
    if surrogatestop = '' then surrogatestop := '0';
    alabel.Caption := surrogatename;
    if (surrogatestart <> '0') and (surrogatestop <> '0') then
      alabel.Caption := surrogatename +
//    ' (from ' + FormatFMDateTimeStr('mmm d,yyyy@hh:nn', surrogatestart) +  <-- original line.  //kt 8/8/2007
      DKLangConstW('uOptions_xfrom')+' ' + FormatFMDateTimeStr(DKLangConstW('uOptions_mmm_dxyyyyxhhxnn'), surrogatestart) + //kt added 8/8/2007
//    ' until ' + FormatFMDateTimeStr('mmm d,yyyy@hh:nn', surrogatestop) + ')'  <-- original line.  //kt 8/8/2007
      DKLangConstW('uOptions_until')+' ' + FormatFMDateTimeStr(DKLangConstW('uOptions_mmm_dxyyyyxhhxnn'), surrogatestop) + ')' //kt added 8/8/2007
    else if surrogatestart <> '0' then
      alabel.Caption := surrogatename +
//    ' (from ' + FormatFMDateTimeStr('mmm d,yyyy@hh:nn', surrogatestart) + ')'  <-- original line.  //kt 8/8/2007
      DKLangConstW('uOptions_xfrom') + FormatFMDateTimeStr(DKLangConstW('uOptions_mmm_dxyyyyxhhxnn'), surrogatestart) + ')' //kt added 8/8/2007
    else if surrogatestop <> '0' then
      alabel.Caption := surrogatename +
//    ' (until ' + FormatFMDateTimeStr('mmm d,yyyy@hh:nn', surrogatestop) + ')'  <-- original line.  //kt 8/8/2007
      DKLangConstW('uOptions_xuntil')+' ' + FormatFMDateTimeStr(DKLangConstW('uOptions_mmm_dxyyyyxhhxnn'), surrogatestop) + ')' //kt added 8/8/2007
    else
      alabel.Caption := surrogatename;
  end
  else
//  alabel.Caption := '<no surrogate designated>';  <-- original line.  //kt 8/8/2007
    alabel.Caption := DKLangConstW('uOptions_xno_surrogate_designatedx'); //kt added 8/8/2007
end;

procedure DisplayPtInfo(PtID: string);
var
  PtRec: TPtIDInfo;
  rpttext: TStringList;
begin
  if strtointdef(PtID, -1) < 0 then exit;
  PtRec := GetPtIDInfo(PtID);
  rpttext := TStringList.Create;
  try
    with PtRec do
    begin
      rpttext.Add('     ' + Name);
      rpttext.Add('SSN: ' + SSN);
      rpttext.Add('DOB: ' + DOB);
      rpttext.Add('');
      rpttext.Add(Sex);
      rpttext.Add(SCSts);
      rpttext.Add(Vet);
      rpttext.Add('');
//    if length(Location) > 0 then rpttext.Add('Location: ' + Location);  <-- original line.  //kt 8/8/2007
      if length(Location) > 0 then rpttext.Add(DKLangConstW('uOptions_Locationx') + Location); //kt added 8/8/2007
//    if length(RoomBed)  > 0 then rpttext.Add('Room/Bed: ' + RoomBed);  <-- original line.  //kt 8/8/2007
      if length(RoomBed)  > 0 then rpttext.Add(DKLangConstW('uOptions_RoomxBedx') + RoomBed); //kt added 8/8/2007
    end;
//  ReportBox(rpttext, 'Patient ID', false);  <-- original line.  //kt 8/8/2007
    ReportBox(rpttext, DKLangConstW('uOptions_Patient_ID'), false); //kt added 8/8/2007
  finally
    rpttext.free
  end;
end;

end.