IBYP667 ;ALB/CXW - IB*2.0*667 POST INIT: REASONABLE CHARGES V3.27 & PERSON CLASS; 11/26/2019
;;2.0;INTEGRATED BILLING;**667**;21-MAR-94;Build 65
;;Per VA Directive 6402, this routine should not be modified.
Q
;
POST ;
N IBA,U S U="^"
D BMSG(" Reasonable Charges v3.27 Post-Install .....")
;
D CHGINA("") ; inactivate all RC charges in #363.2
D ZPDEL ; delete zero charge on provider person class - acupuncturist
;
D BMSG(" Reasonable Charges v3.27 Post-Install Complete")
;
Q
;
BMSG(IBA) ;
D BMES^XPDUTL(IBA)
Q
MSG(IBA) ;
D MES^XPDUTL(IBA)
Q
;
CHGINA(VERS) ; inactive charges from previous versions of Reasonable Charges
; VERS = version to begin inactivations with (1, 1.1, 1.2, ...)
; - Inactive date added is the first RC Version Inactive date after the effective date of the charge
; - if the charge already has an inactive date less than the Version Inactive Date then no change is made
;
N IBA,IBI,IBX,IBSTART,IBENDATE,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
;
D BMSG(" >> Inactivating Existing Reasonable Charges, Please Wait...")
;
S IBSTART="" I $G(VERS)'="" S IBSTART=$$VERSDT^IBCRHBRV(VERS)
S IBENDATE=$$VERSEND^IBCRHBRV
;
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 $E(IBBR0,1,3)'="RC " 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="" Q:-IBNEF<IBSTART 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=""
.... ;
.... F IBI=2:1 S IBX=+$P(IBENDATE,";",IBI) S IBNEWIA=IBX Q:'IBX Q:IBCIEF'>IBX
.... ;
.... I 'IBNEWIA Q
.... I +IBCIIA,IBCIIA'>IBNEWIA Q
.... ;
.... S DR=".04///"_+IBNEWIA,DIE="^IBA(363.2,",DA=+IBCI D ^DIE K DIE,DIC,DA,DR,X,Y S IBCNT=IBCNT+1
;
D MSG(" Done. "_IBCNT_" existing charges inactivated")
Q
ZPDEL ; deletion of zero charge provider person class
N IBCNT,IBPD,IBPD0,IBVAC,IBZC,IBZC0,DA,DIK,X,Y S IBCNT=0
D BMSG(" >> Deleting Zero Charge on Provider Person Class - Acupuncturist V080100")
S IBPD=$O(^IBE(363.32,"B","RC PROVIDER DISCOUNTS",0))
I 'IBPD D MSG(" RC PROVIDER DISCOUNT not defined in the file #363.32, not deleted!") G ZPDELQ
S IBZC=$O(^IBE(363.34,"B","ZERO CHARGE",0))
I 'IBZC D MSG(" ZERO CHARGE not defined in the file #363.34, not deleted!") G ZPDELQ
S IBPD0=$G(^IBE(363.34,IBZC,0))
I +$P(IBPD0,U,2)'=IBPD D MSG(" RC PROVIDER DISCOUNT not associated with ZERO CHARGE, not deleted!") G ZPDELQ
;
S IBZC0=0 F S IBZC0=$O(^IBE(363.34,IBZC,11,IBZC0)) Q:'IBZC0 D
. S IBVAC=$G(^IBE(363.34,IBZC,11,IBZC0,0))
. ; DBIA2823
. I $P($G(^USC(8932.1,IBVAC,0)),U,6)'="V080100" Q
. S DA=IBZC0,DA(1)=IBZC,DIK="^IBE(363.34,"_DA(1)_",11," D ^DIK
. S IBCNT=IBCNT+1
D MSG(" Done. "_IBCNT_" existing person class deleted")
;
ZPDELQ ;
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBYP667 3194 printed Dec 13, 2024@02:36:16 Page 2
IBYP667 ;ALB/CXW - IB*2.0*667 POST INIT: REASONABLE CHARGES V3.27 & PERSON CLASS; 11/26/2019
+1 ;;2.0;INTEGRATED BILLING;**667**;21-MAR-94;Build 65
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 QUIT
+4 ;
POST ;
+1 NEW IBA,U
SET U="^"
+2 DO BMSG(" Reasonable Charges v3.27 Post-Install .....")
+3 ;
+4 ; inactivate all RC charges in #363.2
DO CHGINA("")
+5 ; delete zero charge on provider person class - acupuncturist
DO ZPDEL
+6 ;
+7 DO BMSG(" Reasonable Charges v3.27 Post-Install Complete")
+8 ;
+9 QUIT
+10 ;
BMSG(IBA) ;
+1 DO BMES^XPDUTL(IBA)
+2 QUIT
MSG(IBA) ;
+1 DO MES^XPDUTL(IBA)
+2 QUIT
+3 ;
CHGINA(VERS) ; inactive charges from previous versions of Reasonable Charges
+1 ; VERS = version to begin inactivations with (1, 1.1, 1.2, ...)
+2 ; - Inactive date added is the first RC Version Inactive date after the effective date of the charge
+3 ; - if the charge already has an inactive date less than the Version Inactive Date then no change is made
+4 ;
+5 NEW IBA,IBI,IBX,IBSTART,IBENDATE,IBCS,IBCS0,IBBR0,IBXRF,IBITM,IBNEF,IBCI,IBCI0,IBCIEF,IBCIIA,IBNEWIA
+6 NEW DD,DO,DLAYGO,DIC,DIE,DA,DR,X,Y,IBCNT
SET IBCNT=0
+7 ;
+8 DO BMSG(" >> Inactivating Existing Reasonable Charges, Please Wait...")
+9 ;
+10 SET IBSTART=""
IF $GET(VERS)'=""
SET IBSTART=$$VERSDT^IBCRHBRV(VERS)
+11 SET IBENDATE=$$VERSEND^IBCRHBRV
+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))
IF $EXTRACT(IBBR0,1,3)'="RC "
QUIT
+16 ;
+17 SET IBXRF="AIVDTS"_IBCS
+18 SET IBITM=0
FOR
SET IBITM=$ORDER(^IBA(363.2,IBXRF,IBITM))
if 'IBITM
QUIT
Begin DoDot:2
+19 SET IBNEF=""
FOR
SET IBNEF=$ORDER(^IBA(363.2,IBXRF,IBITM,IBNEF))
if IBNEF=""
QUIT
if -IBNEF<IBSTART
QUIT
Begin DoDot:3
+20 ;
+21 SET IBCI=0
FOR
SET IBCI=$ORDER(^IBA(363.2,IBXRF,IBITM,IBNEF,IBCI))
if 'IBCI
QUIT
Begin DoDot:4
+22 SET IBCI0=$GET(^IBA(363.2,IBCI,0))
if IBCI0=""
QUIT
+23 SET IBCIEF=$PIECE(IBCI0,U,3)
SET IBCIIA=$PIECE(IBCI0,U,4)
SET IBNEWIA=""
+24 ;
+25 FOR IBI=2:1
SET IBX=+$PIECE(IBENDATE,";",IBI)
SET IBNEWIA=IBX
if 'IBX
QUIT
if IBCIEF'>IBX
QUIT
+26 ;
+27 IF 'IBNEWIA
QUIT
+28 IF +IBCIIA
IF IBCIIA'>IBNEWIA
QUIT
+29 ;
+30 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
+31 ;
+32 DO MSG(" Done. "_IBCNT_" existing charges inactivated")
+33 QUIT
ZPDEL ; deletion of zero charge provider person class
+1 NEW IBCNT,IBPD,IBPD0,IBVAC,IBZC,IBZC0,DA,DIK,X,Y
SET IBCNT=0
+2 DO BMSG(" >> Deleting Zero Charge on Provider Person Class - Acupuncturist V080100")
+3 SET IBPD=$ORDER(^IBE(363.32,"B","RC PROVIDER DISCOUNTS",0))
+4 IF 'IBPD
DO MSG(" RC PROVIDER DISCOUNT not defined in the file #363.32, not deleted!")
GOTO ZPDELQ
+5 SET IBZC=$ORDER(^IBE(363.34,"B","ZERO CHARGE",0))
+6 IF 'IBZC
DO MSG(" ZERO CHARGE not defined in the file #363.34, not deleted!")
GOTO ZPDELQ
+7 SET IBPD0=$GET(^IBE(363.34,IBZC,0))
+8 IF +$PIECE(IBPD0,U,2)'=IBPD
DO MSG(" RC PROVIDER DISCOUNT not associated with ZERO CHARGE, not deleted!")
GOTO ZPDELQ
+9 ;
+10 SET IBZC0=0
FOR
SET IBZC0=$ORDER(^IBE(363.34,IBZC,11,IBZC0))
if 'IBZC0
QUIT
Begin DoDot:1
+11 SET IBVAC=$GET(^IBE(363.34,IBZC,11,IBZC0,0))
+12 ; DBIA2823
+13 IF $PIECE($GET(^USC(8932.1,IBVAC,0)),U,6)'="V080100"
QUIT
+14 SET DA=IBZC0
SET DA(1)=IBZC
SET DIK="^IBE(363.34,"_DA(1)_",11,"
DO ^DIK
+15 SET IBCNT=IBCNT+1
End DoDot:1
+16 DO MSG(" Done. "_IBCNT_" existing person class deleted")
+17 ;
ZPDELQ ;
+1 QUIT
+2 ;
