frmjbjy.frm

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

         BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} 
            Name            =   "宋体"
            Size            =   9
            Charset         =   134
            Weight          =   400
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
      End
      Begin XPControls.XPCommandButton btn_JYDel 
         Height          =   435
         Left            =   -71190
         TabIndex        =   27
         Top             =   6270
         Width           =   1125
         _ExtentX        =   1984
         _ExtentY        =   767
         Caption         =   "删除"
         BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} 
            Name            =   "宋体"
            Size            =   9
            Charset         =   134
            Weight          =   400
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
      End
      Begin XPControls.XPCommandButton btn_JYSave 
         Height          =   435
         Left            =   -69630
         TabIndex        =   28
         Top             =   6270
         Width           =   1125
         _ExtentX        =   1984
         _ExtentY        =   767
         Caption         =   "保存"
         BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} 
            Name            =   "宋体"
            Size            =   9
            Charset         =   134
            Weight          =   400
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
      End
      Begin VB.Label Label6 
         Caption         =   "建议内容"
         Height          =   285
         Left            =   -74610
         TabIndex        =   22
         Top             =   4830
         Width           =   735
      End
      Begin VB.Label Label5 
         Caption         =   "建议名称"
         Height          =   225
         Left            =   -74610
         TabIndex        =   21
         Top             =   4380
         Width           =   825
      End
      Begin VB.Label Label1 
         Caption         =   "分类名称"
         Height          =   255
         Left            =   450
         TabIndex        =   17
         Top             =   5130
         Width           =   855
      End
      Begin VB.Label Label2 
         Caption         =   "说明"
         Height          =   255
         Left            =   810
         TabIndex        =   16
         Top             =   5610
         Width           =   375
      End
      Begin VB.Label Label3 
         Caption         =   "疾病名称"
         Height          =   225
         Left            =   -74460
         TabIndex        =   15
         Top             =   5100
         Width           =   735
      End
      Begin VB.Label Label4 
         Caption         =   "疾病说明"
         Height          =   285
         Left            =   -74460
         TabIndex        =   14
         Top             =   5550
         Width           =   885
      End
   End
End
Attribute VB_Name = "frmJBJY"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Dim mblnChange As Boolean
Dim menuOperation As OperationType
Dim jbenum As JBType
Dim jyenum As JYType
Dim m_strMenu As String
Dim ks As String
Dim fl As String
Dim jb As String

Public Sub ShowForm(ByVal strMenu As String)
    m_strMenu = strMenu
    Me.Show vbModal
End Sub

'启用/禁用输入控件
Private Sub EnableInput(ByVal blnFlag As Boolean)
    txtjbmc.Locked = Not blnFlag
    txtsm.Locked = Not blnFlag
    txtJB.Locked = Not blnFlag
    txtJBSM.Locked = Not blnFlag
    txtJYMC.Locked = Not blnFlag
    txtJYNR.Locked = Not blnFlag
  '  txtJYNR.Locked = Not blnFlag
End Sub
Private Sub btn_add_Click()
   '权限验证
'    If g_blnIsNew Then
'        If Not g_clsAuthority.CheckOperationAuthority(m_strMenu, INSERT_W) Then GoTo ExitLab
'    End If
    '验证完毕
    
    ClearInput
    
    btn_Add.Enabled = False
    btn_edit.Enabled = False
    btn_save.Enabled = True
    
    EnableInput True
    
    txtjbmc.SetFocus
    menuOperation = Add
    
ExitLab:
End Sub
'清除输入控件
Private Sub ClearInput()
    txtjbmc.Text = ""
    txtsm.Text = ""
    txtJB.Text = ""
    txtJBSM.Text = ""
    txtJYMC.Text = ""
    txtJYNR.Text = ""
    
End Sub


Private Sub btn_del_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 lvwXMu.SelectedItem Is Nothing Then GoTo ExitLab
    
    If MsgBox("确实要删除体检建议项“" & lvwXMu.SelectedItem.Text & "”吗？", _
            vbQuestion + vbYesNo + vbDefaultButton2, "提示") = vbNo Then GoTo ExitLab
    
    strSQL = "delete from SET_QHFLB" _
            & " where LBID='" & Mid(lvwXMu.SelectedItem.Key, 2) & "'"
    Set cmd = New ADODB.Command
    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
        txtjbmc.Text = ""
        txtsm.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
    
    txtjbmc.Text = lvwXMu.SelectedItem.Text
    txtsm.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
    
    txtjbmc.SetFocus
    
    menuOperation = Modify
    mblnChange = False
ExitLab:
End Sub

Private Sub btn_JBAdd_Click()
   '权限验证
'    If g_blnIsNew Then
'        If Not g_clsAuthority.CheckOperationAuthority(m_strMenu, INSERT_W) Then GoTo ExitLab
'    End If
    '验证完毕
    
    ClearInput
    
    btn_JBAdd.Enabled = False
    btn_JBEdit.Enabled = False
    btn_JBSave.Enabled = True
    
    EnableInput True
    
    txtJB.SetFocus
    jbenum = AddJB
    
ExitLab:
End Sub

Private Sub btn_JBDel_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 listJB.SelectedItem Is Nothing Then GoTo ExitLab
    
    If MsgBox("确实要删除此疾病名称“" & listJB.SelectedItem.Text & "”吗？", _
            vbQuestion + vbYesNo + vbDefaultButton2, "提示") = vbNo Then GoTo ExitLab
    
    strSQL = "delete from SET_QHJBZB" _
            & " where JBID='" & Mid(listJB.SelectedItem.Key, 2) & "'"
    Set cmd = New ADODB.Command
    Set cmd.ActiveConnection = GCon
    cmd.CommandText = strSQL
    cmd.Execute

    intIndex = listJB.SelectedItem.Index
    listJB.ListItems.Remove intIndex
    
    If listJB.ListItems.Count > 0 Then
        If intIndex > 1 Then
            Set listJB.SelectedItem = listJB.ListItems(intIndex - 1)
        Else
            Set listJB.SelectedItem = listJB.ListItems(intIndex)
        End If
    Else
        txtJB.Text = ""
        txtJBSM.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_JBEdit_Click()
     '权限验证
'    If g_blnIsNew Then
'        If Not g_clsAuthority.CheckOperationAuthority(m_strMenu, UPDATE_W) Then GoTo ExitLab
'    End If
'    '验证完毕
    
    '是否有选择
    If listJB.SelectedItem Is Nothing Then Exit Sub
    
    txtJB.Text = listJB.SelectedItem.Text
    txtJBSM.Text = listJB.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_JBAdd.Enabled = False
    btn_JBEdit.Enabled = False
    btn_JBSave.Enabled = True
    btn_JBDel.Enabled = False
    
    EnableInput True
    
    txtJB.SetFocus
    
    jbenum = ModifyJB
    mblnChange = False
ExitLab:
End Sub

Private Sub btn_JBSave_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 JBType
    Dim dtmNow As Date
    
    Me.MousePointer = vbHourglass
    
    
    If txtJB.Text = "" Then
        MsgBox "请输入疾病名称！", vbInformation, "提示"
        txtJB.SetFocus
        GoTo ExitLab
    End If
    

    '同一个类别内不允许重复
    '诊断结论是否已经存在
    strSQL = ""
    If jbenum = AddJB Then '添加
        strSQL = "select count(*) from SET_QHJBZB" _
                & " where jbmc='" & txtJB.Text & "'"
    Else '修改
        If txtJB.Text <> listJB.SelectedItem.Text Then
            strSQL = "select count(*) from SET_QHJBZB" _
                    & " where jbmc='" & txtJB.Text & "'"
        End If
    End If
    If strSQL <> "" Then
        strSQL = strSQL & " and LBID='" & Mid(tvwXMu.SelectedItem.Key, 2) & "'"
        Set rsTemp = New ADODB.Recordset
        rsTemp.Open strSQL, GCon, adOpenKeyset, adLockReadOnly
        If rsTemp(0) >= 1 Then
            MsgBox "您输入的疾病名称已经存在！请核对后重新输入！", vbInformation, "提示"
            txtJB.SetFocus
            GoTo ExitLab
        End If
        rsTemp.Close
    End If
    
 
    
    Set cmd = New ADODB.Command
    Set cmd.ActiveConnection = GCon
    '如果是添加，则首先获取当前最大的ID号
    If jbenum = AddJB Then
        strXMID = GetMaxID("SET_QHJBZB", "JBID", "000001")
      '  MsgBox strXMID
        '插入一条空记录
        strSQL = "insert into SET_QHJBZB(JBID,LBID) values(" _
                & "'" & strXMID & "'" _
                & ",'" & Mid(tvwXMu.SelectedItem.Key, 2) & "'" _
                & ")"
        cmd.CommandText = strSQL
        cmd.Execute
    Else
        '修改时直接取ID号
        strXMID = Mid(listJB.SelectedItem.Key, 2)
    End If
    
    dtmNow = Now