IB20P578.m

IB20P578 ;ALB/CXW - UPDATE RX ADMINISTRATIVE FEE FOR CY2017 ;11-01-2016

 ;;2.0;INTEGRATED BILLING;**578**;21-MAR-94;Build 3

 ;;Per VA Directive 6402, this routine should not be modified.

 Q

POST ; 

 ; Update pharmacy administrative fee for CY17 in Rate Schedule file 363

 N IBA,U S U="^"

 D MSG("IB*2.0*578 Post-Install starts.....")

 D TRXAF

 D MSG("IB*2.0*578 Post-Install is complete.")

 Q

 ;

TRXAF ; Rate Schedule

 N IBCT,IBI,IBT,IBMSG,IBX,IBRS,IBRSIN,IBRATY,IBEFFDT,IBADFE,IBDISP,IBADJUST

 D MSG("")

 D MSG("  >>>Effect. JAN 01, 2017 of RX Rate Schedule Adjustment for the Rate Type:")

 S IBADFE="",IBEFFDT="3170101",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 cy2016 and add new rx entry for cy2017

 . D ENT^IB3PSOU(IBRATY,IBEFFDT,IBADFE,IBDISP,IBADJUST)

 . ; double check

 . I '$$RSEXIST(IBEFFDT,IBRSIN) D MSG("       "_IBRATY_" not added") Q

 . S IBCT=IBCT+1 D MSG("       "_IBRATY_" added")

 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 ; Rate type^dispensing fee^adjustment

 ;;HUMANITARIAN^16.36^S X=X+16.36

 ;;INELIGIBLE^16.36^S X=X+16.36

 ;;INTERAGENCY^16.36^S X=X+16.36

 ;;NO FAULT INS.^16.36^S X=X+16.36

 ;;REIMBURSABLE INS.^16.36^S X=X+16.36

 ;;TORT FEASOR^16.36^S X=X+16.36

 ;;WORKERS' COMP.^16.36^S X=X+16.36

 ;;TRICARE REIMB. INS.^13.72^S X=X+13.72

 ;;TRICARE^13.72^S X=X+13.72

 ;;Q

 ;

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---IB20P578   2292     printed  Mar 13, 2025@21:08:38                                                                                                                                                                                                    Page 2

IB20P578  ;ALB/CXW - UPDATE RX ADMINISTRATIVE FEE FOR CY2017 ;11-01-2016

 +1       ;;2.0;INTEGRATED BILLING;**578**;21-MAR-94;Build 3

 +2       ;;Per VA Directive 6402, this routine should not be modified.

 +3        QUIT 

POST      ; 

 +1       ; Update pharmacy administrative fee for CY17 in Rate Schedule file 363

 +2        NEW IBA,U

           SET U="^"

 +3        DO MSG("IB*2.0*578 Post-Install starts.....")

 +4        DO TRXAF

 +5        DO MSG("IB*2.0*578 Post-Install is complete.")

 +6        QUIT 

 +7       ;

TRXAF     ; Rate Schedule

 +1        NEW IBCT,IBI,IBT,IBMSG,IBX,IBRS,IBRSIN,IBRATY,IBEFFDT,IBADFE,IBDISP,IBADJUST

 +2        DO MSG("")

 +3        DO MSG("  >>>Effect. JAN 01, 2017 of RX Rate Schedule Adjustment for the Rate Type:")

 +4        SET IBADFE=""

           SET IBEFFDT="3170101"

           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 cy2016 and add new rx entry for cy2017

 +16               DO ENT^IB3PSOU(IBRATY,IBEFFDT,IBADFE,IBDISP,IBADJUST)

 +17      ; double check

 +18               IF '$$RSEXIST(IBEFFDT,IBRSIN)

                       DO MSG("       "_IBRATY_" not added")

                       QUIT 

 +19               SET IBCT=IBCT+1

                   DO MSG("       "_IBRATY_" added")

               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       ; Rate type^dispensing fee^adjustment

 +1       ;;HUMANITARIAN^16.36^S X=X+16.36

 +2       ;;INELIGIBLE^16.36^S X=X+16.36

 +3       ;;INTERAGENCY^16.36^S X=X+16.36

 +4       ;;NO FAULT INS.^16.36^S X=X+16.36

 +5       ;;REIMBURSABLE INS.^16.36^S X=X+16.36

 +6       ;;TORT FEASOR^16.36^S X=X+16.36

 +7       ;;WORKERS' COMP.^16.36^S X=X+16.36

 +8       ;;TRICARE REIMB. INS.^13.72^S X=X+13.72

 +9       ;;TRICARE^13.72^S X=X+13.72

 +10      ;;Q

 +11      ;