frmjywh.frm

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

    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,EmployeeID,JLRQ) values(" _
                & "'" & strXMID & "'" _
                & ",'" & Mid(tvwXMu.SelectedItem.Key, 2) & "'" _
                & "," & gintManagerID _
                & ",'" & Date & "')"
        cmd.CommandText = strSQL
        cmd.Execute
    Else
        '修改时直接取ID号
        strXMID = Mid(lvwXMu.SelectedItem.Key, 2)
    End If
    
    '构造SQL语句
    If ChkSFJB.Value = vbChecked Then
        If ChkSFCJB.Value = vbChecked Then
            strSQL = "update DM_ZJJY set" _
                    & " DMValue='" & txtZDJL.Text & "'" _
                    & ",JYMC='" & txtJYMC.Text & "'" _
                    & ",JYNR='" & txtJYNR.Text & "'" _
                    & ",SFJB=1" _
                    & ",SFCJB=1" _
                    & " where JYDMID='" & strXMID & "'"
        Else
            strSQL = "update DM_ZJJY set" _
                    & " DMValue='" & txtZDJL.Text & "'" _
                    & ",JYMC='" & txtJYMC.Text & "'" _
                    & ",JYNR='" & txtJYNR.Text & "'" _
                    & ",SFJB=1" _
                    & ",SFCJB=0" _
                    & " where JYDMID='" & strXMID & "'"
        End If
    Else
        If ChkSFCJB.Value = vbChecked Then
            strSQL = "update DM_ZJJY set" _
                    & " DMValue='" & txtZDJL.Text & "'" _
                    & ",JYMC='" & txtJYMC.Text & "'" _
                    & ",JYNR='" & txtJYNR.Text & "'" _
                    & ",SFJB=0" _
                    & ",SFCJB=1" _
                    & " where JYDMID='" & strXMID & "'"
        Else
            strSQL = "update DM_ZJJY set" _
                    & " DMValue='" & txtZDJL.Text & "'" _
                    & ",JYMC='" & txtJYMC.Text & "'" _
                    & ",JYNR='" & txtJYNR.Text & "'" _
                    & ",SFJB=0" _
                    & ",SFCJB=0" _
                    & " where JYDMID='" & strXMID & "'"
        End If
    End If
    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:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    Me.MousePointer = vbDefault
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
    
    '加上自定义建议
    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"
    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("DMValue"))
            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