📄 formbzb_yxhz.frm
字号:
'记录当前选择单位的预约编号
strYYID = arrYYID(cmbDWei.ItemData(cmbDWei.ListIndex))
'获取当前单位的总人数
strSQL = "select Count(*) from SET_GRXX" _
& " where YYID='" & strYYID & "'"
Set rsTemp = New ADODB.Recordset
rsTemp.Open strSQL, GCon, adOpenStatic, adLockOptimistic
intCount = rsTemp(0)
rsTemp.Close
If intCount < 1 Then
MsgBox "当前单位“" & cmbDWei.Text & "”没有人员参加体检，无从导出！，", vbInformation, "提示"
GoTo ExitLab
End If
'******************************************************************
'写入题头
'******************************************************************
strSummary = "单位体检阳性指征名单：" & vbCrLf
strSuggest = "症状分析及建议：" & vbCrLf
'******************************************************************
'写入详细信息
'******************************************************************
'循环所有选择的项目
intIndex = 0
For i = 1 To tvwXMu.Nodes.Count
'首先判断选择的是大项还是小项
strXMID = Mid(tvwXMu.Nodes(i).Key, 2)
strSQL = ""
If (Len(strXMID) = 11) And (tvwXMu.Nodes(i).Checked = True) Then
strXMID = Right(strXMID, 7)
'******************************************************************
'选择了小项
'******************************************************************
strSQL = "select DXPYSX,XXPYSX,XXType from SET_XX,SET_DX" _
& " where SET_XX.XXID='" & strXMID & "'" _
& " and SET_DX.DXID='" & Mid(tvwXMu.Nodes(i).Parent.Key, 2) & "'"
End If
If strSQL <> "" Then
'******************************************************************
'如果查询语句不为空，说明为最终的体检项目，需要进行统计
'******************************************************************
strXMMC = tvwXMu.Nodes(i).Text
Set rsHZ = New ADODB.Recordset
rsHZ.Open strSQL, GCon, adOpenStatic, adLockOptimistic
If rsHZ.RecordCount > 0 Then
If Len(strXMID) = 4 Then
strDXPYSX = rsHZ(0)
intType = rsHZ(1)
Else
strDXPYSX = rsHZ(0)
strXXPYSX = rsHZ(1)
intType = rsHZ(2)
End If
rsHZ.Close
'***********************************
'以下构建查询语句的Select部分
'***********************************
strSelect = "select distinct SET_GRXX.GUID as 流水号,SET_GRXX.YYRXM as 姓名"
If Len(strXMID) = 4 Then
strSelect = strSelect & ",[" & strDXPYSX & "Value]"
Else
strSelect = strSelect & ",[Data_" & strDXPYSX & "].[" & strXXPYSX & "]"
End If
strSelect = strSelect & " as [抽查结果]"
strSelect = strSelect & ",DW,CKXX,CKSX"
' strSelect = strSelect & ",NormalVal as 标准值"
'***********************************
'以下构建用户的查询条件
'***********************************
If intType = 1 Then
'数值型
If Len(strXMID) = 4 Then
'大项
strCondition = " and (cast([" & strDXPYSX & "Value] as float)<cast(CKXX as float)" _
& " or cast([" & strDXPYSX & "Value] as float)>cast(CKSX as float))"
Else
'小项
strCondition = " and (cast([Data_" & strDXPYSX & "].[" & strXXPYSX & "] as float)<cast(CKXX as float)" _
& " or cast([Data_" & strDXPYSX & "].[" & strXXPYSX & "] as float)>cast(CKSX as float))"
End If
Else
'非数值型
If Len(strXMID) = 4 Then
'大项
strCondition = " and [" & strDXPYSX & "Value]<>NormalVal"
Else
'小项
strCondition = " and [Data_" & strDXPYSX & "].[" & strXXPYSX & "]<>NormalVal"
End If
End If
'设置性别
If optMale.Value = True Then
strCondition = strCondition & " and SET_GRXX.SEX='男'"
End If
If optFemale.Value = True Then
strCondition = strCondition & " and SET_GRXX.SEX='女'"
End If
'体检日期
strCondition = strCondition & " and [DATA_" & strDXPYSX & "].TJRQ>='" & dtpBegin.Value & "'" _
& " and [DATA_" & strDXPYSX & "].TJRQ<='" & dtpStop.Value & " 23:59:59'"
'***********************************
'以下根据用户选择决定显示全部还是只显示团检客户
'***********************************
'团体总是要包括
strTJ = " from SET_GRXX,FZ_FZSJ,FZ_FZSY,SET_TJBZDT,[Data_" & strDXPYSX & "]" _
& " where not (SET_GRXX.YYID is null)" _
& " and SET_GRXX.YYID=FZ_FZSJ.YYID" _
& " and SET_GRXX.GUID=FZ_FZSJ.GUID"
If cmbDWei.Text <> "" Then
'只有选择团体时才加下一判断
strTJ = strTJ & " and FZ_FZSJ.YYID='" & strYYID & "'"
End If
strTJ = strTJ & " and FZ_FZSJ.FZID=FZ_FZSY.FZID" _
& " and FZ_FZSY.BZID=SET_TJBZDT.BZID" _
& " and SET_TJBZDT.XMID='" & strXMID & "'" _
& " and [Data_" & strDXPYSX & "].GUID=SET_GRXX.GUID"
'***********************************
'构建最后的查询语句
'***********************************
strSQL = strSelect & strTJ & strCondition
'***********************************
'执行查询
'***********************************
Set rsHZ = New ADODB.Recordset
rsHZ.Open strSQL, GCon, adOpenStatic, adLockOptimistic
intIndex = intIndex + 1
strSummary = strSummary & intIndex & "、" & strXMMC & vbCrLf & " "
strSuggest = strSuggest & intIndex & "、" & strXMMC & vbCrLf & " "
strTempSuggest = ""
If rsHZ.RecordCount < 1 Then
'全部体检通过
strSummary = strSummary & "（无）"
strSuggest = strSuggest & "（全体通过）"
Else
'**************************************************
'有客户未通过体检
'**************************************************
strSuggest = strSuggest & "本次体检“" & strXMMC & "”不正常者共 " _
& rsHZ.RecordCount & " 人，占单位体检人数的" _
& Format(rsHZ.RecordCount * 100 / intCount, "##.##") & "%。" _
& vbCrLf _
& "建议：" _
& vbCrLf & " "
rsHZ.MoveFirst
'循环每个取出的记录集
blnHave = False
Do
If Trim(rsHZ("抽查结果")) <> "" Then
blnHave = True
If intType = 1 Then
'数值型
strSummary = strSummary & rsHZ("姓名")
If Val(rsHZ("抽查结果")) < Val(rsHZ("CKXX")) Then
strJYMC = strXMMC & "偏低"
Else
strJYMC = strXMMC & "偏高"
End If
Else
'说明型
strSummary = strSummary & rsHZ("姓名")
'判断是否阴阳型
If rsHZ("抽查结果") = "阳性" Then
strJYMC = strXMMC & "阳性"
Else
strJYMC = rsHZ("抽查结果")
End If
End If
strSQL = "select JYNR from DM_ZJJY" _
& " where JYMC='" & strJYMC & "'"
'姓名后面跟一个逗号
strSummary = strSummary & "，"
'检查是否有建议
Set rsTemp = New ADODB.Recordset
rsTemp.Open strSQL, GCon, adOpenStatic, adLockOptimistic
If rsTemp.RecordCount > 0 Then
If Not IsNull(rsTemp(0)) Then
If InStr(1, strTempSuggest, rsTemp(0)) < 1 Then
strTempSuggest = strTempSuggest & strJYMC & "：" & rsTemp(0) & vbCrLf
End If
End If
End If
End If
rsHZ.MoveNext
Loop Until rsHZ.EOF
rsHZ.Close
If blnHave = True Then
'截掉最后一个逗号
strSummary = Left(strSummary, Len(strSummary) - 1)
End If
If strTempSuggest <> "" Then
strSuggest = strSuggest & strTempSuggest
End If
End If
'每个项目后面跟一个回车换行
strSummary = strSummary & vbCrLf
strSuggest = strSuggest & vbCrLf
'不要让系统呈现死机状态
DoEvents
End If
End If
Next i
'判断是否有记录
If strSummary = "" Then
MsgBox "没有记录！", vbInformation, "提示"
GoTo ExitLab
End If
'最后写入文件
If WriteTextFile(strFileName, strSummary & vbCrLf & strSuggest) Then
'用记事本打开文件
Shell "notepad.exe " & strFileName, vbNormalFocus
End If
GoTo ExitLab
ErrMsg:
Status = SetError(Err.Number, Err.Description, Err.Source)
ErrMsg Status
ExitLab:
Me.MousePointer = 0
End Sub
Private Sub CmdQuery_Click()
On Error GoTo ErrMsg
Dim Status
Dim strSQL As String
Dim strSelect As String 'SQL语句的Select部分
Dim strSJ As String '散检部分
Dim strTJ As String '团检部分
Dim strCondition As String '用户输入的查询条件
Dim rsHZ As ADODB.Recordset
Dim strXMID As String '项目ID
Dim strDXPYSX As String
Dim strXXPYSX As String
Dim intType As Integer '项目类型
Me.MousePointer = 11
'是否选择了单位
' If cmbDWei.Text = "" Then
' MsgBox "请选择要汇总的单位！", vbInformation, "提示"
' GoTo ExitLab
' End If
'日期是否符合规范
If dtpBegin.Value > dtpStop.Value Then
MsgBox "起始日期不应大于终止日期！请核对后重新输入！", vbInformation, "提示"
dtpBegin.SetFocus
GoTo ExitLab
End If
'用户是否选择
If tvwXMu.SelectedItem Is Nothing Then
MsgBox "请在左侧的树形结构中选择要汇总的项目！", vbInformation, "提示"
GoTo ExitLab
End If
'是否选择的是科室或根节点，或组合
If Len(tvwXMu.SelectedItem.Key) <= 5 Then
MsgBox "请选择左侧树形结构中科室下的具体项目！", vbInformation, "提示"
GoTo ExitLab
End If
'******************************************************
'检验完毕
'******************************************************
'构造查询语句
'首先判断选择的是大项还是小项
strXMID = Mid(tvwXMu.SelectedItem.Key, 6)
'选择了小项
strSQL = "select DXPYSX,XXPYSX,XXType from SET_XX,SET_DX" _
& " where SET_XX.XXID='" & strXMID & "'" _
& " and SET_DX.DXID='" & Mid(tvwXMu.SelectedItem.Parent.Key, 2) & "'"
Set rsHZ = New ADODB.Recordset
rsHZ.Open strSQL, GCon, adOpenStatic, adLockOptimistic
If rsHZ.RecordCount > 0 Then
If Len(strXMID) = 4 Then
strDXPYSX = rsHZ(0)
intType = rsHZ(1)
Else
strDXPYSX = rsHZ(0)
strXXPYSX = rsHZ(1)
intType = rsHZ(2)
End If
rsHZ.Close
'***********************************
'以下构建查询语句的Select部分
'***********************************
strSelect = "select distinct SET_GRXX.GUID as 流水号,YYRXM as 姓名,SET_GRXX.SEX as 性别" _
& ",[DATA_" & strDXPYSX & "].TJRQ as 体检日期,"
If Len(strXMID) = 4 Then
strSelect = strSelect & "[" & strDXPYSX & "Value]"
Else
strSelect = strSelect & "[Data_" & strDXPYSX & "].[" & strXXPYSX & "]"
End If
strSelect = strSelect & " as [抽查结果(" & tvwXMu.SelectedItem.Text & ")]"
strSelect = strSelect & ",NormalVal as 标准值"
'***********************************
'以下构建用户的查询条件
'***********************************
If intType = 1 Then
'数值型
'小项
strCondition = " and (cast([Data_" & strDXPYSX & "].[" & strXXPYSX & "] as float)<cast(CKXX as float)" _
& " or cast([Data_" & strDXPYSX & "].[" & strXXPYSX & "] as float)>cast(CKSX as float))"
Else
'非数值型
'小项
strCondition = " and [Data_" & strDXPYSX & "].[" & strXXPYSX & "]<>NormalVal"
End If
'设置性别
If optMale.Value = True Then
strCondition = strCondition & " and SET_GRXX.SEX='男'"
End If
If optFemale.Value = True Then
strCondition = strCondition & " and SET_GRXX.SEX='女'"
End If
'体检日期
strCondition = strCondition & " and [DATA_" & strDXPYSX & "].TJRQ>='" & dtpBegin.Value & "'" _
& " and [DATA_" & strDXPYSX & "].TJRQ<='" & dtpStop.Value & " 23:59:59'"
'***********************************
'以下根据用户选择决定显示全部还是只显示团检客户
'***********************************
'团体总是要包括
strTJ = " from SET_GRXX,FZ_FZSJ,FZ_FZSY,SET_TJBZDT,[Data_" & strDXPYSX & "]" _
& " where not (SET_GRXX.YYID is null)" _
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -