frmxmsz_a.frm

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

'    '加载所有体检标准
'    strSQL = "select BZID,BZMC from SET_TJBZIndex where SFQY=1"
'    Set rsXX = New ADODB.Recordset
'    rsXX.Open strSQL, GCon, adOpenStatic, adLockOptimistic
'    If rsXX.RecordCount > 0 Then
'        rsXX.MoveFirst
'        Do
'            cmbBZMC.AddItem rsXX("BZMC")
'            cmbBZMC.ItemData(cmbBZMC.NewIndex) = rsXX("BZID")
'
'            rsXX.MoveNext
'        Loop Until rsXX.EOF
'        rsXX.Close
'
'        cmbBZMC.ListIndex = 0
'    Else
'        cmbBZMC_Click
'    End If
    
    GoTo ExitLab
    
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    Screen.MousePointer = 0
End Sub

Private Sub Form_Unload(Cancel As Integer)
    Set frmXMSZ_A = Nothing
End Sub

Private Sub optWZX_Click()
    fraDXLXing.Enabled = True
    If (optDXSMing.Value = False) And (optDXSZhi.Value = False) And (optDXYYang.Value = False) Then
        optDXSMing.Value = True
    End If
End Sub

Private Sub optYZX_Click()
    optDXSMing.Value = False
    optDXSZhi.Value = False
    optDXYYang.Value = False
    fraDXLXing.Enabled = False
End Sub

'模拟tvwXMu_Click()
Private Sub tvwXMuClick()
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim strKey As String
    Dim rsTemp As ADODB.Recordset
    Dim intSXH As Integer
    Dim i As Integer
    
    Me.MousePointer = 11
    
    If tvwXMu.Nodes.Count < 1 Then GoTo ExitLab
    If tvwXMu.SelectedItem Is Nothing Then GoTo ExitLab
    
    cmdSave.Enabled = False
    '记录关键字
    strKey = tvwXMu.SelectedItem.Key
    '去掉第一位
    strKey = Mid(strKey, 2)
    Select Case Len(strKey)
        Case 0 '单击了根节点
            fraDX.Visible = False
            fraXX.Visible = False
            
            cmdAdd.Enabled = False
            cmdDelete.Enabled = False
            cmdModify.Enabled = False
        Case 2 '单击了科室
            fraDX.Visible = False
            fraXX.Visible = False
            
            cmdAdd.Enabled = True
            cmdDelete.Enabled = False
            cmdModify.Enabled = False
        Case 4 '单击了大项
            fraDX.Visible = True
            fraXX.Visible = False
            
            cmdAdd.Enabled = True
            cmdDelete.Enabled = True
            cmdModify.Enabled = True
            
            
            '获取该大项的信息
            strSQL = "select * from SET_DX" _
                    & " where DXID='" & strKey & "'"
        Case 7 '单击了小项
            fraDX.Visible = False
            fraXX.Visible = True
            
            cmdAdd.Enabled = True
            cmdDelete.Enabled = True
            cmdModify.Enabled = True
            
            '获取该小项的信息
            strSQL = "select * from SET_XX" _
                    & " where XXID='" & strKey & "'"
    End Select
    
    If strSQL <> "" Then
        Set rsTemp = New ADODB.Recordset
        rsTemp.Open strSQL, GCon, adOpenStatic, adLockOptimistic
        strSQL = ""
        If Not rsTemp.EOF Then
            If Len(strKey) = 4 Then
                '*********************************************
                '单击了大项
                '*********************************************
                txtDXID.Text = rsTemp("DXID")
                txtDXMC.Text = rsTemp("DXMC")
                txtDXPYSX.Text = rsTemp("DXPYSX")
                txtDXWBSX.Text = IIf(IsNull(rsTemp("DXWBSX")), "", rsTemp("DXWBSX"))
                If rsTemp("DXSFYZX") = 0 Then
                    '无子项
                    optWZX.Value = True
                    If rsTemp("DXType") = 0 Then
                        optDXSMing.Value = True
                    ElseIf rsTemp("DXType") = 1 Then
                        optDXSZhi.Value = True
                    Else
                        optDXYYang.Value = True
                    End If
                    
                    cmdAdd.Enabled = False
                Else
                    '有子项
                    optYZX.Value = True
                    cmdAdd.Enabled = True
                End If
                '性别
                If rsTemp("DXNNTY") = 0 Then '通用
                    optNNTY.Value = True
                ElseIf rsTemp("DXNNTY") = 1 Then '男性
                    OptMale.Value = True
                Else '女性
                    OptFemale.Value = True
                End If
                '
                txtDXJG.Text = IIf(IsNull(rsTemp("DXJG")), "", rsTemp("DXJG"))
                txtDXSM.Text = IIf(IsNull(rsTemp("DXSM")), "", rsTemp("DXSM"))
                
                '此处加入查询顺序号的语句
                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")
            ElseIf Len(strKey) = 7 Then
                '*********************************************
                '单击了小项
                '*********************************************
                txtXXID.Text = rsTemp("XXID")
                txtXXMC.Text = rsTemp("XXMC")
                txtXXPYSX.Text = rsTemp("XXPYSX")
                txtXXWBSX.Text = IIf(IsNull(rsTemp("XXWBSX")), "", rsTemp("XXWBSX"))
                
                If rsTemp("XXType") = 0 Then
                    optXXSMing.Value = True
                ElseIf rsTemp("XXType") = 1 Then
                    optXXSZhi.Value = True
                Else
                    optXXYYang.Value = True
                End If
                
                '性别
                If rsTemp("XXNNTY") = 1 Then
                    '男性
                    optXXMale.Value = True
                ElseIf rsTemp("XXNNTY") = 2 Then
                    '女性
                    optXXFemale.Value = True
                Else
                    '其它为通用
                    optXXNNTY.Value = True
                End If
                
                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 = IIf(IsNull(rsTemp("XXSM")), "", rsTemp("XXSM"))
                
                '此处加入查询顺序号的语句
                strSQL = "select distinct SXH from SET_SXH" _
                        & " where SXH not in (" _
                        & "select SXH from SET_XX" _
                        & " where left(XXID,4)='" & Left(rsTemp("XXID"), 4) & "'" _
                        & " and XXID<>'" & rsTemp("XXID") & "')"
                intSXH = rsTemp("SXH")
            End If
            
            '获取顺序号
            If strSQL <> "" Then
                '打开记录集
                Set rsTemp = New ADODB.Recordset
                rsTemp.Open strSQL, GCon, adOpenStatic, adLockOptimistic
                '清空可能存在的显示
        
                If 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
                Else '小项序号
                    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
                End If
                
                rsTemp.Close
                Set rsTemp = Nothing
            End If
        End If
    End If
    
    SetAllDXInput False
    SetAllXXInput False
    
    GoTo ExitLab
    
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    Me.MousePointer = 0
End Sub

Private Sub tvwXMu_NodeClick(ByVal Node As MSComctlLib.Node)
    tvwXMuClick
End Sub

Private Sub SetAllDXInput(ByVal blnFlag As Boolean)
    txtDXMC.Enabled = blnFlag
    txtDXPYSX.Enabled = blnFlag
    txtDXWBSX.Enabled = blnFlag
    cmbDXSXH.Enabled = blnFlag
    txtDXSM.Enabled = blnFlag
    txtDXJG.Enabled = blnFlag
    optYZX.Enabled = blnFlag
    optWZX.Enabled = blnFlag
    fraDXLXing.Enabled = blnFlag
    optNNTY.Enabled = blnFlag
    OptMale.Enabled = blnFlag
    OptFemale.Enabled = blnFlag
End Sub

Private Sub ClearAllDXInput()
    txtDXMC.Text = ""
    txtDXPYSX.Text = ""
    txtDXWBSX.Text = ""
    txtDXSM.Text = ""
    txtDXJG.Text = ""
    optYZX.Value = True
    optWZX.Value = False
    optNNTY.Value = True
    OptMale.Value = False
    OptFemale.Value = False
End Sub

Private Sub SetAllXXInput(ByVal blnFlag As Boolean)
    txtXXMC.Enabled = blnFlag
    txtXXPYSX.Enabled = blnFlag
'    txtXXCKSX.Enabled = blnFlag
'    txtXXCKXX.Enabled = blnFlag
'    txtXXDW.Enabled = blnFlag
    optXXSMing.Enabled = blnFlag
    optXXSZhi.Enabled = blnFlag
    optXXYYang.Enabled = blnFlag
    txtXXWBSX.Enabled = blnFlag
    cmbXXSXH.Enabled = blnFlag
    optXXNNTY.Enabled = blnFlag
    optXXMale.Enabled = blnFlag
    optXXFemale.Enabled = blnFlag
    txtXXSM.Enabled = blnFlag
    optXJieNo.Enabled = blnFlag
    optXJieYes.Enabled = blnFlag
    optJYiNo.Enabled = blnFlag
    optJYiYes.Enabled = blnFlag
  
'  '如果是说明型或阴阳型，禁用上下限和单位
'    If (Option3.Value = True) Or (optXXYYang.Value = True) Then
'      TextXXCKSX.Enabled = False
'      TextXXCKXX.Enabled = False
'      TextXXDW.Enabled = False
'    End If
End Sub

Private Sub ClearAllXXInput()
    txtXXMC.Text = ""
'    txtXXCKSX.Text = ""
'    txtXXCKXX.Text = ""
'    txtXXDW.Text = ""
    optXXSMing.Value = True
    txtXXPYSX.Text = ""
    txtXXWBSX.Text = ""
    
    optXJieYes.Value = True
    optJYiYes.Value = True
    
    txtXXSM.Text = ""
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
    
'*************小吴代码****************
'    intID = 0
'    strSQL = "select max(DXID) from SET_DX" _
'            & " WHERE KSID=" & "'" & strKSID & "'"
'    rsTemp.Open strSQL, GCon, adOpenDynamic, adLockOptimistic
'    If Not rsTemp.EOF Then
'        If IsNull(rsTemp(0)) Then
'            intID = 0
'        Else
'            intID = Val(Right(rsTemp(0), 2))
'        End If
'        intID = intID + 1
'        rsTemp.Close
'    End If
'
'    If intID > 99 Then
'        MsgBox "你设置了过多的大项,请删除一些", vbInformation, "提示"
'        GoTo ExitLab
'    End If
'
'    GetDXID = LongToString(intID, 2)
'    GetDXID = strKSID & GetDXID
'
'    GoTo ExitLab
'*************小吴代码完****************

    
'**********获取第一个空余的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  '如果当前科室还无大项,