frmjbjywh.frm

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

    Set cmd.ActiveConnection = GCon
    cmd.CommandText = strSQL
    cmd.Execute

    intIndex = lvwXMu.SelectedItem.Index
    lvwXMu.ListItems.Remove intIndex
    
    If lvwXMu.ListItems.Count > 0 Then
        If intIndex > 1 Then
            Set lvwXMu.SelectedItem = lvwXMu.ListItems(intIndex - 1)
        Else
            Set lvwXMu.SelectedItem = lvwXMu.ListItems(intIndex)
        End If
    Else
        txtmc.Text = ""
        txtJYNR.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 btn_edit_Click()
    '权限验证
'    If g_blnIsNew Then
'        If Not g_clsAuthority.CheckOperationAuthority(m_strMenu, UPDATE_W) Then GoTo ExitLab
'    End If
'    '验证完毕
    
    '是否有选择
    If lvwXMu.SelectedItem Is Nothing Then Exit Sub
    
    txtmc.Text = lvwXMu.SelectedItem.Text
    txtJYNR.Text = lvwXMu.SelectedItem.SubItems(1)
'    txtJYNR.Text = lvwXMu.SelectedItem.SubItems(2)
    
'    If lvwXMu.SelectedItem.SubItems(3) = 0 Then
'        chkSFJB.Value = vbUnchecked
'    ElseIf lvwXMu.SelectedItem.SubItems(3) = 1 Then
'        chkSFJB.Value = vbChecked
'    End If
'    If lvwXMu.SelectedItem.SubItems(4) = 0 Then
'        chkSFCJB.Value = vbUnchecked
'    ElseIf lvwXMu.SelectedItem.SubItems(4) = 1 Then
'        chkSFCJB.Value = vbChecked
'    End If
    
    btn_add.Enabled = False
    btn_edit.Enabled = False
    btn_save.Enabled = True
    btn_del.Enabled = False
    
    EnableInput True
    
    txtmc.SetFocus
    
    menuOperation = Modify
    mblnChange = False
ExitLab:
End Sub

Private Sub btn_save_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 txtmc.Text = "" Then
        MsgBox "请输入疾病建议名称！", vbInformation, "提示"
        txtmc.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 SET_QHJBMXB" _
                & " where jymc='" & txtmc.Text & "'"
    Else '修改
        If txtmc.Text <> lvwXMu.SelectedItem.Text Then
            strSQL = "select count(*) from SET_QHJBMXB" _
                    & " where jymc='" & txtmc.Text & "'"
        End If
    End If
    If strSQL <> "" Then
        strSQL = strSQL & " and JBID='" & Mid(tvwXMu.SelectedItem.Key, 2) & "'"
        Set rsTemp = New ADODB.Recordset
        rsTemp.Open strSQL, GCon, adOpenKeyset, adLockReadOnly
        If rsTemp(0) >= 1 Then
            MsgBox "您输入的疾病名称已经存在！请核对后重新输入！", vbInformation, "提示"
            txtmc.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("SET_QHJBMXB", "JYID", "00001")
      
        '插入一条空记录
        strSQL = "insert into SET_QHJBMXB(JYID,JBID) 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 SET_QHJBMXB set" _
            & " JYMC='" & txtmc.Text & "'" _
            & ",jYNR='" & txtJYNR.Text & "'"
           
           
           
'    If menuOperation = Add Then
'        strSQL = strSQL & ",JLSJ='" & dtmNow & "'" _
'                & ",BuildManager=" & gintManagerID
'    End If
    strSQL = strSQL & " where JYID='" & strXMID & "'"
    cmd.CommandText = strSQL
    cmd.Execute
    
    intOperation = menuOperation
    If menuOperation = Add Then
        Set itmXMu = lvwXMu.ListItems.Add(, "W" & strXMID, txtmc.Text)
        itmXMu.SubItems(1) = txtJYNR.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 = txtmc.Text
        lvwXMu.SelectedItem.SubItems(1) = txtJYNR.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 btn_add_Click
    
    GoTo ExitLab
    
ErrMsg:
    MsgBoxW Err
ExitLab:
    Me.MousePointer = vbDefault
End Sub

Private Sub Form_Load()
      Call LoadKeShiAndXiangMu(tvwXMu)
End Sub

Private Sub tvwXMu_Click()
  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
        btn_add.Enabled = False
        btn_save.Enabled = False
        
        GoTo ExitLab
    End If
    
    strKSID = Mid(tvwXMu.SelectedItem.Key, 2)
    
    '是否选择了根节点
    If Len(strKSID) = 2 Then
     
      '  ClearInput
        
        lvwXMu.ListItems.Clear
        btn_add.Enabled = False
        btn_edit.Enabled = False
        btn_save.Enabled = False
        btn_del.Enabled = False
        
        GoTo ExitLab
    End If
    
    '获取当前选中科室的所有建议
    strSQL = "select * from SET_QHJBMXB" _
            & " where JBID='" & strKSID & "'" & " order by JYMC"
    
    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("JYID"), rsTemp("JYMC"))
           
           itmXMu.SubItems(1) = rsTemp("JYNR")
         
            rsTemp.MoveNext
        Loop Until rsTemp.EOF
    Else
            txtmc.Text = ""
          txtJYNR.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 lvwXMu_Click()
    'cmdModify_Click
    
    If lvwXMu.SelectedItem Is Nothing Then
        btn_edit.Enabled = False
        btn_del.Enabled = False
    Else
        btn_edit.Enabled = True
        btn_del.Enabled = True
    End If
    
    EnableInput False
    
        
    If Len(tvwXMu.SelectedItem.Key) = 1 Then
        btn_add.Enabled = False
    Else
        btn_add.Enabled = True
    End If
    btn_save.Enabled = False
End Sub

'启用/禁用输入控件
Private Sub EnableInput(ByVal blnFlag As Boolean)
    txtmc.Locked = Not blnFlag
    txtJYNR.Locked = Not blnFlag
   
End Sub