IB20P558 ;ALB/CXW - UPDATE POS & TRICARE RX ADMINISTRATIVE FEE; 11/23/2015
;;2.0;INTEGRATED BILLING;**558**;21-MAR-94;Build 32
;;Per VA Directive 6402, this routine should not be modified.
Q
POST ;
; Update pos code in place of service file 353.1
; Update tricare pharmacy administrative fee in Rate Schedule file 363
N IBA,U S U="^"
D MSG("IB*2.0*558 Post-Install starts.....")
D TRXAF,POS
D MSG("IB*2.0*558 Post-Install is complete.")
Q
;
POS ; Place Of Service
N IBCNT,IBI,IBX,IBY,IBZ,DA,DD,DO,DLAYGO,DIC,DIE,DR,X,Y
S IBCNT=0
D MSG(" >>>Place of Service Code")
F IBI=1:1 S IBX=$P($T(POSU+IBI),";;",2) Q:IBX="Q" D
. S IBY=$P(IBX,U,1)
. S IBZ=$P(IBX,U,1)_" "_$P(IBX,U,2)
. S IBY=$O(^IBE(353.1,"B",IBY,0))
. I 'IBY D Q
.. S DLAYGO=353.1,DIC="^IBE(353.1,",DIC(0)="L",X=$P(IBX,U,1) D FILE^DICN
.. I Y<1 K X,Y D MSG(" >>>ERROR when adding #"_IBZ_" to the file, Log a Remedy ticket!") Q
.. S DA=+Y,DIE=DIC,DR=".02///"_$P(IBX,U,2)_";.03///"_$P(IBX,U,3) D ^DIE
.. D MSG(" "_IBZ_" added")
.. S IBCNT=IBCNT+1
. I $G(^IBE(353.1,IBY,0))=$P(IBX,U,1,3) D MSG(" "_IBZ_" already exists, no change") Q
. S DA=IBY,DIE="^IBE(353.1,",DR=".02///"_$P(IBX,U,2)_";.03///"_$P(IBX,U,3) D ^DIE
. D MSG(" "_IBZ_" updated")
. S IBCNT=IBCNT+1
D MSG(" Total "_IBCNT_" code"_$S(IBCNT>1:"s",1:"")_" updated in the Place of Service file (#353.1)")
D MSG("")
Q
;
TRXAF ; Rate Schedule
N IBCT,IBI,IBT,IBMSG,IBX,IBRS,IBRSIN,IBRATY,IBEFFDT,IBADFE,IBDISP,IBADJUST
D MSG(""),MSG(" >>>Rate Schedule")
S IBMSG="Rx Administrative Fee "
S IBADFE="",IBEFFDT="3160101",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_" Rate Type not defined, the "_IBMSG_"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_" Rate Type not active, the "_IBMSG_" not added") Q
. I $$RSEXIST(IBEFFDT,IBRSIN) D MSG(" CY2016 "_IBRATY_" "_IBMSG_"already exists, no change") Q
. S IBDISP=$P(IBT,U,2)
. S IBADJUST=$P(IBT,U,3)
. ; procedure of outpatient rx administrative fee update
. D ENT^IB3PSOU(IBRATY,IBEFFDT,IBADFE,IBDISP,IBADJUST)
. ; double check
. I $$RSEXIST(IBEFFDT,IBRSIN) S IBCT=IBCT+1 D MSG(" CY2016 "_IBRATY_" "_IBMSG_"added")
D MSG(" Total "_IBCT_$S(IBCT>1:" entries",1:" entry")_" updated in 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
;
POSU ; Place of Service code^name^abbreviation
;;17^WALK-IN RETAIL HEALTH CLINIC^WLK-IN RET HLTH CL
;;19^OFF CAMPUS-OUTPATIENT HOSPITAL^OFF CAMP OP HOSP
;;22^ON CAMPUS-OUTPATIENT HOSPITAL^ON CAMP OP HOSP
;;Q
;
RSF ; Rate type^dispensing fee^adjustment
;;TRICARE REIMB. INS.^12.19^S X=X+12.19
;;TRICARE^12.19^S X=X+12.19
;;Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIB20P558 3185 printed Dec 13, 2024@02:03:42 Page 2
IB20P558 ;ALB/CXW - UPDATE POS & TRICARE RX ADMINISTRATIVE FEE; 11/23/2015
+1 ;;2.0;INTEGRATED BILLING;**558**;21-MAR-94;Build 32
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 QUIT
POST ;
+1 ; Update pos code in place of service file 353.1
+2 ; Update tricare pharmacy administrative fee in Rate Schedule file 363
+3 NEW IBA,U
SET U="^"
+4 DO MSG("IB*2.0*558 Post-Install starts.....")
+5 DO TRXAF
DO POS
+6 DO MSG("IB*2.0*558 Post-Install is complete.")
+7 QUIT
+8 ;
POS ; Place Of Service
+1 NEW IBCNT,IBI,IBX,IBY,IBZ,DA,DD,DO,DLAYGO,DIC,DIE,DR,X,Y
+2 SET IBCNT=0
+3 DO MSG(" >>>Place of Service Code")
+4 FOR IBI=1:1
SET IBX=$PIECE($TEXT(POSU+IBI),";;",2)
if IBX="Q"
QUIT
Begin DoDot:1
+5 SET IBY=$PIECE(IBX,U,1)
+6 SET IBZ=$PIECE(IBX,U,1)_" "_$PIECE(IBX,U,2)
+7 SET IBY=$ORDER(^IBE(353.1,"B",IBY,0))
+8 IF 'IBY
Begin DoDot:2
+9 SET DLAYGO=353.1
SET DIC="^IBE(353.1,"
SET DIC(0)="L"
SET X=$PIECE(IBX,U,1)
DO FILE^DICN
+10 IF Y<1
KILL X,Y
DO MSG(" >>>ERROR when adding #"_IBZ_" to the file, Log a Remedy ticket!")
QUIT
+11 SET DA=+Y
SET DIE=DIC
SET DR=".02///"_$PIECE(IBX,U,2)_";.03///"_$PIECE(IBX,U,3)
DO ^DIE
+12 DO MSG(" "_IBZ_" added")
+13 SET IBCNT=IBCNT+1
End DoDot:2
QUIT
+14 IF $GET(^IBE(353.1,IBY,0))=$PIECE(IBX,U,1,3)
DO MSG(" "_IBZ_" already exists, no change")
QUIT
+15 SET DA=IBY
SET DIE="^IBE(353.1,"
SET DR=".02///"_$PIECE(IBX,U,2)_";.03///"_$PIECE(IBX,U,3)
DO ^DIE
+16 DO MSG(" "_IBZ_" updated")
+17 SET IBCNT=IBCNT+1
End DoDot:1
+18 DO MSG(" Total "_IBCNT_" code"_$SELECT(IBCNT>1:"s",1:"")_" updated in the Place of Service file (#353.1)")
+19 DO MSG("")
+20 QUIT
+21 ;
TRXAF ; Rate Schedule
+1 NEW IBCT,IBI,IBT,IBMSG,IBX,IBRS,IBRSIN,IBRATY,IBEFFDT,IBADFE,IBDISP,IBADJUST
+2 DO MSG("")
DO MSG(" >>>Rate Schedule")
+3 SET IBMSG="Rx Administrative Fee "
+4 SET IBADFE=""
SET IBEFFDT="3160101"
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_" Rate Type not defined, the "_IBMSG_"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_" Rate Type not active, the "_IBMSG_" not added")
QUIT
+12 IF $$RSEXIST(IBEFFDT,IBRSIN)
DO MSG(" CY2016 "_IBRATY_" "_IBMSG_"already exists, no change")
QUIT
+13 SET IBDISP=$PIECE(IBT,U,2)
+14 SET IBADJUST=$PIECE(IBT,U,3)
+15 ; procedure of outpatient rx administrative fee update
+16 DO ENT^IB3PSOU(IBRATY,IBEFFDT,IBADFE,IBDISP,IBADJUST)
+17 ; double check
+18 IF $$RSEXIST(IBEFFDT,IBRSIN)
SET IBCT=IBCT+1
DO MSG(" CY2016 "_IBRATY_" "_IBMSG_"added")
End DoDot:1
+19 DO MSG(" Total "_IBCT_$SELECT(IBCT>1:" entries",1:" entry")_" updated in the Rate Schedule file (#363)")
+20 DO MSG("")
+21 QUIT
+22 ;
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 ;
POSU ; Place of Service code^name^abbreviation
+1 ;;17^WALK-IN RETAIL HEALTH CLINIC^WLK-IN RET HLTH CL
+2 ;;19^OFF CAMPUS-OUTPATIENT HOSPITAL^OFF CAMP OP HOSP
+3 ;;22^ON CAMPUS-OUTPATIENT HOSPITAL^ON CAMP OP HOSP
+4 ;;Q
+5 ;
RSF ; Rate type^dispensing fee^adjustment
+1 ;;TRICARE REIMB. INS.^12.19^S X=X+12.19
+2 ;;TRICARE^12.19^S X=X+12.19
+3 ;;Q
+4 ;
