frmxmsz.frm

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

        Else
            Set nodTemp = tvwXMu.Nodes.Add("W" & strKey, tvwNext, "W" & strXXID, txtXXMC.Text)
        End If
        Set tvwXMu.SelectedItem = nodTemp
    Else '修改项目
        If txtXXMC.Text <> txtXXMC.Tag Then
            tvwXMu.SelectedItem.Text = txtXXMC.Text
        End If
    End If
    
    '调用单击事件
    tvwXMu_NodeClick tvwXMu.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 rsXX 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 XXID,XXMC from SET_XX" _
                        & " where left(XXID,2)='" & rsKS("KSID") & "'" _
                        & " order by SXH"
                Set rsXX = New ADODB.Recordset
                rsXX.Open strSQL, GCon, adOpenStatic, adLockOptimistic
                If rsXX.RecordCount > 0 Then
                    rsXX.MoveFirst
                    '内层循环
                    Do
                        '关键字长度：1＋7＝8
                        Set nodTemp = .Add("W" & rsKS("KSID"), tvwChild, "W" & rsXX("XXID"), rsXX("XXMC"))
                        
                        rsXX.MoveNext
                    Loop Until rsXX.EOF
                    rsXX.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 optJYiNo_KeyPress(KeyAscii As Integer)
    EnterToTab KeyAscii
End Sub

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

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

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

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

Private Sub optXXJSuan_Click()
    If optXXJSuan.Enabled = True Then
        EnableExpression True
    Else
        EnableExpression False
    End If
End Sub

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

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

Private Sub optXXSMing_Click()
    EnableExpression False
End Sub

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

Private Sub optXXSZhi_Click()
    EnableExpression False
End Sub

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

Private Sub optXXYYang_Click()
    EnableExpression False
End Sub

Private Sub optXXYYang_KeyPress(KeyAscii As Integer)
    EnterToTab KeyAscii
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 intSXH As Integer
    Dim i As Integer
    Dim intPos As Integer
    
    Me.MousePointer = vbHourglass
    
    cmdSave.Enabled = False
    
    If tvwXMu.SelectedItem Is Nothing Then GoTo ExitLab
    
    strKey = Mid(tvwXMu.SelectedItem.Key, 2)
    Select Case Len(strKey)
        Case 0 '根节点
            fraXX.Visible = False
            
            cmdAdd.Enabled = False
            cmdDelete.Enabled = False
            cmdModify.Enabled = False
        Case 2 '科室节点
            fraXX.Visible = False
            
            cmdAdd.Enabled = True
            cmdDelete.Enabled = False
            cmdModify.Enabled = False
        Case 7 '项目节点
            fraXX.Visible = True
            
            cmdAdd.Enabled = True
            cmdDelete.Enabled = True
            cmdModify.Enabled = True
            
            EnableXXInput False
            
            '显示项目信息
            strSQL = "select * from SET_XX" _
                    & " where XXID='" & strKey & "'"
            Set rstemp = New ADODB.Recordset
            rstemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
            txtXXID.Text = rstemp("XXID")
            txtXXMC.Text = rstemp("XXMC")
            txtXXMC.Tag = rstemp("XXMC") '记录Tag标志
            txtExpression.Text = "" '清除计算型表达式
            txtExpression.Tag = ""
            '是否含有图像
            chkHavePhoto.Value = IIf(rstemp("HavePhoto"), vbChecked, vbUnchecked)
            chkHavePhoto.Tag = IIf(rstemp("HavePhoto"), 1, 0)
            
            lblXMLX.Tag = "" '清空标识
            Select Case rstemp("XXType")
                Case 0 '说明型
                    optXXSMing.Value = True
                    '记录项目类型。只记录说明型
                    lblXMLX.Tag = rstemp("XXType") '便于修改
                Case 1 '数值型
                    optXXSZhi.Value = True
                Case 2 '阴阳型
                    optXXYYang.Value = True
                Case 3 '计算型
                    optXXJSuan.Value = True
                    
                    If Not IsNull(rstemp("XXExpression")) Then
                        intPos = InStr(1, rstemp("XXExpression"), ",")
                        txtExpression.Text = Left(rstemp("XXExpression"), intPos - 1)
                        txtExpression.Tag = Mid(rstemp("XXExpression"), intPos + 1)
                    End If
                Case Else '
                    '
            End Select
            txtXXPYSX.Text = rstemp("XXPYSX")
            txtXXPYSX.Tag = rstemp("XXPYSX") '记录Tag标志
            txtXXWBSX.Text = rstemp("XXWBSX") & ""
            txtXXPrice.Text = rstemp("XXPrice") & ""
            
            Select Case rstemp("XXNNTY")
                Case 1
                    optXXMale.Value = True
                Case 2
                    optXXFemale.Value = True
                Case Else
                    optXXNNTY.Value = True
            End Select
            If rstemp("XXSFJRXJ") = True Then
                optXJieYes.Value = True
            Else
                optXJieNo.Value = True
            End If
            
            If rstemp("XXSFYJY") = True Then
                optJYiYes.Value = True
            Else
                optJYiNo.Value = True
            End If
            
            txtXXSM.Text = rstemp("XXSM") & ""
            
            intSXH = rstemp("SXH")
            '此处加入查询顺序号的语句
            strSQL = "select distinct SXH from SET_SXH" _
                    & " where SXH not in (" _
                        & "select SXH from SET_XX" _
                        & " where left(XXID,2)='" & Left(rstemp("XXID"), 2) & "'" _
                        & " and SXH<>" & intSXH _
                    & ")"
            
            '首先关闭前面打开的记录集
            rstemp.Close
            '再次打开记录集，获取顺序号
            Set rstemp = New ADODB.Recordset
            rstemp.Open strSQL, GCon, adOpenStatic, adLockOptimistic
            '清空可能存在的显示
            cmbXXSXH.Clear
            For i = 1 To rstemp.RecordCount
                cmbXXSXH.AddItem rstemp("SXH")
                If rstemp("SXH") = intSXH Then
                    cmbXXSXH.ListIndex = cmbXXSXH.NewIndex
                End If
                
                rstemp.MoveNext
            Next
            
            rstemp.Close
            Set rstemp = Nothing
    End Select
    
    GoTo ExitLab
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    Me.MousePointer = vbDefault
End Sub

'启用/禁用输入按钮
Private Sub EnableXXInput(ByVal blnFlag As Boolean)
    txtXXMC.Enabled = blnFlag
    optXXSMing.Enabled = blnFlag
    optXXSZhi.Enabled = blnFlag
    optXXYYang.Enabled = blnFlag
    optXXJSuan.Enabled = blnFlag
    If (blnFlag) And (optXXJSuan.Value = True) Then
        EnableExpression True
    Else
        EnableExpression False
    End If
    chkHavePhoto.Enabled = blnFlag
    txtXXPYSX.Enabled = blnFlag
    txtXXWBSX.Enabled = blnFlag
    txtXXPrice.Enabled = blnFlag
    cmbXXSXH.Enabled = blnFlag
    optXXNNTY.Enabled = blnFlag
    optXXMale.Enabled = blnFlag
    optXXFemale.Enabled = blnFlag
    optXJieNo.Enabled = blnFlag
    optXJieYes.Enabled = blnFlag
    optJYiNo.Enabled = blnFlag
    optJYiYes.Enabled = blnFlag
    txtXXSM.Enabled = blnFlag
End Sub

Private Sub txtExpression_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
    Clipboard.Clear
End Sub

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

Private Sub txtXXMC_LostFocus()
    txtXXPYSX.Text = Trim(txtXXPYSX.Text)
    If txtXXPYSX.Text = "" Then
        txtXXPYSX.Text = GetPYJM(txtXXMC.Text)
    End If
End Sub

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

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

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

Private Sub EnableExpression(ByVal blnFlag As Boolean)
    txtExpression.Enabled = blnFlag
    cmdExpression.Enabled = blnFlag
End Sub