- IB20P725 ;ALB/CXW - UPDATE RX ADMINISTRATIVE FEE FOR CY 2022 ; 11/29/2021
- ;;2.0;INTEGRATED BILLING;**725**;21-MAR-94;Build 10
- ;;Per VA Directive 6402, this routine should not be modified.
- ; Reference to MES^XPDUTL in ICR #10141
- Q
- POST ; Update pharmacy administrative fee for CY 2022 in Rate Schedule file 363
- N IBA,U S U="^"
- D MSG("IB*2.0*725 Post-Install starts.....")
- D RXUPD
- D MSG("IB*2.0*725 Post-Install is complete.")
- Q
- ;
- RXUPD ; Rate Schedule
- N IBCT,IBI,IBT,IBX,IBRS,IBRSIN,IBRATY,IBEFFDT,IBADFE,IBDISP,IBADJUST
- D MSG("")
- D MSG(" >>>Effect. JAN 01, 2022 of RX Rate Schedule Adjustment for the Rate Type:"),MSG("")
- S IBADFE="",IBEFFDT="3220101",IBCT=0
- F IBX=1:1 S IBT=$P($T(RSF+IBX),";;",2) Q:IBT="Q" D
- . S IBRATY=$P(IBT,U)
- . S IBRSIN=$O(^DGCR(399.3,"B",IBRATY,0))
- . I 'IBRSIN D MSG(" "_IBRATY_" not defined in the Rate Type file (#399.3), not added") Q
- . ; latest entry
- . S IBRSIN=$O(^DGCR(399.3,"B",IBRATY,99999),-1)
- . I $P($G(^DGCR(399.3,+IBRSIN,0)),U,3) D MSG(" "_IBRATY_" inactivated in the Rate Type file (#399.3), not added") Q
- . I $$RSEXIST(IBEFFDT,IBRSIN) D MSG(" "_IBRATY_" already exists") Q
- . S IBDISP=$P(IBT,U,2)
- . S IBADJUST=$P(IBT,U,3)
- . ; inactivate rx entry for cy 2021 and add new rx entry for cy 2022
- . D ENT^IB3PSOU(IBRATY,IBEFFDT,IBADFE,IBDISP,IBADJUST)
- . ; double check if no active RS
- . I '$$RSEXIST(IBEFFDT,IBRSIN) D MSG(" "_IBRATY_" not added, no active RX Rate Schedule found") Q
- . S IBCT=IBCT+1 D MSG(" "_IBRATY)
- D MSG("")
- D MSG(" Total "_IBCT_$S(IBCT>1:" entries",1:" entry")_" added to the Rate Schedule file (#363)")
- D MSG("")
- 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
- ;
- MSG(IBA) ;
- D MES^XPDUTL(IBA)
- Q
- ;
- RSF ; 23 Rate types^dispensing fee^adjustment
- ;;CC MTF REIMB INS^13.26^S X=X+13.26
- ;;CC NO-FAULT AUTO^13.26^S X=X+13.26
- ;;CC REIMB INS^13.26^S X=X+13.26
- ;;CC TORT FEASOR^13.26^S X=X+13.26
- ;;CC WORKERS' COMP^13.26^S X=X+13.26
- ;;CCN NO-FAULT AUTO^13.26^S X=X+13.26
- ;;CCN REIMB INS^13.26^S X=X+13.26
- ;;CCN TORT FEASOR^13.26^S X=X+13.26
- ;;CCN WORKERS' COMP^13.26^S X=X+13.26
- ;;CHOICE NO-FAULT AUTO^13.26^S X=X+13.26
- ;;CHOICE REIMB INS^13.26^S X=X+13.26
- ;;CHOICE TORT FEASOR^13.26^S X=X+13.26
- ;;CHOICE WORKERS' COMP^13.26^S X=X+13.26
- ;;DENTAL REIMB. INS.^13.26^S X=X+13.26
- ;;HUMANITARIAN^13.26^S X=X+13.26
- ;;HUMANITARIAN REIMB. INS.^13.26^S X=X+13.26
- ;;INELIGIBLE^13.26^S X=X+13.26
- ;;INTERAGENCY^13.26^S X=X+13.26
- ;;INELIGIBLE REIMB. INS.^13.26^S X=X+13.26
- ;;NO FAULT INS.^13.26^S X=X+13.26
- ;;REIMBURSABLE INS.^13.26^S X=X+13.26
- ;;TORT FEASOR^13.26^S X=X+13.26
- ;;WORKERS' COMP.^13.26^S X=X+13.26
- ;;Q
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIB20P725 2954 printed Mar 13, 2025@21:09:28 Page 2
- IB20P725 ;ALB/CXW - UPDATE RX ADMINISTRATIVE FEE FOR CY 2022 ; 11/29/2021
- +1 ;;2.0;INTEGRATED BILLING;**725**;21-MAR-94;Build 10
- +2 ;;Per VA Directive 6402, this routine should not be modified.
- +3 ; Reference to MES^XPDUTL in ICR #10141
- +4 QUIT
- POST ; Update pharmacy administrative fee for CY 2022 in Rate Schedule file 363
- +1 NEW IBA,U
- SET U="^"
- +2 DO MSG("IB*2.0*725 Post-Install starts.....")
- +3 DO RXUPD
- +4 DO MSG("IB*2.0*725 Post-Install is complete.")
- +5 QUIT
- +6 ;
- RXUPD ; Rate Schedule
- +1 NEW IBCT,IBI,IBT,IBX,IBRS,IBRSIN,IBRATY,IBEFFDT,IBADFE,IBDISP,IBADJUST
- +2 DO MSG("")
- +3 DO MSG(" >>>Effect. JAN 01, 2022 of RX Rate Schedule Adjustment for the Rate Type:")
- DO MSG("")
- +4 SET IBADFE=""
- SET IBEFFDT="3220101"
- SET IBCT=0
- +5 FOR IBX=1:1
- SET IBT=$PIECE($TEXT(RSF+IBX),";;",2)
- if IBT="Q"
- QUIT
- Begin DoDot:1
- +6 SET IBRATY=$PIECE(IBT,U)
- +7 SET IBRSIN=$ORDER(^DGCR(399.3,"B",IBRATY,0))
- +8 IF 'IBRSIN
- DO MSG(" "_IBRATY_" not defined in the Rate Type file (#399.3), not added")
- QUIT
- +9 ; latest entry
- +10 SET IBRSIN=$ORDER(^DGCR(399.3,"B",IBRATY,99999),-1)
- +11 IF $PIECE($GET(^DGCR(399.3,+IBRSIN,0)),U,3)
- DO MSG(" "_IBRATY_" inactivated in the Rate Type file (#399.3), not added")
- QUIT
- +12 IF $$RSEXIST(IBEFFDT,IBRSIN)
- DO MSG(" "_IBRATY_" already exists")
- QUIT
- +13 SET IBDISP=$PIECE(IBT,U,2)
- +14 SET IBADJUST=$PIECE(IBT,U,3)
- +15 ; inactivate rx entry for cy 2021 and add new rx entry for cy 2022
- +16 DO ENT^IB3PSOU(IBRATY,IBEFFDT,IBADFE,IBDISP,IBADJUST)
- +17 ; double check if no active RS
- +18 IF '$$RSEXIST(IBEFFDT,IBRSIN)
- DO MSG(" "_IBRATY_" not added, no active RX Rate Schedule found")
- QUIT
- +19 SET IBCT=IBCT+1
- DO MSG(" "_IBRATY)
- End DoDot:1
- +20 DO MSG("")
- +21 DO MSG(" Total "_IBCT_$SELECT(IBCT>1:" entries",1:" entry")_" added to the Rate Schedule file (#363)")
- +22 DO MSG("")
- +23 QUIT
- +24 ;
- 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 ;
- MSG(IBA) ;
- +1 DO MES^XPDUTL(IBA)
- +2 QUIT
- +3 ;
- RSF ; 23 Rate types^dispensing fee^adjustment
- +1 ;;CC MTF REIMB INS^13.26^S X=X+13.26
- +2 ;;CC NO-FAULT AUTO^13.26^S X=X+13.26
- +3 ;;CC REIMB INS^13.26^S X=X+13.26
- +4 ;;CC TORT FEASOR^13.26^S X=X+13.26
- +5 ;;CC WORKERS' COMP^13.26^S X=X+13.26
- +6 ;;CCN NO-FAULT AUTO^13.26^S X=X+13.26
- +7 ;;CCN REIMB INS^13.26^S X=X+13.26
- +8 ;;CCN TORT FEASOR^13.26^S X=X+13.26
- +9 ;;CCN WORKERS' COMP^13.26^S X=X+13.26
- +10 ;;CHOICE NO-FAULT AUTO^13.26^S X=X+13.26
- +11 ;;CHOICE REIMB INS^13.26^S X=X+13.26
- +12 ;;CHOICE TORT FEASOR^13.26^S X=X+13.26
- +13 ;;CHOICE WORKERS' COMP^13.26^S X=X+13.26
- +14 ;;DENTAL REIMB. INS.^13.26^S X=X+13.26
- +15 ;;HUMANITARIAN^13.26^S X=X+13.26
- +16 ;;HUMANITARIAN REIMB. INS.^13.26^S X=X+13.26
- +17 ;;INELIGIBLE^13.26^S X=X+13.26
- +18 ;;INTERAGENCY^13.26^S X=X+13.26
- +19 ;;INELIGIBLE REIMB. INS.^13.26^S X=X+13.26
- +20 ;;NO FAULT INS.^13.26^S X=X+13.26
- +21 ;;REIMBURSABLE INS.^13.26^S X=X+13.26
- +22 ;;TORT FEASOR^13.26^S X=X+13.26
- +23 ;;WORKERS' COMP.^13.26^S X=X+13.26
- +24 ;;Q
- +25 ;
