IB20P541 ;ALB/CXW - IB*2.0*541 Post Init: Administrative Charge Update; 12-10-2014
;;2.0;INTEGRATED BILLING;**541**;21-MAR-94;Build 31
;;Per VA Directive 6402, this routine should not be modified.
Q
;
;
POST ; post-install of patch installation
; use default rate types of rx 3rd party to update RS in #363
; ibraty=rate type names from file #399.3
; ibeffdt=effective external date (mm/dd/yyyy)
; ibadfe=administrative fee (dollar.cent)
; ibdisp=dispensing fee (dollar.cent)
; ibadjust=adjustment mumps code
;
N IBCT,IBI,IBJ,IBT,IBMSG,IBX,IBRS,IBRSIN,IBRATY,IBEFFDT,IBADFE,IBDISP,IBADJUST
D MES^XPDUTL("Patch IB*2.0*541 Post-Install starts...")
D MES^XPDUTL("")
S IBMSG="rate schedule with adjustments"
S IBADFE="",IBEFFDT="3150220",IBCT=0
F IBX=1:1 S IBT=$P($T(RSF+IBX),";",3) Q:'$L(IBT) D
. S IBRATY=$P(IBT,U),IBRATY=$TR(IBRATY,"/",U)
. S IBRS=""
. F IBI=1:1 S IBJ=$P(IBRATY,U,IBI) Q:IBJ="" D
.. S IBRSIN=$O(^DGCR(399.3,"B",IBJ,0))
.. I 'IBRSIN D MES^XPDUTL(" >>>"_IBJ_" not defined, the "_IBMSG_" not added") Q
.. I $P($G(^DGCR(399.3,+IBRSIN,0)),U,3) S IBRSIN=$O(^DGCR(399.3,"B",IBJ,99999),-1)
.. I $P($G(^DGCR(399.3,+IBRSIN,0)),U,3) D MES^XPDUTL(" >>>"_IBJ_" not active, the "_IBMSG_" not added") Q
.. I $$RSEXIST(IBEFFDT,IBRSIN) D MES^XPDUTL(" >>>"_IBJ_" "_IBMSG_" already exists") Q
.. S IBRS=IBRS_U_IBJ
. S IBRATY=$E(IBRS,2,$L(IBRS)) Q:IBRS=""
. S IBDISP=$P(IBT,U,2)
. S IBADJUST=$P(IBT,U,3)
. D ENT^IB3PSOU(IBRATY,IBEFFDT,IBADFE,IBDISP,IBADJUST)
. F IBI=1:1 S IBJ=$P(IBRATY,U,IBI) Q:IBJ="" D
.. S IBRSIN=$O(^DGCR(399.3,"B",IBJ,0))
.. I $$RSEXIST(IBEFFDT,IBRSIN) S IBCT=IBCT+1 D MES^XPDUTL(" >>>"_IBJ_" "_IBMSG_" added")
D MES^XPDUTL(" Total "_IBCT_$S(IBCT=1:" entry",1:" entries")_" updated in the Rate Schedule file (#363)")
D MES^XPDUTL("")
D MES^XPDUTL("Patch IB*2.0*541 Post-Install is complete.")
Q
;
RSEXIST(IBEFFDT,IBRSIN) ; return RS IFN if Rate Schedule exists for Effective Date
N IBX,IBRSFN,IBRS0 S IBX=0
S IBRSFN=0 F S IBRSFN=$O(^IBE(363,IBRSFN)) Q:'IBRSFN D I IBX Q
. S IBRS0=$G(^IBE(363,IBRSFN,0))
. I $P(IBRS0,U,2)=IBRSIN,$P(IBRS0,U,5)=IBEFFDT S IBX=IBRSFN
Q IBX
;
RSF ; 2 rate types separated by '/'^dispensing fee^adjustment
;;TRICARE REIMB. INS./TRICARE^11.16^S X=X+11.16
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIB20P541 2321 printed Dec 13, 2024@02:03:36 Page 2
IB20P541 ;ALB/CXW - IB*2.0*541 Post Init: Administrative Charge Update; 12-10-2014
+1 ;;2.0;INTEGRATED BILLING;**541**;21-MAR-94;Build 31
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 QUIT
+4 ;
+5 ;
POST ; post-install of patch installation
+1 ; use default rate types of rx 3rd party to update RS in #363
+2 ; ibraty=rate type names from file #399.3
+3 ; ibeffdt=effective external date (mm/dd/yyyy)
+4 ; ibadfe=administrative fee (dollar.cent)
+5 ; ibdisp=dispensing fee (dollar.cent)
+6 ; ibadjust=adjustment mumps code
+7 ;
+8 NEW IBCT,IBI,IBJ,IBT,IBMSG,IBX,IBRS,IBRSIN,IBRATY,IBEFFDT,IBADFE,IBDISP,IBADJUST
+9 DO MES^XPDUTL("Patch IB*2.0*541 Post-Install starts...")
+10 DO MES^XPDUTL("")
+11 SET IBMSG="rate schedule with adjustments"
+12 SET IBADFE=""
SET IBEFFDT="3150220"
SET IBCT=0
+13 FOR IBX=1:1
SET IBT=$PIECE($TEXT(RSF+IBX),";",3)
if '$LENGTH(IBT)
QUIT
Begin DoDot:1
+14 SET IBRATY=$PIECE(IBT,U)
SET IBRATY=$TRANSLATE(IBRATY,"/",U)
+15 SET IBRS=""
+16 FOR IBI=1:1
SET IBJ=$PIECE(IBRATY,U,IBI)
if IBJ=""
QUIT
Begin DoDot:2
+17 SET IBRSIN=$ORDER(^DGCR(399.3,"B",IBJ,0))
+18 IF 'IBRSIN
DO MES^XPDUTL(" >>>"_IBJ_" not defined, the "_IBMSG_" not added")
QUIT
+19 IF $PIECE($GET(^DGCR(399.3,+IBRSIN,0)),U,3)
SET IBRSIN=$ORDER(^DGCR(399.3,"B",IBJ,99999),-1)
+20 IF $PIECE($GET(^DGCR(399.3,+IBRSIN,0)),U,3)
DO MES^XPDUTL(" >>>"_IBJ_" not active, the "_IBMSG_" not added")
QUIT
+21 IF $$RSEXIST(IBEFFDT,IBRSIN)
DO MES^XPDUTL(" >>>"_IBJ_" "_IBMSG_" already exists")
QUIT
+22 SET IBRS=IBRS_U_IBJ
End DoDot:2
+23 SET IBRATY=$EXTRACT(IBRS,2,$LENGTH(IBRS))
if IBRS=""
QUIT
+24 SET IBDISP=$PIECE(IBT,U,2)
+25 SET IBADJUST=$PIECE(IBT,U,3)
+26 DO ENT^IB3PSOU(IBRATY,IBEFFDT,IBADFE,IBDISP,IBADJUST)
+27 FOR IBI=1:1
SET IBJ=$PIECE(IBRATY,U,IBI)
if IBJ=""
QUIT
Begin DoDot:2
+28 SET IBRSIN=$ORDER(^DGCR(399.3,"B",IBJ,0))
+29 IF $$RSEXIST(IBEFFDT,IBRSIN)
SET IBCT=IBCT+1
DO MES^XPDUTL(" >>>"_IBJ_" "_IBMSG_" added")
End DoDot:2
End DoDot:1
+30 DO MES^XPDUTL(" Total "_IBCT_$SELECT(IBCT=1:" entry",1:" entries")_" updated in the Rate Schedule file (#363)")
+31 DO MES^XPDUTL("")
+32 DO MES^XPDUTL("Patch IB*2.0*541 Post-Install is complete.")
+33 QUIT
+34 ;
RSEXIST(IBEFFDT,IBRSIN) ; return RS IFN if Rate Schedule exists for Effective Date
+1 NEW IBX,IBRSFN,IBRS0
SET IBX=0
+2 SET IBRSFN=0
FOR
SET IBRSFN=$ORDER(^IBE(363,IBRSFN))
if 'IBRSFN
QUIT
Begin DoDot:1
+3 SET IBRS0=$GET(^IBE(363,IBRSFN,0))
+4 IF $PIECE(IBRS0,U,2)=IBRSIN
IF $PIECE(IBRS0,U,5)=IBEFFDT
SET IBX=IBRSFN
End DoDot:1
IF IBX
QUIT
+5 QUIT IBX
+6 ;
RSF ; 2 rate types separated by '/'^dispensing fee^adjustment
+1 ;;TRICARE REIMB. INS./TRICARE^11.16^S X=X+11.16
+2 ;
