frmhcsyqk.frm

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

Private Sub cmdQuery_Click()
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim rstemp As ADODB.Recordset
    Dim strYYID As String
    Dim strAssisSQL As String
    
    Me.MousePointer = vbHourglass
    
    '检查日期是否符合条件
    If dtpBegin.Value > dtpStop.Value Then
        MsgBox "起始日期不能大一终止日期！请重新输入！", vbInformation, "提示"
        dtpBegin.SetFocus
        GoTo ExitLab
    End If
    
    '终止日期是否大于当前日期
    If dtpStop.Value > Date Then
        MsgBox "终止日期不能大于当前日期！请重新输入！", vbInformation, "提示"
        dtpStop.SetFocus
        GoTo ExitLab
    End If
    
    '获取起始日期
    mdtmBegin = dtpBegin.Value
    mdtmStop = dtpStop.Value & " 23:59:59"
    
    '是否选择了团体
    If cmbDWei.Text <> "" Then
        strYYID = arrYYID(cmbDWei.ItemData(cmbDWei.ListIndex))
        strAssisSQL = " and SET_GRXX.YYID='" & strYYID & "'"
    Else
        strAssisSQL = ""
    End If
    
    '检索符合条件的所有人员记录
    strSQL = "select SET_GRXX.GUID as 流水号,HealthID as " & g_strSystemIDTitle _
            & ",SelfBH as " & g_strSelfIDTitle & ",TJSerialNum as 体检序号" _
            & ",YYRXM as 姓名,Sex as 性别,TJRQ as 体检日期" _
            & " from SET_GRXX" _
            & " where TJRQ between '" & mdtmBegin & "' and '" & mdtmStop & "'" _
            & strAssisSQL _
            & " and SET_GRXX.GUID in(" _
            & "select distinct YY_SJDJDX.GUID from YY_SJDJDX" _
            & " where YY_SJDJDX.GUID=SET_GRXX.GUID" _
            & " and SFTJ=1)"
    Set rstemp = New ADODB.Recordset
    rstemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
    If rstemp.RecordCount < 1 Then
        lblInfo.Caption = ""
        MsgBox "没有找到匹配记录，请重新设置查询条件！", vbInformation, "提示"
        dtpBegin.SetFocus
        GoTo ExitLab
    Else
        lblInfo.Caption = "查询到 " & rstemp.RecordCount & " 人"
    End If
    rstemp.Close
    Set rstemp = Nothing
    
    RefreshGrid Me, Me.MSHFlexGrid1, strSQL
    
    '默认选中第一行
    If Me.MSHFlexGrid1.TextMatrix(1, 0) <> "" Then
        With Me.MSHFlexGrid1
            .Row = 1
            .col = 0
            .ColSel = .Cols - 1
        End With
    End If
    
    If optZL.Value Then
        optZLClick
    Else
        optGRClick
    End If
    
    GoTo ExitLab
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    Me.MousePointer = vbDefault
End Sub

Private Sub Form_Load()
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim rstemp As ADODB.Recordset
    Dim i As Integer
    
    Screen.MousePointer = vbHourglass
    
    '初始化日期
    dtpBegin.Value = Date
    dtpStop.Value = Date
    
    '设置网格第一列的宽度
    '用于存放流水号
    Me.MSHFlexGrid1.ColWidth(0) = 0
    If Not g_blnSystemID Then
        Me.MSHFlexGrid1.ColWidth(1) = 0
    End If
    If Not g_blnSelfID Then
        Me.MSHFlexGrid1.ColWidth(2) = 0
    End If
    
    '用于存放耗材编号
    Me.MSHFlexGrid2.ColWidth(0) = 0
    
    '显示所有预约的团体
    '刷新团体信息
    strSQL = "select YYID,DWMC" _
            & " from YY_TJDJ,SET_DW" _
            & " where YY_TJDJ.DWID=SET_DW.DWID" _
            & " order by JLRQ desc"
    Set rstemp = New ADODB.Recordset
    rstemp.Open strSQL, GCon, adOpenKeyset, adLockOptimistic
    cmbDWei.Clear
    If rstemp.RecordCount > 0 Then
        ReDim arrYYID(rstemp.RecordCount)
        
        '首先添加一个空行，以便用户不选择单位
        cmbDWei.AddItem ""
        
        '添加已经预约过的团体
        rstemp.MoveFirst
        For i = 1 To rstemp.RecordCount
            cmbDWei.AddItem rstemp("DWMC")
            cmbDWei.ItemData(cmbDWei.NewIndex) = i
            arrYYID(i) = rstemp("YYID") 'YYID字段太长，ItemData属性无法存放，只能存入数组
            
            rstemp.MoveNext
        Next
        rstemp.Close
        Set rstemp = Nothing
        
        cmbDWei.ListIndex = 0
    End If
    
    GoTo ExitLab
    
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    Screen.MousePointer = vbDefault
End Sub

Private Sub optGRClick()
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim lngGUID As Long
    
    Me.MousePointer = vbHourglass
    
    '检查第一个网格里面是否有记录
    If Me.MSHFlexGrid1.TextMatrix(1, 0) = "" Then GoTo ExitLab
    
    '记录唯一编号
    lngGUID = Val(Me.MSHFlexGrid1.TextMatrix(Me.MSHFlexGrid1.Row, 0))
    If lngGUID < 1 Then GoTo ExitLab
    
    '如果有记录，则检索符合条件的耗材使用总量
    strSQL = "select HCID,HCMC as 耗材名称,sum(YL) as 总用量,sum(Price) as 总费用,HCSM as 耗材说明" _
            & " from" _
            & " (select SET_GRXX.GUID,TJHC_HCXM.HCID,HCMC,YL,Price,HCSM" _
            & " from SET_GRXX,YY_SJDJDX,TJHC_HCXM,TJHC_Index" _
            & " where SET_GRXX.GUID=" & lngGUID _
            & " and SET_GRXX.GUID=YY_SJDJDX.GUID" _
            & " and YY_SJDJDX.SFTJ=1" _
            & " and len(TJHC_HCXM.XMID)>=4" _
            & " and YY_SJDJDX.DXID=left(TJHC_HCXM.XMID,4)" _
            & " and TJHC_HCXM.HCID=TJHC_Index.HCID)" _
            & " AS TemptableA"
    strSQL = strSQL & " group by HCID,HCMC,HCSM"
    strSQL = strSQL & " union "
    strSQL = strSQL & "select HCID,HCMC as 耗材名称,sum(YL) as 总用量,sum(Price) as 总费用,HCSM as 耗材说明" _
            & " from" _
            & " (select SET_GRXX.GUID,TJHC_HCXM.HCID,HCMC,YL,Price,HCSM" _
            & " from SET_GRXX,YY_SJDJDX,TJHC_HCXM,TJHC_Index" _
            & " where SET_GRXX.GUID=" & lngGUID _
            & " and SET_GRXX.GUID=YY_SJDJDX.GUID" _
            & " and YY_SJDJDX.SFTJ=1" _
            & " and len(TJHC_HCXM.XMID)=2" _
            & " and left(YY_SJDJDX.DXID,2)=TJHC_HCXM.XMID" _
            & " and TJHC_HCXM.HCID=TJHC_Index.HCID)" _
            & " AS TemptableB"
    strSQL = strSQL & " group by HCID,HCMC,HCSM"

    RefreshGrid Me, Me.MSHFlexGrid2, strSQL
    
    GoTo ExitLab
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    Me.MousePointer = vbDefault
End Sub

Private Sub optZLClick()
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim strYYID As String
    Dim strAssisSQL As String
    
    Me.MousePointer = vbHourglass
    
    '检查第一个网格里面是否有记录
    If Me.MSHFlexGrid1.TextMatrix(1, 0) = "" Then GoTo ExitLab
    
    '是否选择了团体
    If cmbDWei.Text <> "" Then
        strYYID = arrYYID(cmbDWei.ItemData(cmbDWei.ListIndex))
        strAssisSQL = " and SET_GRXX.YYID='" & strYYID & "'"
    Else
        strAssisSQL = ""
    End If
    
    '如果有记录，则检索符合条件的耗材使用总量
    strSQL = "select HCID,HCMC as 耗材名称,sum(YL) as 总用量,sum(Price) as 总费用,HCSM as 耗材说明" _
            & " from" _
            & " (select SET_GRXX.GUID,TJHC_HCXM.HCID,HCMC,YL,Price,HCSM" _
            & " from SET_GRXX,YY_SJDJDX,TJHC_HCXM,TJHC_Index" _
            & " where SET_GRXX.TJRQ between '" & mdtmBegin & "' and '" & mdtmStop & "'" _
            & strAssisSQL _
            & " and SET_GRXX.GUID=YY_SJDJDX.GUID" _
            & " and YY_SJDJDX.SFTJ=1" _
            & " and len(TJHC_HCXM.XMID)>=4" _
            & " and YY_SJDJDX.DXID=left(TJHC_HCXM.XMID,4)" _
            & " and TJHC_HCXM.HCID=TJHC_Index.HCID)" _
            & " AS TemptableA"
    strSQL = strSQL & " group by HCID,HCMC,HCSM"
    strSQL = strSQL & " union "
    strSQL = strSQL & "select HCID,HCMC as 耗材名称,sum(YL) as 总用量,sum(Price) as 总费用,HCSM as 耗材说明" _
            & " from" _
            & " (select SET_GRXX.GUID,TJHC_HCXM.HCID,HCMC,YL,Price,HCSM" _
            & " from SET_GRXX,YY_SJDJDX,TJHC_HCXM,TJHC_Index" _
            & " where SET_GRXX.TJRQ between '" & mdtmBegin & "' and '" & mdtmStop & "'" _
            & strAssisSQL _
            & " and SET_GRXX.GUID=YY_SJDJDX.GUID" _
            & " and YY_SJDJDX.SFTJ=1" _
            & " and len(TJHC_HCXM.XMID)=2" _
            & " and left(YY_SJDJDX.DXID,2)=TJHC_HCXM.XMID" _
            & " and TJHC_HCXM.HCID=TJHC_Index.HCID)" _
            & " AS TemptableB"
    strSQL = strSQL & " group by HCID,HCMC,HCSM"

    RefreshGrid Me, Me.MSHFlexGrid2, strSQL
    
    GoTo ExitLab
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    Me.MousePointer = vbDefault
End Sub

Private Sub MSHFlexGrid1_Click()
    If optGR.Value Then
        optGRClick
    End If
End Sub

Private Sub optGR_Click()
    cmdQuery_Click
End Sub

Private Sub optZL_Click()
    cmdQuery_Click
End Sub