frmhcsz.frm

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

    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    Screen.MousePointer = vbDefault
End Sub

Private Sub lvwAllTJHC_Click()
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim rstemp As ADODB.Recordset
    Dim intID As Integer
    
    Me.MousePointer = vbHourglass
    
    '是否有记录
    If Me.lvwAllTJHC.ListItems.Count < 1 Then
        ClearInput
        GoTo ExitLab
    End If
    
    '是否有选择
    If Me.lvwAllTJHC.SelectedItem Is Nothing Then
        ClearInput
        GoTo ExitLab
    End If
    
    '提取id
    intID = Val(Mid(Me.lvwAllTJHC.SelectedItem.Key, 2))
    
    strSQL = "select * from TJHC_Index" _
            & " where HCID=" & intID
    Set rstemp = New ADODB.Recordset
    rstemp.Open strSQL, GCon, adOpenStatic, adLockOptimistic
    If rstemp.RecordCount > 0 Then
        txtHCID.Text = rstemp("HCID")
        txtHCMC.Text = rstemp("HCMC")
        txtHCSM.Text = rstemp("HCSM")
        txtHCYL.Text = rstemp("MRYL")
        txtHCJG.Text = rstemp("Price")
        
        If rstemp("NNTY") = 0 Then
            optTY.Value = True
        ElseIf rstemp("NNTY") = 1 Then
            optMale.Value = True
        Else
            optFemale.Value = True
        End If
    End If
    
    GoTo ExitLab
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    Me.MousePointer = vbDefault
End Sub

Private Sub lvwAllTJHC_DragDrop(Source As Control, x As Single, y As Single)
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim rstemp As ADODB.Recordset
    Dim strXMID As String
    Dim intID As Integer
    Dim intNumber  As Integer
    Dim strRet As String
    Dim intIndex As Integer
    
    Me.MousePointer = vbHourglass
    
    '是否选择了项目
    If tvwXMu.Nodes.Count < 1 Then GoTo ExitLab
    If tvwXMu.SelectedItem Is Nothing Then
        MsgBox "请首先在左侧的树型结构中选择某一项目！", vbInformation, "提示"
        tvwXMu.SetFocus
        GoTo ExitLab
    End If
    
    '记录体检项目
    strXMID = Mid(Me.tvwXMu.SelectedItem.Key, 2)
    If Len(strXMID) < 2 Then
        MsgBox "请首先在左侧的树型结构中选择某一具体项目！", vbInformation, "提示"
        tvwXMu.SetFocus
        GoTo ExitLab
    End If
    
    If Len(strXMID) > 7 Then
        strXMID = Right(strXMID, 7)
    End If
    
    '判断是否从预定目标拖动过来
    If Source.name = Me.lvwTJHC.name Then
        '是否有选择
        If Me.lvwTJHC.ListItems.Count < 1 Then GoTo ExitLab
        If Me.lvwTJHC.SelectedItem Is Nothing Then GoTo ExitLab
        
        '记录id
        intID = Val(Mid(Me.lvwTJHC.SelectedItem.Key, 2))
        
        
        '写入数据库
        strSQL = "delete from TJHC_HCXM" _
                & " where XMID='" & strXMID & "'" _
                & " and HCID=" & intID
        GCon.Execute strSQL
        
        '添加到目的处
        Me.lvwAllTJHC.ListItems.Add , Me.lvwTJHC.SelectedItem.Key, Me.lvwTJHC.SelectedItem.Text
        
        intIndex = Me.lvwTJHC.SelectedItem.Index
        '从源处删除
        Me.lvwTJHC.ListItems.Remove intIndex
        
        '移动焦点
        If lvwTJHC.ListItems.Count >= 1 Then
            If intIndex <= 1 Then
                Set lvwTJHC.SelectedItem = lvwTJHC.ListItems(intIndex)
            Else
                Set lvwTJHC.SelectedItem = lvwTJHC.ListItems(intIndex - 1)
            End If
        Else
            ClearInput
        End If
        lvwTJHC_Click
    End If
    
    GoTo ExitLab
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    Me.MousePointer = vbDefault
End Sub

Private Sub lvwAllTJHC_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
    lvwAllTJHC_Click
    
    lvwAllTJHC.Drag vbBeginDrag
End Sub

Private Sub lvwAllTJHC_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
    lvwAllTJHC.Drag vbEndDrag
End Sub

Private Sub lvwTJHC_Click()
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim rstemp As ADODB.Recordset
    Dim intID As Integer
    
    Me.MousePointer = vbHourglass
    
    '是否有记录
    If Me.lvwTJHC.ListItems.Count < 1 Then
        ClearInput
        GoTo ExitLab
    End If
    
    '是否有选择
    If Me.lvwTJHC.SelectedItem Is Nothing Then
        ClearInput
        GoTo ExitLab
    End If
    
    '提取id
    intID = Val(Mid(Me.lvwTJHC.SelectedItem.Key, 2))
    
    strSQL = "select TJHC_Index.HCID,HCMC,HCSM,YL,Price,NNTY" _
            & " from TJHC_Index,TJHC_HCXM" _
            & " where TJHC_Index.HCID=" & intID _
            & " and TJHC_Index.HCID=TJHC_HCXM.HCID"
    Set rstemp = New ADODB.Recordset
    rstemp.Open strSQL, GCon, adOpenStatic, adLockOptimistic
    If rstemp.RecordCount > 0 Then
        txtHCID.Text = rstemp("HCID")
        txtHCMC.Text = rstemp("HCMC")
        txtHCSM.Text = rstemp("HCSM")
        txtHCYL.Text = rstemp("YL")
        txtHCJG.Text = rstemp("Price")
        
        If rstemp("NNTY") = 0 Then
            optTY.Value = True
        ElseIf rstemp("NNTY") = 1 Then
            optMale.Value = True
        Else
            optFemale.Value = True
        End If
    End If
    
    GoTo ExitLab
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    Me.MousePointer = vbDefault
End Sub

Private Sub lvwTJHC_DragDrop(Source As Control, x As Single, y As Single)
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim rstemp As ADODB.Recordset
    Dim strXMID As String
    Dim intID As Integer
    Dim intNumber  As Integer
    Dim strRet As String
    Dim intIndex As Integer
    
    Me.MousePointer = vbHourglass
    
    '是否选择了项目
    If tvwXMu.Nodes.Count < 1 Then GoTo ExitLab
    If tvwXMu.SelectedItem Is Nothing Then
        MsgBox "请首先在左侧的树型结构中选择某一项目！", vbInformation, "提示"
        tvwXMu.SetFocus
        GoTo ExitLab
    End If
    
    '记录体检项目
    strXMID = Mid(Me.tvwXMu.SelectedItem.Key, 2)
    If Len(strXMID) < 2 Then
        MsgBox "请首先在左侧的树型结构中选择某一具体项目！", vbInformation, "提示"
        tvwXMu.SetFocus
        GoTo ExitLab
    End If
    
    If Len(strXMID) > 7 Then
        strXMID = Right(strXMID, 7)
    End If
    
    '判断是否从预定目标拖动过来
    If Source.name = Me.lvwAllTJHC.name Then
        '是否有选择
        If Me.lvwAllTJHC.ListItems.Count < 1 Then GoTo ExitLab
        If Me.lvwAllTJHC.SelectedItem Is Nothing Then GoTo ExitLab
        
        '记录id
        intID = Val(Mid(Me.lvwAllTJHC.SelectedItem.Key, 2))
        
        strRet = InputBox("请输入耗材“" & Me.lvwAllTJHC.SelectedItem.Text & "”在项目“" _
                & tvwXMu.SelectedItem.Text & "”中的用量(不小于的整数)。", "用量")
        If strRet = "" Then GoTo ExitLab
        
        '输入是否合法
        intNumber = Int(Val(strRet))
        If intNumber < 1 Then
            MsgBox "耗材用量不能小于1！", vbInformation, "提示"
            GoTo ExitLab
        End If
        
        '写入数据库
        strSQL = "insert into TJHC_HCXM values(" _
                & "'" & strXMID & "'" _
                & "," & intID _
                & "," & intNumber & ")"
        GCon.Execute strSQL
        
        '添加到目的处
        Me.lvwTJHC.ListItems.Add , Me.lvwAllTJHC.SelectedItem.Key, Me.lvwAllTJHC.SelectedItem.Text
        
        intIndex = Me.lvwAllTJHC.SelectedItem.Index
        '从源处删除
        Me.lvwAllTJHC.ListItems.Remove intIndex
        
        '移动焦点
        If lvwAllTJHC.ListItems.Count >= 1 Then
            If intIndex = 1 Then
                Set lvwAllTJHC.SelectedItem = lvwAllTJHC.ListItems(intIndex)
            Else
                Set lvwAllTJHC.SelectedItem = lvwAllTJHC.ListItems(intIndex - 1)
            End If
        Else
            ClearInput
        End If
        lvwAllTJHC_Click
    End If
    
    GoTo ExitLab
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    Me.MousePointer = vbDefault
End Sub

Private Sub lvwTJHC_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
    lvwTJHC_Click
    
    lvwTJHC.Drag vbBeginDrag
End Sub

Private Sub lvwTJHC_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
    lvwTJHC.Drag vbEndDrag
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 strXMID As String
    
    Me.MousePointer = vbHourglass
    
    '首先清空耗材列表
    lvwTJHC.ListItems.Clear
    lvwAllTJHC.ListItems.Clear
    
    '如果没有项目
    If Me.tvwXMu.Nodes.Count <= 1 Then
        GoTo ExitLab
    End If
    
    '是否有选择
    If Me.tvwXMu.SelectedItem Is Nothing Then GoTo ExitLab
    
    '记录项目id
    strXMID = Mid(Me.tvwXMu.SelectedItem.Key, 2)
    '是否选择了根节点
    If Len(strXMID) < 2 Then GoTo ExitLab
    
    If Len(strXMID) > 7 Then
        strXMID = Right(strXMID, 7)
    End If
    
    strSQL = "select TJHC_HCXM.HCID,HCMC from TJHC_HCXM,TJHC_Index" _
            & " where XMID='" & strXMID & "'" _
            & " and TJHC_HCXM.HCID=TJHC_Index.HCID"
    Set rstemp = New ADODB.Recordset
    rstemp.Open strSQL, GCon, adOpenStatic, adLockOptimistic
    If rstemp.RecordCount > 0 Then
        '添加到已选耗材
        rstemp.MoveFirst
        Do
            lvwTJHC.ListItems.Add , "W" & rstemp("HCID"), rstemp("HCMC")
            
            rstemp.MoveNext
        Loop Until rstemp.EOF
        rstemp.Close
    End If
    
    '检索当前项目未选择的耗材
    strSQL = "select HCID,HCMC from TJHC_Index" _
            & " where HCID not in(" _
            & "select HCID from TJHC_HCXM" _
            & " where XMID='" & strXMID & "')"
    Set rstemp = New ADODB.Recordset
    rstemp.Open strSQL, GCon, adOpenStatic, adLockOptimistic
    If rstemp.RecordCount > 0 Then
        rstemp.MoveFirst
        Do
            lvwAllTJHC.ListItems.Add , "W" & rstemp("HCID"), rstemp("HCMC")
            
            rstemp.MoveNext
        Loop Until rstemp.EOF
    End If
    GoTo ExitLab
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    Me.MousePointer = vbDefault
End Sub

'清空输入框
Private Sub ClearInput()
    txtHCID.Text = ""
    txtHCMC.Text = ""
    txtHCSM.Text = ""
    txtHCYL.Text = ""
    txtHCJG.Text = ""
End Sub