mdlsubmain.bas

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

                Unload dlgServer
                Set dlgServer = Nothing
                End
            End If
        Else
            '直接退出
            End
        End If
    End If
    
'    ComConfiguration '初始化端口配置
'    gblnAuto = False '开始时默认不是自动
'    gblnTransmit = False '开始时没有传输文件
    
'    TimeDelay 800

    '检查是否注册
    If gRegister = True Then
        strSerial = GetSetting(App.EXEName, "Number", "Number", "?")
        For i = 0 To 3
            clsDisk.GetDiskInfo i
            intRet = Asc(Mid(clsDisk.pSerialNumber, 1, 1))
            If ((intRet >= 48) And (intRet <= 57)) Or ((intRet >= 97) And (intRet <= 122)) Or ((intRet >= 65) And (intRet <= 90)) Then
                Exit For
            End If
        Next
        If (strSerial = "?") Or (HexToChar(strSerial) <> clsDisk.GetFixedSerialNumber("", 25)) Then
            gblnRegister = False
            '检查日期是否已到
            intTimes = clsDisk.ProbationDays
            If intTimes > 30 Then
                MsgBox "您已经超过了试用次数限制，不能再试用，如想继续使用,请立即注册！", vbExclamation, "提示"
                FrmXTZC.Show vbModal
                Unload FrmXTZC
                Set FrmXTZC = Nothing
                If gblnRegister = False Then
                    GoTo ExitLab
                End If
            End If
            
            If MsgBox("您现在使用的是未注册版本！试用次数为30次，您目前已经使用了 " & intTimes & " 次。" & vbCrLf _
                    & "在试用期间，您将不能使用报表打印等功能！" & vbCrLf & "注册后，您就立即拥有全部功能，并将获得" & g_strDevelopCompany & "软件科技有限公司的技术支持！" _
                    & "想要现在注册吗？", vbQuestion + vbYesNo + vbDefaultButton1, "提示") = vbYes Then
                If FrmXTZC.ShowRegister = True Then
                    Unload FrmXTZC
                    Set FrmXTZC = Nothing
                    GoTo ExitLab
                Else
                    Unload FrmXTZC
                    Set FrmXTZC = Nothing
                End If
            End If
        Else
            gblnRegister = True
            '删除次数文件
            clsDisk.KillRegFile
        End If
    Else
        gblnRegister = True
    End If
    
    Set clsDisk = Nothing
    
    Set fMainForm = New frmMain
    
    Call CheckHealthIDShow '检索档案号的显示
    Call CheckBarCodeSet '是否启用条形码\
    Call SetHealthIDTitle
    Call GetEnableBZID
    Call LoadFilterSet
    Call UpdateDatabase
    Call GetAllSystemParameters
    Call LoadInterfaceSet
    
    '改写年龄为0的记录
    strSQL = "update SET_GRXX set" _
            & " AGE=null" _
            & " where AGE=0"
    GCon.Execute strSQL
    
    Screen.MousePointer = vbDefault
    
    Load FrmLogin
    FrmLogin.Show vbModeless, frmSplash
    
    Exit Sub
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
'    Set rsTemp = Nothing
    Set GCon = Nothing
ExitLab:
    Set clsDisk = Nothing
    End
End Sub

'检查是否启用条形码功能
Private Function CheckBarCodeSet() As Boolean
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim rstemp As ADODB.Recordset
    Dim arrFormat
    Dim strSelfSet As String
    
    strSQL = "select BCProperty from SET_BC" _
            & " where BCID=0"
    Set rstemp = New ADODB.Recordset
    rstemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
    If Not rstemp.EOF Then
        arrFormat = Split(rstemp("BCProperty"), ",")
        gblnBarCode = arrFormat(0)
        Erase arrFormat
        rstemp.Close
    End If
    
    '获取自定义编号设置参数
    strSQL = "select BCProperty from SET_BC" _
            & " where BCID=3"
    Set rstemp = New ADODB.Recordset
    rstemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
    If rstemp.EOF Then
        strSelfSet = "0,0,5"
        strSQL = "insert into SET_BC(BCID,BCProperty) values(" _
                & "3,'" & strSelfSet & "')"
        GCon.Execute strSQL
    Else
        strSelfSet = rstemp("BCProperty")
        rstemp.Close
    End If
    arrFormat = Split(strSelfSet, ",")
    '是否使用自动生成
    If g_blnSelfID Then
        If arrFormat(0) = "0" Then
            GSelfNumberAuto.Auto = False
        Else
            GSelfNumberAuto.Auto = True
        End If
    Else
        GSelfNumberAuto.Auto = False
    End If
    '是否使用固定长度
    If arrFormat(1) = 0 Then
        GSelfNumberAuto.Fixed = False
    Else
        GSelfNumberAuto.Fixed = True
    End If
    '固定长度值
    GSelfNumberAuto.FixedLength = CLng(Val(arrFormat(2)))
    
    Set rstemp = Nothing
    CheckBarCodeSet = gblnBarCode
    GoTo ExitLab
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    '
End Function

'检索档案号的显示情况
Private Function CheckHealthIDShow() As Boolean
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim rstemp As ADODB.Recordset
    
    strSQL = "select * from SET_SHOWID"
    Set rstemp = New ADODB.Recordset
    rstemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
    If Not rstemp.EOF Then
        g_blnSystemID = CBool(rstemp("SYSTEMID"))
        g_blnSelfID = CBool(rstemp("SELFID"))
        rstemp.Close
    End If
    Set rstemp = Nothing
    CheckHealthIDShow = True
    GoTo ExitLab
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    '
End Function

'检索当前启用的体检标准ID
Private Function GetEnableBZID() As Boolean
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim rstemp As ADODB.Recordset
    
    strSQL = "select BZID from SET_TJBZIndex" _
            & " where SFQY=1"
    Set rstemp = New ADODB.Recordset
    rstemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
    If Not rstemp.EOF Then
        g_intEnableBZID = rstemp("BZID")
        rstemp.Close
    Else
        g_intEnableBZID = 1 '如果没有记录，默认启用第一条体检标准
    End If
    Set rstemp = Nothing
    GetEnableBZID = True
    GoTo ExitLab
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    '
End Function

'获取当前的过滤设置
Private Function LoadFilterSet() As Boolean
On Error GoTo ErrMsg
    Dim Status
    Dim arrFormat
    Dim strFilterSet As String

    '没有记录。写入一条默认记录
    strFilterSet = GetSystemProperty("FilterSet", "0,0,0,0")
        
    '解析数据
    arrFormat = Split(strFilterSet, ",")
    With GFilterSet
        .WJYC_FILTER = CBool(Val(arrFormat(0)))
        .WJMXYC_FILTER = CBool(Val(arrFormat(1)))
        .ZC_FILTER = CBool(Val(arrFormat(2)))
        .NULL_FILTER = CBool(Val(arrFormat(3)))
    End With
    
    '设置过滤参数
    With GFilterString
        .WJYC_FILTER = "未见异常"
        .WJMXYC_FILTER = "未见明显异常"
        .ZC_FILTER = "正常"
        .NULL_FILTER = ""
    End With
    
    LoadFilterSet = True
    GoTo ExitLab
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    '
End Function

'获取与其他系统的连接情况
Private Sub LoadInterfaceSet()
    Dim strValue As String
    
    '是否岱嘉
    strValue = GetINI(gstrCurrPath & DSNINIFile, "Interface", "ConnectRis", "")
    If UCase(strValue) = "TRUE" Or strValue = "1" Then
        g_blnConnectRIS = True
        g_strRISStoredProc = Trim(GetINI(gstrCurrPath & DSNINIFile, "Interface", "RisStoredProc", ""))
        If g_strRISStoredProc = "" Then g_blnConnectRIS = False
    Else
        g_blnConnectRIS = False
    End If
End Sub

'获取系统参数
Public Sub GetAllSystemParameters()
    '获取总检后可以修改的最长天数
    g_intZJModifyDays = CInt(Val(GetSystemProperty("ZJModifyDays", CStr(3))))
    
    '获取是否启用影像记录的设置
    g_blnIDCardAndPerson = CBool(Val(GetSystemProperty("IDCardAndPerson", "0")))
    
    '生成科室小结时，是否需要带上项目名称
    g_blnKSXJWithXMu = CBool(Val(GetSystemProperty("KSXJWithXMu", "1")))
    
    '录入模式、是否显示当前录入员（未录入时）
    g_blnShowCurrentManager = CBool(Val(GetSystemProperty("ShowCurrentManager", "0")))
    
    '录入模式
    g_enuInputMode = CLng(Val(GetSystemProperty("InputMode", CStr(InputMode.CENTRALIZE_INPUT))))
    
    '条码内容
    g_enuBarCodeContents = CLng(Val(GetSystemProperty("BarCodeContents", CStr(BarCodeContents.BC_SELFID))))
    
    '个人预约界面，是否显示条码打印按钮
    g_typPersonRegister.ShowBarCodePrint_InPR = CBool(Val(GetSystemProperty("ShowBarCodePrint_InPR", "1")))
    '个人预约界面，是否显示导引单打印按钮
    g_typPersonRegister.ShowGuiderPrint_InPR = CBool(Val(GetSystemProperty("ShowGuiderPrint_InPR", "1")))
    
    '个人预约界面，是否启用计价功能
    g_typPersonRegister.Price_InPR = CBool(Val(GetSystemProperty("Price_InPR", "1")))
    '个人预约界面，是否启用收费功能
    g_typPersonRegister.Charging_InPR = CBool(Val(GetSystemProperty("Charging_InPR", "1")))
    
    '登记界面，是否启用计价功能
    g_typPersonAffirm.Price_InAffirm = CBool(Val(GetSystemProperty("Price_InAffirm", "1")))
    '登记界面，是否启用收费功能
    g_typPersonAffirm.Charging_InAffirm = CBool(Val(GetSystemProperty("Charging_InAffirm", "1")))
    
    '导引单模式
    g_enuGuiderType = CLng(Val(GetSystemProperty("GuiderType", "0")))
End Sub

'更新数据库
Public Function UpdateDatabase() As Boolean
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim strSQLAppend As String
    Dim dtmCurrentVersion As Date
    Dim dtmModifyDate As Date
    Dim rstemp As ADODB.Recordset
    
    '获取当前数据库当前版本
    dtmCurrentVersion = GetCurrentVersion
    
    '%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
    '检查当前版本是否有咨询电话与网址
    dtmModifyDate = DateValue("2004-11-01")
    '%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
    If dtmCurrentVersion < dtmModifyDate Then
        strSQL = "select * from SET_HOSPITAL"
        Set rstemp = New ADODB.Recordset
        rstemp.Open strSQL, GCon, adOpenForwardOnly, adLockReadOnly
        If Not rstemp.EOF Then
            Err.Clear
            On Error Resume Next
            g_strContactPhone = rstemp("ContactPhone")
            g_strWWWSite = rstemp("WWWSite")
            If Err.Number <> 0 Then
                Err.Clear
                '表明没有相应字段，需要添加
                strSQL = "ALTER TABLE SET_HOSPITAL" _