mdldatabase4.bas

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

End Function

'**********************************************************************
'把科室建议写入科室建议表
'参数1：GUID编号
'参数2：科室编号
'参数3：组合编号
'参数4：要写入的科室建议
'返回值：是否成功
'**********************************************************************
Public Function WriteKSJY(ByVal lngGUID As Long, ByVal strKSID As String, _
        ByVal strDXID As String, ByVal strKSJY As String) As Boolean
    Dim strSQL As String
    Dim rstemp As ADODB.Recordset
    
    '以下代码把建议赋值给DATA_KSJY，便于总检时生成总检建议
    If strKSJY = "" Then GoTo ExitLab
    
    '首先判断当前客户在当前科室是否有记录
    strSQL = "select count(*) from DATA_KSJY" _
            & " where GUID=" & lngGUID _
            & " and KSID='" & strKSID & "'" _
            & " and DXID='" & strDXID & "'"
    Set rstemp = New ADODB.Recordset
    rstemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
    If rstemp(0) >= 1 Then
        '已经存在记录，则更新
        strSQL = "update DATA_KSJY set" _
                & " JYValue='" & strKSJY & "'" _
                & " where GUID=" & lngGUID _
                & " and KSID='" & strKSID & "'" _
                & " and DXID='" & strDXID & "'"

    Else
        '之前不存在记录，添加
        strSQL = "insert into DATA_KSJY values(" _
                & lngGUID _
                & ",'" & Date & "'" _
                & ",'" & strKSID & "'" _
                & ",'" & strDXID & "'" _
                & ",'" & strKSJY & "')"
    End If
    rstemp.Close
    Set rstemp = Nothing
    '写入数据库
    GCon.Execute strSQL
    WriteKSJY = True
    GoTo ExitLab
ExitLab:
    '
End Function

'**********************************************************************
'取得某人某项目的异常结论
'参数1：GUID编号
'参数2：大项拼音所写
'参数3：小项拼音所写
'参数4：小项类型
'返回值：字符串
'**********************************************************************
Public Function GetUnnormalResult(ByVal lngGUID As Long, ByVal strDXPYSX As String, _
        ByVal strXXID As String, ByVal strXXPYSX As String, ByVal strXXMC As String, _
        ByVal intType As Integer, Optional ByVal blnDispose As Boolean = True) As String
    Dim strSQL As String
    Dim rstemp As ADODB.Recordset
    Dim strValue As String
    Dim strRet As String
    
    '检索体检数据
    strSQL = "select [DATA_" & strDXPYSX & "].[" & strXXPYSX & "]" _
            & " from [DATA_" & strDXPYSX & "]" _
            & " where GUID=" & lngGUID
    Set rstemp = New ADODB.Recordset
    rstemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
    '是否有记录
    If rstemp.EOF Then GoTo ExitLab
    '是否为空值
    If IsNull(rstemp(0)) Then GoTo ExitLab
    '是否有数据
    If Len(rstemp(0)) = 0 Then GoTo ExitLab '传说比较长度比比较是否空字符串要快
    
    '检查当前项目是否数值型
    If intType = 1 Or intType = 3 Then
        '如果是数值型，查看录入是否有效
        '是否有效数值
        If Not IsNumeric(rstemp(0)) Then GoTo ExitLab
    End If
    If blnDispose = False Then
        GetUnnormalResult = rstemp(0)
        GoTo ExitLab
    Else
        strValue = rstemp(0)
    End If
    rstemp.Close
    
    If InStr(1, strValue, "未查") >= 1 Then GoTo ExitLab
    
    '提取体检标准数据
'    str(set_xx_bz.xx_min,5,1) AS 参考下限,str(set_xx_bz.xx_max,5,1) as 参考上限
'    select xx_min from set_xx_bz  where xx_id='" & strXMID & "' and zcz='正常值'
    If (intType = 1) Or (intType = 3) Then
        strSQL = "select distinct DW,(select xx_min from set_xx_bz  where xx_id='" & strXXID & "' and zcz='正常值') as CKXX,(select xx_max from set_xx_bz  where xx_id='" & strXXID & "' and zcz='正常值') as CKSX,NormalVal" _
                & " from SET_TJBZDT,set_xx_bz" _
                & " where   set_xx_bz.xx_id=SET_TJBZDT.xmid  and  XMID='" & strXXID & "'" _
                & " and BZID=" & g_intEnableBZID
    Else
        strSQL = "select distinct DW,NormalVal" _
                & " from SET_TJBZDT" _
                & " where   XMID='" & strXXID & "'" _
                & " and BZID=" & g_intEnableBZID
    End If
    'wxw add 根据体检标准生成
    Set rstemp = New ADODB.Recordset
    rstemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
    If rstemp.EOF Then GoTo ExitLab
    
    '处理查询结果
    If (intType = 1) Or (intType = 3) Then
        '数值型
        If (Val(strValue) > Val(rstemp("CKSX") & "")) _
                Or (Val(strValue) < Val(rstemp("CKXX") & "")) Then
            strRet = strXXMC & "：" & strValue & rstemp("DW")
            If Val(strValue) < Val(rstemp("CKXX") & "") Then
                strRet = strRet & "，偏低"
            Else
                strRet = strRet & "，偏高"
            End If
        End If
    Else
        '说明型
        If strValue <> rstemp("NormalVal") & "" Then
            strRet = strXXMC & "：" & strValue
        End If
    End If
    
    GetUnnormalResult = strRet
    
ExitLab:
    '
End Function

'**********************************************************************
'取得某人某项目的异常结论
'参数1：除数
'参数2：被除数
'返回值：字符串
'**********************************************************************
Public Function GetRatio(ByVal lngCount As Long, ByVal lngTotal As Long, _
        Optional ByVal intDecimalLength As Integer = 2, _
        Optional ByVal blnWithPercentSign As Boolean = True) As String
On Error Resume Next
    Dim strRet As String
    
    If lngTotal <= 0 Then GoTo ExitLab
    strRet = Round(lngCount * 100 / lngTotal, intDecimalLength)
    
    If Left(strRet, 1) = "." Then
        strRet = "0" & strRet
    End If
    
    If blnWithPercentSign Then
        GetRatio = strRet & "%"
    Else
        GetRatio = strRet
    End If
    GoTo ExitLab
ExitLab:
    '
End Function

'**********************************************************************
'加载所有科室和大项
'参数1：欲加载项目的树型控件
'参数2：是否显示根节点
'参数3：是否显示具体项目
'返回值：是否成功
'**********************************************************************
Public Function LoadKShiAndXMu(ByRef tvwXMu As TreeView, ByVal blnShowRoot As Boolean, _
        Optional ByVal blnShowXMu As Boolean = False) As Boolean
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim rsKShi As ADODB.Recordset
    Dim rsDX As ADODB.Recordset
    Dim rsXX As ADODB.Recordset
    Dim nodTemp As Node
    
    '显示所有科室
    strSQL = "select KSID,KSMC from SET_KSSZ"
    '按顺序号排序
    strSQL = strSQL & " order by SXH"
    Set rsKShi = New ADODB.Recordset
    rsKShi.Open strSQL, GCon, adOpenStatic, adLockOptimistic
    '添加根节点
    If blnShowRoot Then
        Set nodTemp = tvwXMu.Nodes.Add(, , HEADER, "所有项目")
        nodTemp.Expanded = True
    End If
    If rsKShi.RecordCount > 0 Then
        rsKShi.MoveFirst
        With tvwXMu
            Do
                '添加科室
                '关键字长度：1＋2＝3
                If blnShowRoot Then
                    Set nodTemp = .Nodes.Add(HEADER, tvwChild, "W" & rsKShi("KSID"), rsKShi("KSMC"))
                Else
                    Set nodTemp = .Nodes.Add(, , "W" & rsKShi("KSID"), rsKShi("KSMC"))
                End If
                nodTemp.Expanded = True
                
                strSQL = "select DXID,DXMC,DXSFYZX from SET_DX" _
                        & " where left(DXID,2)='" & rsKShi("KSID") & "'"
                '按顺序号排序
                strSQL = strSQL & " order by SXH"
                Set rsDX = New ADODB.Recordset
                rsDX.Open strSQL, GCon, adOpenStatic, adLockOptimistic
                If rsDX.RecordCount > 0 Then
                    rsDX.MoveFirst
                    Do
                        '添加大项
                        '关键字长度：1＋4＝5
                        Set nodTemp = .Nodes.Add("W" & rsKShi("KSID"), tvwChild, "W" & rsDX("DXID"), rsDX("DXMC"))
                        If Not blnShowXMu Then
                            nodTemp.Expanded = True
                        Else
                            strSQL = "select XXID,XXMC from SET_XX" _
                                    & " where XXID in(" _
                                        & "select XXID from SET_ZH_DATA" _
                                        & " where DXID='" & rsDX("DXID") & "'" _
                                    & ")"
                            '按顺序号排序
                            strSQL = strSQL & " order by SXH"
                            Set rsXX = New ADODB.Recordset
                            rsXX.Open strSQL, GCon, adOpenStatic, adLockReadOnly
                            If Not rsXX.EOF Then
                                Do While Not rsXX.EOF
                                    '关键字长度：1＋4＋7＝12
                                    .Nodes.Add "W" & rsDX("DXID"), tvwChild, _
                                            "W" & rsDX("DXID") & rsXX("XXID")
                                                                        
                                    rsXX.MoveNext
                                Loop
                                rsXX.Close
                            End If
                        End If
                        
                        rsDX.MoveNext
                    Loop Until rsDX.EOF
                    rsDX.Close
                End If
                
                rsKShi.MoveNext
            Loop Until rsKShi.EOF
        End With
        rsKShi.Close
    End If
    
    LoadKShiAndXMu = True
    
    GoTo ExitLab
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    '
End Function

'**********************************************************************
'把字符串按指定的小数位返回
'参数1：欲处理的字符串
'参数2：小数位数。默认为2
'返回值：处理后的字符串
'**********************************************************************
Public Function GetFixedDigit(ByVal strValue As String, _
        Optional ByVal intLength As Integer = 2) As String
    Dim i As Integer
    
    i = InStr(1, strValue, ".")
    If i >= 1 Then
        strValue = Left(strValue, i + intLength)
    End If
    If Left(strValue, 1) = "." Then
        strValue = "0" & strValue
    End If
    GetFixedDigit = strValue
End Function

'**********************************************************************
'把某单位的阳性汇总放入临时表
'参数1：欲处理的单位编号
'返回值：生成的临时表名。如果为空，表示调用失败
'**********************************************************************
Public Function GetYXHZTableOfTT(ByVal strYYID As String) As String
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim rstemp As ADODB.Recordset
    Dim rsZJJL As ADODB.Recordset
    Dim rsJBCJB As ADODB.Recordset
    
    Dim strXMID As String
    Dim strKSMC As String
    Dim i As Integer, j As Integer
    Dim intPerson As Integer '某种疾病的人数
    Dim intTotal As Integer '总人数
    Dim lngCount As Long '唯一标识
    Dim intKShi As Integer '科室编号