frmxiangmu.frm

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

      End
      Begin XPControls.XPCommandButton cmdModify 
         Height          =   375
         Left            =   3600
         TabIndex        =   3
         Top             =   300
         Width           =   1215
         _ExtentX        =   2143
         _ExtentY        =   661
         Caption         =   "修 改"
         BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} 
            Name            =   "MS Sans Serif"
            Size            =   8.25
            Charset         =   0
            Weight          =   400
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
      End
      Begin XPControls.XPCommandButton cmdDelete 
         Height          =   375
         Left            =   2055
         TabIndex        =   4
         Top             =   300
         Width           =   1215
         _ExtentX        =   2143
         _ExtentY        =   661
         Caption         =   "删 除"
         BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} 
            Name            =   "MS Sans Serif"
            Size            =   8.25
            Charset         =   0
            Weight          =   400
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
      End
      Begin XPControls.XPCommandButton cmdAdd 
         Height          =   375
         Left            =   510
         TabIndex        =   5
         Top             =   300
         Width           =   1215
         _ExtentX        =   2143
         _ExtentY        =   661
         Caption         =   "添 加"
         BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} 
            Name            =   "MS Sans Serif"
            Size            =   8.25
            Charset         =   0
            Weight          =   400
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
      End
   End
   Begin MSComctlLib.TreeView tvwXMu 
      Height          =   6705
      Left            =   120
      TabIndex        =   6
      Top             =   450
      Width           =   3270
      _ExtentX        =   5768
      _ExtentY        =   11827
      _Version        =   393217
      HideSelection   =   0   'False
      LabelEdit       =   1
      Style           =   7
      Appearance      =   1
      BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} 
         Name            =   "MS Sans Serif"
         Size            =   8.25
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
   End
   Begin VB.Label Label3 
      BackStyle       =   0  'Transparent
      Caption         =   "参照项目："
      Height          =   195
      Left            =   3540
      TabIndex        =   43
      Top             =   210
      Width           =   1395
   End
   Begin VB.Label Label2 
      BackStyle       =   0  'Transparent
      Caption         =   "项目列表："
      Height          =   195
      Left            =   120
      TabIndex        =   42
      Top             =   210
      Width           =   1395
   End
End
Attribute VB_Name = "frmXiangMu"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Dim menuOperation As OperationType
Dim m_strMenu As String
Dim m_blnIsSystem As Boolean
Dim m_nodDraged As Node
Dim m_blnInDrag As Boolean

Public Sub ShowForm(ByVal strMenu As String)
    m_strMenu = strMenu
    Me.Show vbModal
End Sub

Private Sub cmbXXSXH_KeyPress(KeyAscii As Integer)
    EnterToTab KeyAscii
End Sub

Private Sub cmdAdd_Click()
    Dim strKey As String
    Dim i As Integer
    Dim strSQL As String
    Dim rsSXH As ADODB.Recordset
    
    Me.MousePointer = vbHourglass
    
    '权限验证
    If g_blnIsNew Then
        If Not g_clsAuthority.CheckOperationAuthority(m_strMenu, INSERT_W) Then GoTo ExitLab
    End If
    '验证完毕
    
    If tvwXMu.SelectedItem Is Nothing Then GoTo ExitLab
    
    strKey = Mid(tvwXMu.SelectedItem.Key, 2)
    '是否选择了根节点
    If Len(strKey) = 0 Then GoTo ExitLab
    
    menuOperation = Add
    fraXX.Visible = True
    
    cmdAdd.Enabled = False
    cmdDelete.Enabled = False
    cmdModify.Enabled = False
    cmdSave.Enabled = True
    
    '取出当前科室
    strKey = Left(strKey, 2)
    
    txtXXID.Text = GetXXID(strKey)
    
    EnableXXInput True
    
    If m_blnIsSystem Then
        txtXXPYSX.SetFocus
    Else
        txtXXMC.Text = ""
        txtXXMC.Tag = "" '清除Tag标志
        txtXXPYSX.Text = ""
        txtXXPYSX.Tag = "" '清除Tag标志
        txtXXPrice.Text = ""
        txtXXSM.Text = ""
        txtExpression.Text = ""
        txtExpression.Tag = ""
        chkHavePhoto.Value = vbUnchecked
        chkHavePhoto.Tag = ""
        
        txtXXMC.SetFocus
    End If
    
    strSQL = "select SXH from SET_SXH" _
            & " where SXH not in (" _
            & "select SXH from SET_XX" _
            & " where left(XXID,2)='" & strKey & "')"
    '打开记录集
    Set rsSXH = New ADODB.Recordset
    rsSXH.Open strSQL, GCon, adOpenStatic, adLockOptimistic
    '清空可能存在的显示
    cmbXXSXH.Clear
    For i = 1 To rsSXH.RecordCount
        cmbXXSXH.AddItem rsSXH("SXH")
        rsSXH.MoveNext
    Next
    
    If rsSXH.RecordCount > 0 Then
        cmbXXSXH.ListIndex = 0
        rsSXH.Close
    Else
        MsgBox "添加的同级项目数已经达到最大，请删除掉一部分项目后再添加！", vbInformation, "提示"
        cmdExit_Click
    End If
    Set rsSXH = Nothing
ExitLab:
    Me.MousePointer = vbDefault
End Sub

Private Sub cmdDelete_Click()
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim rsTemp As ADODB.Recordset
    Dim strKey As String
    Dim nodTemp As Node
    Dim lngIndex As Long
    
    Me.MousePointer = vbHourglass
    
    '权限验证
    If g_blnIsNew Then
        If Not g_clsAuthority.CheckOperationAuthority(m_strMenu, DELETE_W) Then GoTo ExitLab
    End If
    '验证完毕
    
    '是否有选择
    If tvwXMu.SelectedItem Is Nothing Then GoTo ExitLab
    
    strKey = Mid(tvwXMu.SelectedItem.Key, 2)
    
    Select Case Len(strKey)
        Case 0, 2 '选择了根节点，或者科室
            GoTo ExitLab
            
        Case 7 '选择了项目
            '确认删除
            If MsgBox("该操作不可恢复！" & vbCrLf & "确实要删除体检项目“" _
                    & tvwXMu.SelectedItem.Text & "”吗？", _
                    vbExclamation + vbYesNo + vbDefaultButton2, "警告") = vbNo Then
                GoTo ExitLab
            End If
            
            '检查该项目是否已经存在于组合中
            '如果存在，则禁止删除
            strSQL = "select Count(*) from SET_ZH_Data" _
                    & " where XXID='" & strKey & "'"
            Set rsTemp = New ADODB.Recordset
            rsTemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
            If rsTemp(0) > 0 Then
                MsgBox "该体检项目存在于 " & rsTemp.RecordCount & _
                        " 个项目组合中，为了维护数据库的完整性，无法删除！" & vbCrLf _
                        & "如果确实要删除该项目，您可以先从这些组合里面移除该项目，然后删除！", _
                        vbCritical, "警告"
                GoTo ExitLab
            End If
            rsTemp.Close
            
            '确认删除字典数据
            strSQL = "select Count(*) from DM_XX" _
                    & " where XXID='" & strKey & "'"
            Set rsTemp = New ADODB.Recordset
            rsTemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
            If rsTemp(0) > 0 Then
                If MsgBox("该体检项目已经存在 " & rsTemp(0) _
                        & " 条字典数据。如果删除该项目，将同时删除这些字典数据！" _
                        & vbCrLf & "您确认要继续吗？", _
                        vbExclamation + vbYesNo + vbDefaultButton2, "警告") = vbNo Then
                    GoTo ExitLab
                End If
            End If
            rsTemp.Close
            
            '确认模板数据
            strSQL = "select Count(*) from DM_XM_Value" _
                    & " where XMID='" & strKey & "'"
            Set rsTemp = New ADODB.Recordset
            rsTemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
            If rsTemp(0) > 0 Then
                If MsgBox("该体检项目已经存在 " & rsTemp(0) _
                        & " 条模板数据。如果删除该项目，将同时删除这些模板数据！" _
                        & vbCrLf & "您确认要继续吗？", _
                        vbExclamation + vbYesNo + vbDefaultButton2, "警告") = vbNo Then
                    GoTo ExitLab
                End If
            End If
            rsTemp.Close
            
            '从数据库删除
            strSQL = "delete from SET_XX" _
                    & " where XXID='" & strKey & "'"
            GCon.Execute strSQL
            
            '删除字典数据
            strSQL = "delete from DM_XX" _
                    & " where XXID='" & strKey & "'"
            GCon.Execute strSQL
            
            '删除模板数据
            strSQL = "delete from DM_XM_Value" _
                    & " where XMID='" & strKey & "'"
            GCon.Execute strSQL
            
            '从树形结构上删除
            If tvwXMu.SelectedItem.Index = tvwXMu.SelectedItem.FirstSibling.Index Then
                lngIndex = tvwXMu.SelectedItem.Parent.Index
            Else
                lngIndex = tvwXMu.SelectedItem.Previous.Index
            End If
            
            tvwXMu.Nodes.Remove tvwXMu.SelectedItem.Index
            Set tvwXMu.SelectedItem = tvwXMu.Nodes(lngIndex)
            
            '调用单击事件
            tvwXMu_NodeClick tvwXMu.SelectedItem
    End Select
    
    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 cmdExpression_Click()
    Dim strRet As String
    Dim intPos As Integer
    
    strRet = dlgBuildExpression.GetExpression(Modify, tvwXMu.SelectedItem.Text, txtExpression.Text)
    Unload dlgBuildExpression
    Set dlgBuildExpression = Nothing
    
    If strRet <> "" Then
        intPos = InStr(1, strRet, ",")
        txtExpression.Text = Left(strRet, intPos - 1)
        txtExpression.Tag = Mid(strRet, intPos + 1)
    End If
End Sub

Private Sub cmdModify_Click()
    Dim strKey As String
    
    Me.MousePointer = vbHourglass
    
    '权限验证
    If g_blnIsNew Then
        If Not g_clsAuthority.CheckOperationAuthority(m_strMenu, UPDATE_W) Then GoTo ExitLab
    End If
    '验证完毕
    
    cmdAdd.Enabled = False
    cmdDelete.Enabled = False
    cmdModify.Enabled = False
    cmdSave.Enabled = True
    
    If tvwXMu.SelectedItem Is Nothing Then GoTo ExitLab
    
    menuOperation = Modify
    strKey = Mid(tvwXMu.SelectedItem.Key, 2)
    Select Case Len(strKey)
        Case 0, 2
            GoTo ExitLab
        Case 7
            EnableXXInput True
            txtXXMC.SetFocus
            If tvwXMu.SelectedItem.Tag <> "" Then Call EnableSysPart(False)
    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 rsDX As ADODB.Recordset
    Dim rsConvert As ADODB.Recordset '转换说明型为其它类型
    Dim strKey As String
    Dim strKSID As String
    Dim nodTemp As Node
    Dim strXXID As String
    Dim intTemp As ItemType
    
    Dim strOldXXPYSX As String      '在修改项目情下，记录原来的小项拼音缩写
    Dim strTableName As String
    
    Me.MousePointer = vbHourglass
    
    If tvwXMu.SelectedItem Is Nothing Then GoTo ExitLab
    
    strKey = Mid(tvwXMu.SelectedItem.Key, 2)
    '取出科室
    strKSID = Left(strKey, 2)
    
    '是否输入了项目名称
    txtXXMC.Text = Trim(txtXXMC.Text)
    If txtXXMC.Text = "" Then
        MsgBox "请输入体检项目名称！", vbInformation, "提示"
        txtXXMC.SetFocus
        GoTo ExitLab
    End If
    
    '项目名称在同一科室下是否重复
    If txtXXMC.Text <> txtXXMC.Tag Or m_blnIsSystem Then
        strSQL = "select Count(*) from SET_XX" _
                & " where XXMC='" & txtXXMC.Text & "'" _
                & " and KSID='" & strKSID & "'"
                
        Set rsTemp = New ADODB.Recordset
        rsTemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
        If rsTemp(0) > 0 Then
            MsgBox "您输入的项目名称已经存在，请核对后重新输入！", vbInformation, "提示"
            If txtXXMC.Enabled Then txtXXMC.SetFocus
            GoTo ExitLab
        End If
        rsTemp.Close
    End If