Routine: IBY473PO

IBY473PO ;ALB/ESG - Post Install for IB patch 473 ;2-FEB-2012

 ;;2.0;INTEGRATED BILLING;**473**;21-MAR-94;Build 29

 ;;Per VHA Directive 2004-038, this routine should not be modified.

EN ; entry point

 N XPDIDTOT

 S XPDIDTOT=2

 D CVA(1)           ; update CHAMPVA Rx rate schedules

 D TRI(2)           ; update TRICARE Rx rate schedules

EX ; exit point

CVA(IBXPD) ; update CHAMPVA Rx rate schedule data

 N IBMSG,IBRXBS,ERO,ERB,RSNAME

 D BMES^XPDUTL(" STEP "_IBXPD_" of "_XPDIDTOT)

 D MES^XPDUTL("-------------")

 D MES^XPDUTL("Update CHAMPVA Rx Rate Schedules ... ")

 ; attempt to get the PRESCRIPTION billable service ien to file 399.1

 K IBMSG

 S IBRXBS=+$$FIND1^DIC(399.1,,"BO","PRESCRIPTION",,"I $P(^(0),U,13)","IBMSG")

 I IBRXBS'>0!$D(IBMSG("DIERR")) D  G CVAX   ; report error message and get out

 . D MES^XPDUTL("ERROR: Unable to determine the Prescription Billable Service.")

 . D MES^XPDUTL("       IBRXBS = "_IBRXBS)

 . S (ERO,ERB)="IBMSG(""DIERR"""

 . S ERO=ERO_")"

 . F  S ERO=$Q(@ERO) Q:ERO'[ERB  D MES^XPDUTL("       "_ERO_" = "_$G(@ERO))

 . D MES^XPDUTL(" ")

. Q

 ; update both of the CHAMPVA pharmacy rate schedules

 F RSNAME="CVA-RX","CVA RI-RX" D

 . N IEN,DIE,DA,DR,X,Y

 . S IEN=+$O(^IBE(363,"B",RSNAME,""),-1)

 . I 'IEN D MES^XPDUTL("ERROR: Rate Schedule "_RSNAME_" not found.") Q

. ;

 . ; check to see if the changes have already been performed

 . I $P($G(^IBE(363,IEN,0)),U,4)=IBRXBS,$P($G(^IBE(363,IEN,1)),U,1)=5 D  Q

 .. D MES^XPDUTL("Rate Schedule "_RSNAME_" has already been updated...no further action.")

 .. Q

. ;

 . ; perform the updates

 . S DIE=363,DA=IEN,DR=".04////"_IBRXBS_";1.01////5"

 . D ^DIE

 . D MES^XPDUTL("Rate Schedule "_RSNAME_" has been updated successfully.")

. Q

CVAX ;

 D MES^XPDUTL(" Done.")

 D UPDATE^XPDID(IBXPD)

TRI(IBXPD) ; update TRICARE Rx rate schedule data with new dispensing fees

 N IBRATY,IBEFFDT,IBADFE,IBDISP,IBADJUST

 D BMES^XPDUTL(" STEP "_IBXPD_" of "_XPDIDTOT)

 D MES^XPDUTL("-------------")

 D MES^XPDUTL("Update TRICARE Rx Rate Schedules ... ")

 F IBRATY="TRICARE","TRICARE REIMB. INS." D

 . I '$O(^DGCR(399.3,"B",IBRATY,0)) D MES^XPDUTL("ERROR: Rate Type "_IBRATY_" not found.") Q

 . S IBEFFDT="01/23/2012"    ; new effective date

 . S IBADFE=""               ; admin fee (not used)

 . S IBDISP=10.27            ; dispensing fee amount

 . S IBADJUST="S X=X+10.27"  ; adjustment code

 . D ENT^IB3PSOU(IBRATY,IBEFFDT,IBADFE,IBDISP,IBADJUST)

 . D MES^XPDUTL("Pharmacy Rate Schedules for "_IBRATY_" successfully updated.")

. Q

TRIX ;

 D MES^XPDUTL(" Done.")

 D UPDATE^XPDID(IBXPD)

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBY473PO   2661     printed  Apr 23, 2025@18:48:53                                                                                                                                                                                                    Page 2

IBY473PO  ;ALB/ESG - Post Install for IB patch 473 ;2-FEB-2012

 +1       ;;2.0;INTEGRATED BILLING;**473**;21-MAR-94;Build 29

 +2       ;;Per VHA Directive 2004-038, this routine should not be modified.

 +3       ;

EN        ; entry point

 +1        NEW XPDIDTOT

 +2        SET XPDIDTOT=2

 +3       ; update CHAMPVA Rx rate schedules

           DO CVA(1)

 +4       ; update TRICARE Rx rate schedules

           DO TRI(2)

 +5       ;

EX        ; exit point

 +1        QUIT

 +2       ;

CVA(IBXPD) ; update CHAMPVA Rx rate schedule data

 +1        NEW IBMSG,IBRXBS,ERO,ERB,RSNAME

 +2        DO BMES^XPDUTL(" STEP "_IBXPD_" of "_XPDIDTOT)

 +3        DO MES^XPDUTL("-------------")

 +4        DO MES^XPDUTL("Update CHAMPVA Rx Rate Schedules ... ")

 +5       ;

 +6       ; attempt to get the PRESCRIPTION billable service ien to file 399.1

 +7        KILL IBMSG

 +8        SET IBRXBS=+$$FIND1^DIC(399.1,,"BO","PRESCRIPTION",,"I $P(^(0),U,13)","IBMSG")

 +9       ; report error message and get out

           IF IBRXBS'>0!$DATA(IBMSG("DIERR"))

               Begin DoDot:1

 +10               DO MES^XPDUTL("ERROR: Unable to determine the Prescription Billable Service.")

 +11               DO MES^XPDUTL("       IBRXBS = "_IBRXBS)

 +12               SET (ERO,ERB)="IBMSG(""DIERR"""

 +13               SET ERO=ERO_")"

 +14               FOR

                       SET ERO=$QUERY(@ERO)

                       if ERO'[ERB

                           QUIT

                       DO MES^XPDUTL("       "_ERO_" = "_$GET(@ERO))

 +15               DO MES^XPDUTL(" ")

 +16               QUIT

               End DoDot:1

               GOTO CVAX

 +17      ;

 +18      ; update both of the CHAMPVA pharmacy rate schedules

 +19       FOR RSNAME="CVA-RX","CVA RI-RX"

               Begin DoDot:1

 +20               NEW IEN,DIE,DA,DR,X,Y

 +21               SET IEN=+$ORDER(^IBE(363,"B",RSNAME,""),-1)

 +22               IF 'IEN

                       DO MES^XPDUTL("ERROR: Rate Schedule "_RSNAME_" not found.")

                       QUIT

 +23      ;

 +24      ; check to see if the changes have already been performed

 +25               IF $PIECE($GET(^IBE(363,IEN,0)),U,4)=IBRXBS

                       IF $PIECE($GET(^IBE(363,IEN,1)),U,1)=5

                           Begin DoDot:2

 +26                           DO MES^XPDUTL("Rate Schedule "_RSNAME_" has already been updated...no further action.")

 +27                           QUIT

                           End DoDot:2

                           QUIT

 +28      ;

 +29      ; perform the updates

 +30               SET DIE=363

                   SET DA=IEN

                   SET DR=".04////"_IBRXBS_";1.01////5"

 +31               DO ^DIE

 +32               DO MES^XPDUTL("Rate Schedule "_RSNAME_" has been updated successfully.")

 +33               QUIT

               End DoDot:1

 +34      ;

CVAX      ;

 +1        DO MES^XPDUTL(" Done.")

 +2        DO UPDATE^XPDID(IBXPD)

 +3        QUIT

 +4       ;

TRI(IBXPD) ; update TRICARE Rx rate schedule data with new dispensing fees

 +1        NEW IBRATY,IBEFFDT,IBADFE,IBDISP,IBADJUST

 +2        DO BMES^XPDUTL(" STEP "_IBXPD_" of "_XPDIDTOT)

 +3        DO MES^XPDUTL("-------------")

 +4        DO MES^XPDUTL("Update TRICARE Rx Rate Schedules ... ")

 +5       ;

 +6        FOR IBRATY="TRICARE","TRICARE REIMB. INS."

               Begin DoDot:1

 +7                IF '$ORDER(^DGCR(399.3,"B",IBRATY,0))

                       DO MES^XPDUTL("ERROR: Rate Type "_IBRATY_" not found.")

                       QUIT

 +8       ; new effective date

                   SET IBEFFDT="01/23/2012"

 +9       ; admin fee (not used)

                   SET IBADFE=""

 +10      ; dispensing fee amount

                   SET IBDISP=10.27

 +11      ; adjustment code

                   SET IBADJUST="S X=X+10.27"

 +12               DO ENT^IB3PSOU(IBRATY,IBEFFDT,IBADFE,IBDISP,IBADJUST)

 +13               DO MES^XPDUTL("Pharmacy Rate Schedules for "_IBRATY_" successfully updated.")

 +14               QUIT

               End DoDot:1

 +15      ;

TRIX      ;

 +1        DO MES^XPDUTL(" Done.")

 +2        DO UPDATE^XPDID(IBXPD)

 +3        QUIT

 +4       ;

IBY473PO.m