frmks_zhsz.frm

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

                MsgBox "在科室“" & tvwKSZH.SelectedItem.Text & _
                        "”下面尚有组合存在，不能删除该科室！" & vbCrLf _
                        & "您可以先删除该科室下的所有组合，然后删除该科室！", _
                        vbExclamation, "警告"
                GoTo ExitLab
            End If
            rstemp.Close
            
            '如果科室下尚有项目，则禁止删除
            strSQL = "select Count(*) from SET_XX" _
                    & " where left(XXID,2)='" & strKey & "'"
            Set rstemp = New ADODB.Recordset
            rstemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
            If rstemp(0) >= 1 Then
                MsgBox "在科室“" & tvwKSZH.SelectedItem.Text & _
                        "”下面尚有体检项目存在，不能删除该科室！" & vbCrLf _
                        & "您可以先删除该科室下的所有体检项目，然后删除该科室！", _
                        vbExclamation, "警告"
                GoTo ExitLab
            End If
            rstemp.Close
            
            '确认删除字典
            strSQL = "select Count(*) from DM_KS" _
                    & " where KSID='" & strKey & "'"
            Set rstemp = New ADODB.Recordset
            rstemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
            If rstemp(0) >= 1 Then
                If MsgBox("在科室“" & tvwKSZH.SelectedItem.Text & "”下面找到 " & rstemp(0) _
                        & " 条字典数据，如果删除该科室，这些字典数据将同时被删除！" _
                        & vbCrLf & "您确认要继续吗？", _
                        vbExclamation + vbYesNo + vbDefaultButton2, "警告") = vbNo Then
                    GoTo ExitLab
                End If
            End If
            rstemp.Close
            
            '确认体检建议
            strSQL = "select Count(*) from DM_ZJJY" _
                    & " where KSID='" & strKey & "'"
            Set rstemp = New ADODB.Recordset
            rstemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
            If rstemp(0) >= 1 Then
                If MsgBox("在科室“" & tvwKSZH.SelectedItem.Text & "”下面找到 " & rstemp(0) _
                        & " 条体检建议，如果删除该科室，这些体检建议数据将同时被删除！" _
                        & vbCrLf & "您确认要继续吗？", _
                        vbExclamation + vbYesNo + vbDefaultButton2, "警告") = vbNo Then
                    GoTo ExitLab
                End If
            End If
            rstemp.Close
            
            '构造删除语句
            strSQL = "delete from SET_KSSZ" _
                    & " where KSID='" & strKey & "'"
            '从数据库删除
            GCon.Execute strSQL
            
            '从字典中删除
            strSQL = "delete from DM_KS" _
                    & " where KSID='" & strKey & "'"
            GCon.Execute strSQL
            
            '从体检建议中删除
            strSQL = "delete from DM_ZJJY" _
                    & " where KSID='" & strKey & "'"
            GCon.Execute strSQL
            
        Case 4 '选择了组合
            If MsgBox("该操作不可恢复！将同时删除项目组合“" _
                    & tvwKSZH.SelectedItem.Text & "”下的所有体检数据！" _
                    & vbCrLf & "确实要删除项目组合“" _
                    & tvwKSZH.SelectedItem.Text & "”吗？", _
                    vbCritical + vbYesNo + vbDefaultButton2, _
                    "小心") = vbNo Then
                GoTo ExitLab
            End If
            
            '如果组合下尚有小项，则禁止删除
            strSQL = "select Count(*) from SET_ZH_Data" _
                    & " where DXID='" & strKey & "'"
            Set rstemp = New ADODB.Recordset
            rstemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
            If rstemp(0) >= 1 Then
                MsgBox "在项目组合“" & tvwKSZH.SelectedItem.Text & _
                        "”下面尚有体检项目存在，不能删除该组合！" & vbCrLf _
                        & "您可以先删除该项目组合下的所有体检项目，然后删除该组合！", _
                        vbExclamation, "警告"
                GoTo ExitLab
            End If
            rstemp.Close
            
            '获取数据表名称
            strSQL = "select DXPYSX from SET_DX" _
                    & " where DXID='" & strKey & "'"
            Set rstemp = New ADODB.Recordset
            rstemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
            '删除数据表
            strSQL = "drop table [DATA_" & rstemp("DXPYSX") & "]"
            GCon.Execute strSQL
            rstemp.Close
            
            '构造删除语句
            strSQL = "delete from SET_DX" _
                    & " where DXID='" & strKey & "'"
            '从数据库删除
            GCon.Execute strSQL
    End Select
    
    '从树形上移除
    lngIndex = tvwKSZH.SelectedItem.Index
'    Set nodTemp = tvwKSZH.SelectedItem.FirstSibling
    tvwKSZH.Nodes.Remove lngIndex
    '选中前一个节点
    Set tvwKSZH.SelectedItem = tvwKSZH.Nodes(lngIndex - 1) 'nodTemp
    tvwKSZH_NodeClick tvwKSZH.SelectedItem
    
    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 cmdModify_Click()
    Dim strKey As String
    
    Me.MousePointer = vbHourglass
    
    cmdAdd.Enabled = False
    cmdDelete.Enabled = False
    cmdModify.Enabled = False
    cmdSave.Enabled = True
    
    If tvwKSZH.SelectedItem Is Nothing Then GoTo ExitLab
    
    menuOperation = Modify
    strKey = Mid(tvwKSZH.SelectedItem.Key, 2)
    Select Case Len(strKey)
        Case 0
            GoTo ExitLab
        Case 2
            EnableKSInput True
            txtKSMC.SetFocus
        Case 4
            EnableDXInput True
            txtDXMC.SetFocus
    End Select

ExitLab:
    Me.MousePointer = vbDefault
End Sub

Private Sub cmdSave_Click()
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim rstemp As ADODB.Recordset
    Dim nodTemp As Node
    Dim strKey As String
    Dim strID As String
    Dim strText As String
    Dim intSex As Integer
    
    Me.MousePointer = vbHourglass
    
    If tvwKSZH.SelectedItem Is Nothing Then GoTo ExitLab
    
    strKey = Mid(tvwKSZH.SelectedItem.Key, 2)
    '***********************************************************
    '                           输入验证
    '***********************************************************
    If fraKS.Visible = True Then '科室
        '是否输入了科室名称
        txtKSMC.Text = Trim(txtKSMC.Text)
        If txtKSMC.Text = "" Then
            MsgBox "请输入科室名称！", vbInformation, "提示"
            txtKSMC.SetFocus
            GoTo ExitLab
        End If
        
        If txtKSMC.Text <> txtKSMC.Tag Then
            '检查名称是否已经存在
            strSQL = "select Count(*) from SET_KSSZ" _
                    & " where KSMC='" & txtKSMC.Text & "'"
            Set rstemp = New ADODB.Recordset
            rstemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
            If rstemp(0) > 0 Then
                MsgBox "您输入的科室名称已经存在，请核对后重新输入！", vbInformation, "提示"
                txtKSMC.SetFocus
                GoTo ExitLab
            End If
            rstemp.Close
        End If
        
        strText = txtKSMC.Text
    ElseIf fraDX.Visible = True Then '组合
        '是否输入了组合名称
        txtDXMC.Text = Trim(txtDXMC.Text)
        If txtDXMC.Text = "" Then
            MsgBox "请输入项目组合的名称！", vbInformation, "提示"
            txtDXMC.SetFocus
            GoTo ExitLab
        End If
        
        If txtDXMC.Text <> txtDXMC.Tag Then
            '检查名称在同一科室下是否重复
            '考虑到套餐设定，不在同一科室下也不能重复
            strSQL = "select Count(*) from SET_DX" _
                    & " where DXMC='" & txtDXMC.Text & "'"
            Set rstemp = New ADODB.Recordset
            rstemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
            If rstemp(0) > 0 Then
                MsgBox "您输入的项目组合名称已经存在，请核对后重新输入！", vbInformation, "提示"
                txtDXMC.SetFocus
                GoTo ExitLab
            End If
            rstemp.Close
        End If
        
        '是否输入了拼音缩写
        txtDXPYSX.Text = Trim(txtDXPYSX.Text)
        If txtDXPYSX.Text = "" Then
            MsgBox "请输入项目组合的拼音缩写！", vbInformation, "提示"
            txtDXPYSX.SetFocus
            GoTo ExitLab
        End If
        
        If txtDXPYSX.Text <> txtDXPYSX.Tag Then
            '拼音缩写是否已经存在
            strSQL = "select Count(*) from SET_DX" _
                    & " where DXPYSX='" & txtDXPYSX.Text & "'"
            Set rstemp = New ADODB.Recordset
            rstemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
            If rstemp(0) > 0 Then
                MsgBox "您输入的项目组合的拼音缩写已经存在，请核对后重新输入！", vbInformation, "提示"
                txtDXPYSX.SetFocus
                GoTo ExitLab
            End If
            rstemp.Close
        End If
        
        strText = txtDXMC.Text
    End If
    
    '***********************************************************
    '                     验证完毕，写入数据库
    '***********************************************************
GCon.BeginTrans '开始事务
On Error GoTo RollBack
    If menuOperation = Add Then '添加
        Select Case Len(strKey)
            Case 0 '添加科室
                strID = txtKSID.Text
                '添加一条空记录
                strSQL = "insert into SET_KSSZ(KSID) values(" _
                        & "'" & strID & "'" _
                        & ")"
                GCon.Execute strSQL
            Case 2, 4 '添加组合
                strID = txtDXID.Text
                '添加一条空记录
                strSQL = "insert into SET_DX(DXID,KSID) values(" _
                        & "'" & strID & "'" _
                        & ",'" & Left(strID, 2) & "'" _
                        & ")"
                GCon.Execute strSQL
                
                '添加数据表
                strSQL = "CREATE TABLE [DATA_" & txtDXPYSX.Text & "]" & _
                        " ([GUID] bigint PRIMARY KEY,TJRQ smalldatetime)"
                GCon.Execute strSQL
        End Select
    Else '修改
        strID = strKey
    End If
    
    '更新数据库
    Select Case Len(strID)
        Case 2 '更新科室
            strSQL = "update SET_KSSZ set" _
                    & " KSMC='" & txtKSMC.Text & "'" _
                    & ",KSPYSX='" & txtKSPYSX.Text & "'" _
                    & ",KSWBSX='" & txtKSWBSX.Text & "'" _
                    & ",SXH=" & Val(cmbKSSXH.Text) _
                    & ",KSSM='" & txtKSSM.Text & "'" _
                    & ",KStype='" & CmbKsType.Text & "'" _
                    & " where KSID='" & strID & "'"
        Case 4 '更新组合
            If optMale.Value Then
                intSex = 1
            ElseIf optFemale.Value Then
                intSex = 2
            Else
                intSex = 0
            End If
            
            strSQL = "update SET_DX set" _
                    & " DXMC='" & txtDXMC.Text & "'" _
                    & ",DXPYSX='" & txtDXPYSX.Text & "'" _
                    & ",DXWBSX='" & txtDXWBSX.Text & "'" _
                    & ",SXH=" & Val(cmbDXSXH.Text) _
                    & ",DXSFYZX=1" _
                    & ",DXNNTY=" & intSex _
                    & ",DXJG=" & CCur(Val(txtDXJG.Text)) _
                    & ",DXZYSX='" & txtDXZYSX.Text & "'" _
                    & ",DXSM='" & txtDXSM.Text & "'" _
                    & " where DXID='" & strID & "'"
    End Select
    GCon.Execute strSQL
    
    If menuOperation = Add Then '添加
        '添加到左侧的树形结构
        Select Case Len(strKey)
            Case 0, 2
                Set nodTemp = tvwKSZH.Nodes.Add(tvwKSZH.SelectedItem, tvwChild, "W" & strID, strText)
            Case 4
                Set nodTemp = tvwKSZH.Nodes.Add(tvwKSZH.SelectedItem, tvwNext, "W" & strID, strText)
        End Select
        Set tvwKSZH.SelectedItem = nodTemp
    Else '修改
        If fraKS.Visible = True Then
            If txtKSMC.Text <> txtKSMC.Tag Then
                tvwKSZH.SelectedItem.Text = txtKSMC.Text
            End If
        ElseIf fraDX.Visible = True Then
            If txtDXMC.Text <> txtDXMC.Tag Then
                tvwKSZH.SelectedItem.Text = txtDXMC.Text
            End If
            
            '是否更改了大项拼音缩写
            If txtDXPYSX.Text <> txtDXPYSX.Tag Then
                '把旧表数据导入新表
                strSQL = "select * into [DATA_" & txtDXPYSX.Text & "]" _
                        & " from [DATA_" & txtDXPYSX.Tag & "]"
                GCon.Execute strSQL
                
                '删除旧表
                strSQL = "drop table [DATA_" & txtDXPYSX.Tag & "]"
                GCon.Execute strSQL
            End If
        End If
    End If
GCon.CommitTrans '提交事务
    
    On Error GoTo ErrMsg
    
    tvwKSZH_NodeClick tvwKSZH.SelectedItem
    
    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
    Dim strSQL As String
    Dim rsKS As ADODB.Recordset
    Dim rsDX As ADODB.Recordset
    Dim nodTemp As Node
    
    Screen.MousePointer = vbArrowHourglass
    Set rsKS = New ADODB.Recordset
    rsKS.Open "select col_length('set_kssz','KStype') as LenType", GCon, adOpenStatic, adLockOptimistic
    If IsNull(rsKS!LenType) Then
        GCon.Execute "ALTER TABLE set_kssz add KStype CHAR(10)"
    End If
    rsKS.Close
    
    '添加根节点
    '关键字长度：1＝1
    Set nodTemp = tvwKSZH.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 tvwKSZH.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