mdldatabase5.bas

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

        Do While i < 8
            Nums(i) = CInt(Mid(strEANCode, i, 1))
            i = i + 1
        Loop

        K = (Nums(7) * 3)
        K = K + (Nums(6) * 1)
        K = K + (Nums(5) * 3)
        K = K + (Nums(4) * 1)
        K = K + (Nums(3) * 3)
        K = K + (Nums(2) * 1)
        K = K + (Nums(1) * 3)
        K = K Mod 10
        K = 10 - K

        realCK = CStr(K)

    ElseIf Len(strEANCode) = 13 Then
        'Check Digit For EAN 13
        Do While i < 13
            Nums(i) = CInt(Mid(strEANCode, i, 1))
            i = i + 1
        Loop

        K = (Nums(12) * 3)
        K = K + (Nums(11) * 1)
        K = K + (Nums(10) * 3)
        K = K + (Nums(9) * 1)
        K = K + (Nums(8) * 3)
        K = K + (Nums(7) * 1)
        K = K + (Nums(6) * 3)
        K = K + (Nums(5) * 1)
        K = K + (Nums(4) * 3)
        K = K + (Nums(3) * 1)
        K = K + (Nums(2) * 3)
        K = K + (Nums(1) * 1)
        K = K Mod 10
        K = 10 - K

        realCK = CStr(K)
    End If
    
    '防止出现10校验码
    If Len(realCK) > 1 Then realCK = Right(realCK, 1)
    
    '返回
    If realCK = ck Then
        '校验成功，去掉最后的校验码
        strRetCode = Left(strEANCode, Len(strEANCode) - 1)
    Else
        '校验不成功，说明不是ean码，直接返回
        strRetCode = strEANCode
    End If
    
    GoTo ExitLab
ExitLab:
    CheckEANCode = strRetCode
End Function

'写入操作日志
Public Sub WriteToLog(ByVal strContents As String)
On Error Resume Next
    Dim strSQL As String
    Dim rstemp As ADODB.Recordset
    Dim strOperationTime As String
    
    '读取服务器操作时间
    strSQL = "select getdate()"
    Set rstemp = New ADODB.Recordset
    rstemp.Open strSQL, GCon, adOpenForwardOnly, adLockReadOnly
    strOperationTime = CStr(rstemp(0))
    rstemp.Close
    
    '构建写入语句
    strSQL = "insert into LOG_OPERATION(OperationTime) values('" & strOperationTime & "')"
    GCon.Execute strSQL
    
    '更新其余部分
    strSQL = "update LOG_OPERATION set" _
            & " Contents='" & strContents & "'" _
            & ",ManagerName='" & gstrManagerName & "'" _
            & ",FromComputer='" & GetComputerNameW & "'"
    GCon.Execute strSQL
    
End Sub

'错误提示
Public Sub MsgBoxW(ByRef errObject As errObject, Optional ByVal vbMsgStyle As VbMsgBoxStyle = vbInformation, _
        Optional ByVal strMsgTitle As String)
    If errObject.Number = 0 Then Exit Sub
    If strMsgTitle = "" Then strMsgTitle = errObject.Source
    MsgBox "Error " & errObject.Number & " in " & errObject.Source & ":" & vbCrLf _
            & errObject.Description, vbMsgStyle, strMsgTitle
End Sub

'执行命令行
Public Sub ExecString(ByVal strExecString As String)
On Error GoTo ErrMsg
    Dim scrObject As Object
    Dim strSubName As String
    Set scrObject = CreateObject("MSScriptControl.ScriptControl")
    
    strSubName = "HelloWorld"
    If InStr(1, strExecString, "End Sub", vbTextCompare) < 1 Then
        strExecString = "Sub " & strSubName & "()" & vbCrLf _
                & vbTab & strExecString & vbCrLf & "End Sub"
    End If
    scrObject.Language = "vbscript"
    scrObject.AddCode strExecString
    scrObject.ExecuteStatement strSubName
    Set scrObject = Nothing
    GoTo ExitLab
ErrMsg:
    MsgBoxW Err, vbExclamation
ExitLab:
    '
End Sub

'根据登录人员以及当前科室，动态显示科室医生
Public Sub ShowManagerByTime(ByRef cmbDoctor As ComboBox, _
        ByVal strKSID As String, Optional ByVal intSelectManagerID As Integer = -1)
On Error Resume Next
    Dim strSQL As String
    Dim rstemp As ADODB.Recordset
    Dim intManagerID As Integer
    
    If g_enuInputMode = WORKSTATION_INPUT Then GoTo ExitLab
    
    '清空之前的显示
    cmbDoctor.Clear
    
    intManagerID = gintManagerID
    
    '按之前选择顺序显示所有用户
    strSQL = "select RY_Employee.EmployeeID,Name,SET_ORDER.SelectTime from RY_Employee,SET_ORDER" _
            & " where RY_Employee.EmployeeID=SET_ORDER.SelectID" _
            & " and SET_ORDER.EmployeeID=" & intManagerID _
            & " and SET_ORDER.KSID='" & strKSID & "'" _
            & " union " _
            & "select EmployeeID,Name,SelectTime='2000-01-01' from RY_Employee" _
            & " where RY_Employee.EmployeeID not in(" _
                & "select SelectID from SET_ORDER" _
                & " where EmployeeID=" & intManagerID _
                & " and KSID='" & strKSID & "'" _
            & ")" _
            & " order by SelectTime desc,name"
    Set rstemp = New ADODB.Recordset
    rstemp.Open strSQL, GCon, adOpenForwardOnly, adLockReadOnly
    If Not rstemp.EOF Then
        With cmbDoctor
            Do While Not rstemp.EOF
                .AddItem rstemp("Name")
                .ItemData(.NewIndex) = rstemp("EmployeeID")
                If intSelectManagerID > -1 Then
                    If rstemp("EmployeeID") = intSelectManagerID Then
                        .ListIndex = .NewIndex
                    End If
                Else
                    If g_blnShowCurrentManager Then
                        If rstemp("EmployeeID") = gintManagerID Then
                            .ListIndex = .NewIndex
                        End If
                    End If
                End If
                
                rstemp.MoveNext
            Loop
            
            If .ListIndex = -1 Then .ListIndex = 0
        End With
        rstemp.Close
    End If
    
ExitLab:
    '
End Sub

'根据当前选择，刷新顺序表
Public Sub SetInputOrder(ByVal strKSID As String, ByVal intSelectID As Integer)
On Error GoTo ErrMsg
    Dim strSQL As String
    Dim rstemp As ADODB.Recordset
    
    '检查记录是否存在
    strSQL = "select Count(*) from SET_ORDER" _
            & " where EmployeeID=" & gintManagerID _
            & " and KSID='" & strKSID & "'" _
            & " and SelectID=" & intSelectID
    Set rstemp = New ADODB.Recordset
    rstemp.Open strSQL, GCon, adOpenForwardOnly, adLockReadOnly
    If rstemp(0) > 0 Then
        '更新
        strSQL = "update SET_ORDER set" _
                & " SelectTime='" & Now & "'" _
                & " where EmployeeID=" & gintManagerID _
                & " and KSID='" & strKSID & "'" _
                & " and SelectID=" & intSelectID
    Else
        strSQL = "insert into SET_ORDER(EmployeeID,KSID,SelectID,SelectTime) values(" _
                & gintManagerID _
                & ",'" & strKSID & "'" _
                & "," & intSelectID _
                & ",'" & Now & "'" _
                & ")"
    End If
    rstemp.Close
    GCon.Execute strSQL
    
    GoTo ExitLab
ErrMsg:
    MsgBoxW Err
ExitLab:
    '
End Sub

Public Function DetectPrinter() As Boolean
    Dim xp As Printer
    Dim i
    
    i = 0
    For Each xp In Printers
        i = i + 1
    Next
    If i > 0 Then
        DetectPrinter = True
    Else
        DetectPrinter = False
    End If
End Function

'项目导出
Public Sub ExportXiangMu(ByRef dlgDialog As CommonDialog)
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim strFileName As String
    Dim strExport As String
    Dim rstemp As ADODB.Recordset
    Dim lngLength As Long
    Dim i As Integer
    
    Screen.MousePointer = vbHourglass
    lngLength = 40
    
    strFileName = GetFileName(dlgDialog, "文本文件(*.txt)|*.txt", "请设置导出文件名", _
                "项目列表.txt", WRITEFILE)
    If strFileName = "" Then GoTo ExitLab
    
    '导出
    strExport = "欢迎使用项目导出功能！该功能为模板定制提供支持！" & vbCrLf _
            & "在使用下面的列表之前，请确认本机上已经安装Office Word 2000！" & vbCrLf _
            & vbCrLf _
            & "使用方法：" & vbCrLf _
            & "1、在Word 2000中建立模板文件" & vbCrLf _
            & "2、让鼠标停留在需要插入数据库数据的地方，单击“插入”->“书签”，在打开的对话框中输入书签名。" & vbCrLf _
            & "    注：书签命名必须满足如下格式：“【”+“标识符”+“关键字”+“】”，比如“【Q1】”，Q表示表示其它类，1表示输入姓名，前后的符号“【”、“】”是必须的。" & vbCrLf _
            & "    在该格式的前后，可以输入任意提示字符，即“【Q1】”与“姓名【Q1】”等效。" & vbCrLf _
            & "3、重复第2步，直到所有需要插入数据库数据的位置都已建立书签。" & vbCrLf _
            & "4、如需在一个WORD模板中多处使用同一个值，可以如下例设置：" & vbCrLf _
            & "    在一个模板中多处使用体检者姓名，则可定义第一个书签为【Q1A1】,第一个书签为【Q1A2】，" & vbCrLf _
            & "以此类推，可以设置其它字段。" & vbCrLf _
            & "5、在所有类别中，“科室异常的类型和例数（图）”和“团体”两类仅适用于团体报表，其中前者在书签指定位置画出所标记科室异常的类型和例数，默认显示为饼图。" & vbCrLf _
            & " 如在Word文档中某处需加入内科的科室异常的类型和例数（图），内科的科室ID为03，则在该处可定义名为【C03】的书签。" & vbCrLf _
            & "    其它类别，除完全适用于个人报表之外，类别“医生”、“医生(亲笔签名)”也适用于团体报表；在类别“其它”中，仅“打印日期”与“单位名称”两个项目适用于团体报表。" & vbCrLf _
            & "    注：未提到的类别或项目将不适用于团体报表。" _
            & vbCrLf & "6、新增了两种类别：科室医生类（I）、科室医生签名类（L），使用举例：" _
            & "【I01】表示在书签所在位置插入当前客户在编号为01的科室的体检医生。如果当前" _
            & "客户没有选择该科室，则软件将忽略该书签。【L01】的意义相同，不过显示的是在“人员" _
            & "管理”中设置的医生签名。"
    strExport = strExport & vbCrLf & vbCrLf & vbCrLf
    strExport = strExport & GetFixedString("类别", lngLength) & vbTab & "标识符" & vbCrLf _
            & "--------------------------------------------------------------" & vbCrLf _
            & GetFixedString("科室名称", lngLength) & vbTab & gtypHeader.KESHI & vbCrLf _
            & GetFixedString("科室医生", lngLength) & vbTab & gtypHeader.DOCTOR_KESHI & vbCrLf _
            & GetFixedString("科室医生签名", lngLength) & vbTab & gtypHeader.DOCTOR_SIGN_KESHI & vbCrLf _
            & GetFixedString("科室异常的类型和例数（图）", lngLength) & vbTab & gtypHeader.KESHIYICHANG & vbCrLf _
            & GetFixedString("科室小结", lngLength) & vbTab & gtypHeader.KSXJ & vbCrLf _
            & GetFixedString("组合名称", lngLength) & vbTab & gtypHeader.DAXIANG & vbCrLf _
            & GetFixedString("小项名称", lngLength) & vbTab & gtypHeader.XIAOXIANG & vbCrLf _
            & GetFixedString("体检结果", lngLength) & vbTab & gtypHeader.RESULT & vbCrLf _
            & GetFixedString("上次体检结果", lngLength) & vbTab & gtypHeader.SRESULT & vbCrLf _
            & GetFixedString("医生", lngLength) & vbTab & gtypHeader.DOCTOR & vbCrLf _
            & GetFixedString("医生(亲笔签名)", lngLength) & vbTab & gtypHeader.DOCTORSIGN & vbCrLf _
            & GetFixedString("其它", lngLength) & vbTab & gtypHeader.OTHER & vbCrLf _
            & GetFixedString("团体", lngLength) & vbTab & gtypHeader.TUANTI & vbCrLf
'            & GetFixedString("总检结论", lngLength) & vbTab & gtypHeader.ZJJL & vbCrLf _
'            & GetFixedString("总检建议", lngLength) & vbTab & gtypHeader.ZJJY
    strExport = strExport & vbCrLf & vbCrLf & vbCrLf _
            & GetFixedString("名称", lngLength) & vbTab & "关键字" & vbCrLf _
            & "--------------------------------------------------------------" & vbCrLf
    
    strExport = strExport & vbCrLf _
            & "科室类/科室小结类/科室异常的类型和例数（图）类/科室医生类/科室医生(亲笔签名)类" & vbCrLf & vbCrLf
    '科室
    strSQL = "select KSMC,KSID from SET_KSSZ" _
            & " order by SXH"
    Set rstemp = New ADODB.Recordset
    rstemp.Open strSQL, GCon, adOpenStatic, adLockOptimistic
    If rstemp.RecordCount >= 1 Then
        rstemp.MoveFirst
        Do While Not rstemp.EOF
            strExport = strExport & GetFixedString(rstemp("KSMC"), lngLength) & vbTab & rstemp("KSID") & vbCrLf
            rstemp.MoveNext
        Loop
        
        rstemp.Close
    End If
    DoEvents
    
    strExport = strExport & vbCrLf _
            & "组合和体检结果类" & vbCrLf & vbCrLf
    
    '组合
    strSQL = "select DXMC,DXID from SET_DX" _
            & " order by left(DXID,2),SXH"
    Set rstemp = New ADODB.Recordset
    rstemp.Open strSQL, GCon, adOpenStatic, adLockOptimistic
    If rstemp.RecordCount >= 1 Then
        rstemp.MoveFirst
        Do While Not rstemp.EOF
            strExport = strExport & GetFixedString(rstemp("DXMC"), lngLength) & vbTab & rstemp("DXID") & vbCrLf
            rstemp.MoveNext
        Loop
        
        rstemp.Close
    End If
    DoEvents
   
    strExport = strExport & vbCrLf _
            & "小项和体检结果类" & vbCrLf & vbCrLf
   
    '小项
    strSQL = "select XXMC,XXID from SET_XX" _
            & " order by KSID,XXID,SXH"
    Set rstemp = New ADODB.Recordset
    rstemp.Open strSQL, GCon, adOpenStatic, adLockOptimistic
    If rstemp.RecordCount >= 1 Then
        rstemp.MoveFirst
        Do While Not rstemp.EOF
            strExport = strExport & GetFixedString(rstemp("XXMC"), lngLength) & vbTab & rstemp("XXID") & vbCrLf
            rstemp.MoveNext
        Loop
        
        rstemp.Close
    End If
    DoEvents
     
    strExport = strExport & vbCrLf _
            & "医生类/医生(亲笔签名)类" & vbCrLf & vbCrLf
    
    '医生
    strSQL = "select Name,EmployeeID from RY_Employee order by EmployeeID"
    Set rstemp = New ADODB.Recordset
    rstemp.Open strSQL, GCon, adOpenStatic, adLockOptimistic
    If rstemp.RecordCount >= 1 Then
        rstemp.MoveFirst
        Do While Not rstemp.EOF
            strExport = strExport & GetFixedString(rstemp("Name"), lngLength) & vbTab & rstemp("EmployeeID") & vbCrLf
            rstemp.MoveNext
        Loop
        
        rstemp.Close
    End If
    DoEvents