mdldatabase3.bas

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

    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    Screen.MousePointer = vbDefault
End Function

'**********************************************************************
'计算个人的应付总费用（散检）
'参数1：表示某个客户的唯一编号
'返回值：货币型。应付总费用
'**********************************************************************
Public Function GetTotalMoney_GR(ByVal lngGUID As Long) As Currency
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim rstemp As ADODB.Recordset
    Dim rsFZ As ADODB.Recordset
    Dim curTotal As Currency
    Dim curFZTotal As Currency '分组合计
    Dim curTCJG As Currency '套餐价格
    Dim strYYID As String
    Dim intFZID As Integer
    
    Screen.MousePointer = vbHourglass
    
    '检查是否团体人员
    strSQL = "select YYID,FZID from FZ_FZSJ" _
            & " where GUID=" & lngGUID
    Set rstemp = New ADODB.Recordset
    rstemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
    If Not rstemp.EOF Then
        strYYID = rstemp("YYID")
        intFZID = rstemp("FZID")
        rstemp.Close
        GetTotalMoney_GR = GetTotalMoney_TTGRApend(lngGUID, strYYID, intFZID)
        GoTo ExitLab
    End If
    
    '*****************************************************************
    '                  根据普亚要求，这里返回大项的直接和
    '*****************************************************************
    strSQL = "select Sum(DXJG) from SET_DX" _
            & " where DXID in(" _
                & "select DXID from YY_SJDJDX" _
                & " where GUID=" & lngGUID _
            & ")"
    Set rstemp = New ADODB.Recordset
    rstemp.Open strSQL, GCon, adOpenForwardOnly, adLockReadOnly
    If Not rstemp.EOF Then
        If Not IsNull(rstemp(0)) Then
            GetTotalMoney_GR = rstemp(0)
        End If
        rstemp.Close
    End If
    GoTo ExitLab
    
    
    '*****************************************************************
    '                       以下代码不再使用
    '*****************************************************************
    strSQL = "select YY_SJDJ.XZTC,YY_SJDJ.TCID" _
            & " from YY_SJDJ" _
            & " where GUID=" & lngGUID
    Set rsFZ = New ADODB.Recordset
    rsFZ.Open strSQL, GCon, adOpenStatic, adLockReadOnly
    If rsFZ.RecordCount > 0 Then
        rsFZ.MoveFirst
        '第一步：是否有套餐
        If rsFZ("XZTC") = True Then
            '获取套餐价格
            strSQL = "select TCJG from SET_TC" _
                    & " where TCID=" & rsFZ("TCID")
            Set rstemp = New ADODB.Recordset
            rstemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
            If Not IsNull(rstemp("TCJG")) Then
                curTCJG = rstemp("TCJG")
                curFZTotal = curFZTotal + curTCJG
                rstemp.Close
            End If
        End If
        
        '第二步：加上该分组选择的组合的价格
        strSQL = "select Sum(DXJG)" _
                & " from SET_DX" _
                & " where DXID in (" _
                    & "select DXID from YY_SJDJDX" _
                    & " where GUID=" & lngGUID _
                & ")"
        If rsFZ("XZTC") Then
            strSQL = strSQL & " and DXID not in (" _
                        & "select DXID from SET_TCDX" _
                        & " where TCID=" & rsFZ("TCID") _
                    & ")"
        End If
        Set rstemp = New ADODB.Recordset
        rstemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
        If Not IsNull(rstemp(0)) Then
            curFZTotal = curFZTotal + rstemp(0)
            rstemp.Close
        End If
        
        '第三步：减去组合中存在，而套餐中也存在的重复项目
        If rsFZ("XZTC") = True Then
            strSQL = "select Sum(distinct XXPrice)" _
                        & " from SET_XX" _
                        & " where XXID in (" _
                            & "select SET_XX.XXID from SET_XX,SET_ZH_Data" _
                            & " where SET_XX.XXID=SET_ZH_Data.XXID" _
                            & " and SET_ZH_Data.DXID in (" _
                                & "select DXID from YY_SJDJDX" _
                                & " where GUID=" & lngGUID _
                            & ")" _
                            & " and SET_ZH_Data.DXID not in (" _
                                & "select DXID from SET_TCDX" _
                                & " where TCID=" & rsFZ("TCID") _
                            & ")" _
                        & ")" _
                        & " and XXID in (" _
                            & "select SET_XX.XXID from SET_XX,SET_ZH_Data" _
                            & " where SET_XX.XXID=SET_ZH_Data.XXID" _
                            & " and SET_ZH_Data.DXID in (" _
                                & "select DXID from SET_TCDX" _
                                & " where TCID=" & rsFZ("TCID") _
                            & ")" _
                        & ")"
            Set rstemp = New ADODB.Recordset
            rstemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
            If Not rstemp.EOF Then
                If Not IsNull(rstemp(0)) Then
                    curFZTotal = curFZTotal - rstemp(0)
                End If
                rstemp.Close
            End If
        End If
        
        '第四步，减去组合中重复的项目
        strSQL = "select Count(SET_XX.XXID),Sum(XXPrice)" _
                & " from SET_XX,SET_ZH_Data,YY_SJDJDX" _
                & " where SET_XX.XXID=SET_ZH_Data.XXID" _
                & " and SET_ZH_Data.DXID=YY_SJDJDX.DXID" _
                & " and YY_SJDJDX.GUID=" & lngGUID
        If rsFZ("XZTC") Then
            strSQL = strSQL & " and SET_ZH_Data.DXID not in (" _
                        & "select DXID from SET_TCDX" _
                        & " where TCID=" & rsFZ("TCID") _
                    & ")"
        End If
        strSQL = strSQL & " group by SET_XX.XXID" _
                & " having Count(SET_XX.XXID)>1"
        Set rstemp = New ADODB.Recordset
        rstemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
        If Not rstemp.EOF Then
            Do While Not rstemp.EOF
                If Not IsNull(rstemp(1)) Then
                    '只减去多余的部分
                    curFZTotal = curFZTotal - rstemp(1) * (rstemp(0) - 1) / rstemp(0)
                End If
                
                rstemp.MoveNext
            Loop
            
            rstemp.Close
        End If
                
        '最后一步。总人数，为1
        curTotal = curFZTotal * 1
        
        rsFZ.Close
    End If
        
    GetTotalMoney_GR = curTotal
    
    GoTo ExitLab
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    Screen.MousePointer = vbDefault
End Function

'**********************************************************************
'计算个人的应付总费用（团检）
'参数1：表示某个客户的唯一编号
'返回值：货币型。应付总费用
'**********************************************************************
Public Function GetTotalMoney_TTGRApend(ByVal lngGUID As Long, ByVal strYYID As String, _
        ByVal intFZID As Integer) As Currency
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim rstemp As ADODB.Recordset
    Dim curTotal As Currency
    
    Screen.MousePointer = vbHourglass
    
    '第一步，是否有加项
    strSQL = "select Count(*) from YY_SJDJDX" _
            & " where GUID=" & lngGUID _
            & " and DXID not in(" _
                & "select DXID from YY_TJDJDX" _
                & " where YYID='" & strYYID & "'" _
                & " and FZID=" & intFZID _
            & ")"
    Set rstemp = New ADODB.Recordset
    rstemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
    If rstemp(0) < 1 Then
        '没有加项
        GoTo ExitLab
    End If
    rstemp.Close
    
    '第二步，创建临时表，把用户加项放入临时表
    strSQL = "CREATE TABLE " & TempTable _
            & " (DXID Varchar(4))"
    If CreateTable(TempTable, True, strSQL) = False Then GoTo ExitLab
    '把用户选择的项目添加到表中
    strSQL = "insert into " & TempTable & "(DXID)" _
            & " select DXID from YY_SJDJDX" _
            & " where GUID=" & lngGUID _
            & " and DXID not in(" _
                & "select DXID from YY_TJDJDX" _
                & " where YYID='" & strYYID & "'" _
                & " and FZID=" & intFZID _
            & ")"
    GCon.Execute strSQL
    
    '第三步，取得所加大项的费用
    strSQL = "select Sum(DXJG) from SET_DX" _
            & " where DXID in(" _
                & "select DXID from " & TempTable _
            & ")"
    Set rstemp = New ADODB.Recordset
    rstemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
    If Not rstemp.EOF Then
        If Not IsNull(rstemp(0)) Then
            curTotal = rstemp(0)
        End If
        rstemp.Close
    End If
    
    '第四步，减去加项中存在，分组中也选择的项目
    strSQL = "select Sum(XXPrice) from SET_XX" _
            & " where XXID in(" _
                & "select XXID from SET_ZH_DATA" _
                & " where DXID in(" _
                    & "select DXID from " & TempTable _
                & ")" _
            & ")" _
            & " and XXID in(" _
                & "select XXID from SET_ZH_DATA" _
                & " where DXID in(" _
                    & "select DXID from YY_TJDJDX" _
                    & " where YYID='" & strYYID & "'" _
                    & " and FZID=" & intFZID _
                & ")" _
            & ")"
    Set rstemp = New ADODB.Recordset
    rstemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
    If Not rstemp.EOF Then
        If Not IsNull(rstemp(0)) Then
            curTotal = curTotal - rstemp(0)
        End If
        rstemp.Close
    End If
    
    '第五步，去掉加项中重复的项目
    strSQL = "select Count(SET_XX.XXID),Sum(XXPrice)" _
            & " from SET_XX,SET_ZH_Data," & TempTable _
            & " where SET_XX.XXID=SET_ZH_Data.XXID" _
            & " and SET_ZH_Data.DXID=" & TempTable & ".DXID"
    strSQL = strSQL & " group by SET_XX.XXID" _
            & " having Count(SET_XX.XXID)>1"
    Set rstemp = New ADODB.Recordset
    rstemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
    If Not rstemp.EOF Then
        Do While Not rstemp.EOF
            If Not IsNull(rstemp(1)) Then
                '只减去多余的部分
                curTotal = curTotal - rstemp(1) * (rstemp(0) - 1) / rstemp(0)
            End If
            
            rstemp.MoveNext
        Loop
        
        rstemp.Close
    End If
    
    GetTotalMoney_TTGRApend = curTotal
    
    GoTo ExitLab
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    Screen.MousePointer = vbDefault
End Function

'**********************************************************************
'加载所有管理员
'参数1：要加载管理员名字的ComboBox框
'返回值：布尔型。调用是否成功
'**********************************************************************
Public Function LoadAllManager(ByRef cmbDoctor As ComboBox) As Boolean
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim rstemp As ADODB.Recordset
    
    '**************************20040910改 闻*******************************
'        strSQL = "select EmployeeID,Name from RY_Employee" _
'                & " order by Name"
    strSQL = "select EmployeeID,Name from RY_Employee where KSID='" & gstrKSID & "'" _
            & " or KSID is null or KSID=''" _
            & " order by Name"
    strSQL = "select EmployeeID,Name from RY_Employee order by Name"
    '**************************20040910改完 闻*****************************
    Set rstemp = New ADODB.Recordset
    rstemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
    If rstemp.RecordCount > 0 Then
        rstemp.MoveFirst