mdldatabase4.bas

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

    Dim intJBCJB As Integer '疾病编号
    Dim strPerson As String '名单
    
    Screen.MousePointer = vbHourglass
    
    '创建临时表
    strSQL = "CREATE TABLE " & TempTable _
            & " ([GUID] bigint primary key,项目 Varchar(100),名单 Varchar(8000)" _
            & ",人数 Varchar(6),[百分比%] Varchar(8),提示 Varchar(500)"
    strSQL = strSQL & ")"
    Call CreateTable(TempTable, True, strSQL)
    
    '获取当前团体的体检总人数
    strSQL = "select Count(*) from SET_GRXX" _
            & " where YYID='" & strYYID & "'"
    Set rstemp = New ADODB.Recordset
    rstemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
    intTotal = rstemp(0)
    rstemp.Close
    If intTotal < 1 Then
        MsgBox "当前团体没有体检人员！", vbInformation, "提示"
        GoTo ExitLab
    End If
    
    '取出当前单位所有人员的总检结论（一次取出，加快处理速度）
    strSQL = "select SET_GRXX.GUID,YYRXM,JLValue from SET_GRXX,DATA_ZJJL" _
            & " where SET_GRXX.YYID='" & strYYID & "'" _
            & " and SET_GRXX.GUID=DATA_ZJJL.GUID"
    Set rsZJJL = New ADODB.Recordset
    rsZJJL.Open strSQL, GCon, adOpenStatic, adLockOptimistic
    If rsZJJL.EOF Then
        MsgBox "当前团体尚未有人做总检！", vbInformation, "提示"
        GoTo ExitLab
    Else
        '总人数应设置为已做总检人数
        intTotal = rsZJJL.RecordCount
    End If
    
    '检索所有有选择的科室
    strSQL = "select KSID,KSMC from SET_KSSZ" _
            & " where KSID in (" _
            & "select left(DXID,2) from YY_SJDJDX" _
            & " where GUID in (" _
                & "select GUID from SET_GRXX" _
                & " where YYID='" & strYYID & "')" _
            & ")" _
            & " order by SXH"
    Set rstemp = New ADODB.Recordset
    rstemp.Open strSQL, GCon, adOpenForwardOnly, adLockReadOnly
    If rstemp.EOF Then '为保险起见，检查是否有选择科室
        MsgBox "当前团体尚未选择项目！", vbInformation, "提示"
        GoTo ExitLab
    End If
    '循环所有选择的科室
    lngCount = 1
    intKShi = 1
    For i = 1 To rstemp.RecordCount
        strXMID = rstemp("KSID")
        strKSMC = rstemp("KSMC") '科室名称
        
        '插入该科室名称到临时表中
        strSQL = "insert into " & TempTable _
                & "(GUID,项目) values(" _
                & lngCount _
                & ",'（" & intKShi & "）、" & strKSMC & "'" _
                & ")"
        GCon.Execute strSQL
        lngCount = lngCount + 1 '每条记录的唯一标识加1
        intKShi = intKShi + 1 '科室加一
        
        '提取该科室下的所有病症
        strSQL = "select distinct JYMC from DM_ZJJY" _
                & " where KSID='" & strXMID & "'" _
                & " and (SFJB=1 or SFCJB=1)"
        Set rsJBCJB = New ADODB.Recordset
        rsJBCJB.Open strSQL, GCon, adOpenStatic, adLockReadOnly
        If rsJBCJB.RecordCount > 0 Then
            intJBCJB = 1 '初始化疾病编号
            rsJBCJB.MoveFirst
            Do While Not rsJBCJB.EOF
                intPerson = 0 '初始化人数
                strPerson = "" '初始化名单
                '循环处理该单位每个客户的总检结论
                rsZJJL.MoveFirst
                Do While Not rsZJJL.EOF
                    If InStr(1, rsZJJL("JLValue"), rsJBCJB("JYMC")) >= 1 Then
                        intPerson = intPerson + 1
                        strPerson = strPerson & rsZJJL("YYRXM") & "，"
                    End If
                    
                    rsZJJL.MoveNext
                Loop
                '是否有客户患该种疾病
                If intPerson > 0 Then
                    '去掉最后的逗号
                    strPerson = Left(strPerson, Len(strPerson) - 1)
                    strSQL = "insert into " & TempTable _
                            & " values(" _
                            & lngCount _
                            & ",'    " & intJBCJB & "、" & rsJBCJB("JYMC") & "'" _
                            & ",'" & strPerson & "'" _
                            & ",'" & intPerson & "人'" _
                            & ",'" & GetRatio(intPerson, intTotal) & "'" _
                            & ",'')"
                    '写入数据库
                    GCon.Execute strSQL
                    
                    lngCount = lngCount + 1 '每条记录的唯一标识加1
                    intJBCJB = intJBCJB + 1
                End If
                
                rsJBCJB.MoveNext '循环当前科室下的每种疾病
            Loop
            
            rsJBCJB.Close
        End If
        DoEvents
        
        rstemp.MoveNext '循环到下一个科室
    Next i
    If rsZJJL.RecordCount > 0 Then
        rsZJJL.Close
    End If
    Set rstemp = Nothing
    Set rsJBCJB = Nothing
    Set rsZJJL = Nothing
    
    '调用成功，返回临时表名
    GetYXHZTableOfTT = TempTable
    GoTo ExitLab
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    Screen.MousePointer = vbDefault
End Function

'**********************************************************************
'检查指定客户哪些项目尚未录入，如果尚未录入，并且是说明型，则用正常值写入；
'同时检查是否生成了科室小结，如果没有，则生成科室小结
'参数1：欲处理的客户编号
'参数2：当前医生编号
'参数3：是否检查科室小结。可选，默认为检查
'返回值：布尔型，表示调用是否成功
'**********************************************************************
Public Function CheckPersonXMInput(ByVal lngGUID As Long, ByVal intManagerID As Integer, _
        ByVal intBZID As Integer, _
        Optional ByVal blnCheckKSXJ As Boolean = True) As Boolean
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim rsDX As ADODB.Recordset
    Dim rsXX As ADODB.Recordset
    Dim rsData As ADODB.Recordset
    Dim rstemp As ADODB.Recordset
    Dim strTableName As String
    Dim strXXPYSX As String
    Dim intSex As Integer
    Dim strOldKSID As String
    Dim blnProduceKSXJ As Boolean '是否需要生成科室小结
    
    Screen.MousePointer = vbHourglass
    
    '首先检索当前客户的性别
    strSQL = "select SEX from SET_GRXX" _
            & " where GUID=" & lngGUID
    Set rstemp = New ADODB.Recordset
    rstemp.Open strSQL, GCon, adOpenForwardOnly, adLockReadOnly
    If rstemp.EOF Then GoTo ExitLab
    intSex = IIf(rstemp("SEX") = "男", 2, 1)
    rstemp.Close
    
    '检索当前客户选择的所有组合
    strSQL = "select SET_KSSZ.KSID,DXID,DXPYSX from SET_KSSZ,SET_DX" _
            & " where SET_KSSZ.KSID=SET_DX.KSID" _
            & " and SET_DX.DXID in(" _
                & "select DXID from YY_SJDJDX" _
                & " where GUID=" & lngGUID _
            & ")" _
            & " and DXNNTY<>" & intSex _
            & " order by SET_KSSZ.SXH,SET_DX.SXH"
    Set rsDX = New ADODB.Recordset
    rsDX.Open strSQL, GCon, adOpenForwardOnly, adLockReadOnly
    If rsDX.EOF Then GoTo ExitLab '是否有选择项目
    Do While Not rsDX.EOF
        strTableName = "[DATA_" & rsDX("DXPYSX") & "]" '记录表名
        '检索当前组合下的所有小项。只检索说明型
        strSQL = "select XXID,XXPYSX,XXType from SET_XX" _
                & " where XXID in(" _
                    & "select XXID from SET_ZH_DATA" _
                    & " where DXID='" & rsDX("DXID") & "'" _
                & ")" _
                & " and XXType=" & SHUOMING _
                & " and XXNNTY<>" & intSex
        Set rsXX = New ADODB.Recordset
        rsXX.Open strSQL, GCon, adOpenStatic, adLockReadOnly
        If Not rsXX.EOF Then
            '首先检索当前组合是否已有数据
            strSQL = "select Count(*) from " & strTableName _
                    & " where GUID=" & lngGUID
            Set rstemp = New ADODB.Recordset
            rstemp.Open strSQL, GCon, adOpenForwardOnly, adLockReadOnly
            If rstemp(0) < 1 Then
                '首先写入一条空记录
                strSQL = "insert into " & strTableName & "(GUID,TJRQ) values(" _
                        & lngGUID & ",'" & Date & "')"
                GCon.Execute strSQL
            End If
            rstemp.Close
            
            strSQL = "select GUID"
            Do While Not rsXX.EOF
                strSQL = strSQL & ",[" & rsXX("XXPYSX") & "]"
                
                rsXX.MoveNext
            Loop
            strSQL = strSQL & " from " & strTableName _
                    & " where GUID=" & lngGUID
            Set rsData = New ADODB.Recordset
            rsData.Open strSQL, GCon, adOpenForwardOnly, adLockReadOnly
            '检查哪些项目尚未录入
            rsXX.MoveFirst
            Do While Not rsXX.EOF
                strXXPYSX = rsXX("XXPYSX")
                If IsNull(rsData(strXXPYSX)) Then
                    '写入正常值
                    Call WriteNormalValue(lngGUID, intSex, strTableName, rsXX("XXID"), rsXX("XXPYSX"), intBZID)
                End If
                
                rsXX.MoveNext
            Loop
            
            rsXX.Close
        End If
        
        strOldKSID = rsDX("KSID")
        
        rsDX.MoveNext
        If blnCheckKSXJ Then
            blnProduceKSXJ = False
            If rsDX.EOF Then
                '已经处理完最后一个组合
                blnProduceKSXJ = True
            Else
                '一个完整的科室是否已经处理完毕
                If strOldKSID <> rsDX("KSID") Then
                    '上一科室已经处理完毕，需要生成科室小结
                    blnProduceKSXJ = True
                End If
            End If
            If blnProduceKSXJ Then
                '需要生成科室小结
                '检查科室小结是否已经存在
                strSQL = "select Count(*) from DATA_KSXJ" _
                        & " where GUID=" & lngGUID _
                        & " and not (XJValue is null)"
                Set rstemp = New ADODB.Recordset
                rstemp.Open strSQL, GCon, adOpenForwardOnly, adLockReadOnly
                If rstemp(0) < 1 Then
                    '之前未生成科室小结
                    Call GetKSResult(lngGUID, strOldKSID, intSex, intBZID, intManagerID)
                End If
                rstemp.Close
            End If
        End If
    Loop
    rsDX.Close
    
    GoTo ExitLab
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    Screen.MousePointer = vbDefault
End Function

'**********************************************************************
'把指定项目的正常值写入指定客户的数据表
'参数1：欲处理的客户编号
'参数2：当前客户相反的性别
'参数3：数据表名
'参数4：小项编号
'参数5：小项拼音缩写
'参数5：当前客户使用的标准编号
'返回值：布尔型，表示调用是否成功
'**********************************************************************
Private Sub WriteNormalValue(ByVal lngGUID As Long, ByVal intSex As Integer, _
        ByVal strTableName As String, ByVal strXXID As String, ByVal strXXPYSX As String, _
        ByVal intBZID As Integer)
    Dim strSQL As String
    Dim rsBZ As ADODB.Recordset
    
    '首先检索当前小型的体检标准
    strSQL = "select NormalVal from SET_TJBZDT" _
            & " where XMID='" & strXXID & "'" _
            & " and BZID=" & intBZID _
            & " and SEX<>" & intSex
    Set rsBZ = New ADODB.Recordset
    rsBZ.Open strSQL, GCon, adOpenForwardOnly, adLockReadOnly
    If rsBZ.EOF Then GoTo ExitLab '是否有标准
    If IsNull(rsBZ("NormalVal")) Then GoTo ExitLab '是否为空
    '写入数据表
    strSQL = "update " & strTableName & " set" _
            & " [" & strXXPYSX & "]='" & rsBZ("NormalVal") & "'" _
            & " where GUID=" & lngGUID
    GCon