frmxmsz_a.frm

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

            Size            =   9.75
            Charset         =   0
            Weight          =   400
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         Height          =   300
         Left            =   240
         TabIndex        =   49
         Top             =   3675
         Width           =   855
      End
      Begin VB.Label Label3 
         Alignment       =   1  'Right Justify
         BackStyle       =   0  'Transparent
         Caption         =   "说明"
         BeginProperty Font 
            Name            =   "宋体"
            Size            =   9.75
            Charset         =   0
            Weight          =   400
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         Height          =   300
         Left            =   240
         TabIndex        =   48
         Top             =   4110
         Width           =   855
      End
      Begin VB.Label Label7 
         Alignment       =   1  'Right Justify
         BackStyle       =   0  'Transparent
         Caption         =   "性别"
         BeginProperty Font 
            Name            =   "宋体"
            Size            =   9.75
            Charset         =   0
            Weight          =   400
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         Height          =   300
         Left            =   240
         TabIndex        =   47
         Top             =   3210
         Width           =   855
      End
      Begin VB.Label Label8 
         Alignment       =   1  'Right Justify
         BackStyle       =   0  'Transparent
         Caption         =   "显示顺序"
         BeginProperty Font 
            Name            =   "宋体"
            Size            =   9.75
            Charset         =   0
            Weight          =   400
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         Height          =   300
         Left            =   210
         TabIndex        =   46
         Top             =   1170
         Width           =   855
      End
      Begin VB.Label Label21 
         BackStyle       =   0  'Transparent
         Caption         =   "大项类别"
         Height          =   300
         Left            =   300
         TabIndex        =   45
         Top             =   1575
         Width           =   855
      End
   End
End
Attribute VB_Name = "frmXMSZ_A"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Dim menuOperation As OperationType

Private Sub cmdAdd_Click()
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim rsSXH As ADODB.Recordset
    Dim rsVersion As ADODB.Recordset
    Dim intSum As Integer
    Dim i As Integer
    Dim strKey As String
    
    Me.MousePointer = 11
    
    
    '***********************************************************
    '版本控制
    '***********************************************************
    Select Case genuVersion
        Case WLB
            '
        Case ZYB
        
        Case BZB
            strSQL = "select Count(*) from SET_DX" _
                    & " where DXSFYZX=0" _
                    & " union " _
                    & "select Count(*) from SET_XX"
            Set rsVersion = New ADODB.Recordset
            rsVersion.Open strSQL, GCon, adOpenStatic, adLockOptimistic
            
            rsVersion.MoveFirst
            intSum = rsVersion(0)
            rsVersion.MoveNext
            intSum = intSum + rsVersion(0)
            If intSum >= 300 Then
                MsgBox "您使用的是标准版，只能设置300项体检项目！", vbInformation, "提示"
                GoTo ExitLab
            End If
            rsVersion.Close
            Set rsVersion = Nothing
        Case PJB
            strSQL = "select Count(*) from SET_DX" _
                    & " where DXSFYZX=0" _
                    & " union " _
                    & "select Count(*) from SET_XX"
            Set rsVersion = New ADODB.Recordset
            rsVersion.Open strSQL, GCon, adOpenStatic, adLockOptimistic
            
            rsVersion.MoveFirst
            intSum = rsVersion(0)
            rsVersion.MoveNext
            intSum = intSum + rsVersion(0)
            If intSum >= 100 Then
                MsgBox "您使用的是普及版，只能设置100项体检项目！", vbInformation, "提示"
                GoTo ExitLab
            End If
            rsVersion.Close
            Set rsVersion = Nothing
    End Select
    '***********************************************************
    '***********************************************************
    
    
    strSQL = "" '清空查询字符串
'    If Status = "CHANGE" Or Status = "ADD" Then
'        MsgBox "请先按保存按钮保存当前信息"
'        GoTo 100
'    End If
    
    If tvwXMu.Nodes.Count < 1 Then GoTo ExitLab
    If tvwXMu.SelectedItem Is Nothing Then
        MsgBox "请在左侧的树型中选择要修改的项目！", vbInformation, "提示"
        GoTo ExitLab
    End If
    
    '记录关键字
    strKey = tvwXMu.SelectedItem.Key
    '去掉第一位
    strKey = Mid(strKey, 2)
    Select Case Len(strKey)
        Case 0 '单击了根节点
            MsgBox "请选择科室、大项，或小项节点，然后单击“添加”！", vbInformation, "提示"
            GoTo ExitLab
        Case 2 '单击了科室，添加大项
            fraDX.Visible = True
            fraXX.Visible = False
            
            cmdAdd.Enabled = False
            cmdDelete.Enabled = False
            cmdModify.Enabled = False
            cmdSave.Enabled = True
            
            txtDXID.Text = GetDXID(strKey)

            SetAllDXInput True
            ClearAllDXInput
            optYZX.Value = True
            optNNTY.Value = True
            
            '构造查询字符串
            strSQL = "select SXH from SET_SXH" _
                    & " where SXH not in (" _
                    & "select SXH from SET_DX" _
                    & " where left(DXID,2)='" & Left(strKey, 2) & "')"
                    
            menuOperation = Add
        Case 4, 7 '单击了大项或小项，添加小项
            fraDX.Visible = False
            fraXX.Visible = True
            
            cmdAdd.Enabled = False
            cmdDelete.Enabled = False
            cmdModify.Enabled = False
            cmdSave.Enabled = True
            
            SetAllXXInput True
            ClearAllXXInput
            
            If Len(strKey) = 4 Then
                txtXXID.Text = GetXXID(strKey)
            Else
                txtXXID.Text = GetXXID(Left(strKey, 4))
            End If
            
            optXXSMing.Value = True
            optXJieNo.Value = True
            optJYiNo.Value = True
            
            strSQL = "select SXH from SET_SXH" _
                    & " where SXH not in (" _
                    & "select SXH from SET_XX" _
                    & " where left(XXID,4)='" & Left(txtXXID.Text, 4) & "')"
            menuOperation = Add
        Case Else
            MsgBox "您必须选中项目！", vbInformation, "提示"
            GoTo ExitLab
    End Select
      
    cmdDelete.Enabled = False
    cmdModify.Enabled = False
    cmdAdd.Enabled = False
    
    cmdSave.Enabled = True
    cmdOK.Enabled = True
    
    If strSQL <> "" Then
        '打开记录集
        Set rsSXH = New ADODB.Recordset
        rsSXH.Open strSQL, GCon, adOpenStatic, adLockOptimistic
        '清空可能存在的显示

        If Len(strKey) = 2 Then '大项序号
            cmbDXSXH.Clear
            For i = 1 To rsSXH.RecordCount
                cmbDXSXH.AddItem rsSXH("SXH")
                rsSXH.MoveNext
            Next
            
            cmbDXSXH.ListIndex = 0
        Else '小项序号
            cmbXXSXH.Clear
            For i = 1 To rsSXH.RecordCount
                cmbXXSXH.AddItem rsSXH("SXH")
                rsSXH.MoveNext
            Next
            
            cmbXXSXH.ListIndex = 0
        End If
        
        If rsSXH.RecordCount > 0 Then
            rsSXH.Close
        Else
            MsgBox "添加的同级项目数已经达到最大，请删除掉一部分项目后再添加！", vbInformation, "提示"
            cmdExit_Click
        End If
        Set rsSXH = Nothing
    End If
 
    GoTo ExitLab
    
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    Me.MousePointer = 0
End Sub

Private Sub cmdDelete_Click()
On Error GoTo ErrMsg
    Dim Status
    Dim rsTemp As New ADODB.Recordset
    Dim strSQL As String
    Dim cmd As ADODB.Command
    Dim strKey As String
    Dim strDXPYSX As String
    Dim strXXPYSX As String
    Dim intIndex As Integer
    
'    If Status = "CHANGE" Or Status = "ADD" Then
'        MsgBox "请先保存当前项目信息"
'        GoTo 100
'    End If
    
    Me.MousePointer = 11
    
    Set cmd = New ADODB.Command
    Set cmd.ActiveConnection = GCon
    
    If tvwXMu.Nodes.Count < 1 Then GoTo ExitLab
    If tvwXMu.SelectedItem Is Nothing Then
        MsgBox "请在左侧的树型中选择要修改的项目！", vbInformation, "提示"
        GoTo ExitLab
    End If
    
    '记录关键字
    strKey = tvwXMu.SelectedItem.Key
    '去掉第一位
    strKey = Mid(strKey, 2)
    
    Select Case Len(strKey)
        Case Is <= 2 '科室或根节点
            MsgBox "请在科室管理中删除科室！", vbInformation, "提示"
            GoTo ExitLab
        Case 4 '大项
            If MsgBox("该操作不可恢复！确定要删除大项 " & tvwXMu.SelectedItem.Text & " 项吗?", _
                    vbQuestion + vbOKCancel + vbDefaultButton2, "警告") = vbCancel _
                    Then GoTo ExitLab
            '首先获取该大项的拼音缩写
            strSQL = "select DXPYSX from SET_DX" _
                    & " where DXID='" & strKey & "'"
            Set rsTemp = New ADODB.Recordset
            rsTemp.Open strSQL, GCon, adOpenStatic, adLockOptimistic
            If rsTemp.EOF Then
                MsgBox "无法获取当前大项的拼音缩写，请联系系统管理员，确认数据库是否遭到损坏！", vbInformation, "提示"
                GoTo ExitLab
            End If
            strDXPYSX = rsTemp("DXPYSX")
            rsTemp.Close
            
            '首先删除大项表里的记录
            strSQL = "delete from SET_DX" _
                    & " where DXID='" & strKey & "'"
            cmd.CommandText = strSQL
            cmd.Execute
            
            '删除大项对应的表
            strSQL = "DROP TABLE [DATA_" & strDXPYSX & "]"
            cmd.CommandText = strSQL
            cmd.Execute
        
            '删除大项下的所有小项
            strSQL = "delete from SET_XX" _
                    & " where left(XXID,4)='" & strKey & "'"
            cmd.CommandText = strSQL
            cmd.Execute
            
            '*************************20040314*************
            '删除该大项下所有小项对应的数据字典数据
            strSQL = "delete from DM_XX" _
                    & " where left(XXID,4)='" & strKey & "'"
                    
            cmd.CommandText = strSQL
            cmd.Execute
            '*************************20040314*************
            
            '*************************20040314*************
            '如果该大项无子项,则删除该大项数据字典数据
            strSQL = "delete from DM_DX" _
                    & " where DXID='" & strKey & "'"
                    
            cmd.CommandText = strSQL
            cmd.Execute
            '*************************20040314*************
            

            '删除体检标准（包括该大项包含的所有小项）
            strSQL = "delete from SET_TJBZDT" _
                    & " where left(XMID,4)='" & strKey & "'"
            cmd.CommandText = strSQL
            cmd.Execute
                    
            intIndex = tvwXMu.SelectedItem.Index
            tvwXMu.Nodes.Remove intIndex
'            Set tvwXMu.SelectedItem = tvwXMu.Nodes(intIndex - 1)
            tvwXMuClick
        Case 7 '小项
            If MsgBox("该操作不可恢复！确定要删除小项 " & tvwXMu.SelectedItem.Text & " 吗?", _
                    vbQuestion + vbOKCancel + vbDefaultButton2, "确认删除") = vbCancel Then GoTo ExitLab