- 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 Feb 19, 2025@00:02:45 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 ;