- 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 23, 2025@18:18:02 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 ;
