clssickop.cls

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

                GoTo errlbl
            End If
            
            Call Update_m_PatientBaseInfoApd(HISDBUpdate, PatientID, INSID, Nation, IDCardNO, Worker, _
                Tel, Post, Address, Format(Date, "yyyy-mm-dd ") & Format(Time, "HH:NN:SS"), fbPtID, UpdateCondition:="PatientID = '" & Id & "'")
            
        Case DbOpType.HISDBdelete
            If Not Update_Open_m_PatientBaseInfo(HISDBdelete, UpdateCondition:="PatientID = '" & Id & "'") Then
                GoTo errlbl
            End If
            Call Update_m_PatientBaseInfoApd(HISDBdelete, UpdateCondition:="PatientID = '" & Id & "'")
    End Select
    Save = True
    Exit Function
errlbl:
End Function

Private Sub Class_Initialize()
    PtID = gPatientTypesObj.DeFaultID
    PtDes = gPatientTypesObj.DeFaultDes
End Sub

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


Public Function MPrintBack1(ByVal SheetID As String, ByVal ActRevSerial As String, actnum As Integer) As Boolean
    Dim mPg As clsPage
    Dim FairObj As clsItemFairs
    Dim I As Integer, j As Integer, recCount As Integer, Num As Integer, Capnum As Integer
    Dim capstr As String
    Dim tmprs As Recordset
    Dim sql As String
On Error GoTo errlbl
    If gdbobj.GetRs("select count(*) from open_actReceiveSub where actrevserial='" & ActRevSerial & "'") > 0 Then
        recCount = gdbobj.Rs(0)
    End If
    sql = "select Revserial,Open_RecipeMain.recipeserial From Open_RecipeMain " _
        & "inner join Open_ReceiveSub on Open_ReceiveSub.recipeserial=Open_RecipeMain.recipeserial " _
        & "where actrevserial='" & ActRevSerial & "' and recipenum=" & actnum

    Set mPg = New clsPage
    Set mPg.gdbobj = gdbobj
    If Not mPg.ReadFromDB("Open_RevSheet") Then Exit Function
    Set FairObj = New clsItemFairs
    Set tmprs = New Recordset
    Set tmprs = gdbobj.GetNewRs("Open_GetRevCatiFair1 '" & ActRevSerial & "'," & actnum)
    Do While Not tmprs.EOF
        FairObj.DepName = IIf(IsNull(tmprs!DepName), "", tmprs!DepName)
        FairObj.DcName = IIf(IsNull(tmprs!DcName), "", tmprs!DcName)
        FairObj.DsName = IIf(IsNull(tmprs!DsName), "", tmprs!DsName)
        FairObj.Add tmprs!CusmID, tmprs!Des, tmprs!fair
        tmprs.MoveNext
    Loop
    mPg.IDValue("INSID") = Me.INSID
    mPg.IDValue("SheetID") = SheetID
    mPg.IDValue("PatientID") = PatientID
    mPg.IDValue("INSID") = Me.INSID
    mPg.IDValue("Name") = Name
    mPg.IDValue("RevDate") = gfnGetTime("yyyy-mm-dd")
    mPg.IDValue("RevYear") = Format(gfnGetTime("yyyy-mm-dd"), "yyyy")
    mPg.IDValue("RevMonth") = Format(gfnGetTime("yyyy-mm-dd"), "mm")
    mPg.IDValue("RevDay") = Format(gfnGetTime("yyyy-mm-dd"), "dd")
    mPg.IDValue("HdName") = gtydSysConfig.HdName
    mPg.IDValue("HdCode") = gtydSysConfig.hdCode
    mPg.IDValue("PtType") = PtDes
    mPg.IDValue("DepName") = FairObj.DepName
    mPg.IDValue("DsName") = FairObj.DsName
    mPg.IDValue("DcName") = FairObj.DcName
    mPg.IDValue("HospName") = gtydSysConfig.HospName
    If gPatientTypesObj(PtID).Label Then
        mPg.IDValue("IfLabel") = mPg.IDObject("IfLabel").Str
    Else
        mPg.IDValue("IfLabel") = ""
    End If
    I = 1
    Do
        If mPg.IDObject("Cancel" & I) Is Nothing Then Exit Do
        mPg.IDValue("Cancel" & I) = "作废"
        I = I + 1
    Loop
    j = 1
    
    For I = 1 To FairObj.Count
        If mPg.IDObject(FairObj.Item(I).Id) Is Nothing Then
            mPg.IDValue("AddItemDes1") = FairObj.Item(I).Des
            mPg.IDValue("AddItemFair1") = Format(FairObj.Item(I).fair, gstrMONEY_FORMAT)
            j = j + 1
        Else
            mPg.IDValue(FairObj.Item(I).Id) = Format(FairObj.Item(I).fair, gstrMONEY_FORMAT)
            mPg.IDValue(FairObj.Item(I).Id & "Des") = FairObj.Item(I).Des
        End If
        mPg.IDValue("ItemDes1") = FairObj.Item(I).Des
        mPg.IDValue("ItemFair1") = Format(FairObj.Item(I).fair, gstrMONEY_FORMAT)
        mPg.IDValue("Cancel1") = ""
        capstr = Format(FairObj.Item(I).fair * 100, "##################")
        Capnum = 0
        For Capnum = 0 To Len(capstr) - 1
            mPg.IDValue("FairCap" & Format(Capnum, "0")) = GetCap(mID(capstr, Len(capstr) - Capnum, 1))
        Next Capnum
        mPg.IDValue("TotalFairCap") = hisGetMoneyCap(FairObj.Item(I).fair)
        mPg.IDValue("TotalFair") = Format(FairObj.Item(I).fair, gstrMONEY_FORMAT)
        If gtydSysConfig.Status <> 0 Then
           mPg.RPrint
        Else
           mPg.PreView vbModal
        End If
        Set tmprs = gdbobj.GetNewRs(sql)
        If Not tmprs.EOF Then
            Call gdbobj.DBExec("update Open_ReceiveSubSheet set sheetid= '" & SheetID & "' " _
                   & "WHERE revserial='" & tmprs(0) & "' and recipeserial='" & tmprs(1) & "'")
        End If
        If I < recCount Then
            If gDecSheet = 0 Then
                gpdAddSheetID
            Else
                gpdDecSheetID
            End If
            SheetID = gstrSheetID
        End If
        
        mPg.IDValue("ItemDes1") = ""
        mPg.IDValue("ItemFair1") = ""
        mPg.IDValue("Cancel1") = ""
        mPg.IDValue("AddItemDes1") = ""
        mPg.IDValue("AddItemFair1") = ""
        For Capnum = 0 To Len(capstr) - 1
            mPg.IDValue("FairCap" & Format(Capnum, "0")) = ""
        Next Capnum
    Next I
    
    For I = 1 To FairObj.Count
        If mPg.IDObject(FairObj.Item(I).Id) Is Nothing Then
            mPg.IDValue("AddItemDes" & j) = ""
            mPg.IDValue("AddItemFair" & j) = ""
            j = j + 1
        Else
            mPg.IDValue(FairObj.Item(I).Id) = ""
            mPg.IDValue(FairObj.Item(I).Id & "des") = ""
        End If
        mPg.IDValue("ItemDes" & I) = ""
        mPg.IDValue("ItemFair" & I) = ""
        mPg.IDValue("Cancel" & I) = ""
    Next I
    MPrintBack1 = True
errlbl:
End Function

Public Function MPrintBack2(ByVal SheetID As String, ByVal ActRevSerial As String, actnum As Integer) As Boolean
    Dim mPg As clsPage
    Dim FairObj As clsItemFairs
    Dim I As Integer, j As Integer, recCount As Integer, Num As Integer, Capnum As Integer
    Dim capstr As String
    Dim tmprs As Recordset
    Dim sql As String
On Error GoTo errlbl
    If gdbobj.GetRs("select count(*) from open_actReceiveSub where actrevserial='" & ActRevSerial & "'") > 0 Then
        recCount = gdbobj.Rs(0)
    End If
    sql = "select Revserial,Open_RecipeMain.recipeserial From Open_RecipeMain " _
        & "inner join Open_ReceiveSub on Open_ReceiveSub.recipeserial=Open_RecipeMain.recipeserial " _
        & "where actrevserial='" & ActRevSerial & "' and recipenum=" & Num

    Set mPg = New clsPage
    Set mPg.gdbobj = gdbobj
    If Not mPg.ReadFromDB("Open_RevSheet") Then Exit Function
    Set FairObj = New clsItemFairs
    Set tmprs = New Recordset
    Set tmprs = gdbobj.GetNewRs("Open_GetRevCatiFair1 '" & ActRevSerial & "'," & actnum)
    Do While Not tmprs.EOF
        FairObj.DepName = IIf(IsNull(tmprs!DepName), "", tmprs!DepName)
        FairObj.DcName = IIf(IsNull(tmprs!DcName), "", tmprs!DcName)
        FairObj.DsName = IIf(IsNull(tmprs!DsName), "", tmprs!DsName)
        FairObj.Add tmprs!CusmID, tmprs!Des, tmprs!fair
        tmprs.MoveNext
    Loop
    mPg.IDValue("INSID") = Me.INSID
    mPg.IDValue("SheetID") = SheetID
    mPg.IDValue("PatientID") = PatientID
    mPg.IDValue("Name") = Name
    mPg.IDValue("RevDate") = gfnGetTime("yyyy-mm-dd")
    mPg.IDValue("HdName") = gtydSysConfig.HdName
    mPg.IDValue("HdCode") = gtydSysConfig.hdCode
    mPg.IDValue("PtType") = PtDes
    mPg.IDValue("DepName") = FairObj.DepName
    mPg.IDValue("DsName") = FairObj.DsName
    mPg.IDValue("DcName") = FairObj.DcName
    mPg.IDValue("HospName") = gtydSysConfig.HospName
    If gPatientTypesObj(PtID).Label Then
        mPg.IDValue("IfLabel") = mPg.IDObject("IfLabel").Str
    Else
        mPg.IDValue("IfLabel") = ""
    End If
    capstr = Format(FairObj.fair * 100, "##################")
    Capnum = 0
    For Capnum = 0 To Len(capstr) - 1
        mPg.IDValue("FairCap" & Format(Capnum, "0")) = GetCap(mID(capstr, Len(capstr) - Capnum, 1))
    Next Capnum
        
    mPg.IDValue("TotalFairCap") = hisGetMoneyCap(FairObj.fair)
    mPg.IDValue("TotalFair") = Format(FairObj.fair, gstrMONEY_FORMAT)
    I = 1
    Do
        If mPg.IDObject("Cancel" & I) Is Nothing Then Exit Do
        mPg.IDValue("Cancel" & I) = "作废"
        I = I + 1
    Loop
    j = 1
    
    For I = 1 To FairObj.Count
        If mPg.IDObject(FairObj.Item(I).Id) Is Nothing Then
            mPg.IDValue("AddItemDes" & j) = FairObj.Item(I).Des
            mPg.IDValue("AddItemFair" & j) = Format(FairObj.Item(I).fair, gstrMONEY_FORMAT)
            j = j + 1
        Else
            mPg.IDValue(FairObj.Item(I).Id) = Format(FairObj.Item(I).fair, gstrMONEY_FORMAT)
            mPg.IDValue(FairObj.Item(I).Id & "Des") = FairObj.Item(I).Des
        End If
        mPg.IDValue("ItemDes" & I) = FairObj.Item(I).Des
        mPg.IDValue("ItemFair" & I) = Format(FairObj.Item(I).fair, gstrMONEY_FORMAT)
        mPg.IDValue("Cancel" & I) = ""
    Next I
    
    If gtydSysConfig.Status > 0 Then
        mPg.RPrint
    Else
       mPg.PreView vbModal
    End If
    For Capnum = 0 To Len(capstr) - 1
        mPg.IDValue("FairCap" & Format(Capnum, "0")) = ""
    Next Capnum
    For I = 1 To FairObj.Count
        If mPg.IDObject(FairObj.Item(I).Id) Is Nothing Then
            mPg.IDValue("AddItemDes" & j) = ""
            mPg.IDValue("AddItemFair" & j) = ""
            j = j + 1
        Else
            mPg.IDValue(FairObj.Item(I).Id) = ""
            mPg.IDValue(FairObj.Item(I).Id & "des") = ""
        End If
        mPg.IDValue("ItemDes" & I) = ""
        mPg.IDValue("ItemFair" & I) = ""
        mPg.IDValue("Cancel" & I) = ""
    Next I
    Set tmprs = gdbobj.GetNewRs(sql)
    If Not tmprs.EOF Then
        Call gdbobj.DBExec("update Open_ReceiveSubSheet set sheetid= '" & SheetID & "' " _
               & "WHERE revserial='" & tmprs(0) & "' and recipeserial='" & tmprs(1) & "'")
    End If
'    gpdAddSheetID
'    SheetID = gstrSheetID
    
    MPrintBack2 = True
errlbl:
End Function