Routine: IBYPPR

IBYPPR ;ALB/ARH - IB*2.0*106 PRE/POST INIT:  REASONABLE CHARGES ; 10-OCT-1998

 ;;2.0;INTEGRATED BILLING;**106**;21-MAR-94

 ;;Per VHA Directive 10-93-142, this routine should not be modified.

PRE ; in 399, delete all xrefs for certain fields, these fields are all exported with this patch

 ; they must be deleted before the build inserts the updated fields because the xrefs have changed

 N IBX,X,Y,DIK,DA,IBFLD,IBXREF

 D BMES^XPDUTL("Pre-Installation Updates (Cross references will be updated during install)")

 F IBFLD=135,151 D

. ;

 . S IBXREF=0 F  S IBXREF=$O(^DD(399,IBFLD,1,IBXREF)) Q:'IBXREF  D

 .. S DIK="^DD(399,"_IBFLD_",1,",DA(2)=399,DA(1)=IBFLD,DA=IBXREF

 .. D ^DIK K DIK,DA

 . S IBX="   >> ^DGCR(399,"_IBFLD_") cross references deleted." D MES^XPDUTL(IBX)

 F IBFLD=.01,1,5,6 D

. ;

 . S IBXREF=0 F  S IBXREF=$O(^DD(399.0304,IBFLD,1,IBXREF)) Q:'IBXREF  D

 .. S DIK="^DD(399.0304,"_IBFLD_",1,",DA(2)=399.0304,DA(1)=IBFLD,DA=IBXREF

 .. D ^DIK K DIK,DA

 . S IBX="   >> ^DGCR(399,304,"_IBFLD_") cross references deleted." D MES^XPDUTL(IBX)

 ; Output Formatter Updates:  the Data Element (364.7,.03) of a field has changed, update this before the

 ; installation so the incoming field can match correctly with the existing field

 N OLD,NEW,DIC,DIE,DR,X,Y

 ; change ACCEPT ASSIGNMENT (BX-27) (357) from N-GET FROM PREVIOUS EXTRACT (5) to N-ASSIGN OF BENEFITS INDICATOR (24)

 S DA=357

 S OLD=$O(^IBA(364.5,"B","N-GET FROM PREVIOUS EXTRACT",0))

 S NEW=$O(^IBA(364.5,"B","N-ASSIGN OF BENEFITS INDICATOR",0))

 I +OLD,+NEW,$P($G(^IBA(364.7,DA,0)),U,3)=OLD S DIE="^IBA(364.7,",DR=".03////"_NEW D ^DIE

 S IBX="   >> Output Formatter Fields Updated (#364.7,.03)." D MES^XPDUTL(IBX)

 D BMES^XPDUTL("Pre-Installation Updates Completed")

POST ;

 N IBA

 S IBA(1)="",IBA(2)="    Reasonable Charges Post-Install .....",IBA(3)="" D MES^XPDUTL(.IBA) K IBA

 D DELCT ; clear Charge Type field for all Charge Sets   (363.1, .04)

 D RSINDT ; add Rate Schedule Inactive dates (363, .06)

 D ADDBS^IBYPPR1 ; add Bedsections  (399.1,.12)

 D ADDBE^IBYPPR1 ; add Billable Events   (399.1, .21)

 D ADDBI^IBYPPR1 ; add Billable Items   (363.21)

 D ADDRS^IBYPPR1 ; add Rate Schedule   (363)

 D ADDBR^IBYPPR1 ; add Billing Rates   (363.3)

 D SGBR ; add Billing Rates to Special Groups  (363.32,11,.01)

 D RVACT ; activate 41 Revenue Codes (399.2,2)

 S IBA(1)="",IBA(2)="    Reasonable Charges Post-Install Complete",IBA(3)="" D MES^XPDUTL(.IBA) K IBA

DELCT ; Delete Charge Type from all Non-Reasonable Charges Charge Sets (363.1,.04)

 N IBA,IBCS,IBLN,IBBRN,DIC,DIE,DR,DA,X,Y

 S IBCS=0 F  S IBCS=$O(^IBE(363.1,IBCS)) Q:'IBCS  D

 . S IBLN=$G(^IBE(363.1,IBCS,0)) I '$P(IBLN,U,4) Q

 . S IBBRN=$P($G(^IBE(363.3,+$P(IBLN,U,2),0)),U,1) I $E(IBBRN,1,3)="RC " Q

. ;

 . S DR=".04////@",DIE="^IBE(363.1,",DA=+IBCS D ^DIE K DIE,DA,DR,X,Y

DCQ S IBA(1)="      >> Removing Charge Types from non-RC Charge Sets (363.1)..."

 D MES^XPDUTL(.IBA)

RSINDT ; add an inactive date to rate schedules if this is the first time the load is completed (363, .06)

 ; Reimbursable Ins, No Fault, and Workers Comp only

 ; if test account use 9/30/98, if production account use 8/31/99

 N IBA,IBRSFN,IBRS0,IBRSN,IBCNT,IBSTDT,DD,DO,DIC,DIE,DA,DR,X,Y S IBSTDT="",IBCNT=0

 I $O(^IBE(363.3,"B","RC INPATIENT FACILITY",0)) G RSINQ

 S IBSTDT=2990831 I '$$PROD^IBCORC S IBSTDT=2980930

 S IBRSFN=0 F  S IBRSFN=$O(^IBE(363,IBRSFN)) Q:'IBRSFN  D

 . S IBRS0=$G(^IBE(363,IBRSFN,0)),IBRSN=$E(IBRS0,1,3)

 . I IBRSN'="RI-",IBRSN'="NF-",IBRSN'="WC-" Q

 . I ($P(IBRS0,U,5)'="")!($P(IBRS0,U,6)'="") Q

. ;

 . S IBCNT=IBCNT+1,DR=".06////"_IBSTDT,DIE="^IBE(363,",DA=+IBRSFN D ^DIE K DIE,DA,DR,X,Y

RSINQ S IBA(1)="      >> "_IBCNT_" Rate Schedules inactivated on "_$E(IBSTDT,4,5)_"/"_$E(IBSTDT,6,7)_"/"_$E(IBSTDT,2,3)_" (363)..."

 D MES^XPDUTL(.IBA)

SGBR ; add Billing Rates to the Special Groups (363.32,11,.01)

 N IBA,IBSET,IBSG,IBSGFN,IBBR,IBBRFN,IBCNT,DINUM,DD,DO,DLAYGO,DIC,DIE,DA,DR,X,Y S IBCNT=0

 F IBSET="STANDARD RVCD LINKS^RC OUTPATIENT FACILITY","STANDARD RVCD LINKS^RC PHYSICIAN","RC PROVIDER DISCOUNTS^RC PHYSICIAN" D

 . S IBSG=$P(IBSET,U,1) Q:IBSG=""  S IBSGFN=$O(^IBE(363.32,"B",IBSG,0)) Q:'IBSGFN

 . S IBBR=$P(IBSET,U,2) Q:IBBR=""  S IBBRFN=$O(^IBE(363.3,"B",IBBR,0)) Q:'IBBRFN

. ;

 . I $O(^IBE(363.32,+IBSGFN,11,"B",+IBBRFN,0)) Q

. ;

 . S DLAYGO=363.32,DA(1)=+IBSGFN,DIC="^IBE(363.32,"_DA(1)_",11,",DIC(0)="L",X=IBBR,DIC("P")="363.3211PA" D ^DIC K DIC,DIE S IBCNT=IBCNT+1

SGBRQ S IBA(1)="      >> "_IBCNT_" Billing Rates added to Special Groups (363.32)..."

 D MES^XPDUTL(.IBA)

RVACT ; activate (30) Revenue Codes exported in RV-CPT links (399.2,2)

 N IBA,IBLN,IBI,IBRVFN,IBACT,IBCNT,IBJ,DD,DO,DIC,DIE,DA,DR,X,Y S IBCNT=0,IBACT=""

 S IBLN=$P($T(RVF+1),";;",2)

 F IBI=1:1 S IBRVFN=$P(IBLN,",",IBI) Q:'IBRVFN  D

. ;

 . I +$P($G(^DGCR(399.2,IBRVFN,0)),U,3) Q

. ;

 . S IBACT=IBACT_IBRVFN_","

 . S IBCNT=IBCNT+1,DR="2////1",DIE="^DGCR(399.2,",DA=+IBRVFN D ^DIE K DIE,DA,DR,X,Y

 I IBCNT>0 S IBJ=0 F IBI=1:15 S IBJ=IBJ+15 S IBLN=$P(IBACT,",",IBI,IBJ) Q:IBLN=""  D MSG("         "_IBLN)

RVAQ S IBA(1)="      >> "_IBCNT_" Revenue Codes activated (399.2)..."

 D MES^XPDUTL(.IBA)

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)

RVF ;  Revenue Codes to (59) Activate (399.2,2)

 ;;301,302,305,306,307,309,310,311,312,320,322,323,324,333,341,342,351,352,359,360,362,370,401,402,403,404,410,413,420,430,440,441,450,460,470,471,480,481,482,610,636,730,731,740,750,761,901,910,914,915,916,918,920,921,922,924,943,

;;

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBYPPR   5973     printed  Mar 13, 2025@21:41:44                                                                                                                                                                                                      Page 2

IBYPPR    ;ALB/ARH - IB*2.0*106 PRE/POST INIT:  REASONABLE CHARGES ; 10-OCT-1998

 +1       ;;2.0;INTEGRATED BILLING;**106**;21-MAR-94

 +2       ;;Per VHA Directive 10-93-142, this routine should not be modified.

 +3       ;

 +4       ;

 +5        QUIT

PRE       ; in 399, delete all xrefs for certain fields, these fields are all exported with this patch

 +1       ; they must be deleted before the build inserts the updated fields because the xrefs have changed

 +2        NEW IBX,X,Y,DIK,DA,IBFLD,IBXREF

 +3       ;

 +4        DO BMES^XPDUTL("Pre-Installation Updates (Cross references will be updated during install)")

 +5       ;

 +6        FOR IBFLD=135,151

               Begin DoDot:1

 +7       ;

 +8                SET IBXREF=0

FOR

                       SET IBXREF=$ORDER(^DD(399,IBFLD,1,IBXREF))

                       if 'IBXREF

                           QUIT

                       Begin DoDot:2

 +9                        SET DIK="^DD(399,"_IBFLD_",1,"

                           SET DA(2)=399

                           SET DA(1)=IBFLD

                           SET DA=IBXREF

 +10                       DO ^DIK

                           KILL DIK,DA

                       End DoDot:2

 +11               SET IBX="   >> ^DGCR(399,"_IBFLD_") cross references deleted."

                   DO MES^XPDUTL(IBX)

               End DoDot:1

 +12      ;

 +13       FOR IBFLD=.01,1,5,6

               Begin DoDot:1

 +14      ;

 +15               SET IBXREF=0

FOR

                       SET IBXREF=$ORDER(^DD(399.0304,IBFLD,1,IBXREF))

                       if 'IBXREF

                           QUIT

                       Begin DoDot:2

 +16                       SET DIK="^DD(399.0304,"_IBFLD_",1,"

                           SET DA(2)=399.0304

                           SET DA(1)=IBFLD

                           SET DA=IBXREF

 +17                       DO ^DIK

                           KILL DIK,DA

                       End DoDot:2

 +18               SET IBX="   >> ^DGCR(399,304,"_IBFLD_") cross references deleted."

                   DO MES^XPDUTL(IBX)

               End DoDot:1

 +19      ;

 +20      ; Output Formatter Updates:  the Data Element (364.7,.03) of a field has changed, update this before the

 +21      ; installation so the incoming field can match correctly with the existing field

 +22       NEW OLD,NEW,DIC,DIE,DR,X,Y

 +23      ;

 +24      ; change ACCEPT ASSIGNMENT (BX-27) (357) from N-GET FROM PREVIOUS EXTRACT (5) to N-ASSIGN OF BENEFITS INDICATOR (24)

 +25      ;

 +26       SET DA=357

 +27       SET OLD=$ORDER(^IBA(364.5,"B","N-GET FROM PREVIOUS EXTRACT",0))

 +28       SET NEW=$ORDER(^IBA(364.5,"B","N-ASSIGN OF BENEFITS INDICATOR",0))

 +29       IF +OLD

               IF +NEW

                   IF $PIECE($GET(^IBA(364.7,DA,0)),U,3)=OLD

                       SET DIE="^IBA(364.7,"

                       SET DR=".03////"_NEW

                       DO ^DIE

 +30      ;

 +31       SET IBX="   >> Output Formatter Fields Updated (#364.7,.03)."

           DO MES^XPDUTL(IBX)

 +32      ;

 +33       DO BMES^XPDUTL("Pre-Installation Updates Completed")

 +34       QUIT

 +35      ;

POST      ;

 +1        NEW IBA

 +2        SET IBA(1)=""

           SET IBA(2)="    Reasonable Charges Post-Install ....."

           SET IBA(3)=""

           DO MES^XPDUTL(.IBA)

           KILL IBA

 +3       ;

 +4       ; clear Charge Type field for all Charge Sets   (363.1, .04)

           DO DELCT

 +5       ; add Rate Schedule Inactive dates (363, .06)

           DO RSINDT

 +6       ;

 +7       ; add Bedsections  (399.1,.12)

           DO ADDBS^IBYPPR1

 +8       ; add Billable Events   (399.1, .21)

           DO ADDBE^IBYPPR1

 +9       ; add Billable Items   (363.21)

           DO ADDBI^IBYPPR1

 +10      ; add Rate Schedule   (363)

           DO ADDRS^IBYPPR1

 +11      ; add Billing Rates   (363.3)

           DO ADDBR^IBYPPR1

 +12      ;

 +13      ; add Billing Rates to Special Groups  (363.32,11,.01)

           DO SGBR

 +14      ; activate 41 Revenue Codes (399.2,2)

           DO RVACT

 +15      ;

 +16       SET IBA(1)=""

           SET IBA(2)="    Reasonable Charges Post-Install Complete"

           SET IBA(3)=""

           DO MES^XPDUTL(.IBA)

           KILL IBA

 +17      ;

 +18       QUIT

 +19      ;

DELCT     ; Delete Charge Type from all Non-Reasonable Charges Charge Sets (363.1,.04)

 +1        NEW IBA,IBCS,IBLN,IBBRN,DIC,DIE,DR,DA,X,Y

 +2       ;

 +3        SET IBCS=0

FOR

               SET IBCS=$ORDER(^IBE(363.1,IBCS))

               if 'IBCS

                   QUIT

               Begin DoDot:1

 +4                SET IBLN=$GET(^IBE(363.1,IBCS,0))

                   IF '$PIECE(IBLN,U,4)

                       QUIT

 +5                SET IBBRN=$PIECE($GET(^IBE(363.3,+$PIECE(IBLN,U,2),0)),U,1)

                   IF $EXTRACT(IBBRN,1,3)="RC "

                       QUIT

 +6       ;

 +7                SET DR=".04////@"

                   SET DIE="^IBE(363.1,"

                   SET DA=+IBCS

                   DO ^DIE

                   KILL DIE,DA,DR,X,Y

               End DoDot:1

 +8       ;

DCQ        SET IBA(1)="      >> Removing Charge Types from non-RC Charge Sets (363.1)..."

 +1        DO MES^XPDUTL(.IBA)

 +2        QUIT

 +3       ;

RSINDT    ; add an inactive date to rate schedules if this is the first time the load is completed (363, .06)

 +1       ; Reimbursable Ins, No Fault, and Workers Comp only

 +2       ; if test account use 9/30/98, if production account use 8/31/99

 +3        NEW IBA,IBRSFN,IBRS0,IBRSN,IBCNT,IBSTDT,DD,DO,DIC,DIE,DA,DR,X,Y

           SET IBSTDT=""

           SET IBCNT=0

 +4       ;

 +5        IF $ORDER(^IBE(363.3,"B","RC INPATIENT FACILITY",0))

               GOTO RSINQ

 +6       ;

 +7        SET IBSTDT=2990831

           IF '$$PROD^IBCORC

               SET IBSTDT=2980930

 +8       ;

 +9        SET IBRSFN=0

FOR

               SET IBRSFN=$ORDER(^IBE(363,IBRSFN))

               if 'IBRSFN

                   QUIT

               Begin DoDot:1

 +10               SET IBRS0=$GET(^IBE(363,IBRSFN,0))

                   SET IBRSN=$EXTRACT(IBRS0,1,3)

 +11               IF IBRSN'="RI-"

                       IF IBRSN'="NF-"

                           IF IBRSN'="WC-"

                               QUIT

 +12               IF ($PIECE(IBRS0,U,5)'="")!($PIECE(IBRS0,U,6)'="")

                       QUIT

 +13      ;

 +14               SET IBCNT=IBCNT+1

                   SET DR=".06////"_IBSTDT

                   SET DIE="^IBE(363,"

                   SET DA=+IBRSFN

                   DO ^DIE

                   KILL DIE,DA,DR,X,Y

               End DoDot:1

 +15      ;

RSINQ      SET IBA(1)="      >> "_IBCNT_" Rate Schedules inactivated on "_$EXTRACT(IBSTDT,4,5)_"/"_$EXTRACT(IBSTDT,6,7)_"/"_$EXTRACT(IBSTDT,2,3)_" (363)..."

 +1        DO MES^XPDUTL(.IBA)

 +2        QUIT

 +3       ;

SGBR      ; add Billing Rates to the Special Groups (363.32,11,.01)

 +1        NEW IBA,IBSET,IBSG,IBSGFN,IBBR,IBBRFN,IBCNT,DINUM,DD,DO,DLAYGO,DIC,DIE,DA,DR,X,Y

           SET IBCNT=0

 +2       ;

 +3        FOR IBSET="STANDARD RVCD LINKS^RC OUTPATIENT FACILITY","STANDARD RVCD LINKS^RC PHYSICIAN","RC PROVIDER DISCOUNTS^RC PHYSICIAN"

               Begin DoDot:1

 +4                SET IBSG=$PIECE(IBSET,U,1)

                   if IBSG=""

                       QUIT

                   SET IBSGFN=$ORDER(^IBE(363.32,"B",IBSG,0))

                   if 'IBSGFN

                       QUIT

 +5                SET IBBR=$PIECE(IBSET,U,2)

                   if IBBR=""

                       QUIT

                   SET IBBRFN=$ORDER(^IBE(363.3,"B",IBBR,0))

                   if 'IBBRFN

                       QUIT

 +6       ;

 +7                IF $ORDER(^IBE(363.32,+IBSGFN,11,"B",+IBBRFN,0))

                       QUIT

 +8       ;

 +9                SET DLAYGO=363.32

                   SET DA(1)=+IBSGFN

                   SET DIC="^IBE(363.32,"_DA(1)_",11,"

                   SET DIC(0)="L"

                   SET X=IBBR

                   SET DIC("P")="363.3211PA"

                   DO ^DIC

                   KILL DIC,DIE

                   SET IBCNT=IBCNT+1

               End DoDot:1

 +10      ;

SGBRQ      SET IBA(1)="      >> "_IBCNT_" Billing Rates added to Special Groups (363.32)..."

 +1        DO MES^XPDUTL(.IBA)

 +2        QUIT

 +3       ;

RVACT     ; activate (30) Revenue Codes exported in RV-CPT links (399.2,2)

 +1        NEW IBA,IBLN,IBI,IBRVFN,IBACT,IBCNT,IBJ,DD,DO,DIC,DIE,DA,DR,X,Y

           SET IBCNT=0

           SET IBACT=""

 +2       ;

 +3        SET IBLN=$PIECE($TEXT(RVF+1),";;",2)

 +4       ;

 +5        FOR IBI=1:1

               SET IBRVFN=$PIECE(IBLN,",",IBI)

               if 'IBRVFN

                   QUIT

               Begin DoDot:1

 +6       ;

 +7                IF +$PIECE($GET(^DGCR(399.2,IBRVFN,0)),U,3)

                       QUIT

 +8       ;

 +9                SET IBACT=IBACT_IBRVFN_","

 +10               SET IBCNT=IBCNT+1

                   SET DR="2////1"

                   SET DIE="^DGCR(399.2,"

                   SET DA=+IBRVFN

                   DO ^DIE

                   KILL DIE,DA,DR,X,Y

               End DoDot:1

 +11      ;

 +12       IF IBCNT>0

               SET IBJ=0

               FOR IBI=1:15

                   SET IBJ=IBJ+15

                   SET IBLN=$PIECE(IBACT,",",IBI,IBJ)

                   if IBLN=""

                       QUIT

                   DO MSG("         "_IBLN)

 +13      ;

RVAQ       SET IBA(1)="      >> "_IBCNT_" Revenue Codes activated (399.2)..."

 +1        DO MES^XPDUTL(.IBA)

 +2        QUIT

 +3       ;

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

 +4       ;

RVF       ;  Revenue Codes to (59) Activate (399.2,2)

 +1       ;;301,302,305,306,307,309,310,311,312,320,322,323,324,333,341,342,351,352,359,360,362,370,401,402,403,404,410,413,420,430,440,441,450,460,470,471,480,481,482,610,636,730,731,740,750,761,901,910,914,915,916,918,920,921,922,924,943,

 +2       ;;

IBYPPR.m