frmks_zhsz.frm

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

        rsKS.Close
    End If
    
    If tvwKSZH.Nodes.Count > 1 Then
        '说明至少存在一个科室
        '默认选中第一个科室，即第二个节点
        Set tvwKSZH.SelectedItem = tvwKSZH.Nodes(2)
    Else
        '没有科室
        '选中第一个根节点
        Set tvwKSZH.SelectedItem = tvwKSZH.Nodes(1)
    End If
    tvwKSZH_NodeClick tvwKSZH.SelectedItem
        
    GoTo ExitLab
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    Screen.MousePointer = vbDefault
End Sub

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

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

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

Private Sub tvwKSZH_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 '用户当前选择的项目ID
    Dim intSXH As Integer '顺序号
    Dim i As Integer
    
    Me.MousePointer = vbHourglass
    
    '是否有选择
    If tvwKSZH.SelectedItem Is Nothing Then GoTo ExitLab
    
    '记录选择的ID
    strKey = Mid(tvwKSZH.SelectedItem.Key, 2)
    
    '禁用保存按钮
    cmdSave.Enabled = False
    '启用添加按钮
    cmdAdd.Enabled = True
    
    cmdDelete.Enabled = True
    cmdModify.Enabled = True
    '检测用户单击了哪一类节点
    Select Case Len(strKey)
        Case 0 '根节点
            fraKS.Visible = False
            fraDX.Visible = False
            
            cmdDelete.Enabled = False
            cmdModify.Enabled = False
        Case 2 '科室
            fraKS.Visible = True
            fraDX.Visible = False
            EnableKSInput False
            
            '显示科室信息
            strSQL = "select * from SET_KSSZ" _
                    & " where KSID='" & strKey & "'"
            Set rstemp = New ADODB.Recordset
            rstemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
            txtKSID.Text = rstemp("KSID")
            txtKSMC.Text = rstemp("KSMC")
            txtKSMC.Tag = rstemp("KSMC")
            txtKSPYSX.Text = rstemp("KSPYSX")
            txtKSWBSX.Text = rstemp("KSWBSX") & ""
            txtKSSM.Text = rstemp("KSSM") & ""
            CmbKsType.Text = Trim(rstemp("KStype")) & ""
            
            '此处加入查询顺序号的语句
            strSQL = "select distinct SXH from SET_SXH" _
                    & " where SXH not in (" _
                    & "select SXH from SET_KSSZ" _
                    & " where KSID<>'" & rstemp("KSID") & "')"
            intSXH = rstemp("SXH")
            
            rstemp.Close
        Case 4 '组合
            fraKS.Visible = False
            fraDX.Visible = True
            
            EnableDXInput False
            
            '显示组合信息
            strSQL = "select * from SET_DX" _
                    & " where DXID='" & strKey & "'"
            Set rstemp = New ADODB.Recordset
            rstemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
            txtDXID.Text = rstemp("DXID")
            txtDXMC.Text = rstemp("DXMC") & ""
            txtDXMC.Tag = rstemp("DXMC") & ""
            txtDXPYSX.Text = rstemp("DXPYSX") & ""
            txtDXPYSX.Tag = rstemp("DXPYSX") & ""
            txtDXWBSX.Text = rstemp("DXWBSX") & ""
            Select Case rstemp("DXNNTY")
                Case 0
                    optNNTY.Value = True
                Case 1
                    optMale.Value = True
                Case 2
                    optFemale.Value = True
            End Select
            txtDXJG.Text = rstemp("DXJG")
            txtDXPYSX.Text = rstemp("DXPYSX") & ""
            txtDXSM.Text = rstemp("DXSM") & ""
            txtDXZYSX.Text = rstemp("DXZYSX") & ""
            
            '此处加入查询顺序号的语句
            strSQL = "select distinct SXH from SET_SXH" _
                    & " where SXH not in (" _
                    & "select SXH from SET_DX" _
                    & " where left(DXID,2)='" & Left(rstemp("DXID"), 2) & "'" _
                    & " and DXID<>'" & rstemp("DXID") & "')"
            intSXH = rstemp("SXH")
                
            rstemp.Close
    End Select
    
    '获取顺序号
    If strSQL <> "" Then
        '打开记录集
        Set rstemp = New ADODB.Recordset
        rstemp.Open strSQL, GCon, adOpenStatic, adLockOptimistic
        '清空可能存在的显示

        If Len(strKey) = 2 Then '科室序号
            cmbKSSXH.Clear
            For i = 1 To rstemp.RecordCount
                cmbKSSXH.AddItem rstemp("SXH")
                If rstemp("SXH") = intSXH Then
                    cmbKSSXH.ListIndex = cmbKSSXH.NewIndex
                End If
                
                rstemp.MoveNext
            Next
        ElseIf Len(strKey) = 4 Then '大项序号
            cmbDXSXH.Clear
            For i = 1 To rstemp.RecordCount
                cmbDXSXH.AddItem rstemp("SXH")
                If rstemp("SXH") = intSXH Then
                    cmbDXSXH.ListIndex = cmbDXSXH.NewIndex
                End If
                
                rstemp.MoveNext
            Next
        End If
        
        rstemp.Close
        Set rstemp = Nothing
    End If
    
    GoTo ExitLab
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    Me.MousePointer = vbDefault
End Sub

'获取某一科室的最大可用大项id
Private Function GetDXID(ByVal strKSID As String) As String
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim rstemp  As New ADODB.Recordset
    Dim intID As Integer
    Dim blIDExist(1 To 99) As Boolean
    Dim i, j As Integer
    
'**********获取第一个空余的DXID号(20040311晚加)*****************
    For i = 1 To 99
        blIDExist(i) = False
    Next i

    strSQL = "SELECT * FROM SET_DX WHERE KSID='" & strKSID & "'" _
           & " ORDER BY SXH"
    rstemp.Open strSQL, GCon, adOpenDynamic, adLockOptimistic
    If rstemp.RecordCount = 0 Then  '如果当前科室还无大项,则返回"01"
        GetDXID = strKSID & LongToString(1, 2)
    Else   '否则
        For j = 1 To 99
            rstemp.MoveFirst
            For i = 1 To rstemp.RecordCount
                If Right(rstemp("DXID"), 2) = LongToString(j, 2) Then
                    blIDExist(j) = True
                    Exit For
                End If
                rstemp.MoveNext
            Next i
        Next j
        '查找第一个未用的ID号
        For i = 1 To 99
            If blIDExist(i) = False Then
                intID = i
                Exit For
            End If
        Next i
        GetDXID = strKSID & LongToString(intID, 2)
    End If
'**********获取第一个空余的DXID号(20040311晚加)完*****************
    
    GoTo ExitLab
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    Me.MousePointer = vbDefault
End Function

'计算新添加科室的科室ID
Private Function GetKSID() As String
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim rstemp  As New ADODB.Recordset
    Dim intID As Integer
    Dim blIDExist(1 To 99) As Boolean
    Dim i, j As Integer

'**********获取第一个空余的KSID号(20040314加)*****************
    For i = 1 To 99
        blIDExist(i) = False
    Next i

    strSQL = "SELECT * FROM SET_KSSZ "
    rstemp.Open strSQL, GCon, adOpenDynamic, adLockOptimistic
    If rstemp.RecordCount = 0 Then  '如果当前无科室,则返回"01"
        GetKSID = LongToString(1, 2)
    Else   '否则
        For j = 1 To 99
            rstemp.MoveFirst
            For i = 1 To rstemp.RecordCount
                If rstemp("KSID") = LongToString(j, 2) Then
                    blIDExist(j) = True
                    Exit For
                End If
                rstemp.MoveNext
            Next i
        Next j
        '查找第一个未用的ID号
        For i = 1 To 99
            If blIDExist(i) = False Then
                intID = i
                Exit For
            End If
        Next i
        GetKSID = LongToString(intID, 2)
    End If
'**********获取第一个空余的DXID号(20040311晚加)完*****************
    
    GoTo ExitLab
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    Me.MousePointer = vbDefault
End Function

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

Private Sub txtDXJG_GotFocus()
    txtDXJG.SelStart = 0
    txtDXJG.SelLength = Len(txtDXJG.Text)
End Sub

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

Private Sub txtDXJG_LostFocus()
    txtDXJG.Text = Val(txtDXJG.Text)
End Sub

Private Sub txtDXMC_GotFocus()
    txtDXMC.SelStart = 0
    txtDXMC.SelLength = Len(txtDXMC.Text)
End Sub

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

Private Sub txtDXMC_LostFocus()
    txtDXPYSX.Text = Trim(txtDXPYSX.Text)
    If txtDXPYSX.Text = "" Then
        txtDXPYSX.Text = GetPYJM(txtDXMC.Text)
    End If
End Sub

Private Sub txtDXPYSX_GotFocus()
    txtDXPYSX.SelStart = 0
    txtDXPYSX.SelLength = Len(txtDXPYSX.Text)
End Sub

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

Private Sub txtDXSM_GotFocus()
    txtDXSM.SelStart = 0
    txtDXSM.SelLength = Len(txtDXSM.Text)
End Sub

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

Private Sub txtDXWBSX_GotFocus()
    txtDXWBSX.SelStart = 0
    txtDXWBSX.SelLength = Len(txtDXWBSX.Text)
End Sub

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

Private Sub txtDXZYSX_GotFocus()
    txtDXZYSX.SelStart = 0
    txtDXZYSX.SelLength = Len(txtDXZYSX.Text)
End Sub

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

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

Private Sub txtKSMC_GotFocus()
    txtKSMC.SelStart = 0
    txtKSMC.SelLength = Len(txtKSMC.Text)
End Sub

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

Private Sub txtKSMC_LostFocus()
    txtKSPYSX.Text = Trim(txtKSPYSX.Text)
    If txtKSPYSX.Text = "" Then
        txtKSPYSX.Text = GetPYJM(txtKSMC.Text)
    End If
End Sub

'禁用/启用科室输入
Private Sub EnableKSInput(ByVal blnFlag As Boolean)
    txtKSMC.Enabled = blnFlag
    txtKSPYSX.Enabled = blnFlag
    txtKSWBSX.Enabled = blnFlag
    cmbKSSXH.Enabled = blnFlag
    txtKSSM.Enabled = blnFlag
    CmbKsType.Enabled = blnFlag
End Sub

'禁用/启用组合输入
Private Sub EnableDXInput(ByVal blnFlag As Boolean)
    txtDXMC.Enabled = blnFlag
    txtDXPYSX.Enabled = blnFlag
    txtDXWBSX.Enabled = blnFlag
    cmbDXSXH.Enabled = blnFlag
    optNNTY.Enabled = blnFlag
    optMale.Enabled = blnFlag
    optFemale.Enabled = blnFlag
    txtDXJG.Enabled = blnFlag
    txtDXZYSX.Enabled = blnFlag
    txtDXSM.Enabled = blnFlag
End Sub

Private Sub txtKSPYSX_GotFocus()
    txtKSPYSX.SelStart = 0
    txtKSPYSX.SelLength = Len(txtKSPYSX.Text)
End Sub

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

Private Sub txtKSSM_GotFocus()
    txtKSSM.SelStart = 0
    txtKSSM.SelLength = Len(txtKSSM.Text)
End Sub

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

Private Sub txtKSWBSX_GotFocus()
    txtKSWBSX.SelStart = 0
    txtKSWBSX.SelLength = Len(txtKSWBSX.Text)
End Sub

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