| 1 | IBYPSM ;ALB/ARH - IB*2.0*390 POST INIT: REASONABLE CHARGES V3.1 ; 25-JAN-2008
|
|---|
| 2 | ;;2.0;INTEGRATED BILLING;**390**;21-MAR-94;Build 2
|
|---|
| 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.1 Post-Install .....",IBA(3)="" D MES^XPDUTL(.IBA) K IBA
|
|---|
| 11 | ;
|
|---|
| 12 | D CHGINA("") ; inactivate all RC charges in #363.2
|
|---|
| 13 | ;
|
|---|
| 14 | S IBA(1)="",IBA(2)=" Reasonable Charges v3.1 Post-Install Complete",IBA(3)="" D MES^XPDUTL(.IBA) K IBA
|
|---|
| 15 | ;
|
|---|
| 16 | Q
|
|---|
| 17 | ;
|
|---|
| 18 | ;
|
|---|
| 19 | ;
|
|---|
| 20 | CHGINA(VERS) ; inactive charges from previous versions of Reasonable Charges
|
|---|
| 21 | ; VERS = version to begin inactivations with (1, 1.1, 1.2, ...)
|
|---|
| 22 | ; - Inactive date added is the first RC Version Inactive date after the effective date of the charge
|
|---|
| 23 | ; - if the charge already has an inactive date less than the Version Inactive Date then no change is made
|
|---|
| 24 | ;
|
|---|
| 25 | N IBA,IBI,IBX,IBSTART,IBENDATE,IBCS,IBCS0,IBBR0,IBXRF,IBITM,IBNEF,IBCI,IBCI0,IBCIEF,IBCIIA,IBNEWIA
|
|---|
| 26 | N DD,DO,DLAYGO,DIC,DIE,DA,DR,X,Y,IBCNT S IBCNT=0
|
|---|
| 27 | ;
|
|---|
| 28 | S IBA(1)=" >> Inactivating Existing Reasonable Charges, Please Wait..." D MES^XPDUTL(.IBA) K IBA
|
|---|
| 29 | ;
|
|---|
| 30 | S IBSTART="" I $G(VERS)'="" S IBSTART=$$VERSDT^IBCRHBRV(VERS)
|
|---|
| 31 | S IBENDATE=$$VERSEND^IBCRHBRV
|
|---|
| 32 | ;
|
|---|
| 33 | S IBCS=0 F S IBCS=$O(^IBE(363.1,IBCS)) Q:'IBCS D
|
|---|
| 34 | . S IBCS0=$G(^IBE(363.1,IBCS,0)) Q:IBCS0=""
|
|---|
| 35 | . S IBBR0=$G(^IBE(363.3,+$P(IBCS0,U,2),0)) I $E(IBBR0,1,3)'="RC " Q
|
|---|
| 36 | . ;
|
|---|
| 37 | . S IBXRF="AIVDTS"_IBCS
|
|---|
| 38 | . S IBITM=0 F S IBITM=$O(^IBA(363.2,IBXRF,IBITM)) Q:'IBITM D
|
|---|
| 39 | .. S IBNEF="" F S IBNEF=$O(^IBA(363.2,IBXRF,IBITM,IBNEF)) Q:IBNEF="" Q:-IBNEF<IBSTART D
|
|---|
| 40 | ... ;
|
|---|
| 41 | ... S IBCI=0 F S IBCI=$O(^IBA(363.2,IBXRF,IBITM,IBNEF,IBCI)) Q:'IBCI D
|
|---|
| 42 | .... S IBCI0=$G(^IBA(363.2,IBCI,0)) Q:IBCI0=""
|
|---|
| 43 | .... S IBCIEF=$P(IBCI0,U,3),IBCIIA=$P(IBCI0,U,4),IBNEWIA=""
|
|---|
| 44 | .... ;
|
|---|
| 45 | .... F IBI=2:1 S IBX=+$P(IBENDATE,";",IBI) S IBNEWIA=IBX Q:'IBX Q:IBCIEF'>IBX
|
|---|
| 46 | .... ;
|
|---|
| 47 | .... I 'IBNEWIA Q
|
|---|
| 48 | .... I +IBCIIA,IBCIIA'>IBNEWIA Q
|
|---|
| 49 | .... ;
|
|---|
| 50 | .... S DR=".04////"_+IBNEWIA,DIE="^IBA(363.2,",DA=+IBCI D ^DIE K DIE,DIC,DA,DR,X,Y S IBCNT=IBCNT+1
|
|---|
| 51 | ;
|
|---|
| 52 | S IBA(1)=" Done. "_IBCNT_" existing charges inactivated " D MES^XPDUTL(.IBA) K IBA
|
|---|
| 53 | Q
|
|---|
| 54 | ;
|
|---|
| 55 | ;
|
|---|
| 56 | ;
|
|---|
| 57 | MCCRUTL(X,P) ; returns IFN of item in 399.1 if Name is found and piece P is true
|
|---|
| 58 | N IBX,IBY S IBY=""
|
|---|
| 59 | 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
|
|---|
| 60 | Q IBY
|
|---|
| 61 | ;
|
|---|
| 62 | MSG(X) ;
|
|---|
| 63 | N IBX S IBX=$O(IBA(999999),-1) S:'IBX IBX=1 S IBX=IBX+1
|
|---|
| 64 | S IBA(IBX)=$G(X)
|
|---|
| 65 | Q
|
|---|
