source: WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBYPSK.m@ 1464

Last change on this file since 1464 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 1.8 KB
Line 
1IBYPSK ;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 ;
8POST ;
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 ;
19PDDEL ; 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 ;
36PDDELQ 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 ;
45MCCRUTL(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 ;
50MSG(X) ;
51 N IBX S IBX=+$O(IBA(999999),-1) S IBX=IBX+1
52 S IBA(IBX)=" "_$G(X)
53 Q
Note: See TracBrowser for help on using the repository browser.