IB20P538 ;ALB/CXW - IB*2.0*538 Post Init: Administrative Charge Update; 10-15-2014
;;2.0;INTEGRATED BILLING;**538**;21-MAR-94;Build 29
;;Per VA Directive 6402, this routine should not be modified.
Q
;
POST ; post-install of patch installation
; use default rate types for rx 3rd party bill to update RS in #363
; ibraty=rate type name from file #399.3
; ibeffdt=effective fileman date
; ibadfe=administrative fee (dollar.cent)
; ibdisp=dispensing fee (dollar.cent)
; ibadjust=adjustment mumps code
;
N U,IBCT,IBI,IBJ,IBMG,IBT,IBX,IBY,IBRS,IBRSIN,IBRATY,IBEFFDT,IBADFE,IBDISP,IBADJUST,Y
D MES^XPDUTL("Patch IB*2.0*538 Post-Install starts...")
D MES^XPDUTL("")
S IBADFE="",IBCT=0,IBMG="rate schedule adjustment",U="^"
F IBX=1:1 S IBT=$P($T(RSF+IBX),";",3) Q:'$L(IBT) D
. S IBRS=""
. S IBRATY=$P(IBT,U),IBRATY=$TR(IBRATY,"/",U)
. S IBDISP=$P(IBT,U,2)
. S IBADJUST=$P(IBT,U,3)
. S (Y,IBEFFDT)=$P(IBT,U,4)
. D DD^%DT S IBY=Y
. 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 in the Rate Type file (#399.3), no "_IBMG_" added for "_IBY) Q
.. ; find the latest ien if multiple
.. I $P($G(^DGCR(399.3,+IBRSIN,0)),U,3) S IBRSIN=$O(^DGCR(399.3,"B",IBJ,999999),-1)
.. I $P($G(^DGCR(399.3,+IBRSIN,0)),U,3) D MES^XPDUTL(" >>>"_IBJ_" not active in the Rate Type file (#399.3), no "_IBMG_" added for "_IBY) Q
.. I $$RSEXIST(IBEFFDT,IBRSIN) D MES^XPDUTL(" >>>Effective date of "_IBY_" for "_IBJ_" "_IBMG_" already exists") Q
.. S IBRS=IBRS_U_IBJ
. S IBRATY=$E(IBRS,2,$L(IBRS)) Q:IBRS=""
. 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(" >>>Effective date of "_IBY_" for "_IBJ_" "_IBMG_" added")
D MES^XPDUTL(" Total "_IBCT_$S(IBCT=1:" entry",1:" entries")_" added to the Rate Schedule file (#363)")
D MES^XPDUTL("")
D MES^XPDUTL("Patch IB*2.0*538 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 ; rate type separated by '/'^dispensing fee^adjustment^effective date
;;INTERAGENCY^13.07^S X=X+13.07^3140101
;;REIMBURSABLE INS./NO FAULT INS./WORKERS' COMP./TORT FEASOR/INELIGIBLE/HUMANITARIAN/INTERAGENCY^13.10^S X=X+13.10^3150101
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIB20P538 2637 printed Apr 09, 2024@21:13:48 Page 2
IB20P538 ;ALB/CXW - IB*2.0*538 Post Init: Administrative Charge Update; 10-15-2014
+1 ;;2.0;INTEGRATED BILLING;**538**;21-MAR-94;Build 29
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 QUIT
+4 ;
POST ; post-install of patch installation
+1 ; use default rate types for rx 3rd party bill to update RS in #363
+2 ; ibraty=rate type name from file #399.3
+3 ; ibeffdt=effective fileman date
+4 ; ibadfe=administrative fee (dollar.cent)
+5 ; ibdisp=dispensing fee (dollar.cent)
+6 ; ibadjust=adjustment mumps code
+7 ;
+8 NEW U,IBCT,IBI,IBJ,IBMG,IBT,IBX,IBY,IBRS,IBRSIN,IBRATY,IBEFFDT,IBADFE,IBDISP,IBADJUST,Y
+9 DO MES^XPDUTL("Patch IB*2.0*538 Post-Install starts...")
+10 DO MES^XPDUTL("")
+11 SET IBADFE=""
SET IBCT=0
SET IBMG="rate schedule adjustment"
SET U="^"
+12 FOR IBX=1:1
SET IBT=$PIECE($TEXT(RSF+IBX),";",3)
if '$LENGTH(IBT)
QUIT
Begin DoDot:1
+13 SET IBRS=""
+14 SET IBRATY=$PIECE(IBT,U)
SET IBRATY=$TRANSLATE(IBRATY,"/",U)
+15 SET IBDISP=$PIECE(IBT,U,2)
+16 SET IBADJUST=$PIECE(IBT,U,3)
+17 SET (Y,IBEFFDT)=$PIECE(IBT,U,4)
+18 DO DD^%DT
SET IBY=Y
+19 FOR IBI=1:1
SET IBJ=$PIECE(IBRATY,U,IBI)
if IBJ=""
QUIT
Begin DoDot:2
+20 SET IBRSIN=$ORDER(^DGCR(399.3,"B",IBJ,0))
+21 IF 'IBRSIN
DO MES^XPDUTL(" >>>"_IBJ_" not defined in the Rate Type file (#399.3), no "_IBMG_" added for "_IBY)
QUIT
+22 ; find the latest ien if multiple
+23 IF $PIECE($GET(^DGCR(399.3,+IBRSIN,0)),U,3)
SET IBRSIN=$ORDER(^DGCR(399.3,"B",IBJ,999999),-1)
+24 IF $PIECE($GET(^DGCR(399.3,+IBRSIN,0)),U,3)
DO MES^XPDUTL(" >>>"_IBJ_" not active in the Rate Type file (#399.3), no "_IBMG_" added for "_IBY)
QUIT
+25 IF $$RSEXIST(IBEFFDT,IBRSIN)
DO MES^XPDUTL(" >>>Effective date of "_IBY_" for "_IBJ_" "_IBMG_" already exists")
QUIT
+26 SET IBRS=IBRS_U_IBJ
End DoDot:2
+27 SET IBRATY=$EXTRACT(IBRS,2,$LENGTH(IBRS))
if IBRS=""
QUIT
+28 DO ENT^IB3PSOU(IBRATY,IBEFFDT,IBADFE,IBDISP,IBADJUST)
+29 FOR IBI=1:1
SET IBJ=$PIECE(IBRATY,U,IBI)
if IBJ=""
QUIT
Begin DoDot:2
+30 SET IBRSIN=$ORDER(^DGCR(399.3,"B",IBJ,0))
+31 IF $$RSEXIST(IBEFFDT,IBRSIN)
SET IBCT=IBCT+1
DO MES^XPDUTL(" >>>Effective date of "_IBY_" for "_IBJ_" "_IBMG_" added")
End DoDot:2
End DoDot:1
+32 DO MES^XPDUTL(" Total "_IBCT_$SELECT(IBCT=1:" entry",1:" entries")_" added to the Rate Schedule file (#363)")
+33 DO MES^XPDUTL("")
+34 DO MES^XPDUTL("Patch IB*2.0*538 Post-Install is complete.")
+35 QUIT
+36 ;
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 ; rate type separated by '/'^dispensing fee^adjustment^effective date
+1 ;;INTERAGENCY^13.07^S X=X+13.07^3140101
+2 ;;REIMBURSABLE INS./NO FAULT INS./WORKERS' COMP./TORT FEASOR/INELIGIBLE/HUMANITARIAN/INTERAGENCY^13.10^S X=X+13.10^3150101
+3 ;
