frmsuggestion.frm

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

    cmdSave.Enabled = True
    cmdDelete.Enabled = False
    
    EnableInput True
    
    txtZDJL.SetFocus
    
    menuOperation = Modify
    mblnChange = False
ExitLab:

End Sub

Private Sub cmdSave_Click()
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim rsTemp As ADODB.Recordset
    Dim cmd As ADODB.Command
    Dim strXMID As String '记录当前科室的ID号
    Dim itmXMu As ListItem
    Dim intOperation As OperationType
    Dim dtmNow As Date
    
    Me.MousePointer = vbHourglass
    
    '是否输入了诊断结论
    If txtZDJL.Text = "" Then
        MsgBox "请输入诊断结论！", vbInformation, "提示"
        txtZDJL.SetFocus
        GoTo ExitLab
    End If
    
    '是否输入了建议名称
    If txtJYMC.Text = "" Then
        MsgBox "请输入建议名称！", vbInformation, "提示"
        txtJYMC.SetFocus
        GoTo ExitLab
    End If
    
    '是否输入了建议
    If txtJYNR.Text = "" Then
        MsgBox "请输入建议内容！", vbInformation, "提示"
        txtJYNR.SetFocus
        GoTo ExitLab
    End If
    
    '同一个科室内不允许重复
    '诊断结论是否已经存在
    strSQL = ""
    If menuOperation = Add Then '添加
        strSQL = "select count(*) from DM_ZJJY" _
                & " where ZDJL='" & txtZDJL.Text & "'"
    Else '修改
        If txtZDJL.Text <> lvwXMu.SelectedItem.Text Then
            strSQL = "select count(*) from DM_ZJJY" _
                    & " where ZDJL='" & txtZDJL.Text & "'"
        End If
    End If
    If strSQL <> "" Then
        strSQL = strSQL & " and KSID='" & Mid(tvwXMu.SelectedItem.Key, 2) & "'"
        Set rsTemp = New ADODB.Recordset
        rsTemp.Open strSQL, GCon, adOpenKeyset, adLockReadOnly
        If rsTemp(0) >= 1 Then
            MsgBox "您输入的诊断结论已经存在！请核对后重新输入！", vbInformation, "提示"
            txtZDJL.SetFocus
            GoTo ExitLab
        End If
        rsTemp.Close
    End If
    
    '建议名称是否已经存在
    strSQL = ""
    If menuOperation = Add Then '添加
        strSQL = "select count(*) from DM_ZJJY" _
                & " where JYMC='" & txtJYMC.Text & "'"
    Else '修改
        If txtZDJL.Text <> lvwXMu.SelectedItem.Text Then
            strSQL = "select count(*) from DM_ZJJY" _
                    & " where JYMC='" & txtJYMC.Text & "'"
        End If
    End If
    If strSQL <> "" Then
        strSQL = strSQL & " and KSID='" & Mid(tvwXMu.SelectedItem.Key, 2) & "'"
        Set rsTemp = New ADODB.Recordset
        rsTemp.Open strSQL, GCon, adOpenKeyset, adLockReadOnly
        If rsTemp(0) >= 1 Then
            MsgBox "您输入的建议名称已经存在！请核对后重新输入！", vbInformation, "提示"
            txtJYMC.SetFocus
            GoTo ExitLab
        End If
        rsTemp.Close
    End If
    
    Set cmd = New ADODB.Command
    Set cmd.ActiveConnection = GCon
    '如果是添加，则首先获取当前最大的ID号
    If menuOperation = Add Then
        strXMID = GetMaxID("DM_ZJJY", "JYDMID", "00001")
        
        '插入一条空记录
        strSQL = "insert into DM_ZJJY(JYDMID,KSID) values(" _
                & "'" & strXMID & "'" _
                & ",'" & Mid(tvwXMu.SelectedItem.Key, 2) & "'" _
                & ")"
        cmd.CommandText = strSQL
        cmd.Execute
    Else
        '修改时直接取ID号
        strXMID = Mid(lvwXMu.SelectedItem.Key, 2)
    End If
    
    dtmNow = Now
    '构造SQL语句
    strSQL = "update DM_ZJJY set" _
            & " ZDJL='" & txtZDJL.Text & "'" _
            & ",JYMC='" & txtJYMC.Text & "'" _
            & ",JYNR='" & txtJYNR.Text & "'" _
            & ",SFJB=" & IIf(chkSFJB.Value = vbChecked, 1, 0) _
            & ",SFCJB=" & IIf(chkSFCJB.Value = vbChecked, 1, 0) _
            & ",XGSJ='" & dtmNow & "'" _
            & ",ModifyManager='" & gintManagerID & "'"
    If menuOperation = Add Then
        strSQL = strSQL & ",JLSJ='" & dtmNow & "'" _
                & ",BuildManager=" & gintManagerID
    End If
    strSQL = strSQL & " where JYDMID='" & strXMID & "'"
    cmd.CommandText = strSQL
    cmd.Execute
    
    intOperation = menuOperation
    If menuOperation = Add Then
        Set itmXMu = lvwXMu.ListItems.Add(, "W" & strXMID, txtZDJL.Text)
        itmXMu.SubItems(1) = txtJYMC.Text
        itmXMu.SubItems(2) = txtJYNR.Text
        If chkSFJB.Value = vbChecked Then
            itmXMu.SubItems(3) = 1
        Else
            itmXMu.SubItems(3) = 0
        End If
        If chkSFCJB.Value = vbChecked Then
            itmXMu.SubItems(4) = 1
        Else
            itmXMu.SubItems(4) = 0
        End If
    Else
        lvwXMu.SelectedItem.Text = txtZDJL.Text
        lvwXMu.SelectedItem.SubItems(1) = txtJYMC.Text
        lvwXMu.SelectedItem.SubItems(2) = txtJYNR.Text
        If chkSFJB.Value = vbChecked Then
            lvwXMu.SelectedItem.SubItems(3) = 1
        Else
            lvwXMu.SelectedItem.SubItems(3) = 0
        End If
        If chkSFCJB.Value = vbChecked Then
            lvwXMu.SelectedItem.SubItems(4) = 1
        Else
            lvwXMu.SelectedItem.SubItems(4) = 0
        End If
        
        EnableInput False
    End If
    
    lvwXMu_Click
    
    menuOperation = intOperation
    If menuOperation = Add Then cmdAdd_Click
    
    GoTo ExitLab
    
ErrMsg:
    MsgBoxW Err
ExitLab:
    Me.MousePointer = vbDefault
End Sub

'在树型结构中加载所有科室和项目
Public Function LoadKeShiAndXiangMu(ByRef tvwXMu As TreeView) As Boolean
On Error GoTo ErrMsg
    Dim strSQL As String
    Dim rsKS As ADODB.Recordset
    Dim rsXX As ADODB.Recordset
    Dim nodTemp As Node
    
    Screen.MousePointer = vbHourglass
    '获取所有科室
    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 "当前尚未添加任何科室，无法进行其它操作！", vbInformation, "提示"
        GoTo ExitLab
    End If
    
    '添加根节点
    Set nodTemp = tvwXMu.Nodes.Add(, , HEADER, "所有科室")
    nodTemp.Expanded = True
    
    '循环添加所有科室
    With tvwXMu
        Do
            '关键字长度：1＋2＝3
            Set nodTemp = .Nodes.Add(HEADER, tvwChild, HEADER & rsKS("KSID"), rsKS("KSMC"))
            
            '检索该科室下的所有体检项目
            strSQL = "select XXID,XXMC from SET_XX" _
                    & " where KSID='" & rsKS("KSID") & "'" _
                    & " order by SXH"
            Set rsXX = New ADODB.Recordset
            rsXX.Open strSQL, GCon, adOpenForwardOnly, adLockReadOnly
            If Not rsXX.EOF Then
                Do
                    '关键字长度：1＋7＝8
                    .Nodes.Add HEADER & rsKS("KSID"), tvwChild, HEADER & rsXX("XXID"), rsXX("XXMC")
                    
                    rsXX.MoveNext
                Loop While Not rsXX.EOF
                rsXX.Close
            End If
            
            rsKS.MoveNext
        Loop While Not rsKS.EOF
    End With
    rsKS.Close
    
    Set tvwXMu.SelectedItem = tvwXMu.Nodes(1)
    
    LoadKeShiAndXiangMu = True
    GoTo ExitLab
ErrMsg:
    MsgBoxW Err
ExitLab:
    Screen.MousePointer = vbDefault
End Function

Private Sub Form_Load()
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim nodTemp As Node
    Dim rsKShi As ADODB.Recordset
    
    Screen.MousePointer = vbArrowHourglass
    
'    '添加一个总节点
'    '关键字长度：1＝1
'    Set nodTemp = tvwXMu.Nodes.Add(, , "W", "所有科室")
'    nodTemp.Expanded = True
'
'    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", tvwChild, "W" & rsKShi("KSID"), rsKShi("KSMC"))
'            nodTemp.Expanded = True
'
'            rsKShi.MoveNext
'        Loop Until rsKShi.EOF
'        rsKShi.Close
'    End If
  Call LoadKeShiAndXiangMu(tvwXMu)
    '加上自定义建议
    strSQL = "select JYID,JYMC from SET_JY_INDEX" _
            & " order by JYSXH"
    Set rsKShi = New ADODB.Recordset
    rsKShi.Open strSQL, GCon, adOpenStatic, adLockReadOnly
    If Not rsKShi.EOF Then
        Do While Not rsKShi.EOF
            tvwXMu.Nodes.Add HEADER, tvwChild, HEADER & "S" & rsKShi("JYID"), rsKShi("JYMC")
            
            rsKShi.MoveNext
        Loop
        rsKShi.Close
    End If
    
    'HealthStatus
    If gblnIsSpy Then
        strSQL = "select HealthID,HealthName from SET_HEALTH"
        Set rsKShi = New ADODB.Recordset
        rsKShi.Open strSQL, GCon, adOpenForwardOnly, adLockReadOnly
        If Not rsKShi.EOF Then
            Set nodTemp = tvwXMu.Nodes.Add(, , "H", "健康状况")
            nodTemp.Expanded = True
            Do While Not rsKShi.EOF
                tvwXMu.Nodes.Add "H", tvwChild, HEADER & "H" & rsKShi("HealthID"), rsKShi("HealthName")
                
                rsKShi.MoveNext
            Loop
            
            rsKShi.Close
        End If
    End If
    
    Set tvwXMu.SelectedItem = tvwXMu.Nodes(1)
    tvwXMu_NodeClick tvwXMu.SelectedItem
    
    GoTo ExitLab
    
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    Screen.MousePointer = vbDefault
End Sub

Private Sub lvwXMu_Click()
    cmdModify_Click
    
    If lvwXMu.SelectedItem Is Nothing Then
        cmdModify.Enabled = False
        cmdDelete.Enabled = False
    Else
        cmdModify.Enabled = True
        cmdDelete.Enabled = True
    End If
    
    EnableInput False
    
        
    If Len(tvwXMu.SelectedItem.Key) = 1 Then
        cmdAdd.Enabled = False
    Else
        cmdAdd.Enabled = True
    End If
    cmdSave.Enabled = False
End Sub

Private Sub lvwXMu_KeyUp(KeyCode As Integer, Shift As Integer)
    Select Case KeyCode
        Case vbKeyUp, vbKeyDown
            lvwXMu_Click
        Case Else
            '
    End Select
End Sub

'清除输入控件
Private Sub ClearInput()
    txtZDJL.Text = ""
    txtJYMC.Text = ""
    txtJYNR.Text = ""
End Sub

'启用/禁用输入控件
Private Sub EnableInput(ByVal blnFlag As Boolean)
    txtZDJL.Locked = Not blnFlag
    txtJYMC.Locked = Not blnFlag
    txtJYNR.Locked = Not blnFlag
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 strKSID As String '记录当前科室的ID号
    Dim itmXMu As ListItem
    
    Me.MousePointer = vbHourglass
    
    lvwXMu.ListItems.Clear
    
    '是否有选择
    If tvwXMu.SelectedItem Is Nothing Then
      
        ClearInput
        
        lvwXMu_Click
        cmdAdd.Enabled = False
        cmdSave.Enabled = False
        
        GoTo ExitLab
    End If
    
    strKSID = Mid(tvwXMu.SelectedItem.Key, 2)
    '是否选择了根节点
    If Len(strKSID) = 0 Then
     
        ClearInput
        
        lvwXMu.ListItems.Clear
        cmdAdd.Enabled = False
        cmdModify.Enabled = False
        cmdSave.Enabled = False
        cmdDelete.Enabled = False
        
        GoTo ExitLab
    End If
    
    '获取当前选中科室的所有建议
    strSQL = "select * from DM_ZJJY" _
            & " where KSID='" & strKSID & "'" & " order by JYMC"
'     strSQL = "select isnull(zdjl,'') as zdjl,isnull (JYMC,'') as JYMC,isnull(JYNR,'') JYNR ,isnull(SFJB,0) as SFJB,isnull(SFCJB,0) as SFCJB  from DM_ZJJY " _
'             & " where KSID='" & strKSID & "'" & " order by JYMC desc "
    Set rsTemp = New ADODB.Recordset
   
   rsTemp.Open strSQL, GCon, adOpenKeyset, adLockOptimistic
  
    If Not rsTemp.EOF Then
        rsTemp.MoveFirst
      
        Do
            Set itmXMu = lvwXMu.ListItems.Add(, "W" & rsTemp("JYDMID"), rsTemp("zdjl"))
           
           ' itmXMu.SubItems(1) = rsTemp("zdjl")
            itmXMu.SubItems(1) = rsTemp("JYMC")
            itmXMu.SubItems(2) = rsTemp("JYNR") & ""
            itmXMu.SubItems(3) = rsTemp("SFJB")
            itmXMu.SubItems(4) = rsTemp("SFCJB")
            rsTemp.MoveNext
        Loop Until rsTemp.EOF
    Else
        txtZDJL.Text = ""
        txtJYMC.Text = ""
        txtJYNR.Text = ""
    End If
    
    lvwXMu_Click
    GoTo ExitLab
    
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    Me.MousePointer = vbDefault
End Sub

Private Sub txtJYMC_Change()
    mblnChange = True
End Sub

Private Sub txtJYMC_LostFocus()
    txtJYMC.Text = Trim(txtJYMC.Text)
End Sub

Private Sub txtJYNR_Change()
    mblnChange = True
End Sub

Private Sub txtJYNR_LostFocus()
    txtJYNR.Text = Trim(txtJYNR.Text)
End Sub

Private Sub txtZDJL_Change()
    mblnChange = True
End Sub

Private Sub txtZDJL_LostFocus()
    txtZDJL.Text = Trim(txtZDJL.Text)
End Sub