IB20P580.m

IB20P580 ;ALB/CXW - IB*2*580 POST INIT:COST-BASED/INTERAGENCY FIX ;11-07-2016

 ;;2.0;INTEGRATED BILLING;**580**;21-MAR-94;Build 38

 ;;Per VA Directive 6402, this routine should not be modified.

 ; 

 ;

 ; Cost Based/Interagency Rate fix for Polytrauma in Charge Item (363.2)

 Q

POST ;

 N IBEFFDT,IBA,U S U="^"

 D MSG("   IB*2.0*580 Post-Install .....")

 S IBEFFDT=3160707 ; effective date of 07/07/2016

 D UPDTCI(IBEFFDT)  ; update Charge Items (363.2) with 4 rates            

 D MSG("   IB*2.0*580 Post-Install Complete")

 Q

 ;

UPDTCI(IBEFFDT) ; Update Charge Items (363.2) needs Charge Sets, pass in the effective date of the new charges

 N IBC,IBCHG,IBCNT,IBCNT1,IBC,IBCI,IBCS,IBDFLTDT,IBDT,IBI,IBLN,IBPE,IBRVCD,IBX,IBXRF,IBZ,DA,DIE,DR,X,Y

 ; 

 D MSG("")

 S IBCNT=0,IBDFLTDT=+$G(IBEFFDT)

 I 'IBDFLTDT D MSG("** Error: No Effective Date, No Charges Updated") G CIQ

 ;

 F IBI=1:1 S IBLN=$P($T(CIF+IBI),";;",2) Q:+IBLN!(IBLN="")  I $E(IBLN)?1A D SETCI

 ;

CIQ D MSG(">> "_IBCNT_" Cost Based/Interagency for Polytrauma/PM&RS charge items updated (#363.2).")

 D MSG("")

 Q

 ;

SETCI ; set Charge Item (duplicates based on item, CS, eff dt, rev cd)

 ;

 S IBCS=$P(IBLN,U,2),IBCS=+$O(^IBE(363.1,"B",IBCS,0)) I 'IBCS D MSG("** Error: Charge Set "_$P(IBLN,U,2)_" undefined") Q

 S IBCI=+$$MCCRUTL($P(IBLN,U,1),5) I 'IBCI D MSG("** Error: Bed Section "_$P(IBLN,U,2)_" undefined") Q

 S IBDT=IBDFLTDT I +$P(IBLN,U,3) S IBDT=+$P(IBLN,U,3)

 S IBRVCD=$$RVCD($P(IBLN,U,4))

 S IBCHG=+$P(IBLN,U,5)

 S IBXRF="AIVDTS"_IBCS

 ; check for duplicate charge items

 S IBCNT1=0

 ;

 S IBX=0 F  S IBX=$O(^IBA(363.2,IBXRF,IBCI,-IBDT,IBX)) Q:'IBX  S IBZ=$G(^IBA(363.2,IBX,0)) I $P(IBZ,U,6)=IBRVCD D

 . S IBCNT1=IBCNT1+1

 . I +$P(IBZ,U,5)=IBCHG D MSG("   "_$P(IBLN,U,2)_" with $"_IBCHG_" charge item already exists") Q

 . S DIE="^IBA(363.2,",DA=+IBX,DR=".05///"_IBCHG D ^DIE K DIE,DA,DR,X,Y

 . S IBCNT=IBCNT+1

 I IBCNT1>1 D MSG("** Error: "_$P(IBLN,U,2)_" duplicate charge items on 07/07/2016")

 Q

 ;

MCCRUTL(IBC,IBPE) ; returns IEN in 399.1 if Name is found and piece P is true

 N IBX,IBY S IBY=""

 I $G(IBC)'="" S IBX=0 F  S IBX=$O(^DGCR(399.1,"B",IBC,IBX)) Q:'IBX  I $P($G(^DGCR(399.1,IBX,0)),U,+$G(IBPE)) S IBY=IBX

 Q IBY

 ;

RVCD(IBRVCD) ; returns IFN if revenue code is valid and active

 N IBX,IBY S IBY=""

 I +$G(IBRVCD) S IBX=$G(^DGCR(399.2,+IBRVCD,0)) I +$P(IBX,U,3) S IBY=+IBRVCD

 Q IBY

 ;

MSG(IBA) ;

 D MES^XPDUTL(IBA)

 Q

 ;

CIF ; 4 Charge Items (363.2): Bedsection ^ Charge Set ^Effective Date ^ Revenue Code ^ Charge

 ;;     

TORT ;; Cost Based (Tortiously Liable) for outpatient care

 ;;PM&RS OUTPATIENT VISIT^TL-OPT VST PM&RS^^^212

 ;;POLYTRAUMA OUTPATIENT VISIT^TL-OPT VST POLYTRAUMA^^^537

 ;;          

IA ;; Interagency for outpatient care

 ;;PM&RS OUTPATIENT VISIT^IA-OPT VST PM&RS^^^199

 ;;POLYTRAUMA OUTPATIENT VISIT^IA-OPT VST POLYTRAUMA^^^510

 ;;

 Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---IB20P580   2911     printed  Mar 13, 2025@21:08:39                                                                                                                                                                                                    Page 2

IB20P580  ;ALB/CXW - IB*2*580 POST INIT:COST-BASED/INTERAGENCY FIX ;11-07-2016

 +1       ;;2.0;INTEGRATED BILLING;**580**;21-MAR-94;Build 38

 +2       ;;Per VA Directive 6402, this routine should not be modified.

 +3       ; 

 +4       ;

 +5       ; Cost Based/Interagency Rate fix for Polytrauma in Charge Item (363.2)

 +6        QUIT 

POST      ;

 +1        NEW IBEFFDT,IBA,U

           SET U="^"

 +2        DO MSG("   IB*2.0*580 Post-Install .....")

 +3       ; effective date of 07/07/2016

           SET IBEFFDT=3160707

 +4       ; update Charge Items (363.2) with 4 rates            

           DO UPDTCI(IBEFFDT)

 +5        DO MSG("   IB*2.0*580 Post-Install Complete")

 +6        QUIT 

 +7       ;

UPDTCI(IBEFFDT) ; Update Charge Items (363.2) needs Charge Sets, pass in the effective date of the new charges

 +1        NEW IBC,IBCHG,IBCNT,IBCNT1,IBC,IBCI,IBCS,IBDFLTDT,IBDT,IBI,IBLN,IBPE,IBRVCD,IBX,IBXRF,IBZ,DA,DIE,DR,X,Y

 +2       ; 

 +3        DO MSG("")

 +4        SET IBCNT=0

           SET IBDFLTDT=+$GET(IBEFFDT)

 +5        IF 'IBDFLTDT

               DO MSG("** Error: No Effective Date, No Charges Updated")

               GOTO CIQ

 +6       ;

 +7        FOR IBI=1:1

               SET IBLN=$PIECE($TEXT(CIF+IBI),";;",2)

               if +IBLN!(IBLN="")

                   QUIT 

               IF $EXTRACT(IBLN)?1A

                   DO SETCI

 +8       ;

CIQ        DO MSG(">> "_IBCNT_" Cost Based/Interagency for Polytrauma/PM&RS charge items updated (#363.2).")

 +1        DO MSG("")

 +2        QUIT 

 +3       ;

SETCI     ; set Charge Item (duplicates based on item, CS, eff dt, rev cd)

 +1       ;

 +2        SET IBCS=$PIECE(IBLN,U,2)

           SET IBCS=+$ORDER(^IBE(363.1,"B",IBCS,0))

           IF 'IBCS

               DO MSG("** Error: Charge Set "_$PIECE(IBLN,U,2)_" undefined")

               QUIT 

 +3        SET IBCI=+$$MCCRUTL($PIECE(IBLN,U,1),5)

           IF 'IBCI

               DO MSG("** Error: Bed Section "_$PIECE(IBLN,U,2)_" undefined")

               QUIT 

 +4        SET IBDT=IBDFLTDT

           IF +$PIECE(IBLN,U,3)

               SET IBDT=+$PIECE(IBLN,U,3)

 +5        SET IBRVCD=$$RVCD($PIECE(IBLN,U,4))

 +6        SET IBCHG=+$PIECE(IBLN,U,5)

 +7        SET IBXRF="AIVDTS"_IBCS

 +8       ; check for duplicate charge items

 +9        SET IBCNT1=0

 +10      ;

 +11       SET IBX=0

           FOR 

               SET IBX=$ORDER(^IBA(363.2,IBXRF,IBCI,-IBDT,IBX))

               if 'IBX

                   QUIT 

               SET IBZ=$GET(^IBA(363.2,IBX,0))

               IF $PIECE(IBZ,U,6)=IBRVCD

                   Begin DoDot:1

 +12                   SET IBCNT1=IBCNT1+1

 +13                   IF +$PIECE(IBZ,U,5)=IBCHG

                           DO MSG("   "_$PIECE(IBLN,U,2)_" with $"_IBCHG_" charge item already exists")

                           QUIT 

 +14                   SET DIE="^IBA(363.2,"

                       SET DA=+IBX

                       SET DR=".05///"_IBCHG

                       DO ^DIE

                       KILL DIE,DA,DR,X,Y

 +15                   SET IBCNT=IBCNT+1

                   End DoDot:1

 +16       IF IBCNT1>1

               DO MSG("** Error: "_$PIECE(IBLN,U,2)_" duplicate charge items on 07/07/2016")

 +17       QUIT 

 +18      ;

MCCRUTL(IBC,IBPE) ; returns IEN in 399.1 if Name is found and piece P is true

 +1        NEW IBX,IBY

           SET IBY=""

 +2        IF $GET(IBC)'=""

               SET IBX=0

               FOR 

                   SET IBX=$ORDER(^DGCR(399.1,"B",IBC,IBX))

                   if 'IBX

                       QUIT 

                   IF $PIECE($GET(^DGCR(399.1,IBX,0)),U,+$GET(IBPE))

                       SET IBY=IBX

 +3        QUIT IBY

 +4       ;

RVCD(IBRVCD) ; returns IFN if revenue code is valid and active

 +1        NEW IBX,IBY

           SET IBY=""

 +2        IF +$GET(IBRVCD)

               SET IBX=$GET(^DGCR(399.2,+IBRVCD,0))

               IF +$PIECE(IBX,U,3)

                   SET IBY=+IBRVCD

 +3        QUIT IBY

 +4       ;

MSG(IBA)  ;

 +1        DO MES^XPDUTL(IBA)

 +2        QUIT 

 +3       ;

CIF       ; 4 Charge Items (363.2): Bedsection ^ Charge Set ^Effective Date ^ Revenue Code ^ Charge

 +1       ;;     

TORT      ;; Cost Based (Tortiously Liable) for outpatient care

 +1       ;;PM&RS OUTPATIENT VISIT^TL-OPT VST PM&RS^^^212

 +2       ;;POLYTRAUMA OUTPATIENT VISIT^TL-OPT VST POLYTRAUMA^^^537

 +3       ;;          

IA        ;; Interagency for outpatient care

 +1       ;;PM&RS OUTPATIENT VISIT^IA-OPT VST PM&RS^^^199

 +2       ;;POLYTRAUMA OUTPATIENT VISIT^IA-OPT VST POLYTRAUMA^^^510

 +3       ;;

 +4        QUIT