mdldatabase5.bas

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

Attribute VB_Name = "mdlDatabase5"
Option Explicit

Public Enum Version
    WLB = 0
    ZYB = 1
    BZB = 2
    PJB = 3
End Enum
Public genuVersion As Version
Public gstrVersionTitle As String '版本名称

'枚举
Public Enum BarCodeType
    CODE39 = 0
    EAN8Or13 = 1
End Enum

Public Enum PERSON_STATUS
    ALL_PERSON = 0
    UNREGISTER = 1
    UNCHECK = 2
    CHECKING = 3
    UNFINISHED = 4
    FINISHED = 5
End Enum

Public Enum BarCodeContents
    BC_SELFID = 0
    BC_SYSTEMID = 1
End Enum

Public Type PersonRegister
    ShowBarCodePrint_InPR As Boolean
    ShowGuiderPrint_InPR As Boolean
    Price_InPR As Boolean
    Charging_InPR As Boolean
End Type
Public g_typPersonRegister As PersonRegister

Public Type PersonAffirm
    Price_InAffirm As Boolean
    Charging_InAffirm As Boolean
End Type
Public g_typPersonAffirm As PersonAffirm

Public g_enuGuiderType As GuiderType '导引单模式
Public gblnBarCode As Boolean '是否具有条形码打印功能
Public g_blnSystemID As Boolean '是否显示系统自带档案号
Public g_blnSelfID As Boolean '是否显示自定义档案号
Public g_blnIDCardAndPerson As Boolean '
Public g_blnKSXJWithXMu As Boolean
Public g_enuInputMode As InputMode
Public g_blnShowCurrentManager As Boolean
Public g_enuBarCodeContents As BarCodeContents

Public gLisInterface As Boolean
Public g_strReportPrinter As String
Public gTiJiao As Boolean              '是否在录入时采用提交方式

Public g_blnIsNew As Boolean
Public g_clsAuthority As New clsAuthority

' 32-bit EZTWAIN functions for Visual Basic 5.0
Public Declare Function TWAIN_AcquireToClipboard Lib "EZTW32.DLL" (ByVal hwndApp&, ByVal wPixTypes&) As Long
Public Declare Function TWAIN_SelectImageSource Lib "EZTW32.DLL" (ByVal hwndApp&) As Long


'**********************************************************************
'获取指定条件的人数与人员列表
'**********************************************************************
Public Function GetPersonCheckStatus(ByVal enuStatus As PERSON_STATUS, _
        Optional ByVal strYYID As String, _
        Optional ByVal intFZID As Integer = -1, _
        Optional ByVal dtmBegin As Date = "2000-12-01", _
        Optional ByVal dtmStop As Date = "2079-06-05", _
        Optional ByVal blnReturnPerson As Boolean = False, _
        Optional ByVal strAppendCondition As String) As String
'参数1：获取哪一种状态的体检人
'参数2：如果获取的是单位数据，表示预约ID
'参数3：如果是单位数据，表示分组编号
'参数4：起始日期
'参数5：终止日期
'参数6：是否返回人员列表
    Dim strSQL As String
    Dim rsPerson As ADODB.Recordset
    Dim strPersons As String
    Dim lngPersonCount As Long
    
    If blnReturnPerson Then
        strSQL = "select YYRXM"
    Else
        strSQL = "select Count(YYRXM)"
    End If
    strSQL = strSQL & " from SET_GRXX" _
            & " where SET_GRXX.TJRQ between '" & dtmBegin & "' and '" & dtmStop & "'"
    If strYYID <> "" Then
        strSQL = strSQL & " and SET_GRXX.YYID='" & strYYID & "'"
        
        If intFZID > 0 Then
            strSQL = strSQL & " and SET_GRXX.GUID in(" _
                        & "select FZ_FZSJ.GUID from FZ_FZSJ" _
                        & " where FZ_FZSJ.GUID=SET_GRXX.GUID" _
                        & " and FZ_FZSJ.FZID=" & intFZID _
                    & ")"
        End If
    End If
    
    If strAppendCondition <> "" Then
        strSQL = strSQL & " and " & strAppendCondition
    End If
    
    Select Case enuStatus
        Case ALL_PERSON '满足条件的所有人
            '
        Case UNREGISTER '待登记
            strSQL = strSQL & " and SET_GRXX.QRDJ=0"
        Case UNCHECK '待体检
            strSQL = strSQL & " and SET_GRXX.QRDJ>0" _
                    & " and not exists(" _
                        & "select YY_SJDJDX.GUID from YY_SJDJDX" _
                        & " where YY_SJDJDX.GUID=SET_GRXX.GUID" _
                        & " and SFTJ=1" _
                    & ")"
        Case CHECKING '体检中
            strSQL = strSQL & " and SET_GRXX.QRDJ>0" _
                    & " and exists(" _
                        & "select YY_SJDJDX.GUID from YY_SJDJDX" _
                        & " where YY_SJDJDX.GUID=SET_GRXX.GUID" _
                        & " and SFTJ=1" _
                    & ")" _
                    & " and exists(" _
                        & "select YY_SJDJDX.GUID from YY_SJDJDX" _
                        & " where YY_SJDJDX.GUID=SET_GRXX.GUID" _
                        & " and SFTJ=0" _
                    & ")" _
                    & " and not exists(" _
                        & "select DATA_ZJJL.GUID from DATA_ZJJL" _
                        & " where DATA_ZJJL.GUID=SET_GRXX.GUID" _
                    & ")"
        Case UNFINISHED '待总检
            strSQL = strSQL & " and SET_GRXX.QRDJ>0" _
                    & " and not exists(" _
                        & "select YY_SJDJDX.GUID from YY_SJDJDX" _
                        & " where YY_SJDJDX.GUID=SET_GRXX.GUID" _
                        & " and SFTJ=0" _
                    & ")" _
                    & " and not exists(" _
                        & "select DATA_ZJJL.GUID from DATA_ZJJL" _
                        & " where DATA_ZJJL.GUID=SET_GRXX.GUID" _
                    & ")"
        Case FINISHED '已总检
            strSQL = strSQL & " and SET_GRXX.QRDJ>0" _
                    & " and exists(" _
                        & "select DATA_ZJJL.GUID from DATA_ZJJL" _
                        & " where DATA_ZJJL.GUID=SET_GRXX.GUID" _
                    & ")"
        Case Else
            '
    End Select
    If blnReturnPerson Then strSQL = strSQL & " order by YYRXM"
    
    Set rsPerson = New ADODB.Recordset
    rsPerson.Open strSQL, GCon, adOpenForwardOnly, adLockReadOnly
    If Not rsPerson.EOF Then
        If Not blnReturnPerson Then
            '仅返回人数
            lngPersonCount = CStr(rsPerson(0))
        Else
            '返回人数、人员列表
            Do
                strPersons = strPersons & "，" & rsPerson("YYRXM")
                lngPersonCount = lngPersonCount + 1
                
                rsPerson.MoveNext
            Loop While Not rsPerson.EOF
            '截掉第一个逗号
            strPersons = Mid(strPersons, 2)
        End If
        
        rsPerson.Close
    End If
    Set rsPerson = Nothing
    
    '返回
    GetPersonCheckStatus = CStr(lngPersonCount)
    If blnReturnPerson Then
        GetPersonCheckStatus = GetPersonCheckStatus & HEADER & strPersons
    End If
    
    GoTo ExitLab
ExitLab:
    '
End Function
        
'**********************************************************************
'写入指定客户的照片与身份证
'**********************************************************************
Public Function WritePersonVideo(ByVal lngGUID As Long, ByVal strPhotoFile As String, _
        ByVal strScanFile As String, ByRef con As ADODB.Connection) As Boolean
    Dim rsVideo As ADODB.Recordset
    Dim strSQL As String
    Dim blnUpdate As Boolean
    
    blnUpdate = False
    
    strSQL = "if not exists(select GUID from SET_GRXX_VIDEO where GUID=" & lngGUID & ")" _
            & " insert into SET_GRXX_VIDEO(GUID) values(" & lngGUID & ")"
    con.Execute strSQL
    
    strSQL = "select * from SET_GRXX_VIDEO" _
            & " where GUID=" & lngGUID
    Set rsVideo = New ADODB.Recordset
    rsVideo.Open strSQL, con, adOpenKeyset, adLockOptimistic
    If (Dir(strPhotoFile) <> "") And (strPhotoFile <> "") Then
        '写入照片
        Call FileToColumn(rsVideo("Photo_Person"), strPhotoFile)
        
        Kill strPhotoFile
        blnUpdate = True
    End If
    
    If (Dir(strScanFile) <> "") And (strScanFile <> "") Then
        '写入照片
        Call FileToColumn(rsVideo("Photo_IDCard"), strScanFile)
        
        Kill strScanFile
        blnUpdate = True
    End If
    
    If blnUpdate Then
        rsVideo.Update
    End If
    
    WritePersonVideo = True
End Function

'**********************************************************************
'获取指定条件的团体支付情况
'**********************************************************************
Public Function GetPersonUnitPay(ByVal strYYID As String, _
        Optional ByVal intFZID As Integer = -1, _
        Optional ByVal lngGUID As Long = -1) As Currency
'参数1：团体YYID
'参数2：分组ID
'参数3：如果是个人，则该参数为个人GUID
'返回值：费用
    Dim strSQL As String
    Dim rsMoney As ADODB.Recordset
    
    '创建查询语句
    strSQL = "select isnull(Sum(SFFY),0) from SET_SFMX_GR"
    If lngGUID > 0 Then
        strSQL = strSQL & " where GUID=" & lngGUID
    Else
        strSQL = strSQL & " where GUID in(" _
                & "select GUID from FZ_FZSJ" _
                & " where YYID='" & strYYID & "'"
        If intFZID > 0 Then
            strSQL = strSQL & " and FZID=" & intFZID
        End If
        strSQL = strSQL & ")"
    End If
    strSQL = strSQL & " and UnitPay=1"
    
    '提交查询
    Set rsMoney = New ADODB.Recordset
    rsMoney.Open strSQL, GCon, adOpenForwardOnly, adLockReadOnly
    GetPersonUnitPay = rsMoney(0)
    rsMoney.Close
End Function

'根据指定的科室ID和阳性体征名称，获取所属组合ID，并计算满足附加条件的选择了该组合的人数
Public Function GetCountFromSpecifyIll(ByVal strKSID As String, ByVal strJBMC As String, _
        ByVal strCondition As String) As Long
    Dim strSQL As String
    Dim rstemp As ADODB.Recordset
    Dim strXXID As String
    Dim intLength As Integer
    
    '提取指定科室下的所有小项
    strSQL = "select XXID,XXMC from SET_XX" _
            & " where KSID='" & strKSID & "'"
    Set rstemp = New ADODB.Recordset
    rstemp.Open strSQL, GCon, adOpenForwardOnly, adLockReadOnly
    If Not rstemp.EOF Then
        Do While Not rstemp.EOF
            If strJBMC Like "*" & rstemp("XXMC") & "*" Then
                If Len(rstemp("XXMC")) > intLength Then
                    strXXID = rstemp("XXID")
                    intLength = Len(rstemp("XXMC"))
                End If
            End If
            
            rstemp.MoveNext
        Loop
        rstemp.Close
    End If
    
    '是否找到记录
    If strXXID <> "" Then
        '检查有多少人选择了该项目
        strSQL = "select Count(GUID) from SET_GRXX" _
                & " where " & strCondition _
                & " and exists(" _
                    & "select YY_SJDJDX.GUID from YY_SJDJDX,SET_ZH_DATA" _
                    & " where YY_SJDJDX.GUID=SET_GRXX.GUID" _
                    & " and YY_SJDJDX.DXID=SET_ZH_DATA.DXID and SET_ZH_DATA.XXID='" & strXXID & "'" _
                & ")"
        Set rstemp = New ADODB.Recordset
        rstemp.Open strSQL, GCon, adOpenForwardOnly, adLockReadOnly
        GetCountFromSpecifyIll = rstemp(0)
        rstemp.Close
    Else
       ' MsgBox "无法为" & strJBMC & "建立关联，因而无法取得计算比例的基数！", vbInformation, "提示"
    End If
End Function

'校验条形码
Public Function CheckEANCode(ByVal strEANCode As String) As String
    Dim Nums(12), i, K As Integer
    Dim ck As String
    Dim realCK As String
    Dim strRetCode As String
    Dim strSQL As String
    Dim rstemp As ADODB.Recordset
    Dim enuBarCodeType As BarCodeType
    
    strRetCode = strEANCode
    
    '当前是否启用了条码
    If Not gblnBarCode Then GoTo ExitLab
    
    'If not is numeric EAN code Exit
    If Not IsNumeric(strEANCode) Then GoTo ExitLab
    
    If Len(strEANCode) <> 8 And Len(strEANCode) <> 13 Then GoTo ExitLab
    
    '当前使用的条码类型
    strSQL = "select SYSTEMPROPERTY from SET_SYSTEM" _
            & " where SYSTEMNAME='BarCodeType'"
    Set rstemp = New ADODB.Recordset
    rstemp.Open strSQL, GCon, adOpenForwardOnly, adLockReadOnly
    If rstemp.EOF Then
        enuBarCodeType = CODE39
        '增加新记录
        strSQL = "insert into SET_SYSTEM(SYSTEMNAME,SYSTEMPROPERTY) values(" _
                & "'BarCodeType'" _
                & ",'" & CStr(enuBarCodeType) & "'" _
                & ")"
        GCon.Execute strSQL
    Else
        enuBarCodeType = rstemp("SYSTEMPROPERTY")
        rstemp.Close
    End If
    '是否EAN码
    If enuBarCodeType <> EAN8Or13 Then GoTo ExitLab
    
    'check byte
    ck = Right(strEANCode, 1)
    
    i = 1
    If Len(strEANCode) = 8 Then
        'Check Digit For EAN 8