formtjbzwh.frm

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

Private Sub CmdDel_Click()
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim intBZID As Integer
    Dim intIndex As Integer
    
    If cmbBZMC.ListIndex < 0 Then
        cmbBZMC.Text = ""
        txtBZSM.Text = ""
        
        GoTo ExitLab
    End If
    
    '让用户确认
    If MsgBox("该操作不可恢复！" & vbCrLf _
            & "确实要删除标准“" & cmbBZMC.Text & "”及该标准下的所有数据吗？", _
            vbExclamation + vbYesNo + vbDefaultButton2, "小心") = vbNo Then Exit Sub
    '准备删除
    intBZID = Val(cmbBZMC.ItemData(cmbBZMC.ListIndex))
    strSQL = "update SET_TJBZIndex set" _
            & " SFQY=0" _
            & " where BZID=" & intBZID
    GCon.Execute strSQL
    
    intIndex = cmbBZMC.ListIndex
    cmbBZMC.RemoveItem intIndex
    If cmbBZMC.ListCount = 0 Then
        cmbBZMC.Text = ""
        txtBZSM.Text = ""
        
        cmdChange.Enabled = False
    Else
        If intIndex = 0 Then
            cmbBZMC.ListIndex = intIndex
        Else
            cmbBZMC.ListIndex = intIndex - 1
        End If
    End If
    
    tvwXMuClick
    
    GoTo ExitLab
    
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    Me.MousePointer = vbDefault
End Sub

Private Sub cmdExit_Click()
    Unload Me
End Sub

Private Sub cmdSave_Click()
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim intBZID As Integer
    Dim rsBZ As ADODB.Recordset
    Dim cmd As ADODB.Command

    Me.MousePointer = vbHourglass
    
    Set cmd = New ADODB.Command
    Set cmd.ActiveConnection = GCon
    
    If mintBZID = -1 Then
        '添加标准
        '标准名称是否为空
        If cmbBZMC.Text = "" Then
            MsgBox "标准名称不能为空，请重新输入！", vbInformation, "提示"
            cmbBZMC.SetFocus
            GoTo ExitLab
        End If
        
        '检查是否重复
        strSQL = "select count(*) from SET_TJBZIndex" _
                & " where BZMC='" & cmbBZMC.Text & "'"
        Set rsBZ = New ADODB.Recordset
        rsBZ.Open strSQL, GCon, adOpenStatic, adLockOptimistic
        If rsBZ(0) > 0 Then
            '重复了
            MsgBox "您输入的标准名称已经存在，请核对后重新输入！", vbInformation, "提示"
            cmbBZMC.SetFocus
            GoTo ExitLab
        End If
        rsBZ.Close
        
        '获取当前最大的标准id号
        strSQL = "select max(BZID) from SET_TJBZIndex"
        Set rsBZ = New ADODB.Recordset
        rsBZ.Open strSQL, GCon, adOpenStatic, adLockOptimistic
        If rsBZ.RecordCount > 0 Then
            If IsNull(rsBZ(0)) Then
                intBZID = 1
            Else
                intBZID = rsBZ(0) + 1
            End If
            
            rsBZ.Close
        Else
            intBZID = 1
        End If
        
        '添加一条空记录
        strSQL = "insert into SET_TJBZIndex(BZID)" _
                & " values(" & intBZID & ")"
        cmd.CommandText = strSQL
        cmd.Execute
    Else
        '修改标准
        '检查是否重复
        strSQL = "select count(*) from SET_TJBZIndex" _
                & " where BZMC='" & cmbBZMC.Text & "'" _
                & " and BZID<>" & mintBZID
        Set rsBZ = New ADODB.Recordset
        rsBZ.Open strSQL, GCon, adOpenStatic, adLockOptimistic
        If rsBZ(0) > 0 Then
            '重复了
            MsgBox "您输入的标准名称已经存在，请核对后重新输入！", vbInformation, "提示"
            GoTo ExitLab
        End If
        
        intBZID = mintBZID
    End If
    
    '更新标准信息
    strSQL = "update SET_TJBZIndex set" _
            & " BZMC='" & cmbBZMC.Text & "'" _
            & ",BZSM='" & txtBZSM.Text & "'" _
            & ",JLRQ='" & Date & "'" _
            & ",EmployeeID=" & gintManagerID _
            & " where BZID=" & intBZID
    cmd.CommandText = strSQL
    cmd.Execute
    
    If mintBZID = -1 Then
        cmbBZMC.AddItem cmbBZMC.Text
        cmbBZMC.ItemData(cmbBZMC.NewIndex) = intBZID
        cmbBZMC.ListIndex = cmbBZMC.NewIndex
    Else
        cmbBZMC.List(mintIndex) = cmbBZMC.Text
        cmbBZMC.ListIndex = mintIndex
    End If
    
    cmdAdd.Enabled = False '已经保存过，说明至少存在一条，所以禁用添加按钮
    cmdChange.Enabled = True
    cmdSave.Enabled = False
    
    GoTo ExitLab
    
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    Me.MousePointer = vbDefault
End Sub

Private Sub cmdSaveInfo_Click()
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim rsBZ As ADODB.Recordset
    Dim intBZID As Integer
    Dim strXMID As String
    Dim intSex As Integer

    Me.MousePointer = vbHourglass
    
    '如果fraBZMX禁用，说明无需保存
    If fraBZMX.Enabled = False Then GoTo ExitLab
    
    '是否选择了项目
    If tvwXMu.SelectedItem Is Nothing Then GoTo ExitLab
    
    '当前是否有体检标准
    If cmbBZMC.ListIndex < 0 Then GoTo ExitLab
    
    '处理上限
    txtCKSX.Text = Trim(txtCKSX.Text)
    If txtCKSX.Text <> "" Then
        txtCKSX.Text = Val(txtCKSX.Text)
    End If
    
    '处理下限
    txtCKXX.Text = Trim(txtCKXX.Text)
    If txtCKXX.Text <> "" Then
        txtCKXX.Text = Val(txtCKXX.Text)
    End If
    
    '上限不能比下限小
    If txtCKSX.Enabled = True And (txtCKSX.Text <> "") And (txtCKXX.Text <> "") Then
        If Val(txtCKSX.Text) <= Val(txtCKXX.Text) Then
            MsgBox "参考上限不能等于或小于参考下限！", vbInformation, "提示"
            txtCKSX.SetFocus
            
            GoTo ExitLab
        End If
        
'        '正常值应该在参考上限和参考下限之间
'        If (Val(txtNormalVal.Text) > Val(txtCKSX.Text)) Or (Val(txtNormalVal.Text) < Val(txtCKXX.Text)) Then
'            MsgBox "正常值应该在参考下限与参考上限之间！请核对后重新输入！", vbInformation, "提示"
'            txtNormalVal.SetFocus
'            GoTo ExitLab
'        End If
    End If
    
    '最小值不能大于等于最大值
    If txtMinVal.Enabled = True Then
        If Val(txtMinVal.Text) > Val(txtMaxVal.Text) And (txtCKSX.Text <> "") And (txtCKXX.Text <> "") Then
            MsgBox "最小值不能等于或大于最大值！", vbInformation, "提示"
            txtMinVal.SetFocus
            
            GoTo ExitLab
        End If
'
'        '正常值应该在参考上限和参考下限之间
'        If (Val(txtNormalVal.Text) > Val(txtMaxVal.Text)) Or (Val(txtNormalVal.Text) < Val(txtMinVal.Text)) Then
'            MsgBox "正常值应该在最小值与最大值之间！请核对后重新输入！", vbInformation, "提示"
'            txtNormalVal.SetFocus
'            GoTo ExitLab
'        End If
    End If
    
    intBZID = Val(cmbBZMC.ItemData(cmbBZMC.ListIndex))
    strXMID = Mid(tvwXMu.SelectedItem.Key, 2)
    If optMale.Value Then
        intSex = 1
    ElseIf optFemale.Value Then
        intSex = 2
    Else
        intSex = 0
    End If
    '首先检查是添加还是修改
    strSQL = "select count(*) from SET_TJBZDT" _
            & " where BZID=" & intBZID _
            & " and XMID='" & strXMID & "'" _
            & " and Sex=" & intSex
    Set rsBZ = New ADODB.Recordset
    rsBZ.Open strSQL, GCon, adOpenKeyset, adLockOptimistic
    
    '开始事务
    GCon.BeginTrans
    On Error GoTo RollBack
    
    If rsBZ(0) < 1 Then
        '原来不存在，需要重新添加
        '首先添加一条空记录
        strSQL = "insert into SET_TJBZDT(BZID,XMID,Sex) values(" _
                & intBZID _
                & ",'" & strXMID & "'" _
                & "," & intSex _
                & ")"
        GCon.Execute strSQL
    End If
    
    '构造更新语句
    strSQL = "update SET_TJBZDT set" _
            & " NormalVal='" & txtNormalVal.Text & "'" _
            & ",CKSX='" & txtCKSX.Text & "'" _
            & ",CKXX='" & txtCKXX.Text & "'" _
            & ",DW='" & txtDW.Text & "'" _
            & ",HighInfo='" & txtHighInfo.Text & "'" _
            & ",LowInfo='" & txtLowInfo.Text & "'" _
            & ",MaxVal='" & txtMaxVal.Text & "'" _
            & ",MinVal='" & txtMinVal.Text & "'" _
            & " where BZID=" & intBZID _
            & " and XMID='" & strXMID & "'" _
            & " and Sex=" & intSex
    GCon.Execute strSQL
    
    '检查选择的是否“所有”性别
    If Not optNNTY.Value Then
        '如果设置了“男”、“女”标准，则删除可能存在的“所有”标准
        strSQL = "delete from SET_TJBZDT" _
                & " where BZID=" & intBZID _
                & " and XMID='" & strXMID & "'" _
                & " and SEX=0"
        GCon.Execute strSQL
    Else
        '如果设置了所有，则删除可能存在的男女标准
        strSQL = "delete from SET_TJBZDT" _
                & " where BZID=" & intBZID _
                & " and XMID='" & strXMID & "'" _
                & " and SEX<>0"
        GCon.Execute strSQL
    End If
    
    '提交事务
    GCon.CommitTrans
    
    cmdSaveInfo.Enabled = False
    
    GoTo ExitLab
    
RollBack:
    '回退事务
    GCon.RollbackTrans
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    Me.MousePointer = vbDefault
    
    
'wxw add 20050621 保存选中项目的标准
If fraNumTyp.Visible Then
    Me.MousePointer = vbHourglass
    Dim i, cou As Integer
    '检验数值型标准的逻辑关系是否正确
    cou = LsvBZ.ListItems.Count
    Dim blnres As Boolean
        For i = 1 To cou
        If CDbl(LsvBZ.ListItems(i).SubItems(1)) >= CDbl(LsvBZ.ListItems(i).SubItems(2)) Then
            LsvBZ.ListItems(i).ListSubItems(1).ForeColor = &HFF&
            LsvBZ.ListItems(i).ListSubItems(1).ToolTipText = "下限不能大于等于上限"
            LsvBZ.ListItems(i).ListSubItems(2).ForeColor = &HFF&
            LsvBZ.ListItems(i).ListSubItems(2).ToolTipText = "上限不能小于等于下限"
            blnres = True
        End If
        Next
        
        For i = 2 To cou
        If CDbl(LsvBZ.ListItems(i).SubItems(1)) > CDbl(LsvBZ.ListItems(i - 1).SubItems(2)) Then
            LsvBZ.ListItems(i).ListSubItems(1).ForeColor = &HFF00FF
            LsvBZ.ListItems(i).ListSubItems(1).ToolTipText = "本级下限不能小于上级上限"
            If i <> cou Then
                LsvBZ.ListItems(i).ListSubItems(2).ForeColor = &HFF00FF
                LsvBZ.ListItems(i).ListSubItems(2).ToolTipText = "本级上限不能大于下级下限"
            End If
            blnres = True
        End If
        Next
        If blnres Then
            MsgBox "标准逻辑关系存在错误，不能保存，请仔细检查上下限关系！", vbInformation, "提示"
            cmdSaveInfo.Enabled = True
        End If
    
    GCon.BeginTrans
    
    If Not optNNTY.Value Then
        '如果设置了“男”、“女”标准，则删除可能存在的“所有”标准
        strSQL = "delete from SET_XX_BZ" _
                & " where XX_id=" & fraNumTyp.Tag & " and SEX=0 and BZ_ID=" & intBZID
        GCon.Execute strSQL
    Else
        '如果设置了所有，则删除可能存在的男女标准
        strSQL = "delete from SET_XX_BZ" _
                & " where XX_id=" & fraNumTyp.Tag & " and SEX<>0 and BZ_ID=" & intBZID
        GCon.Execute strSQL
    End If
    '删除现有项目的标准
    GCon.Execute "delete from SET_XX_BZ where XX_id='" & fraNumTyp.Tag & "'and sex=" & intSex
    cou = LsvBZ.ListItems.Count
    '将标准存入数据库
    For i = 1 To cou
        SaveBZ LsvBZ.ListItems(i).Text, LsvBZ.ListItems(i).SubItems(1), LsvBZ.ListItems(i).SubItems(2), LsvBZ.ListItems(i).SubItems(3), LsvBZ.ListItems(i).Index, intSex, 0, intBZID
    Next
    GCon.CommitTrans
    Me.MousePointer = vbDefault
End If

End Sub

Private Sub CmdSet_Click()
    Dim intSex As Integer
    If optMale.Value Then
        intSex = 1
    ElseIf optFemale.Value Then
        intSex = 2
    Else
        intSex = 0
    End If
    GCon.Execute "update set_xx_bz set zcz=''  where BZ_ID=" & Val(cmbBZMC.ItemData(cmbBZMC.ListIndex)) _
                    & " and XX_ID='" & Mid(tvwXMu.SelectedItem.Key, 2) & "'" _
                    & " and Sex=" & intSex