- 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 Mar 13, 2025@21:23:58 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
