frmbzb_ttdj.frm

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

    Dim strSQL As String
    Dim rsTemp As ADODB.Recordset
    Dim rsKShi As ADODB.Recordset
    Dim rsDX As ADODB.Recordset
    Dim nodTemp As Node
    Dim i As Integer
    
    Screen.MousePointer = vbArrowHourglass
    
    '获取已经存在的单位
    strSQL = "select DWID,DWMC from SET_DW order by DWID"
    Set rsTemp = New ADODB.Recordset
    rsTemp.Open strSQL, GCon, adOpenStatic, adLockOptimistic
    If rsTemp.RecordCount >= 1 Then
        rsTemp.MoveFirst
        Do
            cmbTDWei.AddItem rsTemp("DWMC")
            cmbTDWei.ItemData(cmbTDWei.NewIndex) = rsTemp("DWID")
            rsTemp.MoveNext
        Loop Until rsTemp.EOF
        rsTemp.Close
    End If
    '*****************************20040418加入 闻*************************
    Me.Top = 2000
    Me.Left = 2000
    '*****************************20040418加入完 闻*************************
    '刷新团体信息
    sstInfoClick

    '体检日期设为当天
    dtpTTJRQ.Value = Date
    
    '初始化网格
    With Me.MSHFlexGrid1
        .Cols = 5
        '流水号
        .TextMatrix(0, 0) = "流水号"
        .ColWidth(0) = 0
        
        .TextMatrix(0, 1) = "登记编号"
        .ColWidth(1) = Me.TextWidth(.TextMatrix(0, 1)) + 200
        
        .TextMatrix(0, 2) = "登记人"
        .ColWidth(2) = Me.TextWidth(.TextMatrix(0, 2)) + 200
        
        .TextMatrix(0, 3) = "团体名称"
        .ColWidth(3) = Me.TextWidth(.TextMatrix(0, 3)) + 200
        
        .TextMatrix(0, 4) = "体检日期"
        .ColWidth(4) = Me.TextWidth(.TextMatrix(0, 4)) + 500
        
        '显示尚未体检，但已经预约的个人或团体
        '首先显示团体
        strSQL = "select YYID,LXR,DWMC,TJRQ" _
                & " from YY_TJDJ,SET_DW" _
                & " where YY_TJDJ.DWID=SET_DW.DWID" _
                & " and (SFTJ=0 or SFTJ=1)"
        Set rsTemp = New ADODB.Recordset
        rsTemp.Open strSQL, GCon, adOpenKeyset, adLockOptimistic
        If rsTemp.RecordCount > 0 Then
            rsTemp.MoveFirst
            Do
                If .TextMatrix(1, 1) = "" Then
                    i = 1
                Else
                    i = .Rows
                    .Rows = i + 1
                End If
                .TextMatrix(i, 0) = ""
                .TextMatrix(i, 1) = rsTemp("YYID")
                .TextMatrix(i, 2) = rsTemp("LXR")
                .TextMatrix(i, 3) = rsTemp("DWMC")
                .TextMatrix(i, 4) = rsTemp("TJRQ")
                If rsTemp("TJRQ") < Date Then
                    .Row = i
                    .col = 4
                    .CellBackColor = vbRed
                End If
                
                rsTemp.MoveNext
            Loop Until rsTemp.EOF
            rsTemp.Close
            
            .Row = 1
            .col = 0
            .ColSel = 4
            MSHFlexGrid1_Click
        End If
    End With
    
    GoTo ExitLab
    
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    Screen.MousePointer = vbDefault
End Sub

Private Sub sstInfoClick()
On Error GoTo ErrMsg
    Dim Status
    Dim i As Integer
    Dim strSQL As String
    Dim rsTemp As ADODB.Recordset
'
'    '刷新团体信息
''    If sstInfo.Tab = 1 Then
'        strSQL = "select YYID,DWMC" _
'                & " from YY_TJDJ,SET_DW" _
'                & " where YY_TJDJ.DWID=SET_DW.DWID" _
'                & " order by JLRQ desc"
'        Set rsTemp = New ADODB.Recordset
'        rsTemp.Open strSQL, GCon, adOpenKeyset, adLockOptimistic
'        If rsTemp.RecordCount > 0 Then
'            cmbGDWei.AddItem "" '首先添加一个空行，便于用户修改
'
'            ReDim arrYYID(rsTemp.RecordCount)
'
'            '添加已经预约过的团体
'            rsTemp.MoveFirst
'            For i = 1 To rsTemp.RecordCount
'                cmbGDWei.AddItem rsTemp("DWMC")
'                cmbGDWei.ItemData(cmbGDWei.NewIndex) = i
'                arrYYID(i) = rsTemp("YYID") 'YYID字段太长，ItemData属性无法存放，只能存入数组
'
'                rsTemp.MoveNext
'            Next
'            rsTemp.Close
'            Set rsTemp = Nothing
'        End If
''    End If
    
    Exit Sub
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
End Sub

Private Sub MSHFlexGrid1_Click()
On Error GoTo ErrMsg
    Dim Status
    Dim i As Integer
    Dim intRow As Integer
    Dim strSQL As String
    Dim rsTemp As ADODB.Recordset
    Dim strDXID As String
    Dim blnHave As Boolean
    
    Dim strHealthID As String
    
    Me.MousePointer = vbHourglass
    
    cmdAdd.Enabled = True
    '禁止删除
    cmdDelete.Enabled = False
    
    SetAllInput False
    
    
    '**************************20040411加入 闻********************************
    mstrStatus = ""
    ClearTTInput
    '**************************20040411加入完 闻********************************
    
    With Me.MSHFlexGrid1
        intRow = .Row
        '是否选择了标题
        If intRow = 0 Then Exit Sub
        '检查有无选择
        If (intRow = 0) Or (.TextMatrix(intRow, 1) = "") Then
            ClearTTInput
            
            cmdModify.Enabled = False
            cmdOK.Enabled = False
'            cmdAffirm.Enabled = False '不可以进行确认
            
            GoTo ExitLab
        Else
            '判断是否团体，如果不是团体，则可以进行确认
            If Me.MSHFlexGrid1.TextMatrix(intRow, 3) <> "" Then
                '个人
'                cmdAffirm.Enabled = True '可以进行确认
            Else
                '团体名称
'                cmdAffirm.Enabled = False '不可以进行确认
            End If
        End If
        
        '如果有选择，则显示选择的详细信息
        '显示团体信息
        strSQL = "select YYID,DJRS,XZTC,TCID,TJRQ,SFTJ,SET_DW.*" _
                & " from YY_TJDJ,SET_DW" _
                & " where YYID='" & .TextMatrix(intRow, 1) & "'" _
                & " and YY_TJDJ.DWID=SET_DW.DWID"
        Set rsTemp = New ADODB.Recordset
        rsTemp.Open strSQL, GCon, adOpenKeyset, adLockOptimistic
        If rsTemp.RecordCount > 0 Then
            rsTemp.MoveFirst
            '显示团体信息
            txtTYYID.Text = rsTemp("YYID")
            For i = 0 To cmbTDWei.ListCount - 1
                If cmbTDWei.List(i) = rsTemp("DWMC") Then
                    cmbTDWei.ListIndex = i
                    Exit For
                End If
            Next
                
            txtTLXR.Text = rsTemp("LXR") & ""
            txtTLXRBGDH.Text = rsTemp("LXRBGDH") & ""
            txtTLXRYDDH.Text = rsTemp("LXRYDDH") & ""
            txtTEMail.Text = rsTemp("LXREMail") & ""
            txtTFZR.Text = rsTemp("FZR") & ""
            txtTFZRBGDH.Text = rsTemp("FZRBGDH") & ""
            txtTFZRYDDH.Text = rsTemp("FZRYDDH") & ""
            txtTYZBM.Text = rsTemp("YZBM") & ""
            txtTYWYH.Text = rsTemp("YWYH") & ""
            txtTYHZH.Text = rsTemp("YHZH") & ""
            txtTQYXZ.Text = rsTemp("QYXZ") & ""
            txtTDJRS.Text = rsTemp("DJRS") & ""
            dtpTTJRQ.Value = rsTemp("TJRQ") & ""
            txtTLXDZ.Text = rsTemp("LXDZ") & ""
            
             '如果体检日期已成为过去，则启用删除按钮
            If rsTemp("SFTJ") < Date Then
                cmdDelete.Enabled = True
            Else
                cmdDelete.Enabled = False
            End If
            
            '是否选择了套餐
'            If rsTemp("XZTC") = True Then
'                For i = 0 To cmbTTCan.ListCount - 1
'                    If cmbTTCan.ItemData(i) = Val(rsTemp("TCID")) Then
'                        cmbTTCan.ListIndex = i
'                        Exit For
'                    End If
'                Next
'            Else
'                cmbTTCan.ListIndex = 0
'            End If
            
'            '显示已经添加的大项
'            strSQL = "select DXID from YY_TJDJDX" _
'                    & " where YYID='" & .TextMatrix(intRow, 1) & "'"
'            rsTemp.Close
'            Set rsTemp = New ADODB.Recordset
'            rsTemp.Open strSQL, GCon, adOpenKeyset, adLockOptimistic
'            If rsTemp.RecordCount > 0 Then
'                For i = 1 To tvwTDXiang.Nodes.Count
'                    strDXID = Mid(tvwTDXiang.Nodes(i).Key, 2)
'                    If Len(strDXID) = 4 Then
'                        rsTemp.MoveFirst
'                        blnHave = False
'
'                        Do
'                            If strDXID = rsTemp("DXID") Then
'                                blnHave = True
'                                Exit Do
'                            End If
'                            rsTemp.MoveNext
'                        Loop Until rsTemp.EOF
'
'                        If blnHave = True Then
'                            tvwTDXiang.Nodes(i).Checked = True
'                        Else
'                            tvwTDXiang.Nodes(i).Checked = False
'                        End If
'                    End If
'                Next
'                rsTemp.Close
'            Else
'                For i = 1 To tvwTDXiang.Nodes.Count
'                    tvwTDXiang.Nodes(i).Checked = False
'                Next
'            End If
        End If
    End With
    
    menuOperation = Modify
    cmdModify.Enabled = True
    cmdOK.Enabled = False
    
    '清除复查标志
    mblnReCheck = False
    
    GoTo ExitLab
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    Me.MousePointer = vbDefault
End Sub

'设置控件的启用与否
Private Sub SetAllInput(ByVal blnFlag As Boolean)
    fraTTi.Enabled = blnFlag
End Sub

'清空所有团体信息显示
Private Sub ClearTTInput()
    txtTYYID.Text = ""
    cmbTDWei.Text = ""
    txtTLXR.Text = ""
    txtTLXRBGDH.Text = ""
    txtTLXRYDDH.Text = ""
    txtTFZR.Text = ""
    txtTEMail.Text = ""
    txtTFZRBGDH.Text = ""
    txtTFZRYDDH.Text = ""
    txtTYZBM.Text = ""
    txtTLXDZ.Text = ""
    txtTYWYH.Text = ""
    txtTYHZH.Text = ""
    txtTQYXZ.Text = ""
    txtTDJRS.Text = ""
End Sub

'置团体信息输入框
Private Sub SetTTInput(Val As Boolean)
    txtTYYID.Enabled = Val
    cmbTDWei.Enabled = Val
    txtTLXR.Enabled = Val
    txtTLXRBGDH.Enabled = Val
    txtTLXRYDDH.Enabled = Val
    txtTFZR.Enabled = Val
    txtTFZRBGDH.Enabled = Val
    txtTFZRYDDH.Enabled = Val
    txtTYZBM.Enabled = Val
    txtTLXDZ.Enabled = Val
    txtTYWYH.Enabled = Val
    txtTYHZH.Enabled = Val
    txtTQYXZ.Enabled = Val
    txtTDJRS.Enabled = Val
End Sub