frmaffirmlvw.frm

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

    '***************20040514加入***********************
    '先清除项目树tvwGDXiang的选取
    For i = 1 To tvwGDXiang.Nodes.Count
        tvwGDXiang.Nodes(i).Checked = False
    Next
    '***************20040514加入***********************
    
    If (mblnAdd = True) And (mblnReCheck = False) Then
        '根据该分组的体检日期更新txtTJXH和txtGYYID
        strHealthID = Format(dtpGTJRQ.Value, "yyyymmdd")
        strSQL = "select SJYYXLH from YY_XLH where RiQi='" & dtpGTJRQ.Value & "'"
        Set rstemp = New ADODB.Recordset
        rstemp.Open strSQL, GCon, adOpenStatic, adLockOptimistic
        If rstemp.RecordCount = 0 Then
            strHealthID = strHealthID & "0001"
            txtTJXH.Text = 1
        ElseIf IsNull(rstemp("SJYYXLH")) Then
            strHealthID = strHealthID & "0001"
            txtTJXH.Text = 1
            rstemp.Close
        Else
            strHealthID = strHealthID & LongToString(rstemp("SJYYXLH") + 1, 4)
            txtTJXH.Text = rstemp("SJYYXLH") + 1
            rstemp.Close
        End If
        Set rstemp = Nothing
        txtGYYID.Text = strHealthID
    End If
    
    '显示该分组所选择的体检项目
    strSQL = "select * from YY_TJDJTC" _
            & " where YYID='" & arrYYID(cmbGDWei.ListIndex) & "'" _
            & " and FZID=" & arrFZ(Val(CmbFZ.ItemData(CmbFZ.ListIndex)))
    Set rstemp = New ADODB.Recordset
    rstemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
    '如果XZTC字段为1，则说明选择了套餐,则将cmbTTCan中显示相应套餐
    If rstemp.RecordCount = 1 Then
        If rstemp("XZTC") = True Then
             For i = 0 To cmbGTCan.ListCount - 1
                 If cmbGTCan.ItemData(i) = Val(rstemp("TCID")) Then
                     cmbGTCan.ListIndex = i
                     Exit For
                 End If
             Next
         Else
             cmbGTCan.ListIndex = 0
         End If
    End If
    
    '显示该分组所选的大项
    strSQL = "select DXID from YY_TJDJDX" _
            & " where YYID='" & arrYYID(cmbGDWei.ListIndex) _
            & "' and FZID=" & arrFZ(Val(CmbFZ.ItemData(CmbFZ.ListIndex)))
    Set rstemp = New ADODB.Recordset
    rstemp.Open strSQL, GCon, adOpenKeyset, adLockOptimistic
    If rstemp.RecordCount > 0 Then
        For i = 1 To tvwGDXiang.Nodes.Count
            strDXID = Mid(tvwGDXiang.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
                    tvwGDXiang.Nodes(i).Checked = True
                Else
                    tvwGDXiang.Nodes(i).Checked = False
                End If
            End If
        Next
        rstemp.Close
    Else
        For i = 1 To tvwGDXiang.Nodes.Count
            tvwGDXiang.Nodes(i).Checked = False
        Next
    End If
    '**************************20040411加入 闻********************************
    mstrStatus = "change"
    '**************************20040411加入完 闻******************************

    Exit Sub
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
End Sub

Private Sub CmbFZ_KeyPress(KeyAscii As Integer)
    EnterToTab KeyAscii
End Sub

Private Sub cmbGDWei_Click()
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim rstemp As ADODB.Recordset
    Dim i As Integer
    
    CmbFZ.Clear
    '如果不选择单位，则表示是个散客登记
    If cmbGDWei.Text = "" Then
'        Me.dtpGTJRQ.Enabled = True
        Me.dtpGTJRQ.Value = Date
    End If
    
    If cmbGDWei.Text <> "" Then '说明属于团体客户
        '团体客户不允许修改套餐和体检标准
        cmbGTCan.Enabled = False
'        fraTJBZ.Enabled = False
'        dtpGTJRQ.Enabled = False
        
'        '显示体检日期
'        strSQL = "select TJRQ from YY_TJDJ" _
'                & " where YYID='" & arrYYID(cmbGDWei.ListIndex) & "'"
'        Set rsTemp = New ADODB.Recordset
'        rsTemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
'        If Not rsTemp.EOF Then
'            dtpGTJRQ.Value = rsTemp(0)
'            rsTemp.Close
'        End If
        
        '****************20040406加入 闻*************************
        '在cmbFZ中显示该单位当前的分组
        strSQL = "select * from FZ_FZSY" _
                & " where YYID='" & arrYYID(cmbGDWei.ListIndex) & "'"
        Set rstemp = New ADODB.Recordset
        rstemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
        If rstemp.RecordCount > 0 Then
            ReDim arrFZ(rstemp.RecordCount)
            rstemp.MoveFirst
            i = 1
            Do While Not rstemp.EOF
                CmbFZ.AddItem rstemp("FZMC")
                CmbFZ.ItemData(CmbFZ.NewIndex) = i
                arrFZ(i) = rstemp("FZID")
                
                rstemp.MoveNext
                i = i + 1
            Loop
        
        Else
            '前面已经清空
        End If
        '****************20040406加入 闻*************************
        
        '清除已经存在的选择
        For i = 1 To tvwGDXiang.Nodes.Count
            tvwGDXiang.Nodes(i).Checked = False
        Next
        cmbGTCan.ListIndex = -1
'        fraTJBZ.Visible = False '只对非团体客户显示体检标准
    Else '散检客户
        cmbGTCan.Enabled = True
'        dtpGTJRQ.Enabled = True
'        fraTJBZ.Visible = True
'        fraTJBZ.Enabled = True
'        cmbTJBZ.Enabled = True
    End If
    
    Exit Sub
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
End Sub

Private Sub cmbGDWei_KeyPress(KeyAscii As Integer)
    EnterToTab KeyAscii
End Sub

Private Sub cmbGHF_KeyPress(KeyAscii As Integer)
    EnterToTab KeyAscii
End Sub

Private Sub cmbGSEX_KeyPress(KeyAscii As Integer)
    EnterToTab KeyAscii
End Sub

Private Sub cmbGTCan_Click()
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim rstemp As ADODB.Recordset
    Dim i As Integer, j As Integer
    Dim strDXID As String
    Dim blnHave As Boolean
    
    Me.MousePointer = vbArrowHourglass
    m_blnCompute = True
    If cmbGTCan.Text = "" Then
        '清除所有选择
        For i = 1 To tvwGDXiang.Nodes.Count
            tvwGDXiang.Nodes(i).Checked = False
        Next
        '去掉套餐描述
        lblGInfo.Caption = ""
        GoTo ExitLab
    End If
    
    '显示该套餐描述
    strSQL = "select TCMC from SET_TC" _
            & " where TCID='" _
            & LongToString(cmbGTCan.ItemData(cmbGTCan.ListIndex), 5) & "'"
    Set rstemp = New ADODB.Recordset
    rstemp.Open strSQL, GCon, adOpenForwardOnly, adLockReadOnly
    lblGInfo.Caption = rstemp("TCMC")
    rstemp.Close
    
    '获取该套餐包含的大项
    strSQL = "select DXID from SET_TCDX" _
            & " where TCID='" _
            & LongToString(cmbGTCan.ItemData(cmbGTCan.ListIndex), 5) & "'"
    Set rstemp = New ADODB.Recordset
    rstemp.Open strSQL, GCon, adOpenKeyset, adLockOptimistic
    If rstemp.RecordCount > 0 Then
        '循环每个大项，如果该大项包含在当前套餐中，则选中，否则不选中
        For i = 1 To tvwGDXiang.Nodes.Count
            '只处理大项
            If Len(tvwGDXiang.Nodes(i).Key) = 5 Then
                strDXID = Mid(tvwGDXiang.Nodes(i).Key, 2)
                
                blnHave = False
                rstemp.MoveFirst
                For j = 1 To rstemp.RecordCount
                    If rstemp("DXID") = strDXID Then
                        blnHave = True
                        Exit For
                    End If
                    rstemp.MoveNext
                Next j
                
                '检查是否包含
                If blnHave = True Then
                    tvwGDXiang.Nodes(i).Checked = True
                    blnHave = False
                Else
                    tvwGDXiang.Nodes(i).Checked = False
                End If
            End If
        Next i
    End If
    
    Set rstemp = Nothing
    
    '*******************20040912加入 闻***************************
    '如果某个大项选中，则选中其父节点
    For i = 1 To tvwGDXiang.Nodes.Count
        If tvwGDXiang.Nodes(i).Checked = True And Len(tvwGDXiang.Nodes(i).Key) > 3 Then
            tvwGDXiang.Nodes(i).Parent.Checked = True
        End If
    Next i
    '*******************20040912加入完 闻***************************
    
    GoTo ExitLab
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    m_blnCompute = True
    lblCurrentPrice.Caption = ComputeMoneyFromCurrentSelect(tvwGDXiang, cmbGTCan) & " 元"
    Me.MousePointer = vbDefault
End Sub


Private Sub cmdAdd_Click()
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim strHealthID As String    '个人id
    Dim strYYID As String        '团体id
    Dim rstemp As ADODB.Recordset
    
    '**************************20040423加入 闻**********************************
    '判断是否是试用版
    If gTryVersion = True Then
        Set rstemp = New ADODB.Recordset
        strSQL = "select Count(*) from SET_GRXX"
        rstemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
        If rstemp(0) > 20 Then
            MsgBox "对不起,您使用的是试用版本,最多不能超过20条体检记录", vbInformation, "试用版"
            GoTo ExitLab
        End If
    End If
    '**************************20040423加入完 闻********************************

    
    Me.MousePointer = vbHourglass
    menuOperation = Add
    mintGrid = 0
    
    ClearGRInput
    
    '生成当前最大的id
    '获取当前的最大编号
    
    '****************************20040404封  闻*******************************
'        strHealthID = Format(Date, "yyyymmdd")
'        strSql = "select SJYYXLH from YY_XLH where RiQi='" & Date & "'"
    '****************************20040404封完  闻*****************************
    
    '****************************20040404加入  闻*****************************
    strHealthID = Format(dtpGTJRQ.Value, "yyyymmdd")
    strSQL = "select SJYYXLH from YY_XLH where RiQi='" & dtpGTJRQ.Value & "'"
    '****************************20040404加入完  闻***************************
    Set rstemp = New ADODB.Recordset
    rstemp.Open strSQL, GCon, adOpenStatic, adLockOptimistic
    If rstemp.RecordCount = 0 Then
        strHealthID = strHealthID & "0001"
        txtTJXH.Text = 1
    ElseIf IsNull(rstemp("SJYYXLH")) Then
        strHealthID = strHealthID & "0001"
        txtTJXH.Text = 1
        rstemp.Close
    Else
        strHealthID = strHealthID & LongToString(rstemp("SJYYXLH") + 1, 4)
        txtTJXH.Text = rstemp("SJYYXLH") + 1
        rstemp.Close
    End If
    Set rstemp = Nothing
    txtGYYID.Text = strHealthID
    
    SetGRInput True
    mblnAdd = True
    
    '清除上一个客户选择的项目
    If CmbFZ.Text <> "" Then
        CmbFZ_Click
    ElseIf cmbGDWei.Text <> "" Then
        cmbGDWei_Click
    Else
        cmbGTCan_Click
    End If
    
    cmdAdd.Enabled = False
    cmdModify.Enabled = False
    cmdPrintGuider.Enabled = False
    cmdPay.Enabled = False
    cmdFaKa.Enabled = False
    cmdAffirm.Enabled = True
    cmdIDCardAndPerson.Enabled = True
    CmdCancelAffirm.Enabled = False
    
    '清除复查标志
    mblnReCheck = False
    mblnBuCha = False
    m_enuCheckType = None
    
    TxtGSelfBH.Text = GetMaxSelfID()
    '设置光标焦点
    If g_blnSelfID Then
        TxtGSelfBH.SetFocus
    Else
        txtGYYRXM.SetFocus
    End If

    GoTo ExitLab
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    Me.MousePointer = vbDefault
End Sub

Private Sub CmdAffirm_Click()
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim rsPerson As ADODB.Recordset
    Dim intRow As Integer
    Dim lngGUID As Long
    Dim strOldHealthID As String
    Dim blnTJ As Boolean '是否团检