frmjbjy.frm

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

'            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 = txtjbmc.Text
        lvwXMu.SelectedItem.SubItems(1) = txtsm.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 listJB_Click()
     ' cmdModify_Click
    
    If listJB.SelectedItem Is Nothing Then
        btn_JBEdit.Enabled = False
        btn_JBDel.Enabled = False
    Else
        btn_JBEdit.Enabled = True
        btn_JBDel.Enabled = True
    End If
    
    EnableInput False
    
        
    If Len(tvwXMu.SelectedItem.Key) <> 6 Then
        btn_JBAdd.Enabled = False
    Else
        btn_JBAdd.Enabled = True
    End If
    btn_JBSave.Enabled = False
End Sub

Private Sub ListJY_Click()
      ' cmdModify_Click
    
    If ListJY.SelectedItem Is Nothing Then
        btn_JYedit.Enabled = False
        btn_JYDel.Enabled = False
    Else
        btn_JYedit.Enabled = True
        btn_JYDel.Enabled = True
    End If
    
    EnableInput False
    
        
    If Len(tvwXMu.SelectedItem.Key) <> 7 Then
        btn_JYAdd.Enabled = False
    Else
        btn_JYAdd.Enabled = True
    End If
    btn_JYSave.Enabled = False
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 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_DblClick()
   
  ' frmJBJYWH.ShowForm "mnuQF_jbjywh"
   '  Set frmJBJYWH = Nothing
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
    listJB.ListItems.Clear
    ListJY.ListItems.Clear
    
    '是否有选择
    If tvwXMu.SelectedItem Is Nothing Then
      
       ' ClearInput
        
        lvwXMu_Click
        btn_Add.Enabled = False
        btn_save.Enabled = False
        
        GoTo ExitLab
    End If
  '  frmJBJY.Caption = Mid(tvwXMu.SelectedItem.Key, 2)
    strKSID = Mid(tvwXMu.SelectedItem.Key, 2)
   
    '是否选择了根节点
    If Len(strKSID) = 0 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
   If Len(tvwXMu.SelectedItem.Key) = 3 Then '选择了科室
       SSTab1.Tab = 0
       SSTab1.TabEnabled(1) = False
       SSTab1.TabEnabled(2) = False
       SSTab1.TabEnabled(0) = True
       ks = Mid(tvwXMu.SelectedItem.Key, 2)
      
       '获取当前选中科室的所有建议
        strSQL = "select * from SET_QHFLB" _
            & " where KSID='" & strKSID & "'" & " order by FLMC"

       Set rsTemp = New ADODB.Recordset
   
       rsTemp.Open strSQL, GCon, adOpenKeyset, adLockOptimistic
       ''    MsgBox rsTemp("jbmc")
       If Not rsTemp.EOF Then
           rsTemp.MoveFirst
      
          Do
             Set itmXMu = lvwXMu.ListItems.Add(, "W" & rsTemp("LBID"), rsTemp("FLMC"))
           
             itmXMu.SubItems(1) = rsTemp("FLSM")
         
              rsTemp.MoveNext
        Loop Until rsTemp.EOF
         Else
            txtjbmc.Text = ""
            txtsm.Text = ""
             '           txtJYNR.Text = ""
       End If
    
         lvwXMu_Click
         rsTemp.Close
    End If
    
    If Len(tvwXMu.SelectedItem.Key) = 6 Then '选择了类别
     
       SSTab1.Tab = 1
        SSTab1.TabEnabled(2) = False
        SSTab1.TabEnabled(0) = False
        SSTab1.TabEnabled(1) = True
       fl = Mid(tvwXMu.SelectedItem.Key, 2)
       '获取当前选中科室的所有建议
        strSQL = "select * from SET_QHJBZB" _
            & " where LBID='" & strKSID & "'" & " order by JBMC"

       Set rsTemp = New ADODB.Recordset
   
       rsTemp.Open strSQL, GCon, adOpenKeyset, adLockOptimistic
       
       If Not rsTemp.EOF Then
           rsTemp.MoveFirst
      
          Do
             Set itmXMu = listJB.ListItems.Add(, "W" & rsTemp("JBID"), rsTemp("JBMC"))
           
             itmXMu.SubItems(1) = rsTemp("JBMC")
         
              rsTemp.MoveNext
        Loop Until rsTemp.EOF
      Else
           ' txtjbmc.Text = ""
           ' txtsm.Text = ""
            
       End If
    
       rsTemp.Close
    End If
    
     If Len(tvwXMu.SelectedItem.Key) = 7 Then '选择了疾病
     
        SSTab1.Tab = 2
        SSTab1.TabEnabled(1) = False
        SSTab1.TabEnabled(0) = False
        SSTab1.TabEnabled(2) = True
       jb = Mid(tvwXMu.SelectedItem.Key, 2)
       '获取当前选中科室的所有建议
        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 = ListJY.ListItems.Add(, "W" & rsTemp("JYID"), rsTemp("JYMC"))
           
             itmXMu.SubItems(1) = rsTemp("JYMC")
         
              rsTemp.MoveNext
        Loop Until rsTemp.EOF
      Else
           ' txtjbmc.Text = ""
           ' txtsm.Text = ""
            
       End If
    
       rsTemp.Close
    End If
    GoTo ExitLab
    
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    Me.MousePointer = vbDefault
End Sub
'在树型结构中加载所有科室和项目
Public Function LoadKeShiAndXiangMu(ByRef tvwXMu As treeview) As Boolean
On Error GoTo ErrMsg
    Dim strSQL As String
    Dim mySql As String
    Dim sql As String
    Dim rsKS As ADODB.Recordset
    Dim rsXX As ADODB.Recordset
    Dim rsJB As ADODB.Recordset
    Dim rsJY 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(, , "W", "所有科室")
    nodTemp.Expanded = True
    
    '循环添加所有科室
    With tvwXMu
        Do
            '关键字长度：1＋2＝3
            Set nodTemp = .Nodes.Add("W", tvwChild, HEADER & rsKS("KSID"), rsKS("KSMC"))
            
            '检索该科室下的所有体检项目
            strSQL = "select LBID,FLMC from SET_QHFLB" _
                    & " where KSID='" & rsKS("KSID") & "'"
                   
            Set rsXX = New ADODB.Recordset
            rsXX.Open strSQL, GCon, adOpenForwardOnly, adLockReadOnly
            If Not rsXX.EOF Then
                Do
                    '关键字长度：1＋7＝8
                    .Nodes.Add "W" & rsKS("KSID"), tvwChild, HEADER & rsXX("LBID"), rsXX("FLMC")
                    
                    
                      mySql = "select JBID, JBMC from Set_QHJBZB where LBID='" & rsXX("LBID") & "'"
                      Set rsJB = New ADODB.Recordset
                      rsJB.Open mySql, GCon, adOpenForwardOnly, adLockReadOnly
                      If Not rsJB.EOF Then
                           Do
                            .Nodes.Add "W" & rsXX("LBID"), tvwChild, HEADER & rsJB("JBID"), rsJB("JBMC")
                            
                             sql = "select JYID,JYMC from SET_QHJBMXB where JBID='" & rsJB("JBID") & "'"
                             Set rsJY = New ADODB.Recordset
                             rsJY.Open sql, GCon, adOpenForwardOnly, adLockReadOnly
                               If Not rsJY.EOF Then
                                    Do
                                     .Nodes.Add "W" & rsJB("JBID"), tvwChild, HEADER & rsJY("JYID"), rsJY("JYMC")
                                     
                                      rsJY.MoveNext
                                    Loop While Not rsJY.EOF
                                    rsJY.Close
                               End If
                            rsJB.MoveNext
                            Loop While Not rsJB.EOF
                            rsJB.Close
                      End If
                      
                    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 XPCommandButton1_Click()

End Sub