IBCRED ;ALB/ARH - RATES: CM DELETE CHARGE ITEMS OPTION ; 22-MAY-1996
;;Per VHA Directive 10-93-142, this routine should not be modified.
ENTER ; OPTION ENTRY POINT: delete charge items for a specific charge set, may be inactive by a date or all
W @IOF W !,?12,"**** DELETE INACTIVE CHARGE ITEMS FROM A CHARGE SET ****"
W !!,?5,"For a given Charge Set, this option allows deletion of all chargeable items",!,?5,"that have been inactivated or replaced before a certain date.",!
W !,?5,"Since all charges for a billing rate and date range may be deleted with",!,?5,"this option, caution is advised.",!
N IBCS,IBDT,IBCSDEL,IBQUIT,DIR,DTOUT,DUOUT,DIRUT,X,Y S IBDT=0,IBCSDEL=0 K ^TMP($J,"IBCRED")
W !!,"The Charge Set to delete Charge items from:" S IBCS=$$GETCS^IBCRU1 I +IBCS<1 Q
W ! S DIR(0)="YO",DIR("A")="Delete ALL charges for this Charge Set" D ^DIR K DIR Q:$D(DIRUT) I Y=1 S IBDT="ALL"
I IBDT="ALL" I IBCS>999!($P(IBCS,U,2)["RC-")!($P(IBCS,U,2)["CMAC") D
. S DIR("?")="Enter Yes to delete the Charge Set and it's links with Rate Schedules and Special Groups. The sets Region will also be deleted if not associated with another set."
. S DIR(0)="YO",DIR("A")="Also delete the Charge Set "_$P(IBCS,U,2) D ^DIR K DIR Q:$D(DIRUT) I Y=1 S IBCSDEL=1
I IBDT'="ALL" W !!,"All charges inactive before this date will be deleted:" S IBDT=$$GETDT^IBCRU1(,"Select INACTIVE DATE") I IBDT'?7N W !,"No deletions",! Q
S DIR(0)="SO^1:Print List of Charges that will be Deleted;2:Delete Charges" D ^DIR K DIR I +Y<1!$D(DIRUT) Q
I +Y=1 D DEV Q:+$G(IBQUIT) G RPT
W !!!,"All charges",$S('IBDT:"",1:" inactive before "_$$DATE(IBDT))," for ",$P(IBCS,U,2)," will be deleted.",!
S DIR(0)="YO",DIR("A")="Is this correct, do you want to continue" D ^DIR K DIR I Y'=1 W !,"No deletions",!
I Y=1 D
. W !,"Beginning Deletions" W !,$$DELETE(IBCS,IBDT)," charges deleted."
. I +IBCSDEL W !!,$P(IBCS,U,2)," ",$P($$CSDELETE(+IBCS),U,2)
DELETE(CS,INDT,SAVE) ; delete all charge items in a set inactive before a certain date
; Input: CS - set to delete charges from,
; INDT - charges not active on this date will be deleted, if ALL- all charges will be deleted from set
; SAVE - if true, charge items that would be deleted are entered into TMP array for printing instead
; Output: returns the count of the charge items deleted
S IBXRF="AIVDTS"_+$G(CS),IBCNT=0,INDT=$G(INDT),IBSUB2="" I INDT="ALL" S INDT=9999999
I +$G(SAVE) S IBSUB2=$$TMPHDR($G(CS),INDT)
S IBITM=0 F S IBITM=$O(^IBA(363.2,IBXRF,IBITM)) Q:'IBITM D
. S IBEFDT=0 F S IBEFDT=$O(^IBA(363.2,IBXRF,IBITM,IBEFDT),-1) Q:'IBEFDT!(IBEFDT'>-INDT) D
.. S IBCIFN=0 F S IBCIFN=$O(^IBA(363.2,IBXRF,IBITM,IBEFDT,IBCIFN)) Q:'IBCIFN D
... S IBINDTCI=$$INACTCI^IBCRU4(IBCIFN)
... I INDT=9999999 D DELCI(IBCIFN,IBSUB2) S IBCNT=IBCNT+1 Q
... I +IBINDTCI,IBINDTCI<INDT D DELCI(IBCIFN,IBSUB2) S IBCNT=IBCNT+1
DELCI(CI,SUB2) ; either save in TMP arry to print or delete
I $G(SUB2)'="" D TMPLN^IBCROI1(CI,"IBCRED",SUB2,1) Q
I $G(^IBA(363.2,+$G(CI),0)) S DA=CI,DIK="^IBA(363.2," D ^DIK K DA,DIK
TMPHDR(CS,INDT) ; set up array header for printed report
N IBHDR,IBHDR2,IBDT,SUB2 S SUB2=$P($G(^IBE(363.1,+CS,0)),U,1)
S IBHDR="Charges (to be deleted) in "_SUB2_" set"
S IBHDR2=" inactive before",IBDT=INDT I IBDT=9999999 S IBHDR2=" (ALL CHARGES IN SET)",IBDT=""
DEV ; get device for printed report
S IBQUIT=0 S %ZIS="QM",%ZIS("A")="OUTPUT DEVICE: " D ^%ZIS I POP S IBQUIT=1 Q
I $D(IO("Q")) S ZTRTN="RPT^IBCRED",ZTDESC="Delete Charges Report",ZTSAVE("IB*")="" D ^%ZTLOAD K IO("Q") S IBQUIT=1
RPT ; print report - entry point for tasked jobs
N IBSCRPT,IBCNT S IBSCRPT="IBCRED" K ^TMP($J,"IBCRED")
I $D(^TMP($J,"IBCRED")) S $P(^TMP($J,"IBCRED"),U,4)=IBCNT_" Charges to be deleted"
CSDELETE(IBCS) ; delete a Charge Set, including all pointers to it, also delete region if not assigned to another set
N IBFN,IB11,IBRG,IBER,DA,DIC,DIE,DIK,X,Y S IBER="0^Charge Set not deleted"
I '$D(^IBE(363.1,+$G(IBCS),0)) G CSDELQ
I $O(^IBA(363.2,"AIVDTS"_+IBCS,"")) S IBER="0^Charge Set has associated Charge Items, can not delete." G CSDELQ
I $P($G(^IBE(350.9,1,9)),U,12)=+IBCS S IBER="0^Charge Set pointed to by AWP CHARGE SET Site Parameter, can not delete." G CSDELQ
; remove from Rate Schedule
S IBFN=0 F S IBFN=$O(^IBE(363,"C",+IBCS,IBFN)) Q:'IBFN D
. S IB11="" F S IB11=$O(^IBE(363,"C",+IBCS,IBFN,IB11)) Q:'IB11 D
.. I +$G(^IBE(363,+IBFN,11,+IB11,0))=+IBCS S DA(1)=+IBFN,DA=+IB11,DIK="^IBE(363,"_DA(1)_",11," D ^DIK K DIK
; remove from Special Groups
S IBFN=0 F S IBFN=$O(^IBE(363.32,IBFN)) Q:'IBFN D
. S IB11=0 F S IB11=$O(^IBE(363.32,IBFN,11,IB11)) Q:'IB11 D
.. I +$P($G(^IBE(363.32,IBFN,11,IB11,0)),U,2)=+IBCS S DA(1)=+IBFN,DA=+IB11,DIK="^IBE(363.32,"_DA(1)_",11," D ^DIK K DIK
; delete region if not assigned to another Charge Set
I +IBRG S IBFN=0 F S IBFN=$O(^IBE(363.1,IBFN)) Q:'IBFN D
. I +IBFN'=+IBCS,$P($G(^IBE(363.1,+IBFN,0)),U,7)=IBRG S IBRG=0
I +IBRG S DA=+IBRG,DIK="^IBE(363.31," D ^DIK K DA,DIK
; delete Charge Set
S DA=+IBCS,DIK="^IBE(363.1," D ^DIK K DA,DIK
S IBER="1^Charge Set Deleted"_$S(+IBRG:", Region Deleted",1:"")_"."
CSDELQ Q IBER
CSEMPTY(BR) ; delete Charge Sets that have no associated Charges (except VA Cost)
; Input: BR may be passed to limit the check for empty Charge Sets to specific Billing Rates
; only CS's of the passed Billing Rate will be checked and deleted if it has no charges
; - pointer to the Billing Rate (363.3) to check
; - first two characters of the Billing Rate Name (363.3,.01) to check
; - if no BR passed then all Charge Sets/Billing Rates are checked
; Returns: count of Charge Sets deleted
N IBCS,IBCS0,IBBR,IBBR0,IBX,IBCNT,X,Y S IBCNT=0
S IBCS=0 F S IBCS=$O(^IBE(363.1,IBCS)) Q:'IBCS D
. S IBCS0=$G(^IBE(363.1,IBCS,0)),IBBR=+$P(IBCS0,U,2),IBBR0=$G(^IBE(363.3,+IBBR,0))
. I '$P(IBBR0,U,4)!($P(IBBR0,U,5)=2) Q ; VA Cost
. I +$G(BR),IBBR'=BR Q ; selected Billing Rates
. I '$G(BR),$G(BR)'="",$E(IBBR0,1,2)'=BR Q ; selected Billing Rate names/types
. I '$O(^IBA(363.2,"AIVDTS"_+IBCS,"")) S IBX=$$CSDELETE(IBCS) I +IBX S IBCNT=IBCNT+1