clssick.cls

来自「医院门诊医生工作站,vb6 SqlServer」· CLS 代码 · 共 829 行 · 第 1/3 页

        End If
    Else
        IfRegInfo = False
    End If
End Property

Public Function FootPrint(ByVal FootSerial As String, ByVal FootDate As String, _
    ByVal TDepName As String, ByVal PayMode As Integer, Optional EndDate As String = "", Optional SheetID As String = "") As Boolean
    Dim Tfootserial As String
    'PayMode 0  现金
    Dim mPg As clsPage
    Dim FairObj As clsItemFairs
    Dim i As Integer, j As Integer
    Dim capstr As String
    Dim tmprs As Recordset, TPrePay As Currency, TPrePayA As Currency
    Dim BeginDate As String
On Error GoTo errlbl
    If InStr(FootSerial, "-") > 0 Then
        Tfootserial = left(FootSerial, InStr(FootSerial, "-") - 1)
    Else
        Tfootserial = FootSerial
    End If
    BeginDate = IIf(mPreFootDate = "", InDate, mPreFootDate)
    EndDate = Format(IIf(EndDate = "", OutDate, EndDate), "yyyy-mm-dd")
    Set mPg = New clsPage
    Set mPg.gdbobj = gdbobj
    If gtydSysConfig.SheetName = "" Then gtydSysConfig.SheetName = "Inpati_sickFoot"
    If mPg.ReadFromDB(gtydSysConfig.SheetName) Then
        Call gdbobj.DBExec("update sickfoot set sheetID='" & SheetID & "' where footserial like '" & Tfootserial & "%' " _
             & "and sheetid is null")
        Set FairObj = New clsItemFairs
        FairObj.Make "Inpati_GetCatiFairBySick '" & SkSerial & "','" & Tfootserial & "','',''"
        mPg.IDValue("Name") = Name
        mPg.IDValue("Sex") = SexDes
        mPg.IDValue("FootDate") = FootDate
        mPg.IDValue("CurDate") = gfnGetTime("yyyy-mm-dd")
        mPg.IDValue("HdName") = gtydSysConfig.HdCode
        mPg.IDValue("HdCode") = gtydSysConfig.HdCode
        mPg.IDValue("PtType") = PtDes
        mPg.IDValue("DepName") = TDepName
        mPg.IDValue("InDate") = Format(BeginDate, "yyyy-mm-dd")
        mPg.IDValue("OutDate") = Format(OutDate, "yyyy-mm-dd")
        mPg.IDValue("InYear") = Format(BeginDate, "yyyy")
        mPg.IDValue("EndDate") = Format(IIf(EndDate = "", OutDate, EndDate), "yyyy-mm-dd")
        mPg.IDValue("InYear") = Format(BeginDate, "yyyy")
        mPg.IDValue("InMonth") = Format(BeginDate, "mm")
        mPg.IDValue("Inday") = Format(BeginDate, "dd")
        mPg.IDValue("OutYear") = Format(OutDate, "yyyy")
        mPg.IDValue("OutMonth") = Format(OutDate, "mm")
        mPg.IDValue("Outday") = Format(OutDate, "dd")
        mPg.IDValue("FootYear") = Format(FootDate, "yyyy")
        mPg.IDValue("FootMonth") = Format(FootDate, "mm")
        mPg.IDValue("Footday") = Format(FootDate, "dd")
        mPg.IDValue("Addr") = Addr
        mPg.IDValue("HospName") = gtydSysConfig.HospName
        mPg.IDValue("BeginDateTitle") = IIf(mPreFootDate = "", "入院日期:", "上次结算:")
        mPg.IDValue("InCase") = Me.InCase

        If FootDate <> "" Then '中途结算
            mPg.IDValue("InDays") = DateDiff("d", BeginDate, EndDate)
            mPg.IDValue("EndDateTitle") = "中结日期:"
            mPg.IDValue("OutDate") = Format(EndDate, "yyyy-mm-dd")
            
        Else
            mPg.IDValue("InDays") = DateDiff("d", BeginDate, OutDate)
            mPg.IDValue("BeginDateTitle") = "出院日期:"
        End If
            
        mPg.IDValue("PayMode") = IIf(PayMode = 0, "现金", "支票")
        mPg.IDValue("Age") = Age
        mPg.IDValue("SkID") = SkID
        j = 1
        For i = 1 To FairObj.Count
            If mPg.IDObject(FairObj.Item(i).Id & "Value") Is Nothing Then
                mPg.IDValue("AddItemDes" & j) = FairObj.Item(i).Des
                mPg.IDValue("AddItemFair" & j) = Format(FairObj.Item(i).InFair, gstrMONEY_FORMAT)
                j = j + 1
            Else
                mPg.IDValue(FairObj.Item(i).Id) = FairObj.Item(i).Des
                mPg.IDValue(FairObj.Item(i).Id & "Value") = Format(FairObj.Item(i).InFair, gstrMONEY_FORMAT)
            End If
            mPg.IDValue("ItemDes" & i) = FairObj.Item(i).Des
            mPg.IDValue("ItemFair" & i) = Format(FairObj.Item(i).InFair, gstrMONEY_FORMAT)
        Next i
        mPg.IDValue("Fair") = Format(FairObj.InFair, gstrMONEY_FORMAT)
        mPg.IDValue("FairCap") = hisGetMoneyCap(FairObj.InFair)
        mPg.IDValue("TFair") = Format(FairObj.Fair, gstrMONEY_FORMAT)
        mPg.IDValue("TFairCap") = hisGetMoneyCap(FairObj.Fair)
        mPg.IDValue("RateFair") = Format(FairObj.Fair - FairObj.InFair, gstrMONEY_FORMAT)
        mPg.IDValue("RateFairCap") = hisGetMoneyCap(FairObj.Fair - FairObj.InFair)
        capstr = Format(Abs(FairObj.InFair * 100), "##################")
        For i = 0 To Len(capstr) - 1
            mPg.IDValue("FairCap" & Format(i, "0")) = GetCap(mID(capstr, Len(capstr) - i, 1))
        Next i

        capstr = Format(Abs(FairObj.Fair * 100), "##################")
        For i = 0 To Len(capstr) - 1
            mPg.IDValue("TFairCap" & Format(i, "0")) = GetCap(mID(capstr, Len(capstr) - i, 1))
        Next i
        
        capstr = Format(Abs((FairObj.Fair - FairObj.InFair) * 100), "##################")
        For i = 0 To Len(capstr) - 1
            mPg.IDValue("RateFairCap" & Format(i, "0")) = GetCap(mID(capstr, Len(capstr) - i, 1))
        Next i
                
'        Set TmpRs = gdbobj.GetNewRs("SELECT Sum(prepay),Sum(Footedfair) " _
'                & "FROM SickPay " _
'                & "inner join sickfoot on sickfoot.footserial=sickpay.footserial " _
'            & "WHERE SickPay.FootSerial like '" & FootSerial & "%' and canceldate is null and paytype>0")
        
        Set tmprs = gdbobj.GetNewRs("SELECT Sum(case when paytype=0 then PayFair else 0 end)," _
                & "Sum(case when paytype=1 or paytype=3 or paytype=2 then PayFair else 0 end) FROM SickPay " _
            & "WHERE FootSerial like '" & FootSerial & "%'")
        
        If IsNull(tmprs.Fields(0)) Then
            TPrePay = 0
        Else
            TPrePay = tmprs.Fields(0)
        End If
        If IsNull(tmprs.Fields(1)) Then
            TPrePayA = 0
        Else
            TPrePayA = Round(tmprs.Fields(1), 2)
        End If
        mPg.IDValue("PrePay") = Format(TPrePay, gstrMONEY_FORMAT)
        mPg.IDValue("PrePayCap") = hisGetMoneyCap(TPrePayA)
        If TPrePay > FairObj.Fair Then
            mPg.IDValue("PaySwitch") = "实退"
            If PayMode = 0 Then
                mPg.IDValue("backPay") = Format(-TPrePayA, gstrMONEY_FORMAT)
            Else
                mPg.IDValue("backPayB") = Format(-TPrePayA, gstrMONEY_FORMAT)
            End If
            mPg.IDValue("BackPayCap") = hisGetMoneyCap(TPrePayA)
            
        Else
            mPg.IDValue("PaySwitch") = "实交"
            If FairObj.Fair - TPrePay > TPrePayA Then
                mPg.IDValue("PayDec") = Format(FairObj.InFair - TPrePay - TPrePayA, gstrMONEY_FORMAT)
            End If
            If PayMode = 0 Then
                mPg.IDValue("Pay") = Format(TPrePayA, gstrMONEY_FORMAT)
            Else
                mPg.IDValue("PayB") = Format(TPrePayA, gstrMONEY_FORMAT)
            End If
            mPg.IDValue("PayCap") = hisGetMoneyCap(TPrePayA)
        End If
        mPg.IDValue("ABSPay") = Format(Abs(FairObj.InFair - TPrePay), gstrMONEY_FORMAT)
        mPg.IDValue("ABSPayCap") = hisGetMoneyCap(Abs(FairObj.InFair - TPrePay))
        If gdbobj.GetRs("SELECT COUNT(DISTINCT SICKFOOT.FOOTSERIAL) FROM SickFoot " _
            & "INNER JOIN SickPay ON SickFoot.FootSerial = SickPay.FootSerial and PayType in (1,2) " _
            & "WHERE SickPay.PayDate <= '" & FootDate & "'") > 0 Then
            mPg.IDValue("FootID") = Format(gdbobj.Rs(0), "000000")
        End If
        If gtydSysConfig.Status > 0 Then
            mPg.RPrint
        Else
            mPg.PreView vbModal
        End If
        FootPrint = True
    End If
errlbl:
End Function


Public Function PrePayPrint(ByVal PreFair As Currency, _
    ByVal HdName As String, ByVal TDate As String, ByVal SheetID As String, ByVal ChequeNo As String, ByVal HdCode As String) As Boolean
    
    Dim mPg As clsPage
    
    '?转科时的重打科别，床位

On Error GoTo errlbl
    Set mPg = New clsPage
    Set mPg.gdbobj = gdbobj
    If mPg.ReadFromDB("Inpati_PrePay") Then
        mPg.IDValue("SkID") = SkID
        mPg.IDValue("Name") = Name
        mPg.IDValue("Sex") = SexDes
        
        mPg.IDValue("Date") = Format(TDate, gstrCHINA_DATE)
        mPg.IDValue("Year") = Format(Date, "yyyy")
        mPg.IDValue("Month") = Format(Date, "mm")
        mPg.IDValue("Day") = Format(Date, "dd")
        
        mPg.IDValue("InDate") = Format(InDate, gstrCHINA_DATE)
        mPg.IDValue("InYear") = Format(InDate, "yyyy")
        mPg.IDValue("InMonth") = Format(InDate, "mm")
        mPg.IDValue("Inday") = Format(InDate, "dd")
        
        mPg.IDValue("PrePay") = Format(PreFair, gstrMONEY_FORMAT_APD)
        mPg.IDValue("DepName") = DepName
        mPg.IDValue("PrePayCap") = hisGetMoneyCap(PreFair)
        mPg.IDValue("HdName") = HdName
        mPg.IDValue("HdName") = HdCode
        mPg.IDValue("BedNum") = BedNum
        mPg.IDValue("paySerial") = SheetID
        mPg.IDValue("PayMode") = IIf(ChequeNo = "", "现金", "支票")
        mPg.IDValue("ChequeNo") = ChequeNo
        If gdbobj.GetRs("select *from Cheque where ChequeNo='" & ChequeNo & "'") > 0 Then
            mPg.IDValue("Bank") = IIf(IsNull(gdbobj.Rs!Bank), "", gdbobj.Rs!Bank)
            mPg.IDValue("Account") = IIf(IsNull(gdbobj.Rs!Account), "", gdbobj.Rs!Account)
        End If
        If gtydSysConfig.Status < 2 Then
        'If gtydSysConfig.Status = 0 Or gtydSysConfig.Status = 1 Or gtydSysConfig.Status = 2 Then
            mPg.PreView
        Else
            mPg.RPrint
        End If
    End If
    PrePayPrint = True
    Exit Function
errlbl:
End Function
Public Function TranAsk(ByVal DestDepCode As String) As Boolean
    Dim Num As Integer
    
On Error GoTo errlbl
    Call gdbobj.DBExec("delete ChangePos where SourceDepCode='" & DepCode & "' " _
               & "and SourceBedID='" & BedID & "' and TargetDepCode='" & DestDepCode & "' and skserial='" & SkSerial & "'")
    Num = mfnGetNewMaxChangePos(SkSerial)
    gdbobj.CNExe.BeginTrans
    If BedID <> "" Then
        If Not Update_SickInfo(HISDBUpdate, BedID:=Null, _
            UpdateCondition:="SkSerial ='" & SkSerial & "'") Then
            
            GoTo errlbl
        End If
        If Not gdbobj.DBExec("UPDATE m_Bed Set Flag=Flag & 239,comment=null WHERE BedID = '" & BedID & "'") Then
        
            GoTo errlbl
        End If
    End If
    If Not Update_ChangePos(HISDbInsert, SkSerial, Num, gfnGetTime, DepCode, BedID, DestDepCode, "", _
        gtydSysConfig.HdCode, "", 1) Then
        
        GoTo errlbl
    End If
    gdbobj.CNExe.CommitTrans
    TranAsk = True
    Exit Function
errlbl:
    gdbobj.CNExe.RollbackTrans
End Function

Private Function GetCap(caps As Integer) As String
    Dim Numstr As String
    Numstr = "零壹贰叁肆伍陆柒捌玖"
    GetCap = mID(Numstr, caps + 1, 1)
    
    
End Function

'是否手术登记
Public Function GetOpInfo(OperNum As Integer) As Integer
    Dim tmprs As Recordset
    Dim i As Integer
    Set tmprs = gdbobj.GetNewRs("SELECT opNum,opName,BeginTime from op_Info where SkSerial = '" & SkSerial & "' and opserial is null order by opnum")
    If Not (tmprs Is Nothing) Then
        If OperNum > tmprs.RecordCount Then Exit Function
        GetOpInfo = tmprs.RecordCount
        i = 1
        Do While Not tmprs.EOF
            OpName = IIf(IsNull(tmprs!OpName), "", tmprs!OpName)
            OpBeginTime = tmprs!BeginTime
            OpNum = tmprs!OpNum
            If i = OperNum Then Exit Do
            tmprs.MoveNext
            i = i + 1
        Loop
    End If
    
End Function