frmfyhz.frm

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

    If Printer.Copies < 1 Then Printer.Copies = 1
    '纵向走纸
    Printer.Orientation = cdlPortrait
On Error GoTo Print_Cancel
    '设成A4纸
    Err.Clear
    Printer.ScaleMode = vbMillimeters
    Printer.ScaleWidth = 210
    Printer.ScaleHeight = 297
    
    '调用打印程序
    '打印选中的每一条记录
    For i = 1 To lvwSJRY.ListItems.Count
        '总计行不能打印
        If (lvwSJRY.ListItems(i).Selected = True) And (Len(lvwSJRY.ListItems(i).Key) > 1) Then
            Call PrintFYQD(Val(Mid(lvwSJRY.ListItems(i).Key, 2)))
        End If
    Next
'    If MsgBox("已经就绪,立即打印吗?", vbYesNo + vbQuestion + vbDefaultButton1, "打印提示") = vbYes Then
'       Printer.EndDoc
'    Else
'       Printer.KillDoc
'    End If
    Exit Sub
Print_Cancel:
    MousePointer = vbDefault
    If Err.Number <> cdlCancel Then
        Status = SetError(Err.Number, "无法完成打印，请确认打印机电源已经开启并与计算机正确连接！:" _
                & vbCrLf & Err.Description, Err.Source)
        ErrMsg Status
    End If
End Sub

'打印当前选择用户的费用清单
Public Sub PrintFYQD(ByVal lngGUID As Long)
On Error GoTo ErrMsg
    Dim Status
    Dim strHealthID As String '当前选中客户
    Dim strYYID As String
    Dim strSQL As String
    Dim rstemp As ADODB.Recordset
    Dim i As Integer
    Dim strName As String
    Dim strSex As String
    Dim strTJRQ As String
    Dim blnTC As Boolean '是否选择了套餐
    Dim lngTCID As Long '套餐ID
    Dim strTCMC As String '套餐名称
    Dim curTCJG As Currency '套餐价格
    Dim curTotal As Currency '项目总价格
    Dim curOtherXMu As Currency '加项价格
    Dim sngZheKou As Single '折扣
    Dim curTotal_CJJG As Currency '成交价格
    Dim curPayed As Currency '已支付
    
    Dim intPage As Integer
    Dim sngCurrY As Single
    Dim intCurrLine As Integer
    
    Dim sngTitleTop As Single
    Dim sngHospitalTop As Single
    
    Dim sngPersonTop As Single
    Dim sngTextLeft As Single
    Dim sngKShiLeft As Single '科室
    Dim sngXMuLeft As Single '项目
    Dim sngTCanLeft As Single '套餐
    Dim sngJGeLeft As Single '价格
    Dim sngHeaderTop As Single
    Dim sngTextTop As Single
    Dim sngTextBottom As Single
    Dim sngPageNumberTop As Single
    
    Me.MousePointer = vbHourglass
    
    sngTitleTop = 25
    sngHospitalTop = 34
    sngPersonTop = 42
    sngTextLeft = 30
    sngKShiLeft = sngTextLeft
    sngXMuLeft = sngTextLeft + 30
    sngTCanLeft = sngTextLeft + 80
    sngJGeLeft = sngTextLeft + 120
    sngHeaderTop = 52
    sngTextTop = 59
    sngTextBottom = 272
    sngPageNumberTop = 285

    strSQL = "select HealthID,SelfBH,YYRXM,SEX,YYID,TJRQ,CJJG from SET_GRXX" _
                & " where GUID=" & lngGUID
    Set rstemp = New ADODB.Recordset
    rstemp.Open strSQL, GCon, adOpenStatic, adLockOptimistic
    If Not g_blnSelfID Then
        strHealthID = rstemp("HealthID")
    Else
        strHealthID = rstemp("SelfBH") & ""
    End If
    strName = rstemp("YYRXM")
    strSex = rstemp("Sex")
    strYYID = rstemp("YYID") & ""
    strTJRQ = str(rstemp("TJRQ"))
    If Not IsNull(rstemp("CJJG")) Then
        curTotal_CJJG = rstemp("CJJG")
    End If
    rstemp.Close
    
    sngZheKou = 1
    
    '获取已支付费用
    strSQL = "select isnull(Sum(SFFY),0) from SET_SFMX_GR" _
            & " where GUID=" & lngGUID
    Set rstemp = New ADODB.Recordset
    rstemp.Open strSQL, GCon, adOpenForwardOnly, adLockReadOnly
    curPayed = rstemp(0)
    rstemp.Close
    
    If strYYID = "" Then
        '********************************************************************
        '散检客户
        '********************************************************************
        strSQL = "select XZTC,TCID from YY_SJDJ" _
                & " where GUID=" & lngGUID
    Else
        '********************************************************************
        '团检客户
        '********************************************************************
        '首先计算个人加项费用
        strSQL = "select isnull(Sum(DXJG),0) from SET_DX" _
                & " where DXID in(" _
                    & "select DXID from YY_SJDJDX" _
                    & " where GUID=" & lngGUID _
                & ")" _
                & " and DXID not in(" _
                    & "select DXID from YY_TJDJDX" _
                    & " where YYID='" & strYYID & "'" _
                    & " and FZID in(" _
                        & "select FZID from FZ_FZSJ" _
                        & " where GUID=" & lngGUID _
                    & ")" _
                & ")"
        Set rstemp = New ADODB.Recordset
        rstemp.Open strSQL, GCon, adOpenForwardOnly, adLockReadOnly
        curOtherXMu = rstemp(0)
        rstemp.Close
        
        '套餐选择情况
        strSQL = "select distinct XZTC,TCID from YY_TJDJTC,FZ_FZSJ" _
                & " where YY_TJDJTC.YYID=FZ_FZSJ.YYID" _
                & " and YY_TJDJTC.FZID=FZ_FZSJ.FZID" _
                & " and FZ_FZSJ.GUID=" & lngGUID
    End If
    Set rstemp = New ADODB.Recordset
    rstemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
    If Not rstemp.EOF Then
        If rstemp("XZTC") = True Then
            blnTC = True
            lngTCID = rstemp("TCID")
            
            '获取套餐名称，价格等信息
            strSQL = "select * from SET_TC" _
                    & " where TCID=" & lngTCID
            rstemp.Close
            Set rstemp = New ADODB.Recordset
            rstemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
            If Not rstemp.EOF Then
                strTCMC = rstemp("TCMC")
                curTCJG = rstemp("TCJG")
            End If
        Else
            '未选择套餐
            blnTC = False
        End If
        If Not rstemp.EOF Then rstemp.Close
    Else
        '未选择套餐
        blnTC = False
    End If
    
    '提取体检项目
    If blnTC = False Then
        strSQL = "select DXMC,DXJG,TCMC='',KSMC,SET_KSSZ.SXH,SET_DX.SXH" _
                & " from YY_SJDJDX,SET_DX,SET_KSSZ" _
                & " where YY_SJDJDX.GUID=" & lngGUID _
                & " and YY_SJDJDX.DXID=SET_DX.DXID" _
                & " and left(SET_DX.DXID,2)=SET_KSSZ.KSID" _
                & " order by SET_KSSZ.SXH,SET_DX.SXH"
    Else
        '首先提取属于套餐的项目
        strSQL = "select DXMC,DXJG,TCMC='" & strTCMC & "',KSMC,SET_KSSZ.SXH,SET_DX.SXH" _
                & " from YY_SJDJDX,SET_DX,SET_KSSZ" _
                & " where YY_SJDJDX.GUID=" & lngGUID _
                & " and YY_SJDJDX.DXID=SET_DX.DXID" _
                & " and YY_SJDJDX.DXID in (" _
                    & "select DXID from SET_TCDX" _
                    & " where TCID=" & lngTCID & ")" _
                & " and left(SET_DX.DXID,2)=SET_KSSZ.KSID"
        strSQL = strSQL & " union "
        '连上不属于套餐的项目
        strSQL = strSQL & "select DXMC,DXJG,TCMC='',KSMC,SET_KSSZ.SXH,SET_DX.SXH" _
                & " from YY_SJDJDX,SET_DX,SET_KSSZ" _
                & " where YY_SJDJDX.GUID=" & lngGUID _
                & " and YY_SJDJDX.DXID=SET_DX.DXID" _
                & " and YY_SJDJDX.DXID not in (" _
                    & "select DXID from SET_TCDX" _
                    & " where TCID=" & lngTCID & ")" _
                & " and left(SET_DX.DXID,2)=SET_KSSZ.KSID"
                
        strSQL = strSQL & " order by SET_KSSZ.SXH,SET_DX.SXH"
    End If
    
    Set rstemp = New ADODB.Recordset
    rstemp.Open strSQL, GCon, adOpenStatic, adLockOptimistic
    If rstemp.EOF Then GoTo ExitLab
    curTotal = 0
    
    DoEvents
    
    intPage = 1 '从第一页开始
    '打印第一页的标题
    GoSub PrintTitle
    
    rstemp.MoveFirst
    With Printer
        '打印报表正文
        '循环打印所有记录
        intCurrLine = 1
        For i = 1 To rstemp.RecordCount
            .FontSize = 9
            .FontBold = False
            '计算纵坐标
            sngCurrY = sngTextTop + (intCurrLine - 1) * .TextHeight("高度") * 1.5
            If sngCurrY > sngTextBottom Then '该分页
                Printer.NewPage
                intPage = intPage + 1
                GoSub PrintTitle
                
                intCurrLine = 1
                .FontSize = 9
                .FontBold = False
                '分页后重新计算纵坐标
                sngCurrY = sngTextTop + (intCurrLine - 1) * .TextHeight("高度") * 1.5
            End If
            '科室名称
            .CurrentX = sngTextLeft
            .CurrentY = sngCurrY
            Printer.Print rstemp("KSMC")
            
            '大项名称
            .CurrentX = sngTextLeft + 30
            .CurrentY = sngCurrY
            Printer.Print rstemp("DXMC")
            
            '套餐名称
            .CurrentX = sngTextLeft + 80
            .CurrentY = sngCurrY
            Printer.Print rstemp("TCMC")
            
            If rstemp("TCMC") = "" Then
                '大项价格
                .CurrentX = sngTextLeft + 120
                .CurrentY = sngCurrY
                Printer.Print rstemp("DXJG") & ""
            End If
            
            curTotal = curTotal + IIf(IsNull(rstemp("DXJG")), "", rstemp("DXJG"))
            
            intCurrLine = intCurrLine + 1
            rstemp.MoveNext
        Next
        rstemp.Close
        
        '打印合计行
        '在最后一页上打印合计
        .FontSize = 9
        .FontBold = True
        sngCurrY = sngTextTop + (intCurrLine - 1) * .TextHeight("高度") * 1.5 + 5
        Printer.Line (sngTextLeft - 5, sngCurrY - 1.5)-(sngTextLeft + sngJGeLeft + 10, sngCurrY - 1.5)
        .CurrentX = sngTextLeft - 5
        .CurrentY = sngCurrY
        Printer.Print "总计："
        
        .CurrentX = sngTextLeft + 7
        .CurrentY = sngCurrY
        Printer.Print "项目累计：" & CStr(curTotal) & " 元"
        
        If strYYID <> "" Then
            .CurrentX = sngTextLeft + 45
            .CurrentY = sngCurrY
            Printer.Print "其中个人加项：" & CStr(curOtherXMu) & " 元"
        End If
        
        .CurrentX = sngTextLeft + 90
        .CurrentY = sngCurrY
        Printer.Print "实际：" & CStr(curTotal_CJJG) & " 元"
        
        .CurrentX = sngTextLeft + 120
        .CurrentY = sngCurrY
        Printer.Print "已收：" & CStr(curPayed) & " 元"
        
        '为每个客户提交一次打印
        Printer.EndDoc
    End With
    GoTo ExitLab

'打印报表标题
PrintTitle:
    With Printer
        '打印标题
        .FontName = "宋体"
        .FontSize = 17
        .FontBold = True
        .FontItalic = False
        .FontUnderline = False
        
        .CurrentX = (Printer.ScaleWidth - .TextWidth("体检费用清单")) / 2
        .CurrentY = sngTitleTop
        Printer.Print "体检费用清单"
        
        '打印单位
        .FontSize = 11
        .CurrentX = (Printer.ScaleWidth - .TextWidth(gstrHospital)) / 2
        .CurrentY = sngHospitalTop
        Printer.Print gstrHospital
        
        '打印个人信息
        .FontSize = 9
        .CurrentX = sngTextLeft - 5
        .CurrentY = sngPersonTop
        Printer.Print "档案号：" & strHealthID
        
        .CurrentX = sngTextLeft + 43 - 5
        .CurrentY = sngPersonTop
        Printer.Print "姓名：" & strName
        
        .CurrentX = sngTextLeft + 75 - 5
        .CurrentY = sngPersonTop
        Printer.Print "性别：" & strSex
        
        .CurrentX = sngTextLeft + 95 - 5
        .CurrentY = sngPersonTop
        Printer.Print "体检日期：" & strTJRQ
        
        '打印报表题头
        Printer.DrawWidth = 5
        Printer.Line (sngTextLeft - 5, sngHeaderTop - 1.5)-(sngTextLeft + sngJGeLeft + 10, sngHeaderTop - 1.5)
        
        .CurrentX = sngKShiLeft
        .CurrentY = sngHeaderTop
        Printer.Print "科室"
        
        .CurrentX = sngXMuLeft
        .CurrentY = sngHeaderTop
        Printer.Print "项目名称"
        
        .CurrentX = sngTCanLeft
        .CurrentY = sngHeaderTop
        Printer.Print "套餐名称"
        
        .CurrentX = sngJGeLeft
        .CurrentY = sngHeaderTop
        Printer.Print "价格(元)"
        Printer.Line (sngTextLeft - 5, sngHeaderTop + .TextHeight("高度") + 1)-(sngTextLeft + sngJGeLeft + 10, sngHeaderTop + .TextHeight("高度") + 1)
    
        .CurrentX = (Printer.ScaleWidth - .TextWidth(str(intPage))) / 2
        .CurrentY = sngPageNumberTop
        Printer.Print intPage
    End With
    Return

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

Public Function ShowFYMX(ByVal dtmDate As Date) As Boolean
    dtpBegin.Value = dtmDate
    dtpStop.Value = dtmDate
    cmdQuery_Click
    Me.Show
    Me.ZOrder 0
    ShowFYMX = True
End Function