untanswerinput.pas

来自「简要说明:对医院幼儿心理情况做的一个调查,统计系统.」· PAS 代码 · 共 726 行 · 第 1/2 页

procedure TfrmAnswerInput.adsQuestionAfterScroll(DataSet: TDataSet);
var
  i: Integer;
  bSelected: Boolean;
begin
  with DataSet do begin
    BitBtn1.Enabled := not Bof;
    BitBtn2.Enabled := not Eof;
  end;
  with FadsSelectItem do begin
    //过滤数据集
    if not Active then exit;
    if Filtered then Filtered := false;
    Filter := 'questioncode='+QuotedStr(DataSet.fieldByName('code').Value);
    Filtered := true;
    //刷新问题选项
    rgItem.Items.Clear;
    rgItem.Columns := RecordCount;
    Sort := 'code';
    First;
    i:=0; bSelected := false;
    while not Eof do begin
      rgItem.Items.Add(FieldByName('selecttag').AsString+'> '+FieldByName('content').AsString);
      if FieldByName('Value').AsInteger = DataSet.FieldByName('score').AsInteger then
        bSelected := True;
      if not bSelected then Inc(i);
      Next;
    end;
    if bSelected then rgItem.ItemIndex := i;
  end;
end;

procedure TfrmAnswerInput.BitBtn1Click(Sender: TObject);
begin
  inherited;
  FadsQuestion.Prior;
  if FadsQuestion.Bof then Exit;

  //触发题目切换事件
  QuestionIndexChange(0, FadsQuestion.FieldByName('XH').AsInteger);
end;

procedure TfrmAnswerInput.BitBtn2Click(Sender: TObject);
begin
  inherited;
  FadsQuestion.Next;
  if FadsQuestion.Eof then Exit;

  //触发题目切换事件
  QuestionIndexChange(0, FadsQuestion.FieldByName('XH').AsInteger);
end;

procedure TfrmAnswerInput.rgItemClick(Sender: TObject);
var
  iResult, i: Integer;
  code, SelectTag: string;
begin
  inherited;
  //得到选择结果分数
  if rgItem.ItemIndex < 0 then Exit;
  with FadsSelectItem do begin
    First;
    i:=0;
    while i<rgItem.ItemIndex do begin
      Next;
      Inc(i);
    end;
    iResult := FieldByName('value').AsInteger;
    code := FieldByName('code').AsString;
    SelectTag := fieldbyname('selecttag').AsString;
  end;
  //触发选项值被改变的事件
  ItemValueChange(0, iResult, code, SelectTag);
end;

procedure TfrmAnswerInput.ItemValueChange(iWay, iResult: Integer;
    code, SelectTag: string);
var
  I: Integer;
  QuestionXH: string;
begin
  //更改SCORE的值
  with FadsQuestion do begin
    if not (State in [dsInsert, dsEdit]) then Edit;
    FieldByName('score').Value := iResult;
    FieldByName('Answer').Value := SelectTag;
  end;
  //通知其他录入方式的控件，做相应的改变
  if iWay <> 0 then begin               //不是通过向导方式，则改变向导的控件
    for I:=0 to rgItem.Items.Count-1 do
      if SelectTag = Copy(rgItem.Items[I], 1, Length(SelectTag)) then
      begin
        rgItem.ItemIndex := I;
        Break;
      end;
  end;
  QuestionXH := GetDBValue(Conn, 'select xh from tquestion where code in (select questioncode from tselectitem where code='+QuotedStr(code)+')');
  if iWay <> 1 then begin
    TEdit(FindComponent('edt2'+QuestionXh)).Text := SelectTag;
  end;

  if iWay <> 2 then begin
    TEdit(FindComponent('edt3'+QuestionXh)).Text := SelectTag;
  end;
end;

procedure TfrmAnswerInput.QuestionIndexChange(iWay, iXH: Integer);
begin
  if iWay <> 0 then begin
    FadsQuestion.Locate('Xh',FXHList.Values['TAG'+IntToStr(iXh)], []);
  end;
  //刷新快速录入里面的选项
  mmoQuestion.Clear;
  mmoQuestion.Text:=FadsQuestion.FieldByName('content').asstring;
  memItem.Lines.Clear;

  with FadsSelectItem do begin
    First;
    while not Eof do begin
      if memItem.Text = '' then
        memItem.Text := FieldByName('SelectTag').Value + '> ' + FieldByName('content').Value
      else
        memItem.Text := memItem.Text+#13+#10+#13+#10
              +FieldByName('SelectTag').Value + '> ' + FieldByName('content').Value;
      Next;
    end;
  end;
end;

function TfrmAnswerInput.GetSelectTagByScore(AScore: Integer): string;
begin
  Result := '';
  with FadsSelectItem do begin
    if Locate('value', AScore, []) then
      Result := FieldByName('SelectTag').Value;
  end;
end;

procedure TfrmAnswerInput.edt3Enter(Sender: TObject);
begin
  inherited;
  QuestionIndexChange(2, TEdit(Sender).Tag);
end;

procedure TfrmAnswerInput.edt2Enter(Sender: TObject);
begin
  QuestionIndexChange(1, TEdit(Sender).Tag);
end;

{procedure TfrmAnswerInput.edt2KeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
var
  iResult: Integer;
  Code: string;
begin
  if Key = VK_RETURN then begin
    if not CheckInput(TEdit(Sender).Tag, Trim(TEdit(Sender).Text), iResult, code) then
    begin
      MsgOK('输入问题选项的代号不正确！');
      Exit;
    end;
    //触发选项值被改变的事件
    ItemValueChange(1, iResult, code, Trim(TEdit(Sender).Text));
  end;
end;

procedure TfrmAnswerInput.edt3KeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
var
  iResult: Integer;
  Code: string;
begin
  if Key = VK_RETURN then begin
    if not CheckInput(TEdit(Sender).Tag, Trim(TEdit(Sender).Text), iResult, code) then
    begin
      MsgOK('输入问题选项的代号不正确！');
      Exit;
    end;
    //触发选项值被改变的事件
    ItemValueChange(2, iResult, code, Trim(TEdit(Sender).Text));
  end;
end;}

function TfrmAnswerInput.CheckInput(QuestionXh: Integer;
  SelectTag: string; var iResult: Integer; var Code: string): Boolean;
var
  strSQL: string;
  ads: TADODataSet;
begin
  strSQL := 'select * '
          + 'from tSelectItem '
          + 'where questioncode in ( '
          + '           select code from tQuestion '
          + '           where xh='+QuotedStr(FXhList.Values['TAG'+IntToStr(QuestionXh)])
          + '             and grpcode in (select grpcode from tquestion where code='+QuotedStr(FadsQuestion['code'])+') '
          + '                      ) '
          + '  and selectTag = '+QuotedStr(SelectTag);
  ads := GetDataSet(Conn, strSQL);
  Result := ads.RecordCount > 0;
  if not Result then begin
    ads.Free;
    Exit;
  end;
  iResult := ads['value'];
  Code := ads['code'];
  ads.Free;
end;

procedure TfrmAnswerInput.edt2Exit(Sender: TObject);
var
  iResult: Integer;
  Code: string;
begin
  if Trim(TEdit(Sender).Text) = '' then Exit;
  if not CheckInput(TEdit(Sender).Tag, Trim(TEdit(Sender).Text), iResult, code) then
  begin
    MsgOK('输入问题选项的代号不正确！');
    TEdit(Sender).SetFocus;
    Exit;
  end;
  //触发选项值被改变的事件
  ItemValueChange(1, iResult, code, Trim(TEdit(Sender).Text));
end;

procedure TfrmAnswerInput.edt3Exit(Sender: TObject);
var
  iResult: Integer;
  Code: string;
begin
  if Trim(TEdit(Sender).Text) = '' then Exit;
  if not CheckInput(TEdit(Sender).Tag, Trim(TEdit(Sender).Text), iResult, code) then
  begin
    MsgOK('输入问题选项的代号不正确！');
    TEdit(Sender).SetFocus;
    Exit;
  end;
  //触发选项值被改变的事件
  ItemValueChange(2, iResult, code, Trim(TEdit(Sender).Text));
end;

procedure TfrmAnswerInput.btnOKClick(Sender: TObject);
var
  str:string;
  ResultID:Integer;
begin
  inherited;
  //保存每个问题的分数
  ADOdsQuestionDa.SQL.Text:='select ResultID,ChildRenID,Code,XH,DA from tQuestionDa';
  ADOdsQuestionDa.Open;
  with FadsQuestion do
  begin
    first;
    while not eof do
    begin
      if Fields[7].AsString<>'' then
      begin
         ADOdsQuestionDa.Append;
         ADOdsQuestionDa.Fields[0].AsInteger:=PatientID;
         ADOdsQuestionDa.Fields[1].AsInteger:=PatientID;
         ADOdsQuestionDa.Fields[2].AsString:=Fields[0].AsString;
         ADOdsQuestionDa.Fields[3].AsString:=Fields[1].AsString;
         ADOdsQuestionDa.Fields[4].AsString:=Fields[7].AsString;
         ADOdsQuestionDa.Post;
       end;

       Next;
    end;
    First;
  end;
  CalcResult;
end;

procedure TfrmAnswerInput.CalcResult;
begin
  LoadMeasureItem;
  if Calc then ModalResult := mrOk;
end;

procedure TfrmAnswerInput.LoadMeasureItem;
var
  strSQL: string;
  I: Integer;
begin
  //创建结果数据集结构
  with FadsResult do begin
    with FieldDefs do begin
      Add('code', ftString, 10);
      Add('name', ftString, 50);
      Add('formula', ftString, 800);
      Add('score', ftFloat);
    end;
    CreateDataSet;
  end;
  //初始化数据
  strSQL := ' select code,name,formula,score=0 '
          + ' from tMeasure_Item '
          + ' where MeasureCode='+QuotedStr(MeasureCode)
          + '   and NeedFormula=1 and ltrim(rtrim(formula))<>''''';
  with GetDataSet(Conn, strSQL) do begin
    try
      First;
      while not Eof do begin
        adsResult.Append;
        for i:=0 to adsResult.FieldCount-1 do
          adsResult.Fields[i].Value := Fields[i].Value;
        adsResult.Post;
        Next;
      end;
    finally
      Free;
    end;
  end;
end;

function TfrmAnswerInput.Calc: Boolean;
var
  args: array of Extended;
  i: Integer;
begin
  Result := false;
  try
    FCalcExpress := TCalcExpress.Create(Self);
    SetLength(args, FadsQuestion.RecordCount);
    with FCalcExpress do begin
      FadsQuestion.First;  i:=0;

      while not FadsQuestion.Eof do begin
         Variables.Add(FadsQuestion['VarTag']);
        //分数初始化为－1，要判断该问题是否得分
        if FadsQuestion.fieldbyname('score').Value<>-1 then
           args[i] := FadsQuestion.fieldbyname('score').Value
        else  args[i]:=0;
        FadsQuestion.Next;
        Inc(i);
      end;
    end;
    with adsResult do begin
      First;
      while not Eof do begin
        Edit;
        FCalcExpress.Formula := FieldByName('formula').AsString;
        FieldByName('score').Value := FCalcExpress.calc(args);
        Post;
        Next;
      end;
    end;
  except
    MsgOK('公式计算出错！');
    Exit;
  end;
  Result := true;
end;

procedure TfrmAnswerInput.pgc1Change(Sender: TObject);
begin
  inherited;
  if pgc1.ActivePageIndex=2   then
     QuestionIndexChange(2,FadsQuestion.FieldByName('XH').AsInteger);

end;

end.