frmristools.frm

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

        rsTemp.Close
    End If
    
    If Not blnKillRelation Then
        '如果不是删除项目对应关系
        intRISID = CInt(Val(txtRISID.Text))
        If intRISID < 1 Then
            MsgBox "请输入体检项目 " & tvwXiangMu.SelectedItem & " 在RIS系统中对应项目的ID号", _
                    vbInformation, "提示"
            txtRISID.SetFocus
            GoTo ExitLab
        End If
    
        '检查该ID是否已经存在
        strSQL = "select Count(*) from SET_DJXM" _
                & " where bhid=" & intRISID
        Set rsTemp = New ADODB.Recordset
        rsTemp.Open strSQL, GCon, adOpenForwardOnly, adLockReadOnly
        If rsTemp.EOF Then
            MsgBox "您输入的RIS系统项目ID号不存在，请核对后重新输入！", vbInformation, "提示"
            txtRISID.SetFocus
            GoTo ExitLab
        End If
    End If
    
    '校验完毕，写入数据库
    strSQL = "update SET_XX set" _
            & " BHID="
    If Not blnKillRelation Then
        strSQL = strSQL & intRISID
    Else
        strSQL = strSQL & "null"
    End If
    strSQL = strSQL & " where XXID='" & strKey & "'"
    GCon.Execute strSQL
    
    '跳转到下一个体检项目
    Call MoveFocusOfTree(tvwXiangMu.SelectedItem.Index + 1)
    
    txtRISID.Text = ""
    txtRISID.SetFocus
    
    GoTo ExitLab
ErrMsg:
    MsgBoxW Err
ExitLab:
    Me.MousePointer = vbDefault
End Sub

Private Sub Form_Load()
On Error GoTo ErrMsg
    Dim strSQL As String
    Dim rsKS As ADODB.Recordset
    Dim rsXX As ADODB.Recordset
    Dim blnClicked As Boolean
    Dim nodTemp As Node
    Dim itmTemp As ListItem
    Dim strValue As String
    
    '以下变量声明用于RIS数据库
    Dim rsKDYY As ADODB.Recordset
    
    Call SetParent(Me.hWnd, lngParentHWnd)
    
    '加载体检软件所有项目
    strSQL = "select KSID,KSMC from SET_KSSZ" _
            & " order by SXH"
    Set rsKS = New ADODB.Recordset
    rsKS.Open strSQL, GCon, adOpenForwardOnly, adLockReadOnly
    If rsKS.EOF Then
        MsgBox "尚未添加任何科室，无法与RIS系统建立连接！", vbInformation, "提示"
        GoTo ExitLab
    Else
        With tvwXiangMu
            Do
                Set nodTemp = .Nodes.Add(, , HEADER & rsKS("KSID"), rsKS("KSMC"), "Close")
                '添加该科室下的所有项目
                strSQL = "select XXID,XXMC from SET_XX" _
                        & " where KSID='" & rsKS("KSID") & "'"
                Set rsXX = New ADODB.Recordset
                rsXX.Open strSQL, GCon, adOpenForwardOnly, adLockReadOnly
                If Not rsXX.EOF Then
                    Do
                        Set nodTemp = .Nodes.Add(HEADER & rsKS("KSID"), tvwChild, HEADER & rsXX("XXID"), rsXX("XXMC"), "Item")
                        If Not blnClicked Then
                            Set .SelectedItem = nodTemp
                            Call tvwXiangMu_NodeClick(.SelectedItem)
                            blnClicked = True
                        End If
                        
                        rsXX.MoveNext
                    Loop While Not rsXX.EOF
                    
                    rsXX.Close
                End If
                
                rsKS.MoveNext
            Loop While Not rsKS.EOF
        End With
        rsKS.Close
    End If
    
    '加载RIS系统中的项目
    strSQL = "select * from SET_DJXM" _
            & " order by JCSB,JCBW,JCFF"
    Set rsXX = New ADODB.Recordset
    rsXX.Open strSQL, GCon, adOpenForwardOnly, adLockReadOnly
    If rsXX.EOF Then
        MsgBox "尚未在体检软件数据库中导入RIS系统项目列表，将无法在体检软件与RIS系统之间建立关联" _
                & "，请联系RIS系统负责人！", vbInformation, "提示"
    Else
        With lvwRISXiangMu
            Do
                Set itmTemp = .ListItems.Add(, HEADER & rsXX("BHID"), rsXX("BHID"), , "Item")
                itmTemp.SubItems(1) = rsXX("JCSB")
                itmTemp.SubItems(2) = rsXX("JCBW")
                itmTemp.SubItems(3) = rsXX("JCFF")
                
                rsXX.MoveNext
            Loop While Not rsXX.EOF
        End With
        
        rsXX.Close
    End If
    
    '从中间数据库读取开单医院等参数
    strSQL = "select distinct REQ_H from RIS_H_D_P"
    Set rsKDYY = New ADODB.Recordset
    rsKDYY.Open strSQL, GRISCon, adOpenForwardOnly, adLockReadOnly
    If Not rsKDYY.EOF Then
        With cmbKDYY
            Do
                .AddItem rsKDYY("REQ_H")
                
                rsKDYY.MoveNext
            Loop While Not rsKDYY.EOF
        End With
        
        rsKDYY.Close
    End If
    
    '读取上一次设置
    Call SelectComboxItem(cmbKDYY, GetSystemProperty("KDYY", ""))
    Call SelectComboxItem(cmbKDKB, GetSystemProperty("KDKB", ""))
    Call SelectComboxItem(cmbKDYS, GetSystemProperty("KDYS", ""))
    
'    Me.Show vbModal
    GoTo ExitLab
ErrMsg:
    MsgBoxW Err, vbExclamation
ExitLab:
    '
End Sub

Private Sub Form_Unload(Cancel As Integer)
'    Call SetParent(Me.hWnd, Null)
End Sub

Private Sub lvwRISXiangMu_DblClick()
    With lvwRISXiangMu
        If .SelectedItem Is Nothing Then Exit Sub
        
        txtRISID.Text = .SelectedItem
        lblInfo.Caption = .SelectedItem.SubItems(1) & vbCrLf & .SelectedItem.SubItems(2) _
                & vbCrLf & .SelectedItem.SubItems(3)
    End With
End Sub

Private Sub lvwRISXiangMu_KeyPress(KeyAscii As Integer)
    If KeyAscii = vbKeyReturn Then
        Call lvwRISXiangMu_DblClick
    End If
End Sub

Private Sub tvwXiangMu_Collapse(ByVal Node As MSComctlLib.Node)
    If Len(tvwXiangMu.SelectedItem.Key) = 3 Then Node.Image = "Close"
End Sub

Private Sub tvwXiangMu_Expand(ByVal Node As MSComctlLib.Node)
    If Len(tvwXiangMu.SelectedItem.Key) = 3 Then Node.Image = "Open"
End Sub

'启用/禁用输入框
Private Sub EnableInput(ByVal blnFlag As Boolean)
    lblTitle.Enabled = blnFlag
    txtRISID.Enabled = blnFlag
    lblInfo.Enabled = blnFlag
    cmdSave.Enabled = blnFlag
End Sub

Private Sub tvwXiangMu_NodeClick(ByVal Node As MSComctlLib.Node)
On Error GoTo ErrMsg
    Dim strKey As String
    Dim strSQL As String
    Dim rsTemp As ADODB.Recordset
    
    Me.MousePointer = vbArrowHourglass
    
    If tvwXiangMu.SelectedItem Is Nothing Then GoTo ExitLab
    strKey = Mid(tvwXiangMu.SelectedItem.Key, 2)
    
    If Len(strKey) = 2 Then
        Call EnableInput(False)
    Else
        Call EnableInput(True)
        
        '提示
        lblTitle.Caption = "请输入 " & tvwXiangMu.SelectedItem.Text & " 对应的ID号"
        
        '获取当前项目的对应关系
        strSQL = "select BHID from SET_XX" _
                & " where XXID='" & strKey & "'"
        Set rsTemp = New ADODB.Recordset
        rsTemp.Open strSQL, GCon, adOpenForwardOnly, adLockReadOnly
        If Not rsTemp.EOF Then
            txtRISID.Text = rsTemp("BHID") & ""
            
            rsTemp.Close
        End If
        '设置焦点
        On Error Resume Next
        txtRISID.SetFocus
        If Err.Number <> 0 Then Err.Clear
    End If
    
    GoTo ExitLab
ErrMsg:
    MsgBoxW Err
ExitLab:
    Me.MousePointer = vbDefault
End Sub

Private Sub txtRISID_Change()
On Error GoTo ErrMsg
    Dim strSQL As String
    Dim rsTemp As ADODB.Recordset
    Dim intDJXM As Integer
    
    Me.MousePointer = vbArrowHourglass
    
    intDJXM = CInt(Val(txtRISID.Text))
    If intDJXM < 1 Then
        lblInfo.Caption = ""
        GoTo ExitLab
    End If
    
    strSQL = "select * from SET_DJXM" _
            & " where bhid=" & intDJXM
    Set rsTemp = New ADODB.Recordset
    rsTemp.Open strSQL, GCon, adOpenForwardOnly, adLockReadOnly
    If Not rsTemp.EOF Then
        lblInfo.Caption = rsTemp("JCSB") & vbCrLf & rsTemp("JCBW") & vbCrLf & rsTemp("JCFF")
        
        rsTemp.Close
    End If
    
    GoTo ExitLab
ErrMsg:
    MsgBoxW Err
ExitLab:
    Me.MousePointer = vbDefault
End Sub

Private Sub txtRISID_GotFocus()
    txtRISID.SelStart = 0
    txtRISID.SelLength = Len(txtRISID.Text)
End Sub

Private Sub txtRISID_KeyPress(KeyAscii As Integer)
    Dim i As Integer
    
    If KeyAscii = vbKeyReturn Then
        cmdSave_Click
    End If
End Sub

'移动树型控件的焦点
Private Sub MoveFocusOfTree(ByVal intLowerIndex As Integer, _
        Optional ByVal intUpperIndex As Integer = -1, _
        Optional ByVal blnUpToDown As Boolean = True)
    Dim i As Integer
    With tvwXiangMu
        If intLowerIndex < 1 Then intLowerIndex = 1
        If intUpperIndex > .Nodes.Count Then intUpperIndex = .Nodes.Count
        If intUpperIndex = -1 Then intUpperIndex = .Nodes.Count
        
        If blnUpToDown Then
            For i = intLowerIndex To intUpperIndex
                If Len(.Nodes(i).Key) >= 8 Then
                    Set .SelectedItem = .Nodes(i)
                    Call tvwXiangMu_NodeClick(.SelectedItem)
                    txtRISID.SelStart = Len(txtRISID.Text)
                    Exit For
                End If
            Next i
        Else
            For i = intUpperIndex To intLowerIndex Step -1
                If Len(.Nodes(i).Key) >= 8 Then
                    Set .SelectedItem = .Nodes(i)
                    Call tvwXiangMu_NodeClick(.SelectedItem)
                    Exit For
                End If
            Next i
        End If
    End With
End Sub

Private Sub txtRISID_KeyUp(KeyCode As Integer, Shift As Integer)
    If tvwXiangMu.SelectedItem Is Nothing Then Exit Sub
    
    If KeyCode = vbKeyUp Then
        Call MoveFocusOfTree(0, tvwXiangMu.SelectedItem.Index - 1, False)
    ElseIf KeyCode = vbKeyDown Then
        Call MoveFocusOfTree(tvwXiangMu.SelectedItem.Index + 1)
    End If
End Sub