Routine: IBYPSK

IBYPSK ;ALB/ARH - IB*2.0*370 POST INIT: RC V3.0 DELETE PROVIDER DISCOUNTS ; 01-FEB-2007

 ;;2.0;INTEGRATED BILLING;**370**;21-MAR-94;Build 5

 ;;Per VHA Directive 2004-038, this routine should not be modified.

POST ;

 N IBA

 S IBA(1)="",IBA(2)="    Reasonable Charges v3.0 Post-Install .....",IBA(3)="" D MES^XPDUTL(.IBA) K IBA

 D PDDEL ; delete all RC Provider Discounts, except Zero Charge

 S IBA(1)="",IBA(2)="    Reasonable Charges v3.0 Post-Install Complete",IBA(3)="" D MES^XPDUTL(.IBA) K IBA

PDDEL ; delete all RC Provider Discounts (except Zero Charge)

 N IBA,IBC,IBSG,IBCNT,IBPD0,IBPDFN,DA,DIK,DIC,DIE,X,Y S IBCNT=0

 S IBC="Delete Reasonable Charges Provider Discounts:" D MSG(IBC)

 S IBSG=$O(^IBE(363.32,"B","RC PROVIDER DISCOUNTS",0))

 I 'IBSG S IBC="** Error, Discounts Not Deleted: Special Group Not Found, Contact Support" D MSG(IBC) G PDDELQ

 S IBPDFN=0 F  S IBPDFN=$O(^IBE(363.34,IBPDFN)) Q:'IBPDFN  D

 . S IBPD0=$G(^IBE(363.34,IBPDFN,0))

. ;

 . I +$P(IBPD0,U,2)'=IBSG Q

 . I $P(IBPD0,U,1)="ZERO CHARGE" Q

. ;

 . S DA=IBPDFN,DIK="^IBE(363.34," D ^DIK K DIK,DA S IBCNT=IBCNT+1

. ;

 . S IBC=">> Discount Deleted: "_$P(IBPD0,U,1) D MSG(IBC)

PDDELQ S IBC=IBCNT_" Provider Discount Groups Deleted (#363.34)" D MSG(IBC)

 D MES^XPDUTL(.IBA) K IBA

 S IBC=0,IBPD0="" F  S IBPD0=$O(^IBE(363.34,"B",IBPD0)) Q:IBPD0=""  I IBPD0'="ZERO CHARGE" S IBC=1

 I +IBC S IBA(1)="",IBA(2)="    ** Provider Discount Groups still exist, Contact Support." D MES^XPDUTL(.IBA)

MCCRUTL(X,P) ; returns IFN of item in 399.1 if Name is found and piece P is true

 N IBX,IBY S IBY=""

 I $G(X)'="" S IBX=0 F  S IBX=$O(^DGCR(399.1,"B",X,IBX)) Q:'IBX  I $P($G(^DGCR(399.1,IBX,0)),U,+$G(P)) S IBY=IBX

 Q IBY

MSG(X) ;

 N IBX S IBX=+$O(IBA(999999),-1) S IBX=IBX+1

 S IBA(IBX)="    "_$G(X)

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBYPSK   1879     printed  Mar 13, 2025@21:41:58                                                                                                                                                                                                      Page 2

IBYPSK    ;ALB/ARH - IB*2.0*370 POST INIT: RC V3.0 DELETE PROVIDER DISCOUNTS ; 01-FEB-2007

 +1       ;;2.0;INTEGRATED BILLING;**370**;21-MAR-94;Build 5

 +2       ;;Per VHA Directive 2004-038, this routine should not be modified.

 +3       ;

 +4       ;

 +5        QUIT

 +6       ;

POST      ;

 +1        NEW IBA

 +2        SET IBA(1)=""

           SET IBA(2)="    Reasonable Charges v3.0 Post-Install ....."

           SET IBA(3)=""

           DO MES^XPDUTL(.IBA)

           KILL IBA

 +3       ;

 +4       ; delete all RC Provider Discounts, except Zero Charge

           DO PDDEL

 +5       ;

 +6        SET IBA(1)=""

           SET IBA(2)="    Reasonable Charges v3.0 Post-Install Complete"

           SET IBA(3)=""

           DO MES^XPDUTL(.IBA)

           KILL IBA

 +7       ;

 +8        QUIT

 +9       ;

 +10      ;

PDDEL     ; delete all RC Provider Discounts (except Zero Charge)

 +1        NEW IBA,IBC,IBSG,IBCNT,IBPD0,IBPDFN,DA,DIK,DIC,DIE,X,Y

           SET IBCNT=0

 +2        SET IBC="Delete Reasonable Charges Provider Discounts:"

           DO MSG(IBC)

 +3       ;

 +4        SET IBSG=$ORDER(^IBE(363.32,"B","RC PROVIDER DISCOUNTS",0))

 +5        IF 'IBSG

               SET IBC="** Error, Discounts Not Deleted: Special Group Not Found, Contact Support"

               DO MSG(IBC)

               GOTO PDDELQ

 +6       ;

 +7        SET IBPDFN=0

FOR

               SET IBPDFN=$ORDER(^IBE(363.34,IBPDFN))

               if 'IBPDFN

                   QUIT

               Begin DoDot:1

 +8                SET IBPD0=$GET(^IBE(363.34,IBPDFN,0))

 +9       ;

 +10               IF +$PIECE(IBPD0,U,2)'=IBSG

                       QUIT

 +11               IF $PIECE(IBPD0,U,1)="ZERO CHARGE"

                       QUIT

 +12      ;

 +13               SET DA=IBPDFN

                   SET DIK="^IBE(363.34,"

                   DO ^DIK

                   KILL DIK,DA

                   SET IBCNT=IBCNT+1

 +14      ;

 +15               SET IBC=">> Discount Deleted: "_$PIECE(IBPD0,U,1)

                   DO MSG(IBC)

               End DoDot:1

 +16      ;

PDDELQ     SET IBC=IBCNT_" Provider Discount Groups Deleted (#363.34)"

           DO MSG(IBC)

 +1        DO MES^XPDUTL(.IBA)

           KILL IBA

 +2       ;

 +3        SET IBC=0

           SET IBPD0=""

FOR

               SET IBPD0=$ORDER(^IBE(363.34,"B",IBPD0))

               if IBPD0=""

                   QUIT

               IF IBPD0'="ZERO CHARGE"

                   SET IBC=1

 +4        IF +IBC

               SET IBA(1)=""

               SET IBA(2)="    ** Provider Discount Groups still exist, Contact Support."

               DO MES^XPDUTL(.IBA)

 +5        QUIT

 +6       ;

 +7       ;

 +8       ;

MCCRUTL(X,P) ; returns IFN of item in 399.1 if Name is found and piece P is true

 +1        NEW IBX,IBY

           SET IBY=""

 +2        IF $GET(X)'=""

               SET IBX=0

FOR

                   SET IBX=$ORDER(^DGCR(399.1,"B",X,IBX))

                   if 'IBX

                       QUIT

                   IF $PIECE($GET(^DGCR(399.1,IBX,0)),U,+$GET(P))

                       SET IBY=IBX

 +3        QUIT IBY

 +4       ;

MSG(X)    ;

 +1        NEW IBX

           SET IBX=+$ORDER(IBA(999999),-1)

           SET IBX=IBX+1

 +2        SET IBA(IBX)="    "_$GET(X)

 +3        QUIT

IBYPSK.m