frmcwhz.frm

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

    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
    
    If strYYID = "" Then
        '********************************************************************
        '散检客户
        '********************************************************************
        strSQL = "select XZTC,TCID from YY_SJDJ" _
                & " where GUID=" & lngGUID
    Else
        '********************************************************************
        '团检客户
        '********************************************************************
        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
            strTCMC = rstemp("TCMC")
            curTCJG = rstemp("TCJG")
        Else
            '未选择套餐
            blnTC = False
        End If
        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
    
    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") & ""
                
                curOtherXMu = curOtherXMu + IIf(IsNull(rstemp("DXJG")), 0, rstemp("DXJG"))
            End If
            
            intCurrLine = intCurrLine + 1
            rstemp.MoveNext
        Next
        
        '打印合计行
        '在最后一页上打印合计
        .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
        .CurrentY = sngCurrY
        Printer.Print "总计："
        
        .CurrentX = sngTextLeft + 15
        .CurrentY = sngCurrY
        Printer.Print "套餐价格：" & curTCJG
        
        .CurrentX = sngTextLeft + 45
        .CurrentY = sngCurrY
        Printer.Print "折扣率：" & sngZheKou
        
        .CurrentX = sngTextLeft + 70
        .CurrentY = sngCurrY
        Printer.Print "加项费用：" & curOtherXMu
        
        .CurrentX = sngTextLeft + 110
        .CurrentY = sngCurrY
        Printer.Print "实际：" & CStr(curTotal_CJJG)
        
        '为每个客户提交一次打印
        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
''''''''''''''''登记信息
Private Function get_djxx(ByVal TJRQ As String) As Integer
     Dim strSQL As String
      Dim rstemp As ADODB.Recordset
     strSQL = "select  isnull(count(guid),0) as rscount from set_grxx where convert(char(10),tjrq,20)='" & TJRQ & "'"
     Set rstemp = New ADODB.Recordset
     rstemp.Open strSQL, GCon, adOpenStatic, adLockOptimistic
     get_djxx = rstemp("rscount")
       
End Function
'''''''''''''''应收金额
Private Function get_ysje(ByVal TJRQ As String) As Currency
     Dim strSQL As String
     Dim ysje As Currency
     Dim rstemp As ADODB.Recordset
     
     'strSQL = " SELECT isnull(sum(set_dx.dxjg),0) as jg FROM YY_SJDJDX LEFT OUTER JOIN SET_DX ON YY_SJDJDX.DXID = SET_DX.DXID LEFT OUTER JOIN SET_GRXX ON YY_SJDJDX.GUID = SET_GRXX.GUID where  CONVERT (char(10), SET_GRXX.TJRQ, 20)='" & TJRQ & "'"
     strSQL = "select isnull(sum(xmjg),0)as jg from set_grxx where convert(char(10),tjrq,20)='" & TJRQ & "'"
     Set rstemp = New ADODB.Recordset
    Set rstemp = GCon.Execute(strSQL)
     ysje = rstemp("jg")
   ' MsgBox ysje
     strSQL = "select isnull(sum(xmjg),0)as ysje from YY_TJDJ where Convert(char(10),TJRQ,20)='" & TJRQ & "'"
     Set rstemp = GCon.Execute(strSQL)
    ' MsgBox rsTemp("ysje")
     get_ysje = ysje + rstemp("ysje")
End Function
'''''''''成交金额
Private Function get_cjje(ByVal TJRQ As String) As Currency
     Dim strSQL As String
     Dim cjje As Currency
     Dim rstemp As ADODB.Recordset
     
     strSQL = " SELECT isnull(sum(cjjg),0) as cjje FROM  SET_GRXX  where  CONVERT (char(10), SET_GRXX.TJRQ, 20)='" & TJRQ & "'"
     Set rstemp = New ADODB.Recordset
     rstemp.Open strSQL, GCon, adOpenStatic, adLockOptimistic
     cjje = rstemp("cjje")
      'MsgBox cjje
     strSQL = "select isnull(sum(cjjg),0)as cjje from YY_TJDJ where Convert(char(10),TJRQ,20)='" & TJRQ & "'"
     Set rstemp = GCon.Execute(strSQL)
      
     get_cjje = cjje + rstemp("cjje")

End Function
'''''''''''实收金额
Private Function get_ssfy(ByVal TJRQ As String) As Currency
  Dim strSQL As String
  Dim rstemp As ADODB.Recordset
  Dim ssfy As Currency
  
  strSQL = "SELECT ISNULL(SUM(SET_SFMX_GR.SFFY), 0) AS ssfy FROM SET_GRXX INNER JOIN  SET_SFMX_GR ON SET_GRXX.GUID = SET_SFMX_GR.GUID WHERE CONVERT(char(10), SET_GRXX.TJRQ, 20) ='" & TJRQ & "'"
   Set rstemp = New ADODB.Recordset
     rstemp.Open strSQL, GCon, adOpenStatic, adLockOptimistic
     ssfy = rstemp("ssfy")
    
     strSQL = " SELECT ISNULL(SUM(SET_SFMX.SFFY), 0) AS sffy FROM SET_SFMX INNER JOIN SET_GRXX ON dbo.SET_SFMX.YYID = SET_GRXX.YYID WHERE CONVERT(char(10), SET_GRXX.TJRQ, 20) ='" & TJRQ & "'"
     Set rstemp = GCon.Execute(strSQL)
     
     get_ssfy = ssfy + rstemp("sffy")
     
End Function
'''''''''''''''''''''''''体检人数
Private Function get_cjxx(ByVal TJRQ As String) As Integer
  Dim strSQL As String
  Dim rstemp As ADODB.Recordset
  strSQL = "SELECT isnull(COUNT(DATA_ZJJL.GUID),0) AS cjcount FROM DATA_ZJJL INNER JOIN SET_GRXX ON DATA_ZJJL.GUID = SET_GRXX.GUID WHERE CONVERT(char(10), SET_GRXX.TJRQ, 20) = '" & TJRQ & "'"
    Set rstemp = New ADODB.Recordset
     rstemp.Open strSQL, GCon, adOpenStatic, adLockOptimistic
     get_cjxx = rstemp("cjcount")
End Function

Private Sub men_delete_Click(Index As Integer)

End Sub

Private Sub MonthView1_DateClick(ByVal DateClicked As Date)
     Dim itmHZ As ListItem
     Dim strrq As String
     Dim n As Integer
     Dim l_djrs As Integer
     Dim c_ysje As Currency
     Dim c_cjje As Currency
     Dim l_cjxx As Integer
     Dim c_ssfy As Currency
   If cmbRepType.Text = "周报表" Then
       cmbRepType_Click
      
   End If
   
    If cmbRepType.Text = "月报表" Then
      cmbRepType_Click
   End If

   If cmbRepType.Text = "日报表" Then
     strrq = Format(CStr(MonthView1.Value), "yyyy-mm-dd")
     Set itmHZ = lvwSJRY.FindItem(strrq, 0)
     If itmHZ Is Nothing Then
        Set itmHZ = lvwSJRY.ListItems.Add()
        itmHZ.Text = strrq
        itmHZ.SubItems(1) = get_djxx(strrq)
        itmHZ.SubItems(2) = get_ysje(strrq)
        itmHZ.SubItems(3) = get_cjje(strrq)
        itmHZ.SubItems(4) = get_cjxx(strrq)
        itmHZ.SubItems(5) = get_ssfy(strrq)
        
          
        
     End If
        
        Set itmHZ = lvwSJRY.FindItem("合计:", 0)
            If itmHZ Is Nothing Then
               Set itmHZ = lvwSJRY.ListItems.Add(1)
                itmHZ.Text = "合计:"
                 For n = 2 To lvwSJRY.ListItems.Count

                  itmHZ.SubItems(1) = lvwSJRY.ListItems.item(n).SubItems(1)
                  itmHZ.SubItems(2) = lvwSJRY.ListItems.item(n).SubItems(2)
                  itmHZ.SubItems(3) = lvwSJRY.ListItems.item(n).SubItems(3)
                  itmHZ.SubItems(4) = lvwSJRY.ListItems.item(n).SubItems(4)
                  itmHZ.SubItems(5) = lvwSJRY.ListItems.item(n).SubItems(5)

                 Next n
              Else
                  For n = 2 To lvwSJRY.ListItems.Count
        
                  
                  l_djrs = l_djrs + CCur(lvwSJRY.ListItems.item(n).SubItems(1))
                  itmHZ.SubItems(1) = l_djrs
                  c_ysje = c_ysje + CCur(lvwSJRY.ListItems.item(n).SubItems(2))
                  itmHZ.SubItems(2) = c_ysje
                  c_cjje = c_cjje + CCur(lvwSJRY.ListItems.item(n).SubItems(3))
                  itmHZ.SubItems(3) = c_cjje
                  l_cjxx = l_cjxx + CCur(lvwSJRY.ListItems.item(n).SubItems(4))
                  itmHZ.SubItems(4) = l_cjxx
                  c_ssfy = c_ssfy + CCur(lvwSJRY.ListItems.item(n).SubItems(5))
                  itmHZ.SubItems(5) = c_ssfy
            
                 Next n
              
            End If
    End If
End Sub

Private Sub optssrq_Click()
    lvwSJRY.ListItems.Clear
    lvwSJRY.ColumnHeaders(1).Text = "收费日期"
    lvwSJRY.ColumnHeaders(2).Text = ""
    lvwSJRY.ColumnHeaders(3).Text = "收费金额"
End Sub

Private Sub opttjrq_Click()
    lvwSJRY.ListItems.Clear
End Sub