frmxmzh.frm

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

ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    Me.MousePointer = vbDefault
End Sub

Private Sub cmdDelete_Click()
On Error GoTo ErrMsg
    Dim Status
    Dim strKey As String
    Dim i As Long
    Dim blnSel As Boolean
    
    Me.MousePointer = vbHourglass
    
    '权限验证
    If g_blnIsNew Then
        If Not g_clsAuthority.CheckOperationAuthority(m_strMenu, DELETE_W) Then GoTo ExitLab
    End If
    '验证完毕
    
    If cmdDelete.Enabled = False Then GoTo ExitLab
    
    If tvwXMu.SelectedItem Is Nothing Then GoTo ExitLab
    
    strKey = Mid(tvwXMu.SelectedItem.Key, 2)
    Select Case Len(strKey)
        Case 0, 2 '选择了根节点，或者科室
            GoTo ExitLab
        Case 4 '选择了项目组合
            '是否有项目
            If lvwChecked.ListItems.Count < 1 Then GoTo ExitLab
            
            '是否有选择
            If lvwChecked.SelectedItem Is Nothing Then
                MsgBox "请在已选项目中选择要删除的项目", vbInformation, "提示"
                GoTo ExitLab
            End If
            
            '删除
            With lvwChecked
                For i = .ListItems.Count To 1 Step -1
                    If .ListItems(i).Selected = True Then
                        blnSel = True
                        If DeleteXMuFromZH(Mid(.ListItems(i).Key, 2), strKey) = True Then
                            '添加到目的列表
                            lvwUnchecked.ListItems.Add , .ListItems(i).Key, .ListItems(i).Text
                            
                            '从源列表中删除
                            .ListItems.Remove (i)
                        End If
                    End If
                Next i
            End With
            
            If Not blnSel Then
                MsgBox "请在已选项目中选择要删除的项目", vbInformation, "提示"
            End If
    End Select
    
    EnableCommand
    
    GoTo ExitLab
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    Me.MousePointer = vbDefault
End Sub

'从可选项目中添加指定项目到已选项目中
'参数1：已选项目中要删除的XXID
'参数2：源组合的DXID
Private Function DeleteXMuFromZH(ByVal strXXID As String, ByVal strDXID As String) As Boolean
    Dim strSQL As String
    Dim rstemp As ADODB.Recordset
    Dim strDXPYSX As String
    Dim strXXPYSX As String
    Dim strDXMC As String
    Dim strXXMC As String
    Dim blnHavePhoto As Boolean
    
    DeleteXMuFromZH = False
    
    '获取大项拼音缩写
    strSQL = "select DXMC,DXPYSX from SET_DX" _
            & " where DXID='" & strDXID & "'"
    Set rstemp = New ADODB.Recordset
    rstemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
    strDXPYSX = rstemp("DXPYSX")
    strDXMC = rstemp("DXMC")
    rstemp.Close
    
    '获取小项拼音缩写
    strSQL = "select XXPYSX,XXMC,HavePhoto from SET_XX" _
            & " where XXID='" & strXXID & "'"
    Set rstemp = New ADODB.Recordset
    rstemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
    strXXPYSX = rstemp("XXPYSX")
    strXXMC = rstemp("XXMC")
    blnHavePhoto = CBool(rstemp("HavePhoto"))
    rstemp.Close
    
    '检查该小项在该组合中是否有体检数据
    strSQL = "select Count(*) from [DATA_" & strDXPYSX & "]" _
            & " where not [" & strXXPYSX & "] is null" _
            & " and [" & strXXPYSX & "]<>''"
    Set rstemp = New ADODB.Recordset
    rstemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
    If rstemp(0) > 0 Then
        MsgBox "在项目组合“" & strDXMC & "”的数据表中，体检项目“" _
                & strXXMC & "”已存在 " & rstemp.RecordCount _
                & " 条体检记录。为保护客户体检数据的完整性，不能删除！", vbExclamation, "警告"
        GoTo ExitLab
    End If
    rstemp.Close
    
    Set rstemp = Nothing
    
    '开启事务
    GCon.BeginTrans
    On Error GoTo RollBack
    '从组合数据表中删除小项
    strSQL = "delete from SET_ZH_Data" _
            & " where DXID='" & strDXID & "'" _
            & " and XXID='" & strXXID & "'"
    GCon.Execute strSQL
    
    '删除数据表字段
    strSQL = "ALTER TABLE " & "[DATA_" & strDXPYSX & "]" _
            & " DROP COLUMN [" & strXXPYSX & "]"
    If blnHavePhoto Then
        strSQL = strSQL & ",[" & strXXPYSX & PHOTO_FIELD & "]"
    End If
    
    GCon.Execute strSQL
    '提交事务
    GCon.CommitTrans
    DeleteXMuFromZH = True
On Error GoTo 0
    GoTo ExitLab
    
RollBack:
    GCon.RollbackTrans
ErrMsg:
    MsgBoxW Err, vbExclamation
ExitLab:
    '
End Function

Private Sub cmdDeleteAll_Click()
On Error GoTo ErrMsg
    Dim Status
    Dim strKey As String
    Dim i As Long
    
    Me.MousePointer = vbHourglass
    
    '权限验证
    If g_blnIsNew Then
        If Not g_clsAuthority.CheckOperationAuthority(m_strMenu, DELETE_W) Then GoTo ExitLab
    End If
    '验证完毕
    
    If cmdDelete.Enabled = False Then GoTo ExitLab
    
    If tvwXMu.SelectedItem Is Nothing Then GoTo ExitLab
    
    strKey = Mid(tvwXMu.SelectedItem.Key, 2)
    Select Case Len(strKey)
        Case 0, 2 '选择了根节点，或者科室
            GoTo ExitLab
        Case 4 '选择了项目组合
            '是否有项目
            If lvwChecked.ListItems.Count < 1 Then GoTo ExitLab
            
            '是否有选择
            If lvwChecked.SelectedItem Is Nothing Then
                MsgBox "请在已选项目中选择要删除的项目", vbInformation, "提示"
                GoTo ExitLab
            End If
            
            '删除
            With lvwChecked
                For i = .ListItems.Count To 1 Step -1
                    If DeleteXMuFromZH(Mid(.ListItems(i).Key, 2), strKey) = True Then
                        '添加到目的列表
                        lvwUnchecked.ListItems.Add , .ListItems(i).Key, .ListItems(i).Text
                        
                        '从源列表中删除
                        .ListItems.Remove (i)
                    End If
                Next i
            End With
    End Select
    
    EnableCommand
    
    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 Form_Load()
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim rsKS As ADODB.Recordset
    Dim rsDX As ADODB.Recordset
    Dim nodTemp As Node
    
    Screen.MousePointer = vbArrowHourglass
    
    '添加根节点
    '关键字长度：1＝1
    Set nodTemp = tvwXMu.Nodes.Add(, , "W", "所有科室")
    nodTemp.Expanded = True
    
    '外层循环，添加所有科室
    strSQL = "select KSID,KSMC from SET_KSSZ order by SXH"
    Set rsKS = New ADODB.Recordset
    rsKS.Open strSQL, GCon, adOpenStatic, adLockOptimistic
    If rsKS.RecordCount > 0 Then
        rsKS.MoveFirst
        With tvwXMu.Nodes
            Do
                '关键字长度：1＋2＝3
                Set nodTemp = .Add("W", tvwChild, "W" & rsKS("KSID"), rsKS("KSMC"))
                
                '对每个科室，循环添加下属的所有组合
                strSQL = "select DXID,DXMC from SET_DX" _
                        & " where KSID='" & rsKS("KSID") & "'" _
                        & " order by SXH"
                Set rsDX = New ADODB.Recordset
                rsDX.Open strSQL, GCon, adOpenStatic, adLockOptimistic
                If rsDX.RecordCount > 0 Then
                    rsDX.MoveFirst
                    '内层循环
                    Do
                        '关键字长度：1＋4＝5
                        Set nodTemp = .Add("W" & rsKS("KSID"), tvwChild, "W" & rsDX("DXID"), rsDX("DXMC"))
                        
                        rsDX.MoveNext
                    Loop Until rsDX.EOF
                    rsDX.Close
                End If
                
                rsKS.MoveNext
            Loop Until rsKS.EOF
        End With
        rsKS.Close
    End If
    
    If tvwXMu.Nodes.Count > 1 Then
        '说明至少存在一个科室
        '默认选中第一个科室，即第二个节点
        Set tvwXMu.SelectedItem = tvwXMu.Nodes(2)
    Else
        '没有科室
        '选中第一个根节点
        Set tvwXMu.SelectedItem = tvwXMu.Nodes(1)
        
        MsgBox "尚未建立任何科室，无法添加项目组合！" & vbCrLf & "请首先添加科室！", vbInformation, "提示"
    End If
    tvwXMu_NodeClick tvwXMu.SelectedItem
        
    GoTo ExitLab
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    Screen.MousePointer = vbDefault
End Sub

Private Sub lvwChecked_DblClick()
    cmdDelete_Click
End Sub

Private Sub lvwUnchecked_DblClick()
    cmdAdd_Click
End Sub

Private Sub tvwXMu_NodeClick(ByVal Node As MSComctlLib.Node)
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim rstemp As ADODB.Recordset
    Dim strKey As String
    Dim itmTemp As ListItem
    Dim i As Long
    
    Me.MousePointer = vbHourglass
    
    '清空已经显示的项目
    lvwChecked.ListItems.Clear
    lvwUnchecked.ListItems.Clear
    
    '是否有选择
    If tvwXMu.SelectedItem Is Nothing Then Exit Sub
    
    strKey = Mid(tvwXMu.SelectedItem.Key, 2)
    Select Case Len(strKey)
        Case 0 '选择了根节点
            cmdAdd.Enabled = False
            cmdDelete.Enabled = False
            cmdAddAll.Enabled = False
            cmdDeleteAll.Enabled = False
            
        Case 2 '选择了科室
            cmdAdd.Enabled = False
            cmdDelete.Enabled = False
            cmdAddAll.Enabled = False
            cmdDeleteAll.Enabled = False
            
            '显示当前科室的所有项目
            strSQL = "select XXID,XXMC,XXPYSX from SET_XX" _
                    & " where KSID='" & strKey & "'" _
                    & " order by SXH"
            GoSub ShowUncheckedXMu
        Case 4 '选择了项目组合
            '显示当前组合包括的项目
            strSQL = "select XXID,XXMC,XXPYSX from SET_XX" _
                    & " where KSID='" & Left(strKey, 2) & "'" _
                    & " and XXID in (" _
                        & "select XXID from SET_ZH_Data" _
                        & " where DXID='" & strKey & "'" _
                    & ")" _
                    & " order by SXH"
            Set rstemp = New ADODB.Recordset
            rstemp.Open strSQL, GCon, adOpenStatic, adLockOptimistic
            If rstemp.RecordCount > 0 Then
                rstemp.MoveFirst
                For i = 1 To rstemp.RecordCount
                    Set itmTemp = lvwChecked.ListItems.Add(, "W" & rstemp("XXID"), rstemp("XXMC"))
                    
                    rstemp.MoveNext
                Next
                
                rstemp.Close
                
                cmdDelete.Enabled = True
                cmdDeleteAll.Enabled = True
            Else
                cmdDelete.Enabled = False
                cmdDeleteAll.Enabled = False
            End If
            
            '显示当前科室下不属于当前组合的的项目
            strSQL = "select XXID,XXMC,XXPYSX from SET_XX" _
                    & " where KSID='" & Left(strKey, 2) & "'" _
                    & " and XXID not in (" _
                        & "select XXID from SET_ZH_Data" _
                        & " where DXID='" & strKey & "'" _
                    & ")" _
                    & " order by SXH"
            GoSub ShowUncheckedXMu
            
            If lvwUnchecked.ListItems.Count > 0 Then
                cmdAdd.Enabled = True
                cmdAddAll.Enabled = True
            Else
                cmdAdd.Enabled = False
                cmdAddAll.Enabled = False
            End If
    End Select
    
    GoTo ExitLab
    
ShowUncheckedXMu:
    Set rstemp = New ADODB.Recordset
    rstemp.Open strSQL, GCon, adOpenStatic, adLockOptimistic
    If rstemp.RecordCount > 0 Then
        rstemp.MoveFirst
        For i = 1 To rstemp.RecordCount
            Set itmTemp = lvwUnchecked.ListItems.Add(, "W" & rstemp("XXID"), rstemp("XXMC"))
            
            rstemp.MoveNext
        Next
        
        rstemp.Close
    End If
    Return
    
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    Me.MousePointer = vbDefault
End Sub

'启用/禁用添加和删除按钮
Private Sub EnableCommand()
    If lvwChecked.ListItems.Count < 1 Then
        cmdDelete.Enabled = False
        cmdDeleteAll.Enabled = False
    Else
        cmdDelete.Enabled = True
        cmdDeleteAll.Enabled = True
    End If
    
    If lvwUnchecked.ListItems.Count < 1 Then
        cmdAdd.Enabled = False
        cmdAddAll.Enabled = False
    Else
        cmdAdd.Enabled = True
        cmdAddAll.Enabled = True
    End If
End Sub