frmjbjy.frm

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

    '构造SQL语句
    strSQL = "update SET_QHJBZB set" _
            & " JBMC='" & txtJB.Text & "'" _
            & ",JBSM='" & txtJBSM.Text & "'"
           
           
           
'    If menuOperation = Add Then
'        strSQL = strSQL & ",JLSJ='" & dtmNow & "'" _
'                & ",BuildManager=" & gintManagerID
'    End If
    strSQL = strSQL & " where JBID='" & strXMID & "'"
    cmd.CommandText = strSQL
    cmd.Execute
    
    intOperation = jbenum
    If jbenum = AddJB Then
        Set itmXMu = listJB.ListItems.Add(, "W" & strXMID, txtJB.Text)
        itmXMu.SubItems(1) = txtJBSM.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
        listJB.SelectedItem.Text = txtJB.Text
        listJB.SelectedItem.SubItems(1) = txtJBSM.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
  
    jbenum = intOperation
    If jbenum = AddJB Then btn_JBAdd_Click
    
    GoTo ExitLab
    
ErrMsg:
    MsgBoxW Err
ExitLab:
    Me.MousePointer = vbDefault
End Sub

Private Sub btn_JYAdd_Click()
     '权限验证
'    If g_blnIsNew Then
'        If Not g_clsAuthority.CheckOperationAuthority(m_strMenu, INSERT_W) Then GoTo ExitLab
'    End If
    '验证完毕
    
    ClearInput
    
    btn_JYAdd.Enabled = False
    btn_JYedit.Enabled = False
    btn_JYSave.Enabled = True
    
    EnableInput True
    
    txtJYMC.SetFocus
    jyenum = AddJY
    
ExitLab:
End Sub

Private Sub btn_JYDel_Click()
   On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim itmXMu As ListItem
    Dim cmd As ADODB.Command
    Dim intIndex As Integer
    
    Me.MousePointer = vbHourglass
'    '权限验证
'    If g_blnIsNew Then
'        If Not g_clsAuthority.CheckOperationAuthority(m_strMenu, DELETE_W) Then GoTo ExitLab
'    End If
'    '验证完毕
    
    If ListJY.SelectedItem Is Nothing Then GoTo ExitLab
    
    If MsgBox("确实要删除体检建议项“" & ListJY.SelectedItem.Text & "”吗？", _
            vbQuestion + vbYesNo + vbDefaultButton2, "提示") = vbNo Then GoTo ExitLab
    
    strSQL = "delete from SET_QHJBMXB" _
            & " where JYID='" & Mid(ListJY.SelectedItem.Key, 2) & "'"
    Set cmd = New ADODB.Command
    Set cmd.ActiveConnection = GCon
    cmd.CommandText = strSQL
    cmd.Execute

    intIndex = ListJY.SelectedItem.Index
    ListJY.ListItems.Remove intIndex
    
    If ListJY.ListItems.Count > 0 Then
        If intIndex > 1 Then
            Set ListJY.SelectedItem = ListJY.ListItems(intIndex - 1)
        Else
            Set ListJY.SelectedItem = ListJY.ListItems(intIndex)
        End If
    Else
        txtJYMC.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_JYedit_Click()
    '权限验证
'    If g_blnIsNew Then
'        If Not g_clsAuthority.CheckOperationAuthority(m_strMenu, UPDATE_W) Then GoTo ExitLab
'    End If
'    '验证完毕
    
    '是否有选择
    If ListJY.SelectedItem Is Nothing Then Exit Sub
    
    txtJYMC.Text = ListJY.SelectedItem.Text
    txtJYNR.Text = ListJY.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_JYAdd.Enabled = False
    btn_JYedit.Enabled = False
    btn_JYSave.Enabled = True
    btn_JYDel.Enabled = False
    
    EnableInput True
    
    txtJYMC.SetFocus
    
    jyenum = ModifyJY
    mblnChange = False
ExitLab:
End Sub

Private Sub btn_JYSave_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 JYType
    Dim dtmNow As Date
    
    Me.MousePointer = vbHourglass
    
    
    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 jyenum = AddJY Then '添加
        strSQL = "select count(*) from SET_QHJBMXB" _
                & " where JYMC='" & txtJYMC.Text & "'"
    Else '修改
        If txtJYMC.Text <> ListJY.SelectedItem.Text Then
            strSQL = "select count(*) from SET_QHJBMXB" _
                    & " where JYMC='" & txtJYMC.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, "提示"
            txtJYMC.SetFocus
            GoTo ExitLab
        End If
        rsTemp.Close
    End If
    
 
    
    Set cmd = New ADODB.Command
    Set cmd.ActiveConnection = GCon
    '如果是添加，则首先获取当前最大的ID号
    If jyenum = AddJY Then
        strXMID = GetMaxID("SET_QHJBMXB", "JYID", "0000001")
       
        '插入一条空记录
        strSQL = "insert into SET_QHJBMXB(JYID,JBID) values(" _
                & "'" & strXMID & "'" _
                & ",'" & Mid(tvwXMu.SelectedItem.Key, 2) & "'" _
                & ")"
        cmd.CommandText = strSQL
        cmd.Execute
    Else
        '修改时直接取ID号
        strXMID = Mid(ListJY.SelectedItem.Key, 2)
    End If
    
    dtmNow = Now
    '构造SQL语句
    strSQL = "update SET_QHJBMXB set" _
            & " JYMC='" & txtJYMC.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 = jyenum
    If jyenum = AddJY Then
        Set itmXMu = ListJY.ListItems.Add(, "W" & strXMID, txtJYMC.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
        ListJY.SelectedItem.Text = txtJYMC.Text
        ListJY.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
   
    jyenum = intOperation
    If jyenum = AddJY Then btn_JYAdd_Click
    
    GoTo ExitLab
    
ErrMsg:
    MsgBoxW Err
ExitLab:
    Me.MousePointer = vbDefault
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 txtjbmc.Text = "" Then
        MsgBox "请输入疾病！", vbInformation, "提示"
        txtjbmc.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_QHFLB" _
                & " where flmc='" & txtjbmc.Text & "'"
    Else '修改
        If txtjbmc.Text <> lvwXMu.SelectedItem.Text Then
            strSQL = "select count(*) from SET_QHFLB" _
                    & " where flmc='" & txtjbmc.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, "提示"
            txtjbmc.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_QHFLB", "LBID", "00001")
       
        '插入一条空记录
        strSQL = "insert into SET_QHFLB(LBID,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 SET_QHFLB set" _
            & " FLMC='" & txtjbmc.Text & "'" _
            & ",FLSM='" & txtsm.Text & "'"
           
           
           
'    If menuOperation = Add Then
'        strSQL = strSQL & ",JLSJ='" & dtmNow & "'" _
'                & ",BuildManager=" & gintManagerID
'    End If
    strSQL = strSQL & " where LBID='" & strXMID & "'"
    cmd.CommandText = strSQL
    cmd.Execute
    
    intOperation = menuOperation
    If menuOperation = Add Then
        Set itmXMu = lvwXMu.ListItems.Add(, "W" & strXMID, txtjbmc.Text)
        itmXMu.SubItems(1) = txtsm.Text
'        itmXMu.SubItems(2) = txtJYNR.Text
'        If chkSFJB.Value = vbChecked Then
'            itmXMu.SubItems(3) = 1
'        Else