IBCRED ;ALB/ARH - RATES: CM DELETE CHARGE ITEMS OPTION ; 22-MAY-1996
;;2.0;INTEGRATED BILLING;**52,106,148,307**;21-MAR-94
;;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)
Q
;
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
;
N IBXRF,IBCNT,IBSUB2,IBEFDT,IBITM,IBCIFN,IBINDTCI
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
;
Q IBCNT
;
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
Q
;
DATE(X) ;
Q $E(X,4,5)_"/"_$E(X,6,7)_"/"_$E(X,2,3)
;
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=""
D TMPHDR^IBCROI1("IBCRED",SUB2,+CS,IBHDR_IBHDR2,"2^1",IBDT)
Q SUB2
;
;
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
Q
;
RPT ; print report - entry point for tasked jobs
N IBSCRPT,IBCNT S IBSCRPT="IBCRED" K ^TMP($J,"IBCRED")
S IBCNT=$$DELETE(IBCS,IBDT,1)
I $D(^TMP($J,"IBCRED")) S $P(^TMP($J,"IBCRED"),U,4)=IBCNT_" Charges to be deleted"
G RPT^IBCROI
Q
;
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
S IBRG=$P($G(^IBE(363.1,+IBCS,0)),U,7)
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
Q IBCNT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCRED 6687 printed Nov 22, 2024@17:29:04 Page 2
IBCRED ;ALB/ARH - RATES: CM DELETE CHARGE ITEMS OPTION ; 22-MAY-1996
+1 ;;2.0;INTEGRATED BILLING;**52,106,148,307**;21-MAR-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
+4 ;
ENTER ; OPTION ENTRY POINT: delete charge items for a specific charge set, may be inactive by a date or all
+1 ;
+2 WRITE @IOF
WRITE !,?12,"**** DELETE INACTIVE CHARGE ITEMS FROM A CHARGE SET ****"
+3 WRITE !!,?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.",!
+4 WRITE !,?5,"Since all charges for a billing rate and date range may be deleted with",!,?5,"this option, caution is advised.",!
+5 ;
+6 NEW IBCS,IBDT,IBCSDEL,IBQUIT,DIR,DTOUT,DUOUT,DIRUT,X,Y
SET IBDT=0
SET IBCSDEL=0
KILL ^TMP($JOB,"IBCRED")
+7 ;
+8 WRITE !!,"The Charge Set to delete Charge items from:"
SET IBCS=$$GETCS^IBCRU1
IF +IBCS<1
QUIT
+9 ;
+10 WRITE !
SET DIR(0)="YO"
SET DIR("A")="Delete ALL charges for this Charge Set"
DO ^DIR
KILL DIR
if $DATA(DIRUT)
QUIT
IF Y=1
SET IBDT="ALL"
+11 IF IBDT="ALL"
IF IBCS>999!($PIECE(IBCS,U,2)["RC-")!($PIECE(IBCS,U,2)["CMAC")
Begin DoDot:1
+12 SET 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."
+13 SET DIR(0)="YO"
SET DIR("A")="Also delete the Charge Set "_$PIECE(IBCS,U,2)
DO ^DIR
KILL DIR
if $DATA(DIRUT)
QUIT
IF Y=1
SET IBCSDEL=1
End DoDot:1
+14 ;
+15 IF IBDT'="ALL"
WRITE !!,"All charges inactive before this date will be deleted:"
SET IBDT=$$GETDT^IBCRU1(,"Select INACTIVE DATE")
IF IBDT'?7N
WRITE !,"No deletions",!
QUIT
+16 ;
+17 SET DIR(0)="SO^1:Print List of Charges that will be Deleted;2:Delete Charges"
DO ^DIR
KILL DIR
IF +Y<1!$DATA(DIRUT)
QUIT
+18 IF +Y=1
DO DEV
if +$GET(IBQUIT)
QUIT
GOTO RPT
+19 ;
+20 WRITE !!!,"All charges",$SELECT('IBDT:"",1:" inactive before "_$$DATE(IBDT))," for ",$PIECE(IBCS,U,2)," will be deleted.",!
+21 ;
+22 SET DIR(0)="YO"
SET DIR("A")="Is this correct, do you want to continue"
DO ^DIR
KILL DIR
IF Y'=1
WRITE !,"No deletions",!
+23 ;
+24 IF Y=1
Begin DoDot:1
+25 WRITE !,"Beginning Deletions"
WRITE !,$$DELETE(IBCS,IBDT)," charges deleted."
+26 IF +IBCSDEL
WRITE !!,$PIECE(IBCS,U,2)," ",$PIECE($$CSDELETE(+IBCS),U,2)
End DoDot:1
+27 QUIT
+28 ;
DELETE(CS,INDT,SAVE) ; delete all charge items in a set inactive before a certain date
+1 ; Input: CS - set to delete charges from,
+2 ; INDT - charges not active on this date will be deleted, if ALL- all charges will be deleted from set
+3 ; SAVE - if true, charge items that would be deleted are entered into TMP array for printing instead
+4 ; Output: returns the count of the charge items deleted
+5 ;
+6 NEW IBXRF,IBCNT,IBSUB2,IBEFDT,IBITM,IBCIFN,IBINDTCI
+7 SET IBXRF="AIVDTS"_+$GET(CS)
SET IBCNT=0
SET INDT=$GET(INDT)
SET IBSUB2=""
IF INDT="ALL"
SET INDT=9999999
+8 IF +$GET(SAVE)
SET IBSUB2=$$TMPHDR($GET(CS),INDT)
+9 ;
+10 SET IBITM=0
FOR
SET IBITM=$ORDER(^IBA(363.2,IBXRF,IBITM))
if 'IBITM
QUIT
Begin DoDot:1
+11 SET IBEFDT=0
FOR
SET IBEFDT=$ORDER(^IBA(363.2,IBXRF,IBITM,IBEFDT),-1)
if 'IBEFDT!(IBEFDT'>-INDT)
QUIT
Begin DoDot:2
+12 SET IBCIFN=0
FOR
SET IBCIFN=$ORDER(^IBA(363.2,IBXRF,IBITM,IBEFDT,IBCIFN))
if 'IBCIFN
QUIT
Begin DoDot:3
+13 ;
+14 SET IBINDTCI=$$INACTCI^IBCRU4(IBCIFN)
+15 IF INDT=9999999
DO DELCI(IBCIFN,IBSUB2)
SET IBCNT=IBCNT+1
QUIT
+16 IF +IBINDTCI
IF IBINDTCI<INDT
DO DELCI(IBCIFN,IBSUB2)
SET IBCNT=IBCNT+1
End DoDot:3
End DoDot:2
End DoDot:1
+17 ;
+18 QUIT IBCNT
+19 ;
DELCI(CI,SUB2) ; either save in TMP arry to print or delete
+1 IF $GET(SUB2)'=""
DO TMPLN^IBCROI1(CI,"IBCRED",SUB2,1)
QUIT
+2 IF $GET(^IBA(363.2,+$GET(CI),0))
SET DA=CI
SET DIK="^IBA(363.2,"
DO ^DIK
KILL DA,DIK
+3 QUIT
+4 ;
DATE(X) ;
+1 QUIT $EXTRACT(X,4,5)_"/"_$EXTRACT(X,6,7)_"/"_$EXTRACT(X,2,3)
+2 ;
TMPHDR(CS,INDT) ; set up array header for printed report
+1 NEW IBHDR,IBHDR2,IBDT,SUB2
SET SUB2=$PIECE($GET(^IBE(363.1,+CS,0)),U,1)
+2 SET IBHDR="Charges (to be deleted) in "_SUB2_" set"
+3 SET IBHDR2=" inactive before"
SET IBDT=INDT
IF IBDT=9999999
SET IBHDR2=" (ALL CHARGES IN SET)"
SET IBDT=""
+4 DO TMPHDR^IBCROI1("IBCRED",SUB2,+CS,IBHDR_IBHDR2,"2^1",IBDT)
+5 QUIT SUB2
+6 ;
+7 ;
DEV ; get device for printed report
+1 SET IBQUIT=0
SET %ZIS="QM"
SET %ZIS("A")="OUTPUT DEVICE: "
DO ^%ZIS
IF POP
SET IBQUIT=1
QUIT
+2 IF $DATA(IO("Q"))
SET ZTRTN="RPT^IBCRED"
SET ZTDESC="Delete Charges Report"
SET ZTSAVE("IB*")=""
DO ^%ZTLOAD
KILL IO("Q")
SET IBQUIT=1
+3 QUIT
+4 ;
RPT ; print report - entry point for tasked jobs
+1 NEW IBSCRPT,IBCNT
SET IBSCRPT="IBCRED"
KILL ^TMP($JOB,"IBCRED")
+2 SET IBCNT=$$DELETE(IBCS,IBDT,1)
+3 IF $DATA(^TMP($JOB,"IBCRED"))
SET $PIECE(^TMP($JOB,"IBCRED"),U,4)=IBCNT_" Charges to be deleted"
+4 GOTO RPT^IBCROI
+5 QUIT
+6 ;
CSDELETE(IBCS) ; delete a Charge Set, including all pointers to it, also delete region if not assigned to another set
+1 NEW IBFN,IB11,IBRG,IBER,DA,DIC,DIE,DIK,X,Y
SET IBER="0^Charge Set not deleted"
+2 IF '$DATA(^IBE(363.1,+$GET(IBCS),0))
GOTO CSDELQ
+3 IF $ORDER(^IBA(363.2,"AIVDTS"_+IBCS,""))
SET IBER="0^Charge Set has associated Charge Items, can not delete."
GOTO CSDELQ
+4 IF $PIECE($GET(^IBE(350.9,1,9)),U,12)=+IBCS
SET IBER="0^Charge Set pointed to by AWP CHARGE SET Site Parameter, can not delete."
GOTO CSDELQ
+5 ;
+6 ; remove from Rate Schedule
+7 SET IBFN=0
FOR
SET IBFN=$ORDER(^IBE(363,"C",+IBCS,IBFN))
if 'IBFN
QUIT
Begin DoDot:1
+8 SET IB11=""
FOR
SET IB11=$ORDER(^IBE(363,"C",+IBCS,IBFN,IB11))
if 'IB11
QUIT
Begin DoDot:2
+9 IF +$GET(^IBE(363,+IBFN,11,+IB11,0))=+IBCS
SET DA(1)=+IBFN
SET DA=+IB11
SET DIK="^IBE(363,"_DA(1)_",11,"
DO ^DIK
KILL DIK
End DoDot:2
End DoDot:1
+10 ;
+11 ; remove from Special Groups
+12 SET IBFN=0
FOR
SET IBFN=$ORDER(^IBE(363.32,IBFN))
if 'IBFN
QUIT
Begin DoDot:1
+13 SET IB11=0
FOR
SET IB11=$ORDER(^IBE(363.32,IBFN,11,IB11))
if 'IB11
QUIT
Begin DoDot:2
+14 IF +$PIECE($GET(^IBE(363.32,IBFN,11,IB11,0)),U,2)=+IBCS
SET DA(1)=+IBFN
SET DA=+IB11
SET DIK="^IBE(363.32,"_DA(1)_",11,"
DO ^DIK
KILL DIK
End DoDot:2
End DoDot:1
+15 ;
+16 ; delete region if not assigned to another Charge Set
+17 SET IBRG=$PIECE($GET(^IBE(363.1,+IBCS,0)),U,7)
+18 IF +IBRG
SET IBFN=0
FOR
SET IBFN=$ORDER(^IBE(363.1,IBFN))
if 'IBFN
QUIT
Begin DoDot:1
+19 IF +IBFN'=+IBCS
IF $PIECE($GET(^IBE(363.1,+IBFN,0)),U,7)=IBRG
SET IBRG=0
End DoDot:1
+20 IF +IBRG
SET DA=+IBRG
SET DIK="^IBE(363.31,"
DO ^DIK
KILL DA,DIK
+21 ;
+22 ; delete Charge Set
+23 SET DA=+IBCS
SET DIK="^IBE(363.1,"
DO ^DIK
KILL DA,DIK
+24 SET IBER="1^Charge Set Deleted"_$SELECT(+IBRG:", Region Deleted",1:"")_"."
CSDELQ QUIT IBER
+1 ;
CSEMPTY(BR) ; delete Charge Sets that have no associated Charges (except VA Cost)
+1 ; Input: BR may be passed to limit the check for empty Charge Sets to specific Billing Rates
+2 ; only CS's of the passed Billing Rate will be checked and deleted if it has no charges
+3 ; - pointer to the Billing Rate (363.3) to check
+4 ; - first two characters of the Billing Rate Name (363.3,.01) to check
+5 ; - if no BR passed then all Charge Sets/Billing Rates are checked
+6 ; Returns: count of Charge Sets deleted
+7 NEW IBCS,IBCS0,IBBR,IBBR0,IBX,IBCNT,X,Y
SET IBCNT=0
+8 SET IBCS=0
FOR
SET IBCS=$ORDER(^IBE(363.1,IBCS))
if 'IBCS
QUIT
Begin DoDot:1
+9 SET IBCS0=$GET(^IBE(363.1,IBCS,0))
SET IBBR=+$PIECE(IBCS0,U,2)
SET IBBR0=$GET(^IBE(363.3,+IBBR,0))
+10 ; VA Cost
IF '$PIECE(IBBR0,U,4)!($PIECE(IBBR0,U,5)=2)
QUIT
+11 ; selected Billing Rates
IF +$GET(BR)
IF IBBR'=BR
QUIT
+12 ; selected Billing Rate names/types
IF '$GET(BR)
IF $GET(BR)'=""
IF $EXTRACT(IBBR0,1,2)'=BR
QUIT
+13 IF '$ORDER(^IBA(363.2,"AIVDTS"_+IBCS,""))
SET IBX=$$CSDELETE(IBCS)
IF +IBX
SET IBCNT=IBCNT+1
End DoDot:1
+14 QUIT IBCNT
