clsfetch.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 = "clsFetch"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Attribute VB_Ext_KEY = "SavedWithClassBuilder" ,"Yes"
Attribute VB_Ext_KEY = "Collection" ,"clsFecthItem"
Attribute VB_Ext_KEY = "Member0" ,"clsFecthItem"
Attribute VB_Ext_KEY = "Top_Level" ,"Yes"
Option Explicit

'局部变量，保存集合
Public ActRevSerial As String
Public Num As Integer
Public DepCode As String
Public DepName As String
Public DcCode As String
Public DcName As String
Public FetchDate As String
Public RecentFetchDate As String
Public HdCode As String
Public Rate As Single
Public DsCode As String
Public PKCount As Integer
Private mCol As Collection
Public Ack As Boolean   '已存盘
Public PName As String
Public ItemFlag As Boolean

Public Function Add(Num, ItemNum, ItemCode, ItemName, model, _
    Cprice, TotalAmount, TotalFair, FetchedAmount, FetchedFair, _
    FetchAmount, FetchFair, Factor, unit, BaseUnit, Flag, gprice, RevDepCode, batchid, Comment, _
    Optional sKey As String) As clsFetchItem
    '创建新对象
    Dim objNewMember As clsFetchItem
    Set objNewMember = New clsFetchItem


    '设置传入方法的属性
    objNewMember.Num = Num
    objNewMember.ItemNum = ItemNum
    objNewMember.ItemCode = ItemCode
    objNewMember.batchid = IIf(IsNull(batchid), "000001", batchid)
    objNewMember.ItemName = ItemName
    objNewMember.model = IIf(IsNull(model), "", model)
    objNewMember.Cprice = Cprice
    objNewMember.TotalAmount = TotalAmount
    objNewMember.TotalFair = TotalFair
    objNewMember.FetchedAmount = FetchedAmount
    objNewMember.FetchedFair = FetchedFair
    objNewMember.FetchAmount = FetchAmount '缺省
    objNewMember.FetchFair = FetchFair  '缺省
    objNewMember.Factor = Factor
    objNewMember.unit = IIf(IsNull(unit), "", unit)
    objNewMember.BaseUnit = IIf(IsNull(unit), "", BaseUnit)
    objNewMember.Comment = IIf(IsNull(Comment), "", Comment)
    objNewMember.Flag = Flag
    objNewMember.gprice = IIf(IsNull(gprice), 0, gprice)
    objNewMember.RevDepCode = IIf(IsNull(RevDepCode), "", RevDepCode)
    If Len(sKey) = 0 Then
        mCol.Add objNewMember
    Else
        mCol.Add objNewMember, sKey
    End If


    '返回已创建的对象
    Set Add = objNewMember
    Set objNewMember = Nothing


End Function

Public Property Get Item(vntIndexKey As Variant) As clsFetchItem
    '引用集合中的一个元素时使用。
    'vntIndexKey 包含集合的索引或关键字，
    '这是为什么要声明为 Variant 的原因
    '语法：Set foo = x.Item(xyz) or Set foo = x.Item(5)
  Set Item = mCol(vntIndexKey)
End Property
Public Property Get ItemByNum(ByVal SubNum As String) As clsFetchItem
    '引用集合中的一个元素时使用。
    'vntIndexKey 包含集合的索引或关键字，
    '这是为什么要声明为 Variant 的原因
    '语法：Set foo = x.Item(xyz) or Set foo = x.Item(5)
    Dim i As Integer
    
    For i = 1 To mCol.Count
        If Item(i).Num = SubNum Then
            Set ItemByNum = Item(i)
            Exit Property
        End If
    Next i
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 Property Get NewEnum() As IUnknown
    '本属性允许用 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 Function Save(Sickobj As clsSickOP) As Boolean
    Dim recipeSerial As String
    Dim i As Integer
    Dim FlushFair As Currency
    Dim Status As Integer
    Dim DrugAmountsObj As clsDrugAmounts
    Dim busserial As String, oldRecipeSerial As String
On Error GoTo errlbl
    busserial = "select Recipeserial from Open_ReceiveMain " _
        & "Inner join Open_Receivesub on Open_ReceiveMain.revserial=Open_Receivesub.revserial " _
        & "where actrevserial='" & ActRevSerial & "'"
    If gdbobj.GetRs(busserial) > 0 Then
         oldRecipeSerial = gdbobj.Rs(0)
    End If
    recipeSerial = gFnGetSerial(stRecipeSerial)
    busserial = gFnGetSerial(stHouseBusSerial)
    Set DrugAmountsObj = New clsDrugAmounts
    If gtydSysConfig.IfDecStore And Not ItemFlag Then
        DrugAmountsObj.Direct = -1
        DrugAmountsObj.DtType = tsH_PATIENT_OUT
        DrugAmountsObj.DsCode = gtydSysConfig.DepCode
        For i = 1 To Count
            DrugAmountsObj.Add Item(i).ItemCode, Item(i).ItemName, Item(i).FetchAmount, Item(i).batchid, Item(i).Cprice, Item(i).gprice
        Next i
        DrugAmountsObj.GetStorage
        If Not DrugAmountsObj.JugeStorageForOut Then
            gdbobj.ErrDes = DrugAmountsObj.Info
            Exit Function
        End If
    End If
    gdbobj.CNExe.BeginTrans
    If gtydSysConfig.IfDecStore And Not ItemFlag Then
        If Not DrugAmountsObj.UpDateStorage Then
            GoTo errlbl
        End If
    End If
    Status = 2 '取过药   必须有药取 无药取不能进入此模块
    If FetchOut Then
        Status = Status + 1
    End If
    If Not Update_Open_ActReceiveSub(HISDBUpdate, Status:=Status, _
        DsCode:=gtydSysConfig.DepCode, PKCount:=PKCount, _
        RecentFetchDate:=Me.FetchDate, RecentFetchHdCode:=Me.HdCode, _
        UpdateCondition:="ActRevSerial = '" & ActRevSerial _
            & "' AND RecipeNum = " & Num) Then
        GoTo errlbl
    End If
    If gtydSysConfig.IFFoot Then
        If Not Update_House_BusMain(HISDbInsert, busserial, gtydSysConfig.DepCode, "15", -1, gfnGetTime, _
                gtydSysConfig.HdCode, "", Sickobj.PatientID, 0, "", PName) Then
            GoTo errlbl
        End If
    End If
    
    If Not FetchOut Then
        '生成负取药处方
        FlushFair = 0
        For i = 1 To mCol.Count
            If Item(i).FetchAmount <> Item(i).ActAmount Then
                If Not Update_Open_RecipeSub(HISDbInsert, recipeSerial, i, Item(i).ItemCode, _
                    Item(i).Cprice, Item(i).FetchAmount - Item(i).ActAmount, _
                    Item(i).FetchFair - Item(i).ActFair, _
                    Item(i).unit, Item(i).Factor, gtydSysConfig.DepCode, Item(i).Flag, Item(i).gprice, _
                    Item(i).gprice * (Item(i).FetchAmount - Item(i).ActAmount), Item(i).batchid) Then
                    
                    GoTo errlbl
                End If
                FlushFair = FlushFair + Item(i).FetchFair - Item(i).ActFair
                
            End If
        Next i
        '不计数处方数
        If Not Update_Open_RecipeMain(HISDbInsert, recipeSerial, Sickobj.Id, DepCode, DcCode, _
            gtydSysConfig.DepCode, HdCode, FetchDate, FlushFair, , , ActRevSerial, Num, 4) Then
            
            GoTo errlbl
        End If
    End If
    '更新ACTReceiveSubItem
    For i = 1 To mCol.Count
        If Item(i).FetchAmount <> 0 Then
            If Item(i).NewFlag = 2 Then
                If Not Update_Open_ActReceiveSubItem(HISDbInsert, ActRevSerial, Num, Item(i).ItemNum, Item(i).ItemCode, _
                    Item(i).TotalAmount, Item(i).FetchAmount, Item(i).Cprice, Item(i).TotalFair, Item(i).FetchFair, _
                    Item(i).unit, Item(i).Factor, Item(i).RevDepCode, Item(i).Flag, Item(i).batchid) Then
                End If
                If Not Update_Open_RecipeSub(HISDbInsert, oldRecipeSerial, i, Item(i).ItemCode, _
                    Item(i).Cprice, Item(i).FetchAmount, Item(i).FetchFair, Item(i).unit, Item(i).Factor, _
                    Item(i).RevDepCode, Item(i).Flag, Item(i).gprice, Item(i).gprice * Item(i).FetchAmount, Item(i).batchid) Then
                    GoTo errlbl
                End If
            Else
                If Not Update_Open_ActReceiveSubItem(HISDBUpdate, _
                    FetchAmount:=Item(i).FetchedAmount + Item(i).FetchAmount, _
                    FetchFair:=Item(i).FetchedFair + Item(i).FetchFair, batchid:=Item(i).batchid, _
                    UpdateCondition:=" ActRevSerial = '" & ActRevSerial _
                    & "' AND RecipeNum = " & Num & " AND Num = " & Item(i).ItemNum) Then
                    
                    GoTo errlbl
                End If
                If Item(i).NewFlag = 1 Then
                    If Not gdbobj.DBExec("Delete open_recipesub WHERE recipeserial='" & oldRecipeSerial & "' and num=" & Item(i).ItemNum) Then
                        GoTo errlbl
                    End If
                    If Not Update_Open_RecipeSub(HISDbInsert, oldRecipeSerial, Item(i).ItemNum, Item(i).ItemCode, _
                        Item(i).Cprice, Item(i).FetchAmount, Item(i).FetchFair, Item(i).unit, Item(i).Factor, _
                        Item(i).RevDepCode, Item(i).Flag, Item(i).gprice, Item(i).gprice * Item(i).FetchAmount, Item(i).batchid) Then
                        GoTo errlbl
                    End If
                End If
                If gtydSysConfig.IFFoot Then
                    If Not Update_House_BusSub(HISDbInsert, busserial, i, Item(i).ItemCode, Item(i).FetchAmount, _
                        Item(i).gprice, Item(i).gprice * Item(i).FetchAmount, Item(i).Cprice, _
                        Item(i).FetchAmount * Item(i).Cprice, Item(i).unit, Item(i).Factor) Then
                    
                        GoTo errlbl
                    End If
                End If
            End If
        End If
    Next i
    '更新处方表
    If Not Update_Open_RecipeMain(HISDBUpdate, FetchDate:=FetchDate, _
        DsCode:=gtydSysConfig.DepCode, _
        FetchHdCode:=HdCode, UpdateCondition:= _
        "ActRevSerial = '" & ActRevSerial & "' AND RecipeNum = " & Num _
        & " AND FetchHdCode IS NULL ") Then
        GoTo errlbl
    End If
    gdbobj.CNExe.CommitTrans
    Ack = True
    Save = True
    Exit Function
errlbl:
    gdbobj.CNExe.RollbackTrans
End Function
Public Property Get FetchOut() As Boolean '是否取完
    Dim i As Integer
    
    For i = 1 To mCol.Count
        If Item(i).ActAmount <> Item(i).FetchAmount Then
            Exit Property
        End If
    Next i
    FetchOut = True
End Property
Public Property Get BackOut() As Boolean '是否全退(除去取的药)
    Dim i As Integer