Class

TfrmMHTest

Module

fMHTest

Last Modified

7/15/2014 3:26:38 PM

Scope

Interfaced

Inherits from

TfrmBase508Form

Declaration


TfrmMHTest = class(TfrmBase508Form)
  sbMain: TScrollBox;
  pnlBottom: TPanel;
  btnCancel: TButton;
  btnOK: TButton;
  btnClear: TButton;
  procedure FormDestroy(Sender: TObject);
  procedure FormCreate(Sender: TObject);
  procedure FormShow(Sender: TObject);
  procedure sbMainResize(Sender: TObject);
  procedure btnOKClick(Sender: TObject);
  procedure FormKeyDown(Sender: TObject; var Key: Word;
    Shift: TShiftState);
  procedure btnClearClick(Sender: TObject);
private
  FIDCount: integer;
  FAnswers: TStringList;
  FObjs: TList;
  FInfoText: string;
  FInfoLabel: TMentalHealthMemo;
  FBuilt: boolean;
  //FMaxLines: integer;
  FBuildingControls: boolean;
  procedure BuildControls;
  {function Answers: string;
  procedure GetQText(QText: TStringList);
  function LoadTest(InitialAnswers, TestName: string): boolean; }
  function CurrentQ: integer;
  procedure GotoQ(x: integer);
public
MHTestComp: string;
MHA3: boolean;
function CallMHDLL(TestName: string; Required: boolean): String;
end;

DFM Objects


frmMHTest : TfrmMHTest
 ├sbMain : TScrollBox
 ├pnlBottom : TPanel
 │ ├btnCancel : TButton
 │ ├btnOK : TButton
 │ └btnClear : TButton
 └amgrMain : TVA508AccessibilityManager

Class Hierarchy


Class Fields

Name Type Scope Comments
btnCancel TButton Public/Published -
btnClear TButton Public/Published -
btnOK TButton Public/Published -
FAnswers TStringList Private -
FBuildingControls Boolean Private FMaxLines: integer;
FBuilt Boolean Private -
FIDCount Integer Private -
FInfoLabel TMentalHealthMemo Private -
FInfoText UnicodeString Private -
FObjs TList Private -
MHA3 Boolean Public -
MHTestComp UnicodeString Public -
pnlBottom TPanel Public/Published -
sbMain TScrollBox Public/Published -

Methods

Name Declaration Scope Comments
btnClearClick procedure btnClearClick(Sender: TObject); Public/Published -
btnOKClick procedure btnOKClick(Sender: TObject); Public/Published -
BuildControls procedure BuildControls; Private -
CallMHDLL function CallMHDLL(TestName: string; Required: boolean): String; Public
Procedure TfrmMHTest.GetQText(QText: TStringList);
var
  i, lx: integer;

begin
  if(FObjs.Count > 99) then
    lx := 5
  else
  if(FObjs.Count > 9) then
    lx := 4
  else
    lx := 3;
  for i := 0 to FObjs.Count-1 do
    QText.Add(copy(IntToStr(i+1) + '.      ', 1, lx) + TMHQuestion(FObjs[i]).Question);
end;
CurrentQ function CurrentQ: integer; Private
Function Answers: string;
    procedure GetQText(QText: TStringList);
    function LoadTest(InitialAnswers, TestName: string): boolean;
FormCreate procedure FormCreate(Sender: TObject); Public/Published
Function TfrmMHTest.Answers: string;
var
  i, XCnt: integer;
  ans: string;

begin
  Result := '';
  XCnt := 0;
  for i := 0 to FObjs.Count-1 do
  begin
    ans := TMHQuestion(FObjs[i]).FAnswer;
    if(ans = Skipped) then
      inc(XCnt);
    Result := Result + ans;
  end;
  if(XCnt = FObjs.Count) then
    Result := '';
end;

function TfrmMHTest.LoadTest(InitialAnswers, TestName: string): boolean;
var
  TstData: TStringList;
  lNum, i, idx: integer;
  Line, LastLine, Inp, Code: string;
  Txt, Spec, p, Spidx, tmp: string;
  RSpec, First, TCodes: boolean;
  QObj: TMHQuestion;

  procedure ParseText;
  var
    i, tlen: integer;

  begin
    Code := '';
    i := 1;
    tlen := length(Txt);
    while(i <= tlen) do
    begin
      while(i <= tlen) and (Txt[i] = ' ') do inc(i);
      if(i > tlen) then
      begin
        Txt := '';
        exit;
      end;
      if(i > 1) then
      begin
        delete(Txt,1,i-1);
        i := 1;
      end;
      if(Spec = 'I') then exit;
      tlen := length(Txt);
      if(tlen < 3) then exit;
      Code := copy(Txt,i,1);
      if(pos(Code, (UpperCaseLetters + LowerCaseLetters + Digits)) = 0) then
      begin
        Code := '';
        exit;
      end;
      inc(i);
      while(i <= tlen) and (Txt[i] = ' ') do inc(i);
      if(Txt[i] in ['.','=']) then
      begin
        if(pos(Code, QObj.FAllowedAnswers) > 0) then
        begin
          inc(i);
          while(i <= tlen) and (Txt[i] = ' ') do inc(i);
          if(i <= tlen) then
            delete(Txt,1,i-1)
          else
            Code := '';
          exit;
        end
        else
        begin
          Code := '';
          exit;
        end;
      end
      else
      begin
        Code := '';
        exit;
      end;
    end;
  end;

  procedure AddTxt2Str(var X: string);
  begin
    if(Txt <> '') then
    begin
      if(X <> '') then
      begin
        X := X + ' ';
        if(copy(Txt, length(Txt), 1) = '.') then
          X := X + ' ';
      end;
      X := X + Txt;
    end;
  end;

begin
  Result := TRUE;
  TstData := TStringList.Create;
  try
    FastAssign(LoadMentalHealthTest(TestName), TstData);
    if TstData.Strings[0] = '1' then MHA3 := True
    else MHA3 := False;
    Screen.Cursor := crHourGlass;
    try
      TstData.Add('99999;X;0');
      idx := 1;
      FMaxLines := 0;
      FInfoText := '';
      LastLine := U;
      First := TRUE;
      RSpec := FALSE;
      TCodes := FALSE;
      QObj := nil;
      while (idx < TstData.Count) do
      begin
        Inp := TstData[idx];
        if(pos('[ERROR]', Inp) > 0) then
        begin
          Result := FALSE;
          break;
        end;
        p := Piece(Inp, U, 1);
        Line := Piece(p, ';', 1);
        Spec := Piece(p, ';', 2);
        SpIdx := Piece(p, ';', 3);
        if(LastLine <> Line) then
        begin
          LastLine := Line;
          if(First) then
            First := FALSE
          else
          begin
            if(not RSpec) then
            begin
              Result := FALSE;
              break;
            end;
          end;
          if(Spec = 'X') then break;
          lNum := StrToIntDef(Line, 0);
          if(lNum <= 0) then
          begin
            Result := FALSE;
            break;
          end;
          RSpec := FALSE;
          TCodes := FALSE;
          QObj := TMHQuestion(FObjs[FObjs.Add(TMHQuestion.Create)]);
          QObj.FLine := lNum;
          if(FMaxLines < lNum) then
            FMaxLines := lNum;
        end;
        Txt := Piece(Inp, U, 2);
        ParseText;
        if(Txt <> '') then
        begin
          if(Spec = 'I') then
          begin
           if MHA3 = True then AddTxt2Str(QObj.FText)
           else
           AddTxt2Str(FInfoText);;
          end
          else
          if(Spec = 'R') then
          begin
            RSpec := TRUE;
            if(spIdx = '0') then
              QObj.FAllowedAnswers := Txt
            else
            if(Code = '') then
              QObj.FAnswerText := Txt
            else
            begin
              QObj.FSeeAnswers := FALSE;
              FAnswers.Add(Code + U + Txt);
              inc(QObj.FAnswerCount);
            end;
          end
          else
          if(Spec = 'T') then
          begin
            if(Code = '') then
            begin
              if(TCodes) then
              begin
                tmp := FAnswers[FAnswers.Count-1];
                AddTxt2Str(tmp);
                FAnswers[FAnswers.Count-1] := tmp;
              end
              else
                AddTxt2Str(QObj.FText);
            end
            else
            begin
              TCodes := TRUE;
              FAnswers.Add(Code + U + Txt);
              inc(QObj.FAnswerCount);
            end;
          end;
        end;
        inc(idx);
      end;
    finally
      Screen.Cursor := crDefault;
    end;
  finally
    TstData.Free;
  end;
  if(not Result) then
    InfoBox('Error encountered loading ' + TestName, 'Error', MB_OK)
  else
  begin
    for i := 0 to FObjs.Count-1 do
    begin
      with TMHQuestion(FObjs[i]) do
      begin
        tmp := copy(InitialAnswers,i+1,1);
        if(tmp <> '') then
          FAnswer := tmp;
      end;
    end;
  end;
end;
FormDestroy procedure FormDestroy(Sender: TObject); Public/Published -
FormKeyDown procedure FormKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); Public/Published -
FormShow procedure FormShow(Sender: TObject); Public/Published -
GotoQ procedure GotoQ(x: integer); Private -
sbMainResize procedure sbMainResize(Sender: TObject); Public/Published -

Referenced By (1)

Module (line) Referrer Type
fMHTest (119) frmMHTest Read