frmsjmb.frm

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

'                        rsXX.MoveFirst
'                        Do
'                            '关键字长度：1＋4＋7＝12
'                            tvwXMu.Nodes.Add "W" & rsDX("DXID"), tvwChild, "W" & rsDX("DXID") & rsXX("XXID"), rsXX("XXMC")
'                            nodTemp.Expanded = True
'
'                            rsXX.MoveNext
'                        Loop Until rsXX.EOF
'                        rsXX.Close
'                    End If
'                End If
'
'                rsDX.MoveNext
'            Loop Until rsDX.EOF
'            rsDX.Close
'        End If

        '显示当前科室的项目
        strSQL = "select XXID,XXMC from SET_XX" _
                & " where left(XXID,2)='" & gstrKSID & "'"
        '按顺序号排序
        strSQL = strSQL & " order by SXH"
        Set rsXX = New ADODB.Recordset
        rsXX.Open strSQL, GCon, adOpenStatic, adLockOptimistic
        If rsXX.RecordCount > 0 Then
            Do
                Set nodTemp = tvwXMu.Nodes.Add("W" & gstrKSID, tvwChild, "W" & rsXX("XXID"), rsXX("XXMC"))
                nodTemp.Expanded = True

                rsXX.MoveNext
            Loop Until rsXX.EOF
        End If
    Else
        '这个时候只有系统管理员和终检医生可以进来
        '所以显示所有科室
        '显示所有科室
        strSQL = "select KSID,KSMC from SET_KSSZ"
        '按顺序号排序
        strSQL = strSQL & " order by SXH"
        Set rsKShi = New ADODB.Recordset
        rsKShi.Open strSQL, GCon, adOpenStatic, adLockOptimistic
        If rsKShi.RecordCount > 0 Then
            rsKShi.MoveFirst
            Do
                '添加科室
                '关键字长度：1＋2＝3
                Set nodTemp = tvwXMu.Nodes.Add(, , "W" & rsKShi("KSID"), rsKShi("KSMC"))
                nodTemp.Expanded = True
                
'                '添加该科室下项目
'                strSQL = "select DXID,DXMC,DXSFYZX from SET_DX" _
'                        & " where left(DXID,2)='" & rsKShi("KSID") & "'"
'                '按顺序号排序
'                strSQL = strSQL & " order by SXH"
'                Set rsDX = New ADODB.Recordset
'                rsDX.Open strSQL, GCon, adOpenStatic, adLockOptimistic
'                If rsDX.RecordCount > 0 Then
'                    rsDX.MoveFirst
'                    Do
'                        '添加大项
'                        '关键字长度：1＋4＝5
'                        Set nodTemp = tvwXMu.Nodes.Add("W" & rsKShi("KSID"), tvwChild, "W" & rsDX("DXID"), rsDX("DXMC"))
'
'                        If rsDX("DXSFYZX") = 1 Then '有子项
'                            strSQL = "select XXID,XXMC from SET_XX" _
'                                    & " where XXID in (" _
'                                        & "select XXID from SET_ZH_Data" _
'                                        & " where DXID='" & rsDX("DXID") & "'" _
'                                    & ")"
'                            '按顺序号排序
'                            strSQL = strSQL & " order by SXH"
'                            Set rsXX = New ADODB.Recordset
'                            rsXX.Open strSQL, GCon, adOpenKeyset, adLockOptimistic
'                            If rsXX.RecordCount > 0 Then
'                                rsXX.MoveFirst
'                                Do
'                                    '关键字长度：1＋4＋7＝12
'                                    tvwXMu.Nodes.Add "W" & rsDX("DXID"), tvwChild, "W" & rsDX("DXID") & rsXX("XXID"), rsXX("XXMC")
'
'                                    rsXX.MoveNext
'                                Loop Until rsXX.EOF
'                                rsXX.Close
'                            End If
'                        End If
'
'                        rsDX.MoveNext
'                    Loop Until rsDX.EOF
'                    rsDX.Close
'                End If
                
                
                '显示当前科室的项目
                strSQL = "select XXID,XXMC from SET_XX" _
                        & " where left(XXID,2)='" & rsKShi("KSID") & "'"
                '按顺序号排序
                strSQL = strSQL & " order by SXH"
                Set rsXX = New ADODB.Recordset
                rsXX.Open strSQL, GCon, adOpenStatic, adLockOptimistic
                If rsXX.RecordCount > 0 Then
                    Do
                        Set nodTemp = tvwXMu.Nodes.Add("W" & rsKShi("KSID"), tvwChild, "W" & rsXX("XXID"), rsXX("XXMC"))
                        nodTemp.Expanded = True
        
                        rsXX.MoveNext
                    Loop Until rsXX.EOF
                End If
                
                rsKShi.MoveNext
            Loop Until rsKShi.EOF
            rsKShi.Close
            
'            '在科室的最后添加总检建议
'            tvwXMu.Nodes.Add , , "W", "总检结论与建议"
        End If
    End If
    
    If tvwXMu.Nodes.Count >= 1 Then
        '选中第一个节点
        Set tvwXMu.SelectedItem = tvwXMu.Nodes(1)
    End If
    Call tvwXMuClick
    
    GoTo ExitLab
    
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    Screen.MousePointer = vbDefault
End Sub

'模拟tvwXMu_Click()
Private Sub tvwXMuClick()
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim rstemp As ADODB.Recordset
    Dim strXMID As String
    
    Me.MousePointer = vbHourglass
    
    '是否有选择
    If tvwXMu.SelectedItem Is Nothing Then GoTo ExitLab
    
    lvwTemplates.ListItems.Clear
    LvwSJMB.ListItems.Clear
    
    '获取用户单击节点的关键字
    strXMID = Mid(tvwXMu.SelectedItem.Key, 2)
    If Len(strXMID) > 7 Then
        strXMID = Right(strXMID, 7)
    End If
    
    Select Case Len(strXMID)
        Case 0      '总检结论论与建议节点
'            EnableCommand True
'
'            '******************20040614加入 闻**************************
'            FrmZJDM.Left = FrmXMDM.Left
'            FrmZJDM.Top = FrmXMDM.Top
'            FrmXMDM.Visible = False
'            FrmZJDM.Visible = True
'            cmdAdd.Enabled = False
'
'            '******************20040614加入完 闻************************
'
'            '显示终检建议
'            strSQL = "select JYDMID,DMValue,JYNR from DM_ZJJY"
'            Set rsTemp = New ADODB.Recordset
'            rsTemp.Open strSQL, GCon, adOpenStatic, adLockOptimistic
'            If Not rsTemp.EOF Then
'                rsTemp.MoveFirst
'                Do
'                    lvwZJJL.ListItems.Add , "W" & rsTemp("JYDMID"), rsTemp("DMValue") & rsTemp("JYNR")
'
'                    rsTemp.MoveNext
'                Loop Until rsTemp.EOF
'                rsTemp.Close
'            End If
'
'            mstrType = "ZJ"
            
        
        Case 2 '系统管理员或者终检医生登陆时的科室节点
            EnableCommand True
            
            '******************20040614加入 闻**************************
            FrmXMDM.Visible = True
            FrmZJDM.Visible = False
            '******************20040614加入完 闻************************
            
            '此时可以添加科室小结
            '显示所有已经存在的科室小结
            strSQL = "select KSDMID,DMValue from DM_KS" _
                    & " where KSID='" & strXMID & "'"
            Set rstemp = New ADODB.Recordset
            rstemp.Open strSQL, GCon, adOpenStatic, adLockOptimistic
            If Not rstemp.EOF Then
                rstemp.MoveFirst
                Do
                    lvwTemplates.ListItems.Add , "W" & rstemp("KSDMID"), rstemp("DMValue")
                    
                    rstemp.MoveNext
                Loop Until rstemp.EOF
                rstemp.Close
            End If
            
            mstrType = "KS"
        Case 4 '大项节点
            '******************20040614加入 闻**************************
            FrmXMDM.Visible = True
            FrmZJDM.Visible = False
            '******************20040614加入完 闻************************
            
            '有子项，禁止输入
            EnableCommand False
            
            mstrType = "DX"
        Case 7 '小项节点
            '******************20040614加入 闻**************************
            FrmXMDM.Visible = True
            FrmZJDM.Visible = False
            '******************20040614加入完 闻************************
            
            EnableCommand True
            
            strSQL = "select XXDMID,DMValue from DM_XX" _
                    & " where XXID='" & strXMID & "'"
            Set rstemp = New ADODB.Recordset
            rstemp.Open strSQL, GCon, adOpenStatic, adLockOptimistic
            If Not rstemp.EOF Then
                rstemp.MoveFirst
                Do
                    lvwTemplates.ListItems.Add , "W" & rstemp("XXDMID"), rstemp("DMValue")
                    rstemp.MoveNext
                Loop Until rstemp.EOF
                rstemp.Close
            End If
            
            '***************20040614加入 闻*************************
            '获取该小项已经存在的数据模板
            strSQL = "select XMDMID,DMValue from DM_XM_Value" _
                    & " where XMID='" & strXMID & "'"
            Set rstemp = New ADODB.Recordset
            rstemp.Open strSQL, GCon, adOpenStatic, adLockOptimistic
            If Not rstemp.EOF Then
                rstemp.MoveFirst
                Do
                    LvwSJMB.ListItems.Add , "W" & rstemp("XMDMID"), rstemp("DMValue")
                    rstemp.MoveNext
                Loop Until rstemp.EOF
                rstemp.Close
            End If
            '***************20040614加入完 闻*************************
            
            mstrType = "XX"
    End Select
    
    mstrXMID = strXMID
    cmdModify.Caption = "修改"
    lvwTemplates_Click
    
    GoTo ExitLab
    
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    Me.MousePointer = vbDefault
End Sub

'启用或禁用输入按钮
Private Sub EnableCommand(ByVal blnFlag As Boolean)
    txtTemplate.Enabled = blnFlag
    cmdAdd.Enabled = blnFlag
    cmdAddToModel.Enabled = blnFlag
    cmdModify.Enabled = blnFlag
    cmdDelete.Enabled = blnFlag
    
    If blnFlag = False Then
        txtTemplate.Text = ""
        txtXXNR.Text = ""
    End If
End Sub



Private Sub LvwSJMB_Click()
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim rstemp As ADODB.Recordset
    Dim strXMID As String
    
    Me.MousePointer = vbHourglass
    
    If LvwSJMB.SelectedItem Is Nothing Then
        txtXXNR.Text = ""
        
        GoTo ExitLab
    End If
    
    Select Case mstrType
        Case "ZJ"
        Case "KS", "DX", "XX"
            strSQL = "select DMValue from DM_XM_Value" _
                    & " where XMDMID='"
    End Select
    strSQL = strSQL & Mid(LvwSJMB.SelectedItem.Key, 2) & "'"
    Set rstemp = New ADODB.Recordset
    rstemp.Open strSQL, GCon, adOpenStatic, adLockOptimistic
    If Not rstemp.EOF Then
        If mstrType = "ZJ" Then
'            txtXXNR.Text = rsTemp(0) & rsTemp(1)
        Else
            txtXXNR.Text = rstemp(0)
        End If
    Else
        txtXXNR.Text = ""
    End If
    
    cmdModify.Caption = "修改"
    
    mlvwType = "数据模板"
    
    GoTo ExitLab
    
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    Me.MousePointer = vbDefault
End Sub

Private Sub lvwTemplates_Click()
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim rstemp As ADODB.Recordset
    Dim strXMID As String
    
    Me.MousePointer = vbHourglass
    
    If lvwTemplates.SelectedItem Is Nothing Then
        txtXXNR.Text = ""
        
        GoTo ExitLab
    End If
    
    Select Case mstrType
        Case "ZJ"
            strSQL = "select DMValue,JYNR from DM_ZJJY" _
                    & " where JYDMID='"
        Case "KS"
            strSQL = "select DMValue from DM_KS" _
                    & " where KSDMID='"
        Case "DX"
            strSQL = "select DMValue from DM_DX" _
                    & " where DXDMID='"
        Case "XX"
            strSQL = "select DMValue from DM_XX" _
                    & " where XXDMID='"
    End Select
    strSQL = strSQL & Mid(lvwTemplates.SelectedItem.Key, 2) & "'"
    Set rstemp = New ADODB.Recordset
    rstemp.Open strSQL, GCon, adOpenStatic, adLockOptimistic
    If Not rstemp.EOF Then
        If mstrType = "ZJ" Then
            txtXXNR.Text = rstemp(0) & rstemp(1)
        Else
            txtXXNR.Text = rstemp(0)
        End If
    Else
        txtXXNR.Text = ""
    End If
    
    cmdModify.Caption = "修改"
    
    mlvwType = "数据字典"
    
    GoTo ExitLab
    
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    Me.MousePointer = vbDefault
End Sub

Private Sub lvwTemplates_DblClick()
    cmdModify_Click
End Sub

Private Sub lvwTemplates_KeyUp(KeyCode As Integer, Shift As Integer)
    If KeyCode = vbKeyUp Or KeyCode = vbKeyDown Then
        lvwTemplates_Click
    End If
End Sub

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