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.
;
;
Q
;
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
;
Q
;
;
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)
Q
;
;
;
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)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBYPSK 1879 printed Dec 13, 2024@02:36:46 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
