mdldatabase2.bas

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

                            If rstemp.RecordCount < 1 Then
                                strSQL = ""
                            Else
                                '重定义数组大小
                                ReDim arrXMID(rstemp.RecordCount - 1)
                                
                                strSQL = "select "
                                rstemp.MoveFirst
                                For i = 1 To rstemp.RecordCount
                                    strSQL = strSQL & "[" & rstemp("XXPYSX") & "] as [" & rstemp("XXMC") & "],"
                                    '记录小项编号
                                    arrXMID(i - 1) = rstemp("XXID")
                                    
                                    rstemp.MoveNext
                                Next
                                
                                rstemp.Close
                                '截掉最后一个逗号
                                strSQL = Left(strSQL, Len(strSQL) - 1)
                            End If
                        Else
                            '*****************************************************
                            '                       无子项
                            '*****************************************************
                            strSQL = "select [" & rsDX("DXPYSX") & "Value] as [" & rsDX("DXMC") & "]"
                            '重定义数组大小
                            ReDim arrXMID(0)
                            '记录大项编号
                            arrXMID(0) = rsDX("DXID")
                        End If
                        '补充完整查询语句
                        If strSQL = "" Then
                            '无项目
                            strLine = "        (无项目)"
                            strResult = strResult & strLine & vbCrLf
                        Else
                            strSQL = strSQL & " from [DATA_" & rsDX("DXPYSX") & "]" _
                                    & " where GUID=" & lngGUID
                            Set rstemp = New ADODB.Recordset
                            rstemp.Open strSQL, GCon, adOpenStatic, adLockOptimistic
                            If rstemp.RecordCount < 1 Then
                                '没有体检
                                strLine = "        (未检查)"
                                strResult = strResult & strLine & vbCrLf
                            Else
                                rstemp.MoveFirst
                                For i = 0 To rstemp.Fields.Count - 1
                                    '★★★★★★★★★★★★★★★★★★★★★★★★★★★
                                    '                   打印小项名称
                                    '★★★★★★★★★★★★★★★★★★★★★★★★★★★
                                    strResult = strResult & "        项目名称：" & rstemp(i).name & vbCrLf
                                    
                                    '首先检查该体检项在体检标准表中是否有记录
                                    blnHave = False
                                    If rsBZ.RecordCount > 1 Then
                                        rsBZ.MoveFirst
                                        Do
                                            If arrXMID(i) = rsBZ("XMID") Then
                                                If rsBZ("CKSX") <> "" Then
                                                    blnHave = True
                                                End If
                                                Exit Do
                                            End If
                                            
                                            rsBZ.MoveNext
                                        Loop Until rsBZ.EOF
        
                                    End If
                                    
                                    '★★★★★★★★★★★★★★★★★★★★★★★★★★★
                                    '                   打印体检值
                                    '★★★★★★★★★★★★★★★★★★★★★★★★★★★
                                    If blnHave = False Then
                                        If Not IsNull(rstemp(i)) Then
                                            strPrint = rstemp(i)
                                        Else
                                            strPrint = ""
                                        End If
                                    Else
                                        '如果有单位，则在体检值后显示单位
                                        If Not IsNull(rstemp(i)) Then
                                            strPrint = rstemp(i) & " " & rsBZ("DW")
                                        Else
                                            strPrint = ""
                                        End If
                                    End If
                                    strResult = strResult & "            体检值：" & strPrint & vbCrLf
                                    
                                    If blnHave = True Then
                                        '★★★★★★★★★★★★★★★★★★★★★★★★★★★
                                        '                   打印正常值
                                        '★★★★★★★★★★★★★★★★★★★★★★★★★★★
                                        strLine = rsBZ("NormalVal") & rsBZ("DW")
                                        strResult = strResult & "            正常值：" & strLine & vbCrLf
                                        
                                        '★★★★★★★★★★★★★★★★★★★★★★★★★★★
                                        '                   打印标准下限
                                        '★★★★★★★★★★★★★★★★★★★★★★★★★★★
                                        strLine = rsBZ("CKXX") & rsBZ("DW")
                                        strResult = strResult & "            标准下限：" & strLine & vbCrLf
                                        
                                        '★★★★★★★★★★★★★★★★★★★★★★★★★★★
                                        '                   打印标准上限
                                        '★★★★★★★★★★★★★★★★★★★★★★★★★★★
                                        strLine = rsBZ("CKSX") & rsBZ("DW")
                                        strResult = strResult & "            标准上限：" & strLine & vbCrLf
                                    End If
                                Next i
                                rstemp.Close
                            End If
                        End If
                        rsDX.MoveNext
                    Loop Until rsDX.EOF
                    rsDX.Close
                End If
            End If
            
            '★★★★★★★★★★★★★★★★★★★★★★★★★★★
            '                   打印科室小结
            '★★★★★★★★★★★★★★★★★★★★★★★★★★★
            strResult = strResult & "    科室小结：" & vbCrLf
            
            strSQL = "select XJValue from DATA_KSXJ" _
                    & " where GUID=" & lngGUID _
                    & " and KSID='" & rsKS("KSID") & "'"
            Set rstemp = New ADODB.Recordset
            rstemp.Open strSQL, GCon, adOpenStatic, adLockOptimistic
            If rstemp.RecordCount > 0 Then
                If Not IsNull(rstemp(0)) Then
                    strPrint = rstemp(0)
                Else
                    strPrint = "（无）"
                End If
                
                rstemp.Close
            Else
                strPrint = "（无）"
            End If
            strResult = strResult & "    " & strPrint & vbCrLf
            
            rsKS.MoveNext
            
            '★★★★★★★★★★★★★★★★★★★★★★★★★★★
            '           每个科室打印完后，打印一条横线
            '★★★★★★★★★★★★★★★★★★★★★★★★★★★
            strResult = strResult & "'................................................................" & vbCrLf
        Loop Until rsKS.EOF
        rsKS.Close
    End If
    Set rsKS = Nothing
    Set rsDX = Nothing
    Set rstemp = Nothing
    Set rsBZ = Nothing
    
    '空一行之后再打印总检结论和建议
    strResult = strResult & vbCrLf
    '★★★★★★★★★★★★★★★★★★★★★★★★★★★
    '                   打印总检结论
    '★★★★★★★★★★★★★★★★★★★★★★★★★★★
    strLine = "总检结论："
    strResult = strResult & strLine & vbCrLf
    
    strSQL = "select JLValue from DATA_ZJJL" _
            & " where GUID=" & lngGUID
    Set rstemp = New ADODB.Recordset
    rstemp.Open strSQL, GCon, adOpenStatic, adLockOptimistic
    If rstemp.RecordCount > 0 Then
        If Not IsNull(rstemp(0)) Then
            If rstemp(0) <> "" Then
                strPrint = rstemp(0)
            Else
                strPrint = "（无）"
            End If
        Else
            strPrint = "（无）"
        End If
        
        rstemp.Close
    Else
        strPrint = "（无）"
    End If
    strResult = strResult & "    " & strPrint & vbCrLf
    
    '★★★★★★★★★★★★★★★★★★★★★★★★★★★
    '                   打印总检建议
    '★★★★★★★★★★★★★★★★★★★★★★★★★★★
    strLine = "总检建议："
    strResult = strResult & strLine & vbCrLf
    
    strSQL = "select JYValue from DATA_ZJJY" _
            & " where GUID=" & lngGUID
    Set rstemp = New ADODB.Recordset
    rstemp.Open strSQL, GCon, adOpenStatic, adLockOptimistic
    If rstemp.RecordCount > 0 Then
        If Not IsNull(rstemp(0)) Then
            strPrint = rstemp(0)
        Else
            strPrint = "（无）"
        End If
        
        rstemp.Close
    Else
        strPrint = "（无）"
    End If
    strResult = strResult & "    " & strPrint & vbCrLf
    
    '★★★★★★★★★★★★★★★★★★★★★★★★★★★
    '               最后提交打印任务
    '★★★★★★★★★★★★★★★★★★★★★★★★★★★
    '写入文件
    WriteTextFile strFileName, strResult
    '用记事本打开
    Shell "notepad.exe " & strFileName, vbNormalFocus
    
    GoTo ExitLab

'打印报表标题
PrintTitle:
    '打印标题
    strTempletFile = gstrCurrPath & TemplateDir & TJResultToText
    '检查模板文件是否存在
    If Dir(strTempletFile) = "" Then
        '如果不存在，用默认值进行修复
        strTemp = "'≌≌≌≌≌≌≌≌≌≌≌≌≌≌≌≌≌≌≌≌≌≌≌≌≌≌≌≌≌≌≌≌" & vbCrLf _
                & "'∷∷∷∷∷∷∷∷∷∷∷∷                ∷∷∷∷∷∷∷∷∷∷∷∷" & vbCrLf _
                & "'∷∷∷∷∷∷∷∷∷∷∷∷    体检结果    ∷∷∷∷∷∷∷∷∷∷∷∷" & vbCrLf _
                & "'∷∷∷∷∷∷∷∷∷∷∷∷                ∷∷∷∷∷∷∷∷∷∷∷∷" & vbCrLf _
                & "'≌≌≌≌≌≌≌≌≌≌≌≌≌≌≌≌≌≌≌≌≌≌≌≌≌≌≌≌≌≌≌≌" & vbCrLf _
                & "'****************************************************************" & vbCrLf _
                & "'医    院：&HOSPITAL" & vbCrLf _
                & "'导出时间：&EXPORTTIME" & vbCrLf _
                & "'========================    个人信息    ========================" & vbCrLf _
                & "'健康档案号：&HEALTHID" & vbCrLf _
                & "'姓名：&NAME" & vbCrLf _
                & "'性别：&SEX" & vbCrLf _
                & "'体检日期：&TJRQ" & vbCrLf _
                & "'****************************************************************"
        If WriteTextFile(strTempletFile, strTemp) = False Then GoTo ExitLab
    End If
    
    arrRet = ReadTextFile(strTempletFile)
    '首先清空导出内容
    strResult = ""
    For i = LBound(arrRet) To UBound(arrRet)
        '这条语句会在后面多加一个回车换行
        strResult = strResult & arrRet(i) & vbCrLf
    Next
    '处理里面的常量
    strResult = Replace(strResult, Hospital, gstrHospital, , , vbTextCompare)
    strResult = Replace(strResult, ExportTime, Date & " " & Time, , , vbTextCompare)
    strResult = Replace(strResult, HEALTHID, strHealthID, , , vbTextCompare)
    strResult = Replace(strResult, name, strName, , , vbTextCompare)
    strResult = Replace(strResult, SEX, strSex, , , vbTextCompare)
    strResult = Replace(strResult, TJRQ, strTJRQ, , , vbTextCompare)
    Return
    
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    Screen.MousePointer = vbDefault
End Function
'*************************************************************************
'*************************************************************************