module1.bas

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

Attribute VB_Name = "Module1"
Option Explicit

Public CurrentUser As String     '记录当前用户
Public FrmRecordStatus As String    '保存当前FrmRecord中的状态

Public FrmRecordSN               '当进入修改记录时，记录当前要修改记录的SerialNum


'*************************20040327 加入 闻***************************************
Public gBCLBGUID As String          '从FrmBCLB返调用模块时，如果是补查,记录选择的受检人GUID
Public gblSFBC As Boolean           '标识从FrmBCLB返回时，是否是补查
'*************************20040327 加入完 闻*************************************

'*************************20040514 加入 闻***************************************
Public gYYorDJFC As String           '标识是从预约或登记模块显示FrmBCLB窗体，"YY"表示从预约模块，"DJ"表示从登记模块
'*************************20040514 加入完 闻*************************************

'*************************20040605 加入 闻***************************************
Public gblDCZJJL          '在单位阳性汇总导出模块中，标识是导出总检结论
Public gblDCZJJY           '在单位阳性汇总导出模块中，标识是导出总检建议
'*************************20040605 加入完 闻*************************************

'*************************20040605 加入 闻***************************************
Public gXMIDForDM As String          '在录入时，双击某体检结果录入框，传递该项目的XMID给数据字典选择模块，以便在该模块中将结果存为数据模板
'*************************20040605 加入完 闻*************************************

'*************************20040605 加入 闻***************************************
Public gblBuCha As Boolean              '标识是否补查,用于在FRMBZB_INPUT模块的CmbFZ_Click事件中标识是否改动该人的HealthID
Public gblFuCha As Boolean              '标识是否复查,用于在FRMBZB_INPUT模块的CmbFZ_Click事件中标识是否改动该人的HealthID
Public gBFHealthID As String            '标识从FrmBCLB返回时，该人的健康档案号
Public gBFName As String                '记录从FrmBCLB返回时，该人的姓名
'*************************20040605 加入完 闻*************************************

Public gintMSH1Count As Integer

'*************************20040728 加入 闻***************************************
Public gintPXFC          '在录入界面和查询体检报告界面中，用于记录选择的排序列号
'*************************20040728 加入完 闻*************************************

Public gJJXGuid As String        '加碱项人的guid，用于登记
'******************20040330加入 闻********************************
'这三个自定义类型用于数据导出,对应BTTJDataExport.mdb中的三张表
Type PersonXX
    GUID As Long
    QueryCode As String
    HEALTHID As String
    TJSerialNum As Integer
    name As String
    SEX As String
    AGE As Integer
    HF As String
    DanWei As String
    TJRQ As String
    EMail As String
    LXDZ As String
    YZBM As String
End Type

Type ExportData
    QueryCode As String
    XMID As String
    XMValue As String
End Type

Type XMIndex
    XMID As String
    XMMC As String
    XMType As Integer
    CKSX As String
    CKXX As String
    XMDW As String
End Type

'******************20040503加入 闻**********************************
'该类型用于在客户管理模块中描述合同情况
Type DWHT
    HTNum As String             '合同号
    HTStartTime As Date         '合同起始时间
    HTEndTime As Date           '合同结束时间
    HTJE As Double              '合同金额
    HTFKQK As String            '合同付款情况
End Type
Public gHT As DWHT
Public gHTOperation As OperationType
'******************20040503加入完 闻********************************

Public TmpPersonXX As PersonXX
Public TmpExportData As ExportData
Public TmpXMIndex As XMIndex

Public garrYYID()             '用于存储团体预约ID的数组

'*************************20040911加入 闻****************************
Public gPayGUID As Long         '为dlgPay存储GUID
Public gstrXMQD As String       '为dlgPay存储项目清单
Public gdblTCFY As Double       '为dlgPay存储套餐费用
Public gdblJXFY As Double       '为dlgPay存储加项费用
'*************************20040911加入完 闻**************************

Public Function SFZHCheck(SFZH As String) As Boolean
    If Len(SFZH) <> 15 And Len(SFZH) <> 18 And Len(SFZH) <> 0 Then
        SFZHCheck = False
    Else
        SFZHCheck = True
    End If
End Function

'**************20040413加入 闻***************************
'去掉主机码中的特殊字符,只留下数字和字母
Public Function strDelSpecial(ByVal incomeStr As String) As String
    Dim strTmp As String
    Dim i, tmpAsc As Integer
    
    For i = 1 To Len(incomeStr)
        tmpAsc = Asc(Mid(incomeStr, i, 1))
        If (tmpAsc >= Asc(0) And tmpAsc <= Asc(9)) Or (tmpAsc >= Asc("a") And tmpAsc <= Asc("z")) Or (tmpAsc >= Asc("A") And tmpAsc <= Asc("Z")) Then
            strTmp = strTmp & Mid(incomeStr, i, 1)
        End If
    Next
    strDelSpecial = strTmp
End Function

'去掉incomestr中的inspestr字符串
Public Function strDelSpeStr(ByVal incomeStr As String, ByVal inspeStr As String) As String
    Dim intTemp As Integer
    Dim strTemp As String
    Dim intLenSpe As String
    Dim strLeft, strRight As String
    
    intLenSpe = Len(inspeStr)
    intTemp = InStr(1, incomeStr, inspeStr, vbTextCompare)
    If intTemp >= 1 Then
        If intTemp = 1 Then
            strLeft = ""
        Else
            strLeft = Mid(incomeStr, 1, intTemp - 1)
        End If
        strRight = Mid(incomeStr, Len(strLeft) + Len(inspeStr) + 1, Len(incomeStr) - Len(strLeft) - Len(inspeStr))
        strDelSpeStr = strLeft & strRight
    Else
        strDelSpeStr = incomeStr
    End If
End Function

'在第i个字符后加入inSpestr字符串
Public Function strAddSpeStr(ByVal incomeStr As String, intPos As Integer, inspeStr As String)
    Dim strLeft As String
    Dim strRight As String
    
    strLeft = Mid(incomeStr, 1, intPos)
    strRight = Mid(incomeStr, intPos + 1, Len(incomeStr) - intPos)
    strAddSpeStr = strLeft & inspeStr & strRight
End Function

'将小数点右移数位,不够补"0"
Public Function RightShiftSpeStr(incomeStr, intNum As Integer)
    Dim i As Integer
    Dim intShiNum As Integer
    Dim strTmp, strLeft, strRight As String
    
    strLeft = Mid(incomeStr, 1, intNum)
    strRight = Mid(incomeStr, intNum + 1, Len(incomeStr) - intNum)
    If Len(strRight) >= intNum Then
        RightShiftSpeStr = strLeft & strAddSpeStr(strRight, intNum, ".")
    Else
        RightShiftSpeStr = strLeft & strRight
        For i = 1 To intNum - Len(strRight)
            RightShiftSpeStr = RightShiftSpeStr & "0"
        Next i
    End If
End Function

'将指数形式变为小数形式或缩小指数中底数的位数
Public Function ChangeStrToE(incomeStr) As String
    Dim intEpos As Integer
    Dim strTemp As String
    Dim intTmp As Integer
    Dim strRight As String
    Dim i As Integer
    
    '如果结果中含有"E",说明为指数形式，需要变为小数
    intEpos = InStr(1, incomeStr, "E", vbTextCompare)
    strTemp = ""
    If intEpos > 1 Then
        strTemp = Mid(incomeStr, intEpos + 1, Len(incomeStr) - intEpos)
        If Mid(strTemp, 1, 1) = "-" Then    '是负数
            intTmp = CInt(Mid(strTemp, 2, Len(strTemp) - 1))
            strTemp = Mid(incomeStr, 1, intEpos - 1)
            strTemp = strDelSpeStr(strTemp, ".")
            For i = 1 To intTmp
                strTemp = 0 & strTemp
            Next
            strTemp = strAddSpeStr(strTemp, 1, ".")
        ElseIf Mid(strTemp, 1, 1) = "+" Then
            intTmp = CInt(Mid(strTemp, 2, Len(strTemp) - 1))
            strRight = strTemp
            strTemp = Mid(incomeStr, 1, intEpos - 1)
            '将E前的数字缩减位数,保留到小数点后三位
            strTemp = Mid(strTemp, 1, 5) & strRight
        End If
    End If
    ChangeStrToE = strTemp
End Function

Public Function strDelHead(ByVal incomeStr As String, ByVal strHead As String) As String
    If UCase(Mid(incomeStr, 1, Len(strHead))) = strHead Then
        strDelHead = Mid(incomeStr, Len(strHead) + 1, Len(incomeStr) - Len(strHead))
    Else
        strDelHead = incomeStr
    End If
End Function
'**************20040413加入完 闻*************************

'**************20040420加入 闻***************************
'将strInput每隔intCount个字符加一个换行符
Public Function FormatStrN(ByVal strInput As String, ByVal intCount As Integer) As String
    Dim strTemp As String
    Dim strResult As String
    Dim i As Integer
    
    If Len(strInput) > intCount Then
        strResult = ""
        strTemp = strInput
        Do While Len(strTemp) > intCount
            strResult = strResult & Mid(strTemp, 1, intCount) & vbCrLf
            strTemp = Mid(strTemp, intCount + 1, Len(strTemp) - intCount)
        Loop
        strResult = strResult & strTemp
        FormatStrN = strResult
    Else
        FormatStrN = strInput
    End If
End Function
'**************20040420加入完 闻*************************

Public Function GetXXID(ByVal strKSID As String) As String
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim rstemp  As New ADODB.Recordset
    Dim intID As Integer
    Dim blnGet As Boolean
    Dim i As Integer
  
    strSQL = "SELECT XXID FROM SET_XX WHERE KSID='" & strKSID & "'" _
           & " ORDER BY XXID"
    rstemp.Open strSQL, GCon, adOpenDynamic, adLockOptimistic
    If rstemp.RecordCount = 0 Then  '如果当前大项还无小项,则返回"01"
        GetXXID = strKSID & LongToString(1, 5)
    Else   '否则
        blnGet = False
        rstemp.MoveFirst
        For i = 1 To rstemp.RecordCount
            If Right(rstemp("XXID"), 5) <> LongToString(i, 5) Then
                blnGet = True
                GetXXID = strKSID & LongToString(i, 5)
                Exit For
            End If
            rstemp.MoveNext
        Next i
        
        If Not blnGet Then
            GetXXID = strKSID & LongToString(rstemp.RecordCount + 1, 5)
        End If
        rstemp.Close
    End If
    Set rstemp = Nothing
    
    GoTo ExitLab
    
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
'    Me.MousePointer = vbDefault
End Function

'**********************************************************************
'根据文件名将EXCEL中的人员信息导入到数据库中，完成团体人员的预约功能
'参数1：inFileName是EXCEL文件名
'参数2：inYYID是单位的YYID号
'参数3：inTJRQ为该单位第一分组预约的体检日期
'参数4：可选。如果非空，表示分组编号。默认值为第一分组
'参数5：可选。序号列索引
'参数6：可选。卡号列索引
'参数7：可选。姓名列索引
'参数8：可选。性别列索引
'参数9：可选。年龄列索引
'参数10：可选。分组编号列索引
'参数11：可选。家庭电话列索引
'参数12：可选。办公电话列索引
'参数13：可选。移动电话列索引
'参数14：可选。身份证好列索引
'参数15：可选。如果非空，表示产生的日志文件名
'返回值：是否成功
'**********************************************************************
Public Function ImportFromExcel(ByVal inFileName As String, ByVal inYYID As String, inTJRQ As Date, _
        Optional ByVal intFZID As Integer = 1, _
        Optional ByVal intNumberCol As Integer = 1, _
        Optional ByVal intICKNumCol As Integer = 2, _
        Optional ByVal intNameCol As Integer = 3, _
        Optional ByVal intSexCol As Integer = 4, _
        Optional ByVal intAgeCol As Integer = 5, _
        Optional ByVal intFZBHCol As Integer = 6, _
        Optional ByVal intJTDHCol As Integer = 7, _
        Optional ByVal intBGDHCol As Integer = 8, _
        Optional ByVal intYDDHCol As Integer = 9, _
        Optional ByVal intSFZHCol As Integer = 10, _
        Optional ByVal intBirthdayCol As Integer = 11, _
         Optional ByVal intYLID As Integer = 12, _
        Optional ByVal strLogFile As String) As Boolean
On Error GoTo ErrMsg