mdldatabase3.bas

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

Attribute VB_Name = "mdlDatabase3"
Option Explicit

Public Const LENGTHOFZFID = 5 '支付方式编号的长度
Public Const LENGTHOFMEMBERID = 5 '会员编号的长度
Public Const LENGTHOFSFID = 10 '收费编号的长度
Public Const LENGTH_OF_JY = 2 '自定义建议编号的长度

Public Type POINTPRINT
    x As Single
    y As Single
End Type

Public Type SelfNumberAuto
    Auto As Boolean
    Fixed As Boolean
    FixedLength As Long
End Type
Public GSelfNumberAuto As SelfNumberAuto

Public Type FilterSet
    WJYC_FILTER As Boolean '过滤未见异常
    WJMXYC_FILTER As Boolean '过滤未见明显异常
    ZC_FILTER As Boolean '过滤正常值
    NULL_FILTER As Boolean '过滤空值
End Type
Public GFilterSet As FilterSet

Public Type FilterString
    WJYC_FILTER As String   '未见异常
    WJMXYC_FILTER As String   '未见明显异常
    ZC_FILTER As String   '正常值
    NULL_FILTER As String   '空值
End Type
Public GFilterString As FilterString

Public Enum CheckType
    None = 0 '都不是
    ReCheckPerson = 1 '复查
    MendCheck = 2 '补查
    ModifySelection = 3 '加减项
End Enum

Public Enum GuiderType
    PuYa = 0
    QingDaoUniversity = 1
End Enum

'**********************************************************************
'加载所有具有“编号”、“名称”格式的表
'参数1：控件名。可以是ListView或者Combox
'参数2：从数据库中提取记录的查询语句。第一列将被视为ID，第二列视为名称
'返回值：布尔型。是否成功
'**********************************************************************
Public Function LoadSETTABLE(ByRef objControl As Object, ByVal strSQL As String) As Boolean
On Error GoTo ErrMsg
    Dim Status
    Dim intCount As Integer
    Dim i As Integer
    Dim itmTemp As ListItem
    Dim rstemp As ADODB.Recordset
    
    LoadSETTABLE = False
    Screen.MousePointer = vbHourglass
    
    Set rstemp = New ADODB.Recordset
    rstemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
    If rstemp.RecordCount > 0 Then
        With objControl
            If TypeOf objControl Is ListView Then
                '列表视图
                '清空已有数据
                .ListItems.Clear
                intCount = rstemp.Fields.Count - 2
                Do While Not rstemp.EOF
                    Set itmTemp = .ListItems.Add(, HEADER & rstemp(0), rstemp(1))
                    For i = 1 To intCount
                        itmTemp.SubItems(i) = rstemp(i + 1)
                    Next i
                    
                    rstemp.MoveNext
                Loop
                '选中第一条
                Set .SelectedItem = .ListItems(1)
            ElseIf TypeOf objControl Is ComboBox Then
                '组合框
                '清空已有数据
                .Clear
                Do While Not rstemp.EOF
                    .AddItem rstemp(1)
                    .ItemData(.NewIndex) = rstemp(0)
                    rstemp.MoveNext
                Loop
                '选择第一条
                .ListIndex = 0
            Else
                '
            End If
        End With
    End If
    
    LoadSETTABLE = True
    GoTo ExitLab
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    Screen.MousePointer = vbDefault
End Function

'**********************************************************************
'删除ListView控件的某一条目，同时移动焦点
'参数1：操作的ListView
'参数2：欲删除条目的索引
'**********************************************************************
Public Sub DeleteItemFromListView(ByRef lvwControl As ListView, ByVal intDeleteIndex As Integer)
On Error Resume Next
    With lvwControl
        .ListItems.Remove intDeleteIndex
        If .ListItems.Count >= 1 Then
            If intDeleteIndex = 1 Then
                '如果删除的是第一条，则移动到当前的第一条
                Set .SelectedItem = .ListItems(intDeleteIndex)
            Else
                '如果删除的不是第一条，则移动到删除条目的前一条
                Set .SelectedItem = .ListItems(intDeleteIndex - 1)
            End If
        End If
    End With
End Sub

'**********************************************************************
'删除Combox控件的某一条目，同时移动焦点
'参数1：操作的Combox
'参数2：欲删除条目的索引
'**********************************************************************
Public Sub DeleteItemFromCombox(ByRef cmbControl As ComboBox, ByVal intDeleteIndex As Integer)
On Error Resume Next
    With cmbControl
        .RemoveItem intDeleteIndex
        If .ListCount >= 1 Then
            If intDeleteIndex = 0 Then
                '如果删除的是第一条，则移动到当前的第一条
                .ListIndex = intDeleteIndex
            Else
                '如果删除的不是第一条，则移动到删除条目的前一条
                .ListIndex = intDeleteIndex - 1
            End If
        End If
    End With
End Sub

'**********************************************************************
'计算团体/分组的应付总费用
'参数1：表示团体的预约ID
'参数2：表示分组的分组ID。可选，省略时表示整个团体
'返回值：货币型。应付总费用
'**********************************************************************
Public Function GetTotalMoney_TT(ByVal strYYID As String, Optional ByVal intFZID As Integer, _
        Optional ByVal blnOnePerson As Boolean = False) 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 intTCID As Integer '套餐编号
    Dim blnHaveTC As Boolean '是否有套餐
    Dim curTCJG As Currency '套餐价格
    
    Screen.MousePointer = vbHourglass
    
    '首先取得分组信息
    strSQL = "select FZ_FZSY.FZID from FZ_FZSY" _
            & " where YYID='" & strYYID & "'"
    If intFZID > 0 Then
        strSQL = strSQL & " and FZ_FZSY.FZID=" & intFZID
    End If
    Set rsFZ = New ADODB.Recordset
    rsFZ.Open strSQL, GCon, adOpenStatic, adLockReadOnly
    If rsFZ.RecordCount > 0 Then
        rsFZ.MoveFirst
        Do While Not rsFZ.EOF
            intFZID = rsFZ("FZID")
            curFZTotal = 0 '初始化每个分组的价格
            
            '第一步：是否有套餐
            blnHaveTC = False
            curTCJG = 0
            strSQL = "select XZTC,TCID from YY_TJDJTC" _
                    & " where YYID='" & strYYID & "'" _
                    & " and FZID=" & intFZID
            Set rstemp = New ADODB.Recordset
            rstemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
            If Not rstemp.EOF Then
                If rstemp("XZTC") = True Then
                    blnHaveTC = True
                    intTCID = rstemp("TCID")
                    rstemp.Close
                    
                    '获取套餐价格
                    strSQL = "select TCJG from SET_TC" _
                            & " where TCID=" & intTCID
                    Set rstemp = New ADODB.Recordset
                    rstemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
                    If Not rstemp.EOF Then
                        If Not IsNull(rstemp("TCJG")) Then
                            curTCJG = rstemp("TCJG")
                        End If
                        rstemp.Close
                    End If
                End If
                rstemp.Close
            End If
            If blnHaveTC Then
                curFZTotal = curFZTotal + curTCJG
            End If
            
            '第二步：加上该分组选择的组合的价格
            strSQL = "select Sum(DXJG)" _
                    & " from SET_DX" _
                    & " where DXID in (" _
                        & "select DXID from YY_TJDJDX" _
                        & " where YYID='" & strYYID & "'" _
                        & " and FZID=" & intFZID _
                    & ")"
            If blnHaveTC Then
                strSQL = strSQL & " and DXID not in (" _
                        & "select DXID from SET_TCDX" _
                            & " where TCID=" & intTCID _
                        & ")"
            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 blnHaveTC 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_TJDJDX" _
                                & " where YYID='" & strYYID & "'" _
                                & " and FZID=" & intFZID _
                            & ")" _
                            & " and SET_ZH_Data.DXID not in (" _
                                & "select DXID from SET_TCDX" _
                                & " where TCID=" & intTCID _
                            & ")" _
                        & ")" _
                        & " 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=" & intTCID _
                            & ")" _
                        & ")"
                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
            End If
            
            '第四步，减去组合中重复的项目
            strSQL = "select Count(SET_XX.XXID),Sum(XXPrice)" _
                    & " from SET_XX,SET_ZH_Data,YY_TJDJDX" _
                    & " where SET_XX.XXID=SET_ZH_Data.XXID" _
                    & " and SET_ZH_Data.DXID=YY_TJDJDX.DXID" _
                    & " and YY_TJDJDX.YYID='" & strYYID & "'" _
                    & " and YY_TJDJDX.FZID=" & intFZID _
                    & " 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
                    
            '最后一步，计算该分组总人数。
            If Not blnOnePerson Then
                strSQL = "select Count(GUID) from FZ_FZSJ" _
                        & " where YYID='" & strYYID & "'" _
                        & " and FZID=" & intFZID
                Set rstemp = New ADODB.Recordset
                rstemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
                curTotal = curTotal + curFZTotal * rstemp(0)
                rstemp.Close
            Else
                '仅计算某团体某分组中一个客户的费用
                curTotal = curTotal + curFZTotal * 1
            End If
            
            rsFZ.MoveNext
        Loop
        rsFZ.Close
    End If
    
    GetTotalMoney_TT = curTotal
    
    GoTo ExitLab
ErrMsg: