| 1 | IBYPSK ;ALB/ARH - IB*2.0*370 POST INIT: RC V3.0 DELETE PROVIDER DISCOUNTS ; 01-FEB-2007
|
|---|
| 2 | ;;2.0;INTEGRATED BILLING;**370**;21-MAR-94;Build 5
|
|---|
| 3 | ;;Per VHA Directive 2004-038, this routine should not be modified.
|
|---|
| 4 | ;
|
|---|
| 5 | ;
|
|---|
| 6 | Q
|
|---|
| 7 | ;
|
|---|
| 8 | POST ;
|
|---|
| 9 | N IBA
|
|---|
| 10 | S IBA(1)="",IBA(2)=" Reasonable Charges v3.0 Post-Install .....",IBA(3)="" D MES^XPDUTL(.IBA) K IBA
|
|---|
| 11 | ;
|
|---|
| 12 | D PDDEL ; delete all RC Provider Discounts, except Zero Charge
|
|---|
| 13 | ;
|
|---|
| 14 | S IBA(1)="",IBA(2)=" Reasonable Charges v3.0 Post-Install Complete",IBA(3)="" D MES^XPDUTL(.IBA) K IBA
|
|---|
| 15 | ;
|
|---|
| 16 | Q
|
|---|
| 17 | ;
|
|---|
| 18 | ;
|
|---|
| 19 | PDDEL ; delete all RC Provider Discounts (except Zero Charge)
|
|---|
| 20 | N IBA,IBC,IBSG,IBCNT,IBPD0,IBPDFN,DA,DIK,DIC,DIE,X,Y S IBCNT=0
|
|---|
| 21 | S IBC="Delete Reasonable Charges Provider Discounts:" D MSG(IBC)
|
|---|
| 22 | ;
|
|---|
| 23 | S IBSG=$O(^IBE(363.32,"B","RC PROVIDER DISCOUNTS",0))
|
|---|
| 24 | I 'IBSG S IBC="** Error, Discounts Not Deleted: Special Group Not Found, Contact Support" D MSG(IBC) G PDDELQ
|
|---|
| 25 | ;
|
|---|
| 26 | S IBPDFN=0 F S IBPDFN=$O(^IBE(363.34,IBPDFN)) Q:'IBPDFN D
|
|---|
| 27 | . S IBPD0=$G(^IBE(363.34,IBPDFN,0))
|
|---|
| 28 | . ;
|
|---|
| 29 | . I +$P(IBPD0,U,2)'=IBSG Q
|
|---|
| 30 | . I $P(IBPD0,U,1)="ZERO CHARGE" Q
|
|---|
| 31 | . ;
|
|---|
| 32 | . S DA=IBPDFN,DIK="^IBE(363.34," D ^DIK K DIK,DA S IBCNT=IBCNT+1
|
|---|
| 33 | . ;
|
|---|
| 34 | . S IBC=">> Discount Deleted: "_$P(IBPD0,U,1) D MSG(IBC)
|
|---|
| 35 | ;
|
|---|
| 36 | PDDELQ S IBC=IBCNT_" Provider Discount Groups Deleted (#363.34)" D MSG(IBC)
|
|---|
| 37 | D MES^XPDUTL(.IBA) K IBA
|
|---|
| 38 | ;
|
|---|
| 39 | S IBC=0,IBPD0="" F S IBPD0=$O(^IBE(363.34,"B",IBPD0)) Q:IBPD0="" I IBPD0'="ZERO CHARGE" S IBC=1
|
|---|
| 40 | I +IBC S IBA(1)="",IBA(2)=" ** Provider Discount Groups still exist, Contact Support." D MES^XPDUTL(.IBA)
|
|---|
| 41 | Q
|
|---|
| 42 | ;
|
|---|
| 43 | ;
|
|---|
| 44 | ;
|
|---|
| 45 | MCCRUTL(X,P) ; returns IFN of item in 399.1 if Name is found and piece P is true
|
|---|
| 46 | N IBX,IBY S IBY=""
|
|---|
| 47 | 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
|
|---|
| 48 | Q IBY
|
|---|
| 49 | ;
|
|---|
| 50 | MSG(X) ;
|
|---|
| 51 | N IBX S IBX=+$O(IBA(999999),-1) S IBX=IBX+1
|
|---|
| 52 | S IBA(IBX)=" "_$G(X)
|
|---|
| 53 | Q
|
|---|
