formtjbzwh.frm

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

        '校验长度
        If Len(txtMinVal.Text) >= 5 Then
            MsgBox "您输入的数字太长！", vbInformation, "提示"
            KeyAscii = 0
            txtMinVal.SetFocus
            Exit Sub
        End If
    End If
    
    EnterToTab KeyAscii
End Sub

Private Sub txtNormalVal_Change()
    cmdSaveInfo.Enabled = True
End Sub

Private Sub txtNormalVal_KeyPress(KeyAscii As Integer)
'    If txtNormalVal.Tag = "1" Then
'        '不是回车和退格键的时候，校验长度和字符
'        If (KeyAscii <> vbKeyBack) And (KeyAscii <> vbKeyReturn) Then
'            '是否输入了数字
'            If (KeyAscii < vbKey0) Or (KeyAscii > vbKey9) Then
'                Beep 50, 10
'                KeyAscii = 0
'            End If
'
'            '校验长度
'            If Len(txtNormalVal.Text) >= 5 Then
'                MsgBox "您输入的数字太长！", vbInformation, "提示"
'                KeyAscii = 0
'                txtNormalVal.SetFocus
'                Exit Sub
'            End If
'        End If
'    End If
    
    EnterToTab KeyAscii
End Sub

Private Sub cmdExport_Click()
On Error GoTo ErrMsg
    Dim fsoOut As New Scripting.FileSystemObject
    Dim TxtStream As Scripting.TextStream
    Dim strOutFileName As String
    Dim Status
    Dim i, j, K As Integer
    Dim strSQL As String
    Dim strTempResult As String
    Dim strXMMC As String
    Dim strXMSex As String
    Dim strPath As String
    
    Dim rsBZ As ADODB.Recordset
    Dim rstemp As ADODB.Recordset
    Dim rsXM As ADODB.Recordset
    
    Me.MousePointer = vbHourglass
    '是否有体检标准
    If cmbBZMC.ListCount < 1 Then
        MsgBox "当前没有体检标准，无法导出！", vbInformation, "提示"
        GoTo ExitLab
    End If
    
    '获取文件名
    strOutFileName = GetFileName(Me.CommonDialog1, "文本文件(*.txt)|*.txt", _
            "体检标准导出", "BTTJ_体检标准导出文件.txt", WRITEFILE)
    If strOutFileName = "" Then GoTo ExitLab
    
    If MsgBox("确实要导出体检标准到文件“" & strOutFileName & "”吗？", _
            vbQuestion + vbYesNo + vbDefaultButton2, "询问") = vbNo Then
        GoTo ExitLab
    End If
    
    Set TxtStream = fsoOut.CreateTextFile(strOutFileName, True, True)
    '执行导出操作
    TxtStream.WriteLine Space(30) & "体检标准导出结果"
    TxtStream.WriteLine
    
    Set rsBZ = New ADODB.Recordset
    rsBZ.Open "select * from SET_TJBZIndex where SFQY=1 order by BZID", GCon, adOpenStatic, adLockReadOnly
    If rsBZ.RecordCount > 0 Then
        TxtStream.WriteLine "共有 " & rsBZ.RecordCount & " 条体检标准"
        rsBZ.MoveFirst
        '对每一条标准执行导出操作
        Do While Not rsBZ.EOF
            TxtStream.WriteLine "**********体检标准：" & rsBZ("BZMC") & " 导出结果**********"
            strSQL = "select * from SET_TJBZDT where BZID=" & rsBZ("BZID") & " order by XMID"
            Set rstemp = New ADODB.Recordset
            rstemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
            If Not rstemp.EOF Then
                rstemp.MoveFirst
                Do While Not rstemp.EOF
                    '得出该XMID所对应的项目名称
                    Set rsXM = New ADODB.Recordset
                    strSQL = "select XXMC,XXType from SET_XX where XXID='" & rstemp("XMID") & "'"
                    rsXM.Open strSQL, GCon, adOpenStatic, adLockReadOnly
                    If Not rsXM.EOF Then
                        strXMMC = rsXM("XXMC")
                        strXMSex = strXMMC
                        If rstemp("SEX") = 1 Then
                            strXMSex = strXMSex & "（适用性别：男）"
                        ElseIf rstemp("SEX") = 2 Then
                            strXMSex = strXMSex & "（适用性别：女）"
                        Else
                            '
                        End If
                        TxtStream.WriteLine strXMSex & "："
                        Select Case rsXM("XXType")
                            Case 0, 2   '是说明型或阴阳型
                                TxtStream.WriteLine "标准值：" & rstemp("NormalVal") & ""
                            Case 1      '是数值型
                                TxtStream.WriteLine "参考下限：" & rstemp("CKXX") & "" _
                                                    & " , 参考上限：" & rstemp("CKSX") & "" _
                                                    & "；最小值：" & rstemp("minVal") & "" _
                                                    & " , 最大值：" & rstemp("maxVal") & "" _
                                                    & "；单位：" & rstemp("DW") & ""
                                TxtStream.WriteLine "偏低提示：" & rstemp("LowInfo") & "" _
                                                    & " , 偏高提示：" & rstemp("HighInfo") & ""
                        End Select
                        
                        TxtStream.WriteLine
                    End If
                    
                    rstemp.MoveNext
                Loop
            End If
            rsBZ.MoveNext
        Loop
    End If
    
    TxtStream.Close
    Set TxtStream = Nothing
    Set fsoOut = Nothing
    Call Shell(gstrCurrPath & "wordpad.exe " & Chr(34) & strOutFileName, vbNormalFocus)
         
    GoTo ExitLab
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Me.Caption & ".cmdBackup_Click")
    ErrMsg Status
ExitLab:
    Me.MousePointer = vbDefault
End Sub







Private Sub txtResult_KeyPress(KeyAscii As Integer)
    If KeyAscii = 13 Then
        XPCmdSave_Click
    End If
End Sub

Private Sub txtSX_KeyPress(KeyAscii As Integer)
    If KeyAscii = 8 Then Exit Sub
    If KeyAscii = 46 Then
    If InStr(1, txtSX.Text, Chr(46)) = False Then Exit Sub
    End If
    
    If KeyAscii = 13 Then
        TxtResult.SetFocus
        Exit Sub
    End If

    If KeyAscii < 48 Or KeyAscii > 57 Then
    KeyAscii = 0
    End If
End Sub


Private Sub txtXX_KeyPress(KeyAscii As Integer)
    If KeyAscii = 8 Then Exit Sub
    If KeyAscii = 46 Then
    If InStr(1, txtXX.Text, Chr(46)) = False Then Exit Sub
    End If
    
    If KeyAscii = 13 Then
        txtSX.SetFocus
        Exit Sub
    End If
    
    If KeyAscii < 48 Or KeyAscii > 57 Then
    KeyAscii = 0
    End If
End Sub

'wxw add 20050620
Private Sub XPCmdAdd_Click()
    txtXX.Enabled = True
    txtSX.Enabled = True
    TxtResult.Enabled = True
    txtXX.Text = ""
    txtSX.Text = ""
    TxtResult.Text = ""
    XPCmdEdit.Enabled = False
    XPCmdSave.Enabled = True
    XPCmdSave.Tag = "ADD"
    XPCmdAdd.Enabled = False
    txtXX.SetFocus
    XPCmdDel.Enabled = False
End Sub

Private Sub XPCmdDel_Click()
    LsvBZ.ListItems.Remove LsvBZ.SelectedItem.Index
    cmdSaveInfo.Enabled = True
End Sub

'wxw add 20050620
Private Sub XPCmdEdit_Click()
txtXX.Enabled = True
txtSX.Enabled = True
TxtResult.Enabled = True
XPCmdSave.Enabled = True
XPCmdEdit.Enabled = False
XPCmdAdd.Enabled = False
XPCmdSave.Tag = "EDIT"
XPCmdDel.Enabled = False
End Sub
'wxw add 20050620
Private Sub XPCmdSave_Click()
If txtXX.Text = "" Or txtSX.Text = "" Or TxtResult.Text = "" Then
MsgBox "上限、下限和结果不能为空！", vbExclamation
Exit Sub
End If
XPCmdSave.Enabled = False
txtXX.Enabled = False
txtSX.Enabled = False
TxtResult.Enabled = False
XPCmdAdd.Enabled = True
XPCmdEdit.Enabled = True
If XPCmdSave.Tag = "ADD" Then
    Dim litem As ListItem
    Set litem = LsvBZ.ListItems.Add(, , fraNumTyp.Tag)
    litem.SubItems(1) = txtXX.Text
    litem.SubItems(2) = txtSX.Text
    litem.SubItems(3) = TxtResult.Text
ElseIf XPCmdSave.Tag = "EDIT" Then
If LsvBZ.SelectedItem Is Nothing Then Exit Sub
    LsvBZ.SelectedItem.SubItems(1) = txtXX.Text
    LsvBZ.SelectedItem.SubItems(2) = txtSX.Text
    LsvBZ.SelectedItem.SubItems(3) = TxtResult.Text
End If
cmdSaveInfo.Enabled = True
txtXX.Text = ""
txtSX.Text = ""
TxtResult.Text = ""
End Sub

'wxw add 20050620
'显示数值型标准内容
Private Sub showBz(ByVal strSQL As String)
    Dim rs As ADODB.Recordset
    Dim itm As ListItem
    Set rs = GCon.Execute(strSQL)
    LsvBZ.ColumnHeaders.Clear
    LsvBZ.ColumnHeaders.Add , , , 0
    LsvBZ.ColumnHeaders.Add , , "下限", 800, 1
    LsvBZ.ColumnHeaders.Add , , "上限", 800, 1
    LsvBZ.ColumnHeaders.Add , , "结果", 2300
    LsvBZ.ColumnHeaders.Add , , "是否正常值", 1100
    LsvBZ.ListItems.Clear
    While Not rs.EOF
        Set itm = LsvBZ.ListItems.Add(, , Trim(rs.Fields(0)))
        itm.SubItems(1) = IIf(Left(rs.Fields(1), 1) = ".", "0" & rs.Fields(1), rs.Fields(1))
        itm.SubItems(2) = IIf(Left(rs.Fields(2), 1) = ".", "0" & rs.Fields(2), rs.Fields(2))
        itm.SubItems(3) = Trim(rs.Fields(3))
        itm.SubItems(4) = Trim(IIf(IsNull(rs.Fields(8)), "", rs.Fields(8)))
        rs.MoveNext
    Wend
End Sub

'保存标准
Private Function SaveBZ(ByVal strXXID As String, _
                    ByVal strXX_Min As Double, _
                    ByVal strXX_Max As Double, _
                    ByVal strXX_Value As String, _
                    ByVal Xindex As Integer, _
                    ByVal SEX As Integer, _
                    ByVal AGE As Integer, _
                    ByVal BZid As Integer) As Boolean
    On Error GoTo er
    Dim strSQL As String
    Dim rs As ADODB.Recordset
    Set rs = GCon.Execute("select * from SET_XX_BZ where XX_ID='" & strXXID & "' and Xindex=" & Xindex & " and BZ_ID=" & BZid)
    If rs.RecordCount >= 1 Then
        strSQL = "update SET_XX_BZ set XX_min=" & strXX_Min & ",XX_max=" & strXX_Max & ",XX_Value='" & strXX_Value & "',sex=" & SEX & ",Age=" & AGE & " where XX_ID='" & strXXID & "' and Xindex=" & Xindex & " and BZ_ID=" & BZid
    Else
        strSQL = "insert into SET_XX_BZ (XX_id,XX_min,XX_max,XX_Value,sex,age,Xindex,BZ_id) values('" & strXXID & "'," & strXX_Min & "," & strXX_Max & ",'" & strXX_Value & "'," & SEX & "," & AGE & "," & Xindex & "," & BZid & ")"
    End If
    GCon.Execute strSQL
    SaveBZ = True
    Exit Function
er:
    MsgBox Err.Description
End Function
Private Sub CreateTable()
    Dim rs As ADODB.Recordset
    Set rs = GCon.Execute("select * from sysobjects where name='SET_XX_BZ'")
    If rs.RecordCount <= 0 Then
        Dim str As String
        str = "if exists (select * from dbo.sysobjects where id = object_id(N'[dbo].[SET_XX_BZ]') and OBJECTPROPERTY(id, N'IsUserTable') = 1)  drop table [dbo].[SET_XX_BZ]"
        GCon.Execute str
        
        str = "CREATE TABLE [dbo].[SET_XX_BZ] ("
        str = str & "    [XX_ID] [char] (7) COLLATE Chinese_PRC_CI_AS NOT NULL ,"
        str = str & "    [XX_Min] [float] NULL ,"
        str = str & "    [XX_Max] [float] NULL ,"
        str = str & "    [XX_Value] [char] (30) COLLATE Chinese_PRC_CI_AS NULL ,"
        str = str & "    [SEX] [int] NULL ,"
        str = str & "    [Xindex] [int] NULL ,"
        str = str & "    [Age] [int] NULL ,"
        str = str & "    [BZ_ID] [int] NULL,"
        str = str & "    [ZCZ] [char] (10) COLLATE Chinese_PRC_CI_AS NULL"
        str = str & ") ON [PRIMARY]"
        GCon.Execute str
        ConvertData
    End If

End Sub

'倒入体检标准数据,将原来上下限区间改为三个区段:
'0-下限        偏低
'下限 -上限    正常
'上限 - 上限*3 偏高
Private Sub ConvertData()
    Dim rs, rs1 As ADODB.Recordset
    Dim str As String
    Set rs1 = GCon.Execute("select BZid from SET_TJBZIndex")
    While Not rs1.EOF
        str = "SELECT dbo.SET_TJBZDT.BZID, dbo.SET_TJBZDT.XMID, dbo.SET_TJBZDT.CKSX, "
        str = str & "dbo.SET_TJBZDT.CKXX , dbo.SET_XX.XXType,dbo.SET_TJBZDT.SEX FROM dbo.SET_XX INNER JOIN "
        str = str & "dbo.SET_TJBZDT ON dbo.SET_XX.XXID = dbo.SET_TJBZDT.XMID WHERE ((dbo.SET_XX.XXType = 1) OR"
        str = str & "(dbo.SET_XX.XXType = 3)) and dbo.SET_TJBZDT.BZID=" & rs1!BZid
        Set rs = GCon.Execute(str)
        While Not rs.EOF
        If Not (IsNull(rs!CKXX) Or rs!CKXX = "") Then
            GCon.Execute "insert into SET_XX_BZ(XX_ID,XX_Min,XX_Max,XX_Value,SEX,Xindex,Age,BZ_ID) values('" & rs!XMID & "',0," & IIf(IsNull(rs!CKXX) Or rs!CKXX = "", 0, rs!CKXX) & ",'偏低'," & rs!SEX & ",1, 0 ," & rs!BZid & ")"
        End If
        
        If Not ((IsNull(rs!CKXX) Or rs!CKXX = "") And (IsNull(rs!CKSX) Or rs!CKSX = "")) Then
            GCon.Execute "insert into SET_XX_BZ(XX_ID,XX_Min,XX_Max,XX_Value,SEX,Xindex,Age,BZ_ID,Zcz) values('" & rs!XMID & "'," & IIf(IsNull(rs!CKXX) Or rs!CKXX = "", 0, rs!CKXX) & "," & IIf(IsNull(rs!CKSX) Or rs!CKSX = "", 0, rs!CKSX) & ",'正常'," & rs!SEX & ", 2 ,0," & rs!BZid & ",'正常值')"
        End If
        
        If Not (IsNull(rs!CKSX) Or rs!CKSX = "") Then
            GCon.Execute "insert into SET_XX_BZ(XX_ID,XX_Min,XX_Max,XX_Value,SEX,Xindex,Age,BZ_ID) values('" & rs!XMID & "'," & IIf(IsNull(rs!CKSX) Or rs!CKSX = "", 0, rs!CKSX) & "," & IIf(IsNull(rs!CKSX) Or rs!CKSX = "", 0, rs!CKSX) * 3 & ",'偏高'," & rs!SEX & ",3," & 0 & "," & rs!BZid & ")"
        End If
            rs.MoveNext
        Wend
    rs1.MoveNext
    Wend
    
End Sub