mdldatabase4.bas

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

Attribute VB_Name = "mdlDatabase4"
Option Explicit
Public g_strSystemIDTitle As String '系统自带档案号标题
Public g_strSelfIDTitle As String '自定义档案号标题
Public g_intEnableBZID As Integer '当前启用的标准ID
Public g_blnPrintPhoneAndWWW As Boolean '是否打印网址与咨询电话
Public g_strContactPhone As String
Public g_strWWWSite As String
Public Const COMMUNICATION_STRING = "Bingtaisjdc"
Public Const COMMUNICATION_STRING_PLUGIN = "[e-mail]"
Public Const DTSDir = "DTS\"
Public Const DTSExeName = "数据导出.Exe"
Public Const DTSConfigFileName = "Config.ini"
Public g_strServerName As String
Public g_strDatabase As String
Public g_strUseWinnt As String
Public g_strUserID As String
Public g_strPassword As String

'根据客户的GUID获取所属单位名称
'参数1：客户的GUID
'参数2：可选。客户为散检时返回的字符串，默认为“个人”
'返回值：客户所属单位
Public Function GetPersonUnit(ByVal lngGUID As Long, _
        Optional ByVal strDefaultUnit As String = "个人", _
        Optional ByVal blnReturnShortName As Boolean = False) As String
    Dim strSQL As String
    Dim rstemp As ADODB.Recordset
    
    strSQL = "select DWMC,ShortName" _
            & " from SET_DW,YY_TJDJ,SET_GRXX" _
            & " where SET_GRXX.GUID=" & lngGUID _
            & " and SET_GRXX.YYID=YY_TJDJ.YYID" _
            & " and YY_TJDJ.DWID=SET_DW.DWID"
    Set rstemp = New ADODB.Recordset
    rstemp.Open strSQL, GCon, adOpenForwardOnly, adLockReadOnly
    If Not rstemp.EOF Then
        If Not blnReturnShortName Then
            GetPersonUnit = rstemp("DWMC") & ""
        Else
            GetPersonUnit = rstemp("ShortName") & ""
        End If
        rstemp.Close
    Else
        GetPersonUnit = strDefaultUnit
    End If
End Function

'**********************************************************************
'检查当前分组是否未选择项目
'如果没有，则检查其它该单位其它分组是否有选择，
'如果有选择，则把其它有选择的项目加到当前分组
'参数1：团体编号
'参数2：分组编号
'返回值：是否成功
'**********************************************************************
Public Function CheckFZSelection(ByVal strYYID As String, ByVal intFZID As Integer) As Boolean
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim rstemp As ADODB.Recordset
    Dim intSelectedFZID As Integer
    Dim intTCID As Integer
    
    Screen.MousePointer = vbHourglass
    
    '首先查看当前分组是否已有选项
    strSQL = "select Count(*) 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 '已有选择
    
    '检查该单位其它分组是否有选项
    strSQL = "select Count(*) as TempCount,FZID from YY_TJDJDX" _
            & " where YYID='" & strYYID & "'" _
            & " and FZID<>" & intFZID _
            & " group by FZID"
    Set rstemp = New ADODB.Recordset
    rstemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
    intSelectedFZID = 0 '初始化
    If Not rstemp.EOF Then
        '检查是否有已选项目的分组
        Do While Not rstemp.EOF
            If rstemp("TempCount") >= 1 Then
                intSelectedFZID = rstemp("FZID")
                Exit Do
            End If
        Loop
        rstemp.Close
    End If
    
    '是否找到符合条件的分组
    If intSelectedFZID > 0 Then
        '***************************************************************
        '首先检查是否有选择套餐
        '***************************************************************
        strSQL = "select TCID from YY_TJDJTC" _
                & " where YYID='" & strYYID & "'" _
                & " and FZID=" & intSelectedFZID _
                & " and XZTC=1"
        Set rstemp = New ADODB.Recordset
        rstemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
        If Not rstemp.EOF > 0 Then
            '选定分组有选择套餐
            intTCID = rstemp("TCID")
            rstemp.Close
            '判断当前分组是否有套餐
            strSQL = "select * 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
                '有选择，需要更新
                strSQL = "update YY_TJDJTC set" _
                        & " XZTC=1,TCID=" & intTCID _
                        & " where YYID='" & strYYID & "'" _
                        & " and FZID=" & intFZID
            Else
                '无选择，插入
                strSQL = "insert into YY_TJDJTC values(" _
                        & "'" & strYYID & "'" _
                        & "," & intFZID _
                        & ",1" _
                        & ",'" & intTCID & "')"
            End If
            GCon.Execute strSQL
        End If
        
        '***************************************************************
        '检查选择的其它项目
        '***************************************************************
        strSQL = "select DXID from YY_TJDJDX" _
                & " where YYID='" & strYYID & "'" _
                & " "
    End If
    
    GoTo ExitLab
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    Screen.MousePointer = vbDefault
End Function

Public Sub SetHealthIDTitle()
'    If g_blnSelfID Then
        g_strSystemIDTitle = "系统档案号"
        g_strSelfIDTitle = "档案号"
'    Else
'        g_strSystemIDTitle = "档案号"
'        g_strSelfIDTitle = "自定义档案号"
'    End If
End Sub

'**********************************************************************
'给指定系统档案号的客户发卡
'参数1：系统档案号
'参数2：新卡号
'参数3：当前使用的连接。这是为了嵌入别的事务
'参数4：是否注销，默认为不注销。如果该参数为True，则参数2可以为空字符串
'参数5：执行成功时，是否进行提示。默认为提示
'参数6：是否在该函数内启动事务。默认为启动
'返回值：是否成功
'**********************************************************************
Public Function SendCardW(ByVal strHealthID As String, _
        ByVal strNewCard As String, ByRef con As ADODB.Connection, _
        Optional ByVal blnCancelCard As Boolean = False, _
        Optional ByVal blnSuccessInfo As Boolean = True, _
        Optional ByVal blnEnableTrans As Boolean = True) As Boolean
    Dim strSQL As String
    Dim rstemp As ADODB.Recordset
    Dim strOldCard As String
    Dim strMsg As String
    Dim blnCommitTrans As Boolean
    
    '初始化
    SendCardW = False
    blnCommitTrans = False
    
    '检查该卡是否已被别人持有
    If (Not blnCancelCard) And (strNewCard <> "") Then
        strSQL = "select YYRXM from SET_ICKGL_Index,SET_GRXX" _
                & " where SET_ICKGL_Index.ICKNum='" & strNewCard & "'" _
                & " and SET_ICKGL_Index.HealthID<>'" & strHealthID & "'" _
                & " and SET_ICKGL_Index.HealthID=SET_GRXX.HealthID"
        Set rstemp = New ADODB.Recordset
        rstemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
        If Not rstemp.EOF Then
            '说明该卡已被他人持有
            MsgBox "卡号 “" & strNewCard & "” 已被客户 “" & rstemp("YYRXM") & "”持有。不能再发给别人！", vbExclamation, "提示"
            rstemp.Close
            '清除SelfBH字段
            strSQL = "update SET_GRXX set" _
                    & " SelfBH=null" _
                    & " where HealthID='" & strHealthID & "'"
            GCon.Execute strSQL
            
            GoTo ExitLab '退出
        End If
    End If
    
    '判断是否需要启动事务
    If blnEnableTrans Then
        Call TimeDelay(10)
        con.BeginTrans
        On Error GoTo RollBack
    End If
    
    '检查在表SET_ICKGL_Index中是否存在记录
    strSQL = "select * from SET_ICKGL_Index" _
            & " where HealthID='" & strHealthID & "'"
    Set rstemp = New ADODB.Recordset
    rstemp.Open strSQL, con, adOpenStatic, adLockReadOnly
    If rstemp.RecordCount >= 1 Then
        '*************************************************
        '之前已经有卡号
        '*************************************************
        strOldCard = rstemp("ICKNum") '记录旧卡号
        rstemp.Close
        
        '第一步，是否注销
        If blnCancelCard = True Then
            '确认注销
            If MsgBox("您确实要注销卡号 “" & strOldCard & "” 吗？", _
                    vbExclamation + vbYesNo + vbDefaultButton2, "提示") = vbYes Then
                strSQL = "update SET_ICKGL_Index set" _
                        & " Status=1" _
                        & " where HealthID='" & strHealthID & "'"
                con.Execute strSQL
                '提示
                MsgBox "注销成功！", vbInformation, "提示"
                SendCardW = True '成功返回
            End If
            
            blnCommitTrans = True
            GoTo ExitLab
        End If
        
        '第二步，检查卡号是否相同
        If strOldCard = strNewCard Then
            '如果卡号相同，则成功退出
            SendCardW = True '成功返回
            blnCommitTrans = True
            GoTo ExitLab
        End If
        
        '第三步，检查新卡号是否为空
        If strNewCard = "" Then
            If MsgBox("当前客户此前持有号码为 “" & strOldCard & _
                    "” 的卡。您现在没有输入任何卡号，如果单击“是”，" _
                    & "将清除当前客户的卡号；如果单击“否”(推荐)，" _
                    & "您可以重新输入卡号。" & vbCrLf & "您确认要清除当前客户的卡号吗？", _
                    vbExclamation + vbYesNo + vbDefaultButton2, "警告") = vbNo Then
                blnCommitTrans = True
                GoTo ExitLab
            Else
                '删除卡号索引表
                strSQL = "delete * from SET_ICKGL_Index" _
                        & " where HealthID='" & strHealthID & "'"
                con.Execute strSQL
                strMsg = "成功删除卡 “" & strOldCard & "”"
            End If
        End If
        
        '第四步，提示是否换卡
        If strOldCard <> strNewCard Then
                If MsgBox("当前客户之前持有号码为 “" & strOldCard _
                        & "” 的卡。您确认要更换为号码是 “" & strNewCard & "” 的卡吗？", _
                        vbExclamation + vbYesNo + vbDefaultButton2, _
                        "小心") = vbNo Then
                    blnCommitTrans = True
                    GoTo ExitLab
                Else
                    '更新卡号索引表
                    strSQL = "update SET_ICKGL_Index set" _
                            & " ICKNum='" & strNewCard & "'" _
                            & " where HealthID='" & strHealthID & "'"
                    con.Execute strSQL
                    strMsg = "成功把卡号 “" & strOldCard & "” 更换为 “" & strNewCard & "”"
                End If
        End If
    Else
        '*************************************************
        '之前没有卡号
        '*************************************************
        '第一步，是否注销
        If blnCancelCard = True Then
            MsgBox "当前用户不存在卡号，无从注销！", vbInformation, "提示"
            blnCommitTrans = True
            GoTo ExitLab
        End If
        
        '第二步，卡号是否为空
        If strNewCard <> "" Then
            
            '第二步，非空的时候发放新卡
            '首先插入一条空记录
            strSQL = "insert into SET_ICKGL_Index(ICKNum,HealthID,FKRQ,Status) values(" _
                    & "'" & strNewCard & "','" & strHealthID & "','" & Date & "',0)"
            con.Execute strSQL
            '更新其余字段
            strSQL = "update SET_ICKGL_Index set" _
                    & " ICKNum='" & strNewCard & "'" _
                    & ",FKRQ='" & Date & "'" _
                    & ",TotalJE=0" _