dlgaffirm.frm

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

        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 '是否团检
    Dim TmpclsDisk As New CDiskInfo
    Dim strTmpQueryCode As String
    Dim rstemp As ADODB.Recordset
    Dim cmdTemp As ADODB.Command
    Dim tmpHealthID As String
    Dim blnSel As Boolean
    Dim i As Integer
    
    Me.MousePointer = vbHourglass
    
    '是否有选择项目
    '循环每个大项，检查是否有输入
    blnSel = False
    For i = 1 To tvwGDXiang.Nodes.Count
        If Len(tvwGDXiang.Nodes(i).Key) = 5 Then
            If tvwGDXiang.Nodes(i).Checked = True Then
                blnSel = True
                Exit For
            End If
        End If
    Next
    If Not blnSel Then
        MsgBox "请选择体检项目！", vbInformation, "提示"
        GoTo ExitLab
    End If
    If txt_p.Text = "" Then
           MsgBox "请输入拼音！", vbInformation, "提示"
            txt_p.SetFocus
            GoTo ExitLab
     End If
     If txtGAGE.Text = "" Then
           MsgBox "请输入年龄！", vbInformation, "提示"
            txtGAGE.SetFocus
            GoTo ExitLab
     End If
    '检查是否添加或修改
    If mblnAdd = True Then
        mTmpHYKH = Trim(TxtGSelfBH.Text)
        cmdOKClick
        GoTo ExitLab
    End If
     
    If cmbGDWei.Text = "" Then
'        If cmbTJBZ.Text = "" Then
'            MsgBox "请选体检标准！", vbInformation, "提示"
'            cmbTJBZ.SetFocus
'            GoTo ExitLab
'        End If
    Else
        If CmbFZ.Text = "" Then
            MsgBox "请选择分组！", vbInformation, "提示"
            CmbFZ.SetFocus
            GoTo ExitLab
        End If
    End If
    
    If mintGrid = 1 Then '从第一个网格来
        '网格里是否有记录
        If Me.MSHFlexGrid1.TextMatrix(1, 0) = "" Then GoTo ExitLab
        
        intRow = Me.MSHFlexGrid1.Row '当前行
        '检查是否有选择
        If Me.MSHFlexGrid1.TextMatrix(intRow, 0) = "" Then GoTo ExitLab
        
        '记录唯一编号
        lngGUID = Val(Me.MSHFlexGrid1.TextMatrix(intRow, 0))
        
        If Me.MSHFlexGrid1.TextMatrix(intRow, 4) <> "" Then
            '团检客户
            '首先检查是否参与分组
            strSQL = "select YYID from FZ_FZSJ" _
                    & " where GUID=" & lngGUID
            Set rsPerson = New ADODB.Recordset
            rsPerson.Open strSQL, GCon, adOpenStatic, adLockReadOnly
            If rsPerson.RecordCount < 1 Then
                MsgBox "客户“" & Me.MSHFlexGrid1.TextMatrix(intRow, 2) _
                        & "”尚未参与分组，无法确认！" _
                        & vbCrLf & "请首先对该客户进行分组！", vbInformation, "提示"
                GoTo ExitLab
            End If
            
            blnTJ = True
        Else
            blnTJ = False
        End If
        
        '记录旧的健康档案号
        strOldHealthID = Me.MSHFlexGrid1.TextMatrix(intRow, 1)
    Else
        '网格里是否有记录
        If Me.MSHFlexGrid2.TextMatrix(1, 0) = "" Then GoTo ExitLab
        
        intRow = Me.MSHFlexGrid2.Row '当前行
        '检查是否有选择
        If Me.MSHFlexGrid2.TextMatrix(intRow, 0) = "" Then GoTo ExitLab
        
        '记录唯一编号
        lngGUID = Val(Me.MSHFlexGrid2.TextMatrix(intRow, 0))
        
        If Me.MSHFlexGrid2.TextMatrix(intRow, 5) <> "" Then
            '团检客户
            '已经确认过，所以无需作是否分组的检查
            blnTJ = True
        Else
            blnTJ = False
        End If
        
        '记录旧的健康档案号
        strOldHealthID = Me.MSHFlexGrid2.TextMatrix(intRow, 1)
    End If
    
    mTmpHYKH = Trim(TxtGSelfBH.Text)
    
    If AffirmPerson(lngGUID, strOldHealthID, blnTJ) = False Then GoTo ExitLab