frmstandardset.frm

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

    
    '正常值
    txtNormalVal.Text = Trim(txtNormalVal.Text)
    
    '处理上限
    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
    End If
    
    '最小值不能大于等于最大值
    If txtMinVal.Enabled = True Then
        txtMinVal.Text = Trim(txtMinVal.Text)
        If txtMinVal.Text <> "" Then txtMinVal.Text = Val(txtMinVal.Text)
        
        txtMaxVal.Text = Trim(txtMaxVal.Text)
        If txtMaxVal.Text <> "" Then txtMaxVal.Text = Val(txtMaxVal.Text)
        
        If Val(txtMinVal.Text) > Val(txtMaxVal.Text) And (txtMinVal.Text <> "") And (txtMaxVal.Text <> "") Then
            MsgBox "最小值不能大于最大值！", vbInformation, "提示"
            txtMinVal.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
    
    '年龄范围
    intLowerAge = CInt(Val(txtDAge.Text))
    intUpperAge = CInt(Val(txtUAge.Text))
    If intLowerAge > intUpperAge Then
        MsgBox "年龄下限不能高于年龄上限！", vbInformation, "提示"
        txtDAge.SetFocus
        GoTo ExitLab
    End If
    
    '检索年龄范围是否交叉
    strSQL = "select Count(*) from SET_TJBZDT" _
            & " where BZID=" & intBZID _
            & " and XMID='" & strXMID & "'" _
            & " and Sex=" & intSex _
            & " and (LowerAge between " & intLowerAge & " and " & intUpperAge _
                & " or UpperAge between " & intLowerAge & " and " & intUpperAge _
            & ")"
    If m_enuOperation = Modify Then
        strSHID = LongToString(cmbAgeRange.ItemData(cmbAgeRange.ListIndex), 10)
        strSQL = strSQL & " and SHID<>'" & strSHID & "'"
    End If
    Set rsBZ = New ADODB.Recordset
    rsBZ.Open strSQL, GCon, adOpenForwardOnly, adLockReadOnly
    If rsBZ(0) > 0 Then
        MsgBox "您输入的年龄范围与同一体检项目、同一性别下已经存在的年龄范围发生了交叉冲突，请核对后重新输入！", vbInformation, "提示"
        txtDAge.SetFocus
        GoTo ExitLab
    End If
    rsBZ.Close
    
    '开始事务
    GCon.BeginTrans
    On Error GoTo RollBack
    
    If m_enuOperation = Add Then
        '原来不存在，需要重新添加
        strSHID = GetMaxID("SET_TJBZDT", "SHID", "0000000001", False)
        '首先添加一条空记录
        strSQL = "insert into SET_TJBZDT(SHID,BZID,XMID,Sex) values(" _
                & "'" & strSHID & "'" _
                & "," & intBZID _
                & ",'" & strXMID & "'" _
                & "," & intSex _
                & ")"
        GCon.Execute strSQL
    End If
    
    '构造更新语句
    strSQL = "update SET_TJBZDT set" _
            & " NormalVal=" & IIf(txtNormalVal.Text = "", "Null", "'" & txtNormalVal.Text & "'") _
            & ",CKSX=" & IIf(txtCKSX.Text = "", "Null", "'" & txtCKSX.Text & "'") _
            & ",CKXX=" & IIf(txtCKXX.Text = "", "Null", "'" & txtCKXX.Text & "'") _
            & ",DW=" & IIf(txtDW.Text = "", "Null", "'" & txtDW.Text & "'") _
            & ",LowerAge=" & intLowerAge _
            & ",UpperAge=" & intUpperAge _
            & ",HighInfo='" & txtHighInfo.Text & "'" _
            & ",LowInfo='" & txtLowInfo.Text & "'" _
            & ",MaxVal='" & txtMaxVal.Text & "'" _
            & ",MinVal='" & txtMinVal.Text & "'" _
            & " where SHID='" & strSHID & "'"
    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
    
    With cmbAgeRange
        If m_enuOperation = Add Then
            .AddItem CStr(intLowerAge) & " - " & CStr(intUpperAge)
            .ItemData(.NewIndex) = strSHID
            .ListIndex = .NewIndex '自动调用cmbAgeRange_Click
        Else
            .List(.ListIndex) = CStr(intLowerAge) & " - " & CStr(intUpperAge)
            Call cmbAgeRange_Click
        End If
    End With
    
    GoTo ExitLab
    
RollBack:
    '回退事务
    GCon.RollbackTrans
ErrMsg:
    MsgBoxW Err
ExitLab:
    Me.MousePointer = vbDefault
End Sub

Private Sub Form_Load()
On Error GoTo ErrMsg
    Dim strSQL As String
    Dim rsTemp As ADODB.Recordset
    
    Call LoadKeShiAndXiangMu(tvwXMu)
    If tvwXMu.Nodes.Count >= 1 Then
        Set tvwXMu.SelectedItem = tvwXMu.Nodes(1)
        Call tvwXMu_NodeClick(tvwXMu.SelectedItem)
    End If
    
    '加载所有体检标准
    strSQL = "select BZID,BZMC from SET_TJBZIndex where SFQY=1"
    Set rsTemp = New ADODB.Recordset
    rsTemp.Open strSQL, GCon, adOpenStatic, adLockOptimistic
    If rsTemp.RecordCount > 0 Then
        rsTemp.MoveFirst
        Do
            cmbBZMC.AddItem rsTemp("BZMC")
            cmbBZMC.ItemData(cmbBZMC.NewIndex) = rsTemp("BZID")
            
            rsTemp.MoveNext
        Loop Until rsTemp.EOF
        rsTemp.Close
        
        cmbBZMC.ListIndex = 0
    Else
        cmbBZMC_Click
    End If
    
    Call updDown_Change
    Call updUp_Change
    
    GoTo ExitLab
ErrMsg:
    MsgBoxW Err
ExitLab:
    Screen.MousePointer = vbDefault
End Sub

Private Sub tvwXMu_NodeClick(ByVal Node As MSComctlLib.Node)
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim rsBZ As ADODB.Recordset
    Dim strID As String
    Dim intLength As Integer
    Dim intSex As Integer
    
    Me.MousePointer = vbHourglass
    Call EnableCommand(False)
    Call EnableInput(False, False)
    cmbAgeRange.Clear
    
    '检查有无选择
    If (tvwXMu.SelectedItem Is Nothing) Or (cmbBZMC.ListIndex < 0) Then
        ClearInfo
        
        GoTo ExitLab
    End If
    
    strID = Mid(tvwXMu.SelectedItem.Key, 2)
    '判断当前选择的是什么节点
    intLength = Len(strID)
    If intLength <= 2 Then
        '选择了科室
        ClearInfo
        
    ElseIf intLength = 7 Then
        '选择了子项
        If optMale.Value Then
            intSex = 1
        ElseIf optFemale.Value Then
            intSex = 2
        Else
            intSex = 0
        End If
        
        strSQL = "select SHID,LowerAge,UpperAge from SET_TJBZDT" _
                & " where BZID=" & Val(cmbBZMC.ItemData(cmbBZMC.ListIndex)) _
                & " and XMID='" & strID & "'"
    End If
    
    If strSQL <> "" Then
        Set rsBZ = New ADODB.Recordset
        rsBZ.Open strSQL, GCon, adOpenStatic, adLockOptimistic
        If Not rsBZ.EOF Then
            '显示所有年龄段
            With cmbAgeRange
                Do
                    .AddItem rsBZ("LowerAge") & " - " & rsBZ("UpperAge") & ""
                    .ItemData(.NewIndex) = rsBZ("SHID")
                    
                    rsBZ.MoveNext
                Loop While Not rsBZ.EOF
                rsBZ.Close
                
                '显示第一条
                .ListIndex = 0
            End With
        Else
            ClearInfo
        End If
        
        strSQL = "select XXType from SET_XX" _
                & " where XXID='" & strID & "'"
        Set rsBZ = New ADODB.Recordset
        rsBZ.Open strSQL, GCon, adOpenStatic, adLockOptimistic
        If rsBZ(0) <> 1 And rsBZ(0) <> 3 Then
            '不是数值型
            txtNormalVal.Tag = "0"
        Else
            '是数值型
            txtNormalVal.Tag = "1"
        End If
        rsBZ.Close
        
        cmdAddInfo.Enabled = True
    End If
    
    GoTo ExitLab
    
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    Me.MousePointer = vbDefault
End Sub

Private Sub txtDAge_Change()
On Error Resume Next
    Dim intAge As Integer

    intAge = Int(Val(txtDAge.Text))
    If intAge >= updDown.Min And intAge <= updDown.Max Then
        updDown.Value = intAge
    End If
End Sub

Private Sub txtUAge_Change()
On Error Resume Next
    Dim intAge As Integer

    intAge = Int(Val(txtUAge.Text))
    If intAge >= updUp.Min And intAge <= updUp.Max Then
        updUp.Value = intAge
    End If
End Sub

Private Sub updDown_Change()
    txtDAge.Text = updDown.Value
End Sub

Private Sub updUp_Change()
    txtUAge.Text = updUp.Value
End Sub

'清除所有标准明细
Private Sub ClearInfo()
    txtNormalVal.Text = ""
    txtCKSX.Text = ""
    txtCKXX.Text = ""
    txtDW.Text = ""
    txtLowInfo.Text = ""
    txtHighInfo.Text = ""
    txtMinVal.Text = ""
    txtMaxVal.Text = ""
End Sub

'启用/禁用按钮
Private Sub EnableCommand(ByVal blnFlag As Boolean, _
        Optional ByVal blnEdit As Boolean = False)
    cmdAddInfo.Enabled = blnFlag
    cmdModifyInfo.Enabled = blnFlag
    cmdDeleteInfo.Enabled = blnFlag
    If blnEdit Then
        cmdSaveInfo.Enabled = True
    Else
        cmdSaveInfo.Enabled = False
    End If
End Sub

'启用/禁用标准录入
Private Sub EnableInput(ByVal blnFlag As Boolean, ByVal blnIsNumeric As Boolean)
    '性别
    optNNTY.Enabled = blnFlag
    optMale.Enabled = blnFlag
    optFemale.Enabled = blnFlag
    
    '标准明细
    txtNormalVal.Enabled = blnFlag
    txtDAge.Enabled = blnFlag
    updDown.Enabled = blnFlag
    txtUAge.Enabled = blnFlag
    updUp.Enabled = blnFlag
    If Not blnFlag Then
        txtCKXX.Enabled = blnFlag
        txtCKSX.Enabled = blnFlag
        txtDW.Enabled = blnFlag
        
        txtLowInfo.Enabled = blnFlag
        txtHighInfo.Enabled = blnFlag
        txtMinVal.Enabled = blnFlag
        txtMaxVal.Enabled = blnFlag
    Else
        txtCKXX.Enabled = blnIsNumeric
        txtCKSX.Enabled = blnIsNumeric
        txtDW.Enabled = blnIsNumeric
        
        txtLowInfo.Enabled = blnIsNumeric
        txtHighInfo.Enabled = blnIsNumeric
        txtMinVal.Enabled = blnIsNumeric
        txtMaxVal.Enabled = blnIsNumeric
    End If
End Sub