IBYPPL ;ALB/ARH - IB*2*307 POST INIT: CMAC 2005, INACTIVATE OLD CHARGES ; 06-JUN-2005
;;2.0;INTEGRATED BILLING;**307**;21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
Q
POST ;
N IBA S IBA(1)="",IBA(2)=" IB*2*307 CMAC 2005 Post-Install .....",IBA(3)="" D MES^XPDUTL(.IBA) K IBA
;
D CHGINA("CMAC",3050401) ; inactivate all CMAC charges effective before 04/01/05 in #363.2
;
S IBA(1)="",IBA(2)=" IB*2*307 CMAC 2005 Post-Install Complete",IBA(3)="" D MES^XPDUTL(.IBA) K IBA
Q
;
CHGINA(BRATE,NEXT) ; inactivate charges for a particular Billing Rate
; For procedure charges of requested Billing Rate, inactivate all charges effective before the date passed in.
; - For each charge the inactive date used is one day before the procedures next charge effective date.
; - If no date is passed in then the last charge is left active.
; - If a date is passed in it is used as the default in case no 'next' date is found.
; BRATE - Billing Rate, any charges whose billing rate contain BRATE will be inactivated
; NEXT - if set, beginning effective date of charges that should not be inactivated
;
N IBA,IBI,IBX,IBCS,IBCS0,IBBR0,IBXRF,IBITM,IBNEF,IBCI,IBCI0,IBCIEF,IBCIIA,IBNEWIA
N DD,DO,DLAYGO,DIC,DIE,DA,DR,X,Y,IBCNT S IBCNT=0 Q:$G(BRATE)="" S NEXT=$G(NEXT) I NEXT'="",NEXT'?7N Q
;
S IBA(1)=" >> Inactivating Existing "_BRATE_" Charges, Please Wait..." D MES^XPDUTL(.IBA) K IBA
;
S IBCS=0 F S IBCS=$O(^IBE(363.1,IBCS)) Q:'IBCS D
. S IBCS0=$G(^IBE(363.1,IBCS,0)) Q:IBCS0=""
. S IBBR0=$G(^IBE(363.3,+$P(IBCS0,U,2),0))
. ;
. I $P(IBBR0,U,1)'[BRATE Q
. ;
. S IBXRF="AIVDTS"_IBCS
. S IBITM=0 F S IBITM=$O(^IBA(363.2,IBXRF,IBITM)) Q:'IBITM D
.. S IBNEF="" F S IBNEF=$O(^IBA(363.2,IBXRF,IBITM,IBNEF)) Q:IBNEF="" D
... ;
... S IBCI=0 F S IBCI=$O(^IBA(363.2,IBXRF,IBITM,IBNEF,IBCI)) Q:'IBCI D
.... S IBCI0=$G(^IBA(363.2,IBCI,0)) Q:IBCI0=""
.... S IBCIEF=$P(IBCI0,U,3),IBCIIA=$P(IBCI0,U,4),IBNEWIA=""
.... ;
.... I +NEXT,IBCIEF'<NEXT Q
.... ;
.... S IBNEWIA=-$O(^IBA(363.2,IBXRF,IBITM,-IBCIEF),-1) I 'IBNEWIA S IBNEWIA=NEXT
.... ;
.... I 'IBNEWIA Q
.... I +IBCIIA,IBCIIA'>IBNEWIA Q
.... ;
.... S IBNEWIA=$$FMADD^XLFDT(IBNEWIA,-1)
.... ;
.... S DR=".04////"_+IBNEWIA,DIE="^IBA(363.2,",DA=+IBCI D ^DIE K DIE,DIC,DA,DR,X,Y S IBCNT=IBCNT+1
;
S IBA(1)=" Done. "_IBCNT_" existing charges inactivated " D MES^XPDUTL(.IBA) K 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 IBX=IBX+1
S IBA(IBX)=$G(X)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBYPPL 2801 printed Apr 09, 2024@21:12:30 Page 2
IBYPPL ;ALB/ARH - IB*2*307 POST INIT: CMAC 2005, INACTIVATE OLD CHARGES ; 06-JUN-2005
+1 ;;2.0;INTEGRATED BILLING;**307**;21-MAR-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
+4 QUIT
POST ;
+1 NEW IBA
SET IBA(1)=""
SET IBA(2)=" IB*2*307 CMAC 2005 Post-Install ....."
SET IBA(3)=""
DO MES^XPDUTL(.IBA)
KILL IBA
+2 ;
+3 ; inactivate all CMAC charges effective before 04/01/05 in #363.2
DO CHGINA("CMAC",3050401)
+4 ;
+5 SET IBA(1)=""
SET IBA(2)=" IB*2*307 CMAC 2005 Post-Install Complete"
SET IBA(3)=""
DO MES^XPDUTL(.IBA)
KILL IBA
+6 QUIT
+7 ;
CHGINA(BRATE,NEXT) ; inactivate charges for a particular Billing Rate
+1 ; For procedure charges of requested Billing Rate, inactivate all charges effective before the date passed in.
+2 ; - For each charge the inactive date used is one day before the procedures next charge effective date.
+3 ; - If no date is passed in then the last charge is left active.
+4 ; - If a date is passed in it is used as the default in case no 'next' date is found.
+5 ; BRATE - Billing Rate, any charges whose billing rate contain BRATE will be inactivated
+6 ; NEXT - if set, beginning effective date of charges that should not be inactivated
+7 ;
+8 NEW IBA,IBI,IBX,IBCS,IBCS0,IBBR0,IBXRF,IBITM,IBNEF,IBCI,IBCI0,IBCIEF,IBCIIA,IBNEWIA
+9 NEW DD,DO,DLAYGO,DIC,DIE,DA,DR,X,Y,IBCNT
SET IBCNT=0
if $GET(BRATE)=""
QUIT
SET NEXT=$GET(NEXT)
IF NEXT'=""
IF NEXT'?7N
QUIT
+10 ;
+11 SET IBA(1)=" >> Inactivating Existing "_BRATE_" Charges, Please Wait..."
DO MES^XPDUTL(.IBA)
KILL IBA
+12 ;
+13 SET IBCS=0
FOR
SET IBCS=$ORDER(^IBE(363.1,IBCS))
if 'IBCS
QUIT
Begin DoDot:1
+14 SET IBCS0=$GET(^IBE(363.1,IBCS,0))
if IBCS0=""
QUIT
+15 SET IBBR0=$GET(^IBE(363.3,+$PIECE(IBCS0,U,2),0))
+16 ;
+17 IF $PIECE(IBBR0,U,1)'[BRATE
QUIT
+18 ;
+19 SET IBXRF="AIVDTS"_IBCS
+20 SET IBITM=0
FOR
SET IBITM=$ORDER(^IBA(363.2,IBXRF,IBITM))
if 'IBITM
QUIT
Begin DoDot:2
+21 SET IBNEF=""
FOR
SET IBNEF=$ORDER(^IBA(363.2,IBXRF,IBITM,IBNEF))
if IBNEF=""
QUIT
Begin DoDot:3
+22 ;
+23 SET IBCI=0
FOR
SET IBCI=$ORDER(^IBA(363.2,IBXRF,IBITM,IBNEF,IBCI))
if 'IBCI
QUIT
Begin DoDot:4
+24 SET IBCI0=$GET(^IBA(363.2,IBCI,0))
if IBCI0=""
QUIT
+25 SET IBCIEF=$PIECE(IBCI0,U,3)
SET IBCIIA=$PIECE(IBCI0,U,4)
SET IBNEWIA=""
+26 ;
+27 IF +NEXT
IF IBCIEF'<NEXT
QUIT
+28 ;
+29 SET IBNEWIA=-$ORDER(^IBA(363.2,IBXRF,IBITM,-IBCIEF),-1)
IF 'IBNEWIA
SET IBNEWIA=NEXT
+30 ;
+31 IF 'IBNEWIA
QUIT
+32 IF +IBCIIA
IF IBCIIA'>IBNEWIA
QUIT
+33 ;
+34 SET IBNEWIA=$$FMADD^XLFDT(IBNEWIA,-1)
+35 ;
+36 SET DR=".04////"_+IBNEWIA
SET DIE="^IBA(363.2,"
SET DA=+IBCI
DO ^DIE
KILL DIE,DIC,DA,DR,X,Y
SET IBCNT=IBCNT+1
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+37 ;
+38 SET IBA(1)=" Done. "_IBCNT_" existing charges inactivated "
DO MES^XPDUTL(.IBA)
KILL IBA
+39 QUIT
+40 ;
+41 ;
+42 ;
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)
if 'IBX
SET IBX=1
SET IBX=IBX+1
+2 SET IBA(IBX)=$GET(X)
+3 QUIT
