untanswerinput.pas

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

unit untAnswerInput;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, untBaseDialog, StdCtrls, Buttons, ExtCtrls, jpeg, ADODB,
  DB, DBCtrls, ComCtrls, CalcExpress, fcButton, fcImgBtn;

type
  TfrmAnswerInput = class(TfrmBaseDialog)
    pgc1: TPageControl;
    TabSheet1: TTabSheet;
    TabSheet2: TTabSheet;
    TabSheet3: TTabSheet;
    BitBtn1: TBitBtn;
    BitBtn2: TBitBtn;
    scbThird: TScrollBox;
    GroupBox1: TGroupBox;
    DBMemo1: TDBMemo;
    rgItem: TRadioGroup;
    dsQuestion: TDataSource;
    scbSecond: TScrollBox;
    grpitem: TGroupBox;
    memItem: TMemo;
    Edit1: TEdit;
    CalcExpress1: TCalcExpress;
    imgImgLeftPanel: TImage;
    grp1: TGroupBox;
    mmoQuestion: TMemo;
    Panel1: TPanel;
    ADOdsQuestionDa: TADOQuery;
    procedure BitBtn1Click(Sender: TObject);
    procedure BitBtn2Click(Sender: TObject);
    procedure rgItemClick(Sender: TObject);
    procedure btnOKClick(Sender: TObject);
    procedure pgc1Change(Sender: TObject);
  private
    FXHList: TStringList;
    FMeasureCode: string;
    FadsResult: TADODataSet;
    FadsQuestion: TADODataSet;
    FadsSelectItem: TADODataSet;
    FConn: TADOConnection;
    FCalcExpress: TCalcExpress;
    procedure CreateSecondPnl(DataSet: TADODataSet; iNo: Integer);
    procedure CreateThirdPnl(DataSet: TADODataSet; iNo: Integer);
    procedure InitComponents;
    procedure LoadQuestion;
    procedure SetConn(const Value: TADOConnection);
    procedure adsQuestionAfterScroll(DataSet: TDataSet);
    procedure edt3Enter(Sender: TObject);
    procedure edt2Enter(Sender: TObject);
    {procedure edt2KeyDown(Sender: TObject; var Key: Word;
          Shift: TShiftState);
    procedure edt3KeyDown(Sender: TObject; var Key: Word;
          Shift: TShiftState);}
    procedure edt2Exit(Sender: TObject);
    procedure edt3Exit(Sender: TObject);
    procedure ItemValueChange(iWay, iResult: Integer; code, SelectTag: string);
    procedure QuestionIndexChange(iWay, iXH: Integer);
    function  GetSelectTagByScore(AScore: Integer): string;
    function  CheckInput(QuestionXh: Integer; SelectTag: string; var iResult: Integer; var Code: string): Boolean;
    procedure CalcResult;
    procedure LoadMeasureItem;
    function Calc: Boolean;
    { Private declarations }
  public
    { Public declarations }
    PatientID: Integer;
    property Conn: TADOConnection read FConn write SetConn;
    property MeasureCode: string read FMeasureCode write FMeasureCode;
    property adsResult: TADODataSet read FadsResult write FadsResult;
    procedure Init;
  end;

function GetMeasureResult(AConn: TADOConnection;
  AMeasureCode: string; APatientID: Integer = -1): TADODataSet;

implementation

uses untGlobalFun, untMessage,untDM;

function GetMeasureResult(AConn: TADOConnection;
  AMeasureCode: string; APatientID: Integer = -1): TADODataSet;
var
  strSQL: string;
begin
  Result := nil;
  strSQL := ' select count(*)           '
           +' from tselectitem          '
           +' where questioncode in     '
           +'   (                       '
           +'     select code           '
           +'     from tquestion        '
           +'     where grpcode in      '
           +'     (                     '
           +'       select questiongrp  '
           +'       from tmeasure       '
           +'       where code = '+QuotedStr(AMeasureCode)
           +'     )                     '

           +'   )';
  if GetDBValue(AConn, strSQL) = 0 then begin
    MsgOK('心理量表的问题集未初始化，请先设置心理量表！');
    Exit;
  end;
  with TfrmAnswerInput.Create(Application) do begin
    PatientID := APatientID;
    Conn := AConn;
    Result := TADODataSet.Create(nil);
    adsResult := Result;
    MeasureCode := AMeasureCode;
    FXhList := TStringList.Create;
    FXHList.Delimiter := ';';
    Init;
    if ShowModal = mrOk then begin
      {if PatientID <> -1 then
        SavePatientResult(PatientID, adsResult); }
      Result := adsResult;
    end;
    FXHList.Free;
    Free;
  end;
end;

{$R *.dfm}

procedure TfrmAnswerInput.Init;
begin
  frmMessage := TfrmMessage.Create(Application);
  frmMessage.lblMessage.Caption := '正在打开题库，请稍侯...';
  frmMessage.pbMessage.Visible := false;
  frmMessage.Show;
  frmMessage.Update;
  //根据MeasureCode加载和问题组有关的问题及选项数据。
  LoadQuestion;
  //初试化FORM上的控件（动态创建）
  frmMessage.lblMessage.Caption := '正在创建问题控件集，请稍侯...';
  frmMessage.pbMessage.Visible := true;
  frmMessage.pbMessage.Max := FadsQuestion.RecordCount;
  InitComponents;
  FreeAndNil(frmMessage);
end;

procedure TfrmAnswerInput.CreateSecondPnl(DataSet: TADODataSet; iNo: Integer);
var
  pnlTotal,pnlRight,pnlLeft,pnlLT,pnlLB: TPanel;
  iLeft: Integer;
  lblSelect: TLabel;
begin
  pnlTotal := TPanel.Create(Self);
  with pnlTotal do begin
    Parent := scbSecond;
    Color := clWindow;
    Caption := '';
    BevelOuter := bvNone;
    Align := alTop;
    Top := iNo*70+1;
    Height := 70;
  end;
  pnlRight := TPanel.Create(Self);
  with pnlRight do begin
    Parent := pnlTotal;
    Color := clWindow;
    Caption := '';
    Align := alRight;
    Width := 150;
  end;
  pnlLeft := TPanel.Create(Self);
  with pnlLeft do begin
    Parent := pnlTotal;
    Color := clWindow;
    Caption := '';
    Align := alClient;
  end;
  pnlLT := TPanel.Create(Self);
  with pnlLT do begin
    Parent := pnlLeft;
    Color := clWindow;
    Caption := '';
    BevelOuter := bvNone;
    Align := alTop;
    Height := 40;
  end;
  pnlLB := TPanel.Create(Self);
  with pnlLB do begin
    Parent := pnlLeft;
    Color := clWindow;
    Caption := '';
    BevelOuter := bvNone;
    Align := alClient;
  end;
  with FadsSelectItem do begin
    if Filtered then Filtered := False;
    Filter := 'questioncode='+QuotedStr(DataSet.fieldByName('code').Value);
    Filtered := true;
    Sort := 'code';
  end;
  with TEdit.Create(Self) do begin
    Parent := pnlRight;
    Top := (pnlTotal.Height-Height) div 2;
    Left := (pnlRight.Width-Width) div 2;
    Name := 'edt2'+DataSet.FieldByName('xh').AsString;
    Text := GetSelectTagByScore(DataSet.FieldByName('score').AsInteger);
    //Tag := DataSet.FieldByName('xh').Value;
    Tag := iNo+1;
    OnEnter := edt2Enter;
    //OnKeyDown := edt2KeyDown;
    OnExit := edt2Exit;
  end;
  with TLabel.Create(Self) do begin
     Parent := pnlLT;
     AutoSize := false;
     WordWrap := true;
     Top := 5;
     Left := 5;
     Width := pnlLT.Width - 10;
     Height := pnlLT.Height - 10;
     Caption := DataSet.fieldbyname('content').AsString;
  end;
  with FadsSelectItem do begin
    First;     iLeft := 10;
    while not Eof do begin
      lblSelect := TLabel.Create(Self);
      with lblSelect do begin
        lblSelect.Parent := pnlLB;
        lblSelect.Top := 5;
        lblSelect.Left := iLeft;
        lblSelect.Caption := FieldByName('SelectTag').AsString+'> '+FieldByName('content').AsString;
        iLeft := iLeft + Canvas.TextWidth(Caption) + 9;
      end;
      Next;
    end;
  end;
end;

procedure TfrmAnswerInput.CreateThirdPnl(DataSet: TADODataSet;
  iNo: Integer);
var
  pnl: TPanel;
  iLeftNo: Integer;
begin
  pnl := TPanel.Create(Self);
  with pnl do begin
    Parent := scbThird;
    Width := 62;
    Height := 30;
    iLeftNo := iNo mod 12;
    if iLeftNo < 6 then
      Left := iLeftNo*Width + 102
    else
      Left := iLeftNo*Width + 122;
    Top := (iNo div 12)*Height + 20;
    Caption := '';
    Color := clWindow;
    BevelOuter := bvNone;

  end;
  with TLabel.Create(Self) do begin
    Parent := pnl;
    Top := 9;
    Left := 1;
    Caption := DataSet.fieldByName('XH').AsString+'.';
  end;
  with TEdit.Create(Self) do begin
    Parent := pnl;
    Top := 5;
    Left := 25;
    Width := 33;
    Name := 'edt3'+DataSet.FieldByName('xh').AsString;
    Text := GetSelectTagByScore(DataSet.FieldByName('score').AsInteger);
    //Tag := DataSet.FieldByName('xh').AsInteger;
    Tag := iNo+1;
    OnEnter := edt3Enter;
    //OnKeyDown := edt3KeyDown;
    OnExit := edt3Exit;
  end;
end;

procedure TfrmAnswerInput.InitComponents;
var
  i: Integer;
begin
  with FadsQuestion do begin
    First;   i:=0;
    while not Eof do begin
      frmMessage.pbMessage.Position := frmMessage.pbMessage.Position+1;
      Application.ProcessMessages;
      //初试化FORM
      FXHList.Add('TAG'+IntToStr(i+1)+'='+FadsQuestion.FieldByName('xh').AsString);
      CreateSecondPnl(FadsQuestion, i);
      CreateThirdPnl(FadsQuestion, i);

      Next;
      Inc(i);
    end;

    FadsQuestion.AfterScroll := adsQuestionAfterScroll;
    dsQuestion.DataSet := FadsQuestion;
    First;
  end;
end;

procedure TfrmAnswerInput.LoadQuestion;
var
  strSQL: string;
  i: Integer;
begin
//======================       选项       ================================
  FadsSelectItem := TADODataSet.Create(Self);
  with FadsSelectItem do begin
    Connection := Conn;
    CommandText := 'select * from tselectitem';
    Active := true;
  end;
//======================       问题       ================================
  //创建结构
  FadsQuestion := TADODataSet.Create(Self);
  with FadsQuestion do begin
    with FieldDefs do begin
      Add('code',ftString, 10);
      Add('XH',ftString,20);
      Add('name',ftString, 20);
      Add('content',ftString, 50);
      Add('vartag',ftString, 10);
      Add('ItemDomain',ftString, 50);
      Add('score',ftInteger);
      Add('Answer',ftString,10);
    end;
    CreateDataSet;
  end;
  //加载数据
  strSQL := 'select code,xh,name,content=convert(varchar,xh)+''.''+content,'+
            '   vartag,ItemDomain,score=-1  '+
            'from tquestion                                          '+
            'where grpcode in                                        '+
            '(                                                       '+
            '  select questiongrp                                    '+
            '  from tmeasure                                         '+
            '  where code = '+QuotedStr(MeasureCode)+
            ')                                                       '+
            'order by xh ';
  with GetDataSet(Conn, strSQL) do begin
    First;
    try
      while not Eof do begin
        FadsQuestion.Append;
        for i:=0 to FadsQuestion.FieldCount-2 do
          FadsQuestion.Fields[i].Value := Fields[i].Value;
        Next;
      end;
    finally
      Free;
    end;
  end;
end;

procedure TfrmAnswerInput.SetConn(const Value: TADOConnection);
begin
  FConn := Value;
end;