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
Q
;
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)
Q
;
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)
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBY473PO 2661 printed Apr 09, 2024@21:34 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 ;
