clsfetchs.cls

医院门诊医生工作站,vb6 SqlServer

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "clsFetchs"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
 Option Explicit


Public Sickobj As clsSickOP
Public RecentDate As String '最近收费日期
Public SheetID As String '为退费用
Public ChequeNo As String
Private mCol As Collection
Private mActRevSerial As String
Public Sub Add(Fetchobj As clsFetch)
    '创建新对象
    mCol.Add Fetchobj


End Sub

Public Property Get Item(vntIndexKey As Variant) As clsFetch
    '引用集合中的一个元素时使用。
    'vntIndexKey 包含集合的索引或关键字，
    '这是为什么要声明为 Variant 的原因
    '语法：Set foo = x.Item(xyz) or Set foo = x.Item(5)
  Set Item = mCol(vntIndexKey)
End Property



Public Property Get Count() As Long
    '检索集合中的元素数时使用。语法：Debug.Print x.Count
    Count = mCol.Count
End Property


Public Sub Remove(vntIndexKey As Variant)
    '删除集合中的元素时使用。
    'vntIndexKey 包含索引或关键字，这是为什么要声明为 Variant 的原因
    '语法：x.Remove(xyz)


    mCol.Remove vntIndexKey
End Sub
Public Sub Clear()
    '删除集合中的元素时使用。
    'vntIndexKey 包含索引或关键字，这是为什么要声明为 Variant 的原因
    '语法：x.Remove(xyz)
    Dim i As Integer
        
    For i = 1 To mCol.Count
        Remove 1
    Next i
End Sub

Public Property Get NewEnum() As IUnknown
Attribute NewEnum.VB_UserMemId = -4
    '本属性允许用 For...Each 语法枚举该集合。
    Set NewEnum = mCol.[_NewEnum]
End Property


Private Sub Class_Initialize()
    '创建类后创建集合
    Set mCol = New Collection
End Sub


Private Sub Class_Terminate()
    '类终止后破坏集合
    Set mCol = Nothing
End Sub
Public Sub Make(ByVal SQL As String)
    Dim Rs As Recordset
    Dim tmpObj As clsFetch
    Dim ActRevSerial As String, Num As Integer
    Dim Row As Integer
    Set Rs = gdbobj.GetNewRs(SQL)
    Row = 1
    Clear
    Do Until Rs.EOF
        RecentDate = Rs!RecentDate
        SheetID = IIf(IsNull(Rs!SheetID), "", Rs!SheetID)
        If ActRevSerial <> Rs!ActRevSerial Or Num <> Rs!RecipeNum Then
            Set tmpObj = New clsFetch
            tmpObj.ActRevSerial = Rs!ActRevSerial
            tmpObj.Num = Rs!RecipeNum
            tmpObj.DepCode = Rs!DepCode
            tmpObj.DepName = Rs!DepName
            tmpObj.DcCode = IIf(IsNull(Rs!DcCode), "", Rs!DcCode)
            tmpObj.DcName = IIf(IsNull(Rs!DcName), "", Rs!DcName)
            tmpObj.RecentFetchDate = IIf(IsNull(Rs!RecentFetchDate), "", Rs!RecentFetchDate)
            tmpObj.Rate = Rs!Rate
            tmpObj.DsCode = IIf(IsNull(Rs!DsCode), "", Rs!DsCode)
            tmpObj.PKCount = IIf(IsNull(Rs!PKCount), 1, Rs!PKCount)
            ActRevSerial = Rs!ActRevSerial
            mActRevSerial = ActRevSerial
            Num = Rs!RecipeNum
            '默认需取数量为 实际可取数量
            tmpObj.Add Row, Rs!Num, Rs!ItemCode, Rs!ItemName, Rs!model, Rs!Cprice, Rs!Amount, _
                Rs!Fair, Rs!FetchAmount, Rs!FetchFair, Rs!Amount - Rs!FetchAmount, _
                Rs!Fair - Rs!FetchFair, Rs!Factor, Rs!unit, Rs!BaseUnit, _
                Rs!Flag, Rs!gprice, Rs!RevDepCode, Rs!batchid, Rs!Comment
            Me.Add tmpObj
        Else
            tmpObj.Add Row, Rs!Num, Rs!ItemCode, Rs!ItemName, Rs!model, Rs!Cprice, Rs!Amount, _
                Rs!Fair, Rs!FetchAmount, Rs!FetchFair, Rs!Amount - Rs!FetchAmount, _
                Rs!Fair - Rs!FetchFair, Rs!Factor, Rs!unit, Rs!BaseUnit, _
                Rs!Flag, Rs!gprice, Rs!RevDepCode, Rs!batchid, Rs!Comment
        End If
        Rs.MoveNext
        Row = Row + 1
    Loop
End Sub
Public Property Let ActRevSerialByQuery(ByVal vdata As String)
    Dim SQL As String
    
    SQL = "SELECT Open_ActReceiveSub.ActRevSerial,Open_ActReceiveSub.RecipeNum," _
        & "Open_ActReceiveSubItem.Num,Open_ActReceiveSub.DcCode,m_Doctor.DcName,open_ActReceiveSubItem.BatchID," _
        & "Open_ActReceiveSub.DepCode,m_Depart.DepName,Open_ActReceiveSubItem.Flag,Open_ActReceiveSub.Rate," _
        & "Open_ActReceiveSubItem.ItemCode,Open_ActReceiveSubItem.RevDepCode,Open_ActReceiveSub.PkCount," _
        & "(CASE WHEN m_Item.ItemCode IS NULL THEN m_Drug.ItemName ELSE m_Item.ItemName END) AS 'ItemName'," _
        & "(CASE WHEN m_Item.ItemCode IS NULL THEN m_Drug.model ELSE '' END) as 'Model'," _
        & "(CASE WHEN m_Item.ItemCode IS NULL THEN m_Drug.Gprice ELSE null END) as 'GPrice'," _
        & "(CASE WHEN m_Item.ItemCode IS NULL THEN m_Drug.BaseUnit ELSE m_Item.Unit END) as 'BaseUnit'," _
        & "Open_ActReceiveSubItem.Cprice,Open_ActReceiveMain.RecentDate,Open_ActReceiveSubItem.Fair," _
        & "Open_ActReceiveSubItem.Unit,Open_ActReceiveSubItem.Factor," _
        & "Open_ActReceiveSubItem.Amount,Open_ActReceiveSubItem.FetchAmount,Open_ActReceiveSubItem.FetchFair, " _
        & "Open_actReceiveSub.recentFetchDate,Open_actReceiveMain.SheetID,Open_ActReceiveSub.DsCode " _
        & "FROM (((((Open_ActReceiveMain INNER JOIN Open_ActReceiveSub " _
        & "ON Open_ActReceiveMain.ActRevSerial =Open_ActReceiveSub.ActRevSerial) " _
        & " INNER JOIN Open_ActReceiveSubItem " _
        & " ON Open_ActReceiveSub.ActRevSerial =Open_ActReceiveSubItem.ActRevSerial" _
        & " AND Open_ActReceiveSub.recipeNum =Open_ActReceiveSubItem.RecipeNum) " _
        & " INNER JOIN m_Depart ON Open_ActReceiveSub.DepCode =m_Depart.DepCode) " _
        & " LEFT JOIN m_Drug ON m_Drug.ItemCode = Open_ActReceiveSubItem.ItemCode) " _
        & " LEFT JOIN m_Item ON m_Item.ItemCode = Open_ActReceiveSubItem.ItemCode) " _
        & " LEFT JOIN m_Doctor ON Open_ActReceiveSub.DcCode =m_Doctor.DcCode " _
        & " WHERE Open_ActReceiveMain.ActRevSerial = '" & vdata & "'" _
        & " ORDER BY Open_ActReceiveSub.ActRevSerial,Open_ActReceiveSub.RecipeNum"
    Make SQL
End Property

Public Function Back() As Boolean
    Dim RevSerial As String
    Dim recipeSerial As String
    Dim tmpObj As clsFetch, i As Integer
    Dim Status As Integer
    Dim TotalAmount As Integer, Cprice As Currency
    Dim oldRecipeSerial As String
    Dim SQL As String
    Dim Flag As Boolean
On Error GoTo errlbl
'    SQL = "update open_recipesub set backamount=5 from open_recipesub " _
'        & "inner join open_recipemain on open_recipesub.recipeserial=open_recipemain.recipeserial " _
'        & "where actrevserial='" & mactrevserial & "' and status=0 "

    RevSerial = gFnGetSerial(stRECEIVE)
    recipeSerial = gFnGetSerial(stRecipeSerial)
    
    gdbobj.CNExe.BeginTrans
    If BackFair = 0 Then
        gdbobj.ErrDes = "无退费！"
        GoTo errlbl
    End If
    If Not Update_Open_ReceiveMain(HISDBUpdate, CancelHdCode:=gtydSysConfig.HdCode, _
        CancelDate:=gfnGetTime(), UpdateCondition:="ActRevSerial ='" & Item(1).ActRevSerial _
        & "' AND CancelHdCode IS NULL ") Then
            
            GoTo errlbl
    End If
    If Not Update_Open_ReceiveMain(HISDbInsert, RevSerial, gfnGetTime(), _
         gtydSysConfig.HdCode, Sickobj.Id, Me.TotalFair - Me.BackFair, Me.TotalInFair - Me.BackInFair, _
         , Item(1).ActRevSerial, SheetID:=IIf(BackClear, Null, SheetID), ChequeNo:=ChequeNo) Then '退费只对某一次收费
        GoTo errlbl
    End If
    If Not Update_Open_ActReceiveMain(HISDBUpdate, RecentDate:=gfnGetTime(), _
        HdCode:=gtydSysConfig.HdCode, SheetID:=IIf(BackClear, Null, SheetID), _
        UpdateCondition:=" ActRevSerial= '" & Item(1).ActRevSerial & "'") Then
        
        GoTo errlbl
    End If
    
    For Each tmpObj In mCol
        If tmpObj.BackFair > 0 Then
            '生成负处方，此处方既不算划价，也不算取药,但统计
            If Not Update_Open_RecipeMain(HISDbInsert, recipeSerial, Sickobj.Id, _
                    tmpObj.DepCode, tmpObj.DcCode, _
                    "", tmpObj.HdCode, tmpObj.FetchDate, tmpObj.BackFair * (-1), ActRevSerial:=tmpObj.ActRevSerial, _
                    RecipeNum:=tmpObj.Num, Status:=2) Then

                GoTo errlbl
            End If
'            If tmpobj.DsCode = "" Then
'                SQL = "update open_recipeMain set Fair=fair-" & tmpobj.BackFair _
'                    & " where actrevserial='" & mactrevserial & "' and fair>0  and recipenum=" & tmpobj.Num
'                If Not gDbObj.DBExec(SQL) Then
'                    GoTo errlbl
'                End If
'            End If
            For i = 1 To tmpObj.Count
                If tmpObj.Item(i).BackAmount <> 0 Then
'                    SQL = "update open_recipesub set amount=amount-" & tmpobj.Item(i).BackAmount & "," _
'                        & "open_recipesub.Fair=open_recipesub.fair-" & tmpobj.Item(i).BackFair & ",GMoney=gmoney-" & tmpobj.Item(i).BackAmount * tmpobj.Item(i).gprice & " from open_recipesub " _
'                        & "inner join open_recipemain on open_recipesub.recipeserial=open_recipemain.recipeserial " _
'                        & "where actrevserial='" & mactrevserial & "' and recipenum=" & tmpobj.Num & " and amount>0" _
'                        & " and itemcode='" & tmpobj.Item(i).ItemCode & "'"
'                    If tmpobj.DsCode = "" Then