IB20P503 ;ALB/CXW - IB*2.0*503 Post Init: Administrative Charge Update; 11-26-2013
;;2.0;INTEGRATED BILLING;**503**;21-MAR-94;Build 15
;;Per VHA Directive 2004-038, 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*503 Post-Install starts...")
S IBMSG="rate schedule with adjustments"
S IBADFE="",IBEFFDT="3140101",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("Patch IB*2.0*503 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 ; 8 rate types separated by '/'^dispensing fee^adjustment
;;REIMBURSABLE INS./NO FAULT INS./WORKERS' COMP./TORT FEASOR/INELIGIBLE/HUMANITARIAN^13.07^S X=X+13.07
;;TRICARE REIMB. INS./TRICARE^11.56^S X=X+11.56
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIB20P503 2393 printed Dec 13, 2024@02:03:19 Page 2
IB20P503 ;ALB/CXW - IB*2.0*503 Post Init: Administrative Charge Update; 11-26-2013
+1 ;;2.0;INTEGRATED BILLING;**503**;21-MAR-94;Build 15
+2 ;;Per VHA Directive 2004-038, 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*503 Post-Install starts...")
+10 SET IBMSG="rate schedule with adjustments"
+11 SET IBADFE=""
SET IBEFFDT="3140101"
SET IBCT=0
+12 FOR IBX=1:1
SET IBT=$PIECE($TEXT(RSF+IBX),";",3)
if '$LENGTH(IBT)
QUIT
Begin DoDot:1
+13 SET IBRATY=$PIECE(IBT,U)
SET IBRATY=$TRANSLATE(IBRATY,"/",U)
+14 SET IBRS=""
+15 FOR IBI=1:1
SET IBJ=$PIECE(IBRATY,U,IBI)
if IBJ=""
QUIT
Begin DoDot:2
+16 SET IBRSIN=$ORDER(^DGCR(399.3,"B",IBJ,0))
+17 IF 'IBRSIN
DO MES^XPDUTL(" >>>"_IBJ_" not defined, the "_IBMSG_" not added")
QUIT
+18 IF $PIECE($GET(^DGCR(399.3,+IBRSIN,0)),U,3)
SET IBRSIN=$ORDER(^DGCR(399.3,"B",IBJ,99999),-1)
+19 IF $PIECE($GET(^DGCR(399.3,+IBRSIN,0)),U,3)
DO MES^XPDUTL(" >>>"_IBJ_" not active, the "_IBMSG_" not added")
QUIT
+20 IF $$RSEXIST(IBEFFDT,IBRSIN)
DO MES^XPDUTL(" >>>"_IBJ_" "_IBMSG_" already exists")
QUIT
+21 SET IBRS=IBRS_U_IBJ
End DoDot:2
+22 SET IBRATY=$EXTRACT(IBRS,2,$LENGTH(IBRS))
if IBRS=""
QUIT
+23 SET IBDISP=$PIECE(IBT,U,2)
+24 SET IBADJUST=$PIECE(IBT,U,3)
+25 DO ENT^IB3PSOU(IBRATY,IBEFFDT,IBADFE,IBDISP,IBADJUST)
+26 FOR IBI=1:1
SET IBJ=$PIECE(IBRATY,U,IBI)
if IBJ=""
QUIT
Begin DoDot:2
+27 SET IBRSIN=$ORDER(^DGCR(399.3,"B",IBJ,0))
+28 IF $$RSEXIST(IBEFFDT,IBRSIN)
SET IBCT=IBCT+1
DO MES^XPDUTL(" >>>"_IBJ_" "_IBMSG_" added")
End DoDot:2
End DoDot:1
+29 DO MES^XPDUTL(" Total "_IBCT_$SELECT(IBCT=1:" entry",1:" entries")_" updated in the Rate Schedule file (#363)")
+30 DO MES^XPDUTL("Patch IB*2.0*503 Post-Install is complete.")
+31 QUIT
+32 ;
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 ; 8 rate types separated by '/'^dispensing fee^adjustment
+1 ;;REIMBURSABLE INS./NO FAULT INS./WORKERS' COMP./TORT FEASOR/INELIGIBLE/HUMANITARIAN^13.07^S X=X+13.07
+2 ;;TRICARE REIMB. INS./TRICARE^11.56^S X=X+11.56
+3 ;
