frmbzb_ttdj.frm

本系统可用于医院和专业体检中心的健康体检管理

    End If
End Sub

Private Sub cmdOK_Click()
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim lngGUID As Long
    Dim strHealthID As String '个人id
    Dim strYYID As String '团体预约id
    Dim strMaxID As String '单位id
    Dim rsTemp As ADODB.Recordset
    Dim cmd As ADODB.Command
    Dim i As Integer
    Dim blnFirst As Boolean
    Dim intSN As Integer
    
    Me.MousePointer = vbHourglass
    
    '**************************20040411加入 闻********************************
    mstrStatus = ""
    '**************************20040411加入 闻********************************
    
    Set cmd = New ADODB.Command
    Set cmd.ActiveConnection = GCon
    
    '*************************************************
    '                   团体信息预约
    '*************************************************
    '是否有id号
    If txtTYYID.Text = "" Then
        MsgBox "请首先单击“添加”按钮，或者单击右侧欲修改的信息，以生成唯一的健康编号！", vbInformation, "提示"
        txtTYYID.SetFocus
        GoTo ExitLab
    End If
    
    '是否输入或选择了单位名称
    If cmbTDWei.Text = "" Then
        MsgBox "请选择或输入单位名称！", vbInformation, "提示"
        cmbTDWei.SetFocus
        GoTo ExitLab
    End If
    
    '是否输入了联系人
    If txtTLXR.Text = "" Then
        MsgBox "请输入单位联系人姓名！", vbInformation, "提示"
        txtTLXR.SetFocus
        GoTo ExitLab
    End If
    
    '登记人数
    If Val(txtTDJRS.Text) < 0 Then
        MsgBox "体检人数不能为负数！", vbInformation, "提示"
        txtTDJRS.SetFocus
        GoTo ExitLab
    End If
                                                                                                                                           
    '体检日期是否有效
    If dtpTTJRQ.Value < Date Then
        MsgBox "您输入的体检日期无效！请核对后重新输入！", vbInformation, "提示"
        dtpTTJRQ.SetFocus
        GoTo ExitLab
    End If
    
'        '如果选择套餐，则检查是否真的选择
'        If optTYes.Value = True Then
'            If cmbTTCan.Text = "" Then
'                MsgBox "请选择套餐！", vbInformation, "提示"
'                cmbTTCan.SetFocus
'                GoTo ExitLab
'            End If
'        End If
    
    
    '▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲
    '                               开始事务
    '▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲
    GCon.BeginTrans
    '▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲
On Error GoTo RollBack
    '查看单位是否已经存在
    If cmbTDWei.ListIndex < 0 And menuOperation = Add Then
        '来的是新单位，提取其资料
        '首先获取单位的最大id
        strMaxID = GetMaxID("SET_DW", "DWID", "00001")
        strSQL = "insert into SET_DW(DWID) values('" & strMaxID & "')"
        cmd.CommandText = strSQL
        cmd.Execute
        
        strSQL = "insert into SET_DW_APPEND(DWID) values('" & strMaxID & "')"
        cmd.CommandText = strSQL
        cmd.Execute

        '添加到组合框中
        cmbTDWei.AddItem cmbTDWei.Text
        cmbTDWei.ItemData(cmbTDWei.NewIndex) = strMaxID
    Else
        strMaxID = LongToString(cmbTDWei.ItemData(cmbTDWei.ListIndex), 5)
    End If
    
    '更新单位信息
    strSQL = "update SET_DW set" _
            & " DWMC='" & cmbTDWei.Text & "'" _
            & ",PYSX='" & "'" _
            & ",WBSX='" & "'" _
            & ",LXR='" & txtTLXR.Text & "'" _
            & ",LXRBGDH='" & txtTLXRBGDH.Text & "'" _
            & ",LXRYDDH='" & txtTLXRYDDH.Text & "'" _
            & ",LXREMail='" & txtTEMail.Text & "'" _
            & ",FZR='" & txtTFZR.Text & "'" _
            & ",FZRBGDH='" & txtTFZRBGDH.Text & "'" _
            & ",FZRYDDH='" & txtTFZRYDDH.Text & "'" _
            & ",LXDZ='" & txtTLXDZ.Text & "'" _
            & ",YZBM='" & txtTYZBM.Text & "'" _
            & ",YWYH='" & txtTYWYH.Text & "'" _
            & ",YHZH='" & txtTYHZH.Text & "'" _
            & ",QYXZ='" & txtTQYXZ.Text & "'" _
            & " where DWID='" & strMaxID & "'"
    cmd.CommandText = strSQL
    cmd.Execute
    
    If menuOperation = Modify Then
        strYYID = txtTYYID.Text
        
        strSQL = "update YY_TJDJ" _
                & " set DWID='" & strMaxID & "'" _
                & ",DJRS=" & Int(Val(txtTDJRS.Text)) _
                & ",TJRQ='" & dtpTTJRQ.Value & "'"
                
        '体检套餐
'        If cmbTTCan.Text <> "" Then
'            strSQL = strSQL & ",XZTC=1" _
'                    & ",TCID='" & LongToString(cmbTTCan.ItemData(cmbTTCan.ListIndex), 5) & "'"
'        Else
            strSQL = strSQL & ",XZTC=0" _
                    & ",TCID=null"
'        End If
                
         strSQL = strSQL & ",EmployeeID=" & gintManagerID _
                & ",SFTJ=0" _
                & " where YYID='" & strYYID & "'"
    Else
        '获取当前最大的序列号
        strYYID = Format(Date, "yyyymmdd")
        strSQL = "select TJYYXLH from YY_XLH where RiQi='" & Date & "'"
        Set rsTemp = New ADODB.Recordset
        rsTemp.Open strSQL, GCon, adOpenStatic, adLockOptimistic
        If rsTemp.RecordCount = 0 Then
            '往数据库里面插入一条记录
            strSQL = "Insert into YY_XLH values(" _
                    & "'" & Date & "',1,null)"
            strYYID = strYYID & "001"
        ElseIf IsNull(rsTemp("TJYYXLH")) Then
            strSQL = "Update YY_XLH" _
                    & " set TJYYXLH=1" _
                    & " where RiQi='" & Date & "'"
            strYYID = strYYID & "001"
            rsTemp.Close
        Else
            strSQL = "Update YY_XLH" _
                    & " set TJYYXLH=TJYYXLH+1" _
                    & " where RiQi='" & Date & "'"
            strYYID = strYYID & LongToString(rsTemp("TJYYXLH") + 1, 3)
            rsTemp.Close
        End If
        Set rsTemp = Nothing
        cmd.CommandText = strSQL
        cmd.Execute
        
        '更新文本框
        txtTYYID.Text = strYYID
        '准备写入数据库
        strSQL = "insert into YY_TJDJ values(" _
                & "'" & strYYID & "'" _
                & ",'" & strMaxID & "'" _
                & "," & Val(txtTDJRS.Text)
        '体检套餐
'        If cmbTTCan.Text <> "" Then
'            strSQL = strSQL & ",1" _
'                    & ",'" & LongToString(cmbTTCan.ItemData(cmbTTCan.ListIndex), 5) & "'"
'        Else
            strSQL = strSQL & ",0" _
                    & ",null"
'        End If
        
        strSQL = strSQL & "," & gintManagerID _
                & ",'" & Date & "'" _
                & ",'" & dtpTTJRQ.Value & "'"
        strSQL = strSQL & ",1,'')" '表示已经登记
        
    End If
    cmd.CommandText = strSQL
    cmd.Execute
    
'        '写入项目选择信息
'        '预约时选择，意味着只分一个组
'        '所以先删除可能存在的分组
'        strSQL = "delete from FZ_FZSY where YYID='" & strYYID & "'"
'        cmd.CommandText = strSQL
'        cmd.Execute
'        '然后建立一个默认分组
'        strSQL = "insert into FZ_FZSY values(" _
'                & "'" & strYYID & "'" _
'                & ",1" _
'                & ",'" & cmbTDWei.Text & "'" _
'                & ",'" & dtpTTJRQ.Value & "'" _
'                & ",'',''" _
'                & ",0" _
'                & ",120,0" _
'                & ",0" _
'                & ",''" _
'                & "," & gintManagerID _
'                & ",'" & Date & "',1)" '标准采用第一个标准
'        cmd.CommandText = strSQL
'        cmd.Execute
'
'        '在分组数据表里面，首先删除可能存在的分组人员
'        strSQL = "delete from FZ_FZSJ where YYID='" & strYYID & "'"
'        cmd.CommandText = strSQL
'        cmd.Execute
'
'        '把所有已经添加的团体用户放到第一个默认分组中
'        strSQL = "insert into FZ_FZSJ" _
'                & " select YYID,GUID,1,1" _
'                & " from SET_GRXX" _
'                & " where YYID='" & strYYID & "'"
'        cmd.CommandText = strSQL
'        cmd.Execute
'
'        '删除团检套餐表里的记录
'        strSQL = "delete from YY_TJDJTC where YYID='" & strYYID & "'"
'        cmd.CommandText = strSQL
'        cmd.Execute
    
    '如果该团体现在选择了套餐，则往团检套餐表里写入一条记录
    '该记录为默认分组的记录
'    If cmbTTCan.Text <> "" Then
'        strSQL = "delete from YY_TJDJTC where YYID='" & strYYID & "'"
'        cmd.CommandText = strSQL
'        cmd.Execute
'
'        '参数依次为：预约编号，分组编号，是否选择套餐，套餐编号
'        strSQL = "insert into YY_TJDJTC values(" _
'                & "'" & strYYID & "'" _
'                & ",1" _
'                & ",1" _
'                & ",'" & LongToString(cmbTTCan.ItemData(cmbTTCan.ListIndex), 5) & "')"
'        cmd.CommandText = strSQL
'        cmd.Execute
'    End If
    
    '检查是否选择了项目
'    blnFirst = False
'    For i = 1 To tvwTDXiang.Nodes.Count
'        If tvwTDXiang.Nodes(i).Checked = True Then
'            If Len(tvwTDXiang.Nodes(i).Key) = 5 Then
'                blnFirst = True
'                Exit For
'            End If
'        End If
'    Next
'    If blnFirst = True Then
'        '如果有选择项目，说明最多只有一个分组
'        '删除可能已经选择的大项
'        strSQL = "delete from YY_TJDJDX" _
'                & " where YYID='" & strYYID & "'" _
'                & " and FZID=1"
'        cmd.CommandText = strSQL
'        cmd.Execute
'    End If
    
    '循环每个大项，检查是否有输入
'    If blnFirst Then
'        For i = 1 To tvwTDXiang.Nodes.Count
'            If tvwTDXiang.Nodes(i).Checked = True Then
'                If Len(tvwTDXiang.Nodes(i).Key) = 5 Then
'                    strSQL = "insert into YY_TJDJDX values(" _
'                            & "'" & strYYID & "'" _
'                            & ",1" _
'                            & ",'" & Mid(tvwTDXiang.Nodes(i).Key, 2) & "')"
'                    cmd.CommandText = strSQL
'                    cmd.Execute
'                End If
'            End If
'        Next
'    End If
    
    '▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲
    '                               提交事务
    '▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲
    GCon.CommitTrans
    '▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲
    
On Error GoTo ErrMsg

    '添加到网格
    With Me.MSHFlexGrid1
        If menuOperation = Modify Then
            i = .Row
        Else
            If .TextMatrix(1, 1) = "" Then
                i = 1
            Else
                i = .Rows
                .Rows = i + 1
            End If
        End If
        
        .TextMatrix(i, 0) = ""
        .TextMatrix(i, 1) = txtTYYID.Text
        .TextMatrix(i, 2) = txtTLXR.Text
        .TextMatrix(i, 3) = cmbTDWei.Text
        .TextMatrix(i, 4) = dtpTTJRQ.Value
        
        .Row = i
        .col = 0
        .ColSel = 4
        MSHFlexGrid1_Click
    End With
    
    cmdOK.Enabled = False
    cmdAdd.Enabled = True

'    ClearTTInput
    SetAllInput False
    
    GoTo ExitLab
    
RollBack:
    GCon.RollbackTrans
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    Me.MousePointer = vbDefault
End Sub

Private Sub Form_Load()
On Error GoTo ErrMsg
    Dim Status