IB20P632 ;ALB/CXW - UPDATE RX ADMINISTRATIVE FEE FOR CY2019;09/03/2018
;;2.0;INTEGRATED BILLING;**632**;21-MAR-94;Build 2
;;Per VA Directive 6402, this routine should not be modified.
Q
POST ;
; Update pharmacy administrative fee for CY19 in Rate Schedule file 363
N IBA,U S U="^"
D MSG("IB*2.0*632 Post-Install starts.....")
D TRXAF
D MSG("IB*2.0*632 Post-Install is complete.")
Q
;
TRXAF ; Rate Schedule
N IBCT,IBI,IBT,IBX,IBRS,IBRSIN,IBRATY,IBEFFDT,IBADFE,IBDISP,IBADJUST
D MSG("")
D MSG(" >>>Effect. JAN 01, 2019 of RX Rate Schedule Adjustment for the Rate Type:"),MSG("")
S IBADFE="",IBEFFDT="3190101",IBDRX="DTR-RX",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
. I IBRATY="DENTAL REIMB. INS.",'$O(^IBE(363,"B",IBDRX,0)),'$$DENT(IBRSIN,IBDRX) D MSG(" "_IBRATY_" not added") Q
. S IBDISP=$P(IBT,U,2)
. S IBADJUST=$P(IBT,U,3)
. ; inactivate rx entry for cy2018 and add new rx entry for cy2019
. 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
DENT(IBRSIN,IBDRX) ; return 1 if initial cs added for dental reim. ins.
N IBCS,DA,DLAYGO,DIC,DIE,DR,X,Y
S IBCS="RX COST"
I '$O(^IBE(363.1,"B",IBCS,0)) Q 0
S DLAYGO=363,(DIC,DIE)="^IBE(363,",DIC(0)="L",X=IBDRX D FILE^DICN
I Y<1 Q 0
S DA=+Y,DR=".02///"_IBRSIN_";.03///"_"OUTPATIENT"_";.05///3180101" D ^DIE
; charge set
S DA(1)=DA,DIC="^IBE(363,"_DA(1)_",11,",X=IBCS,DIC(0)="L",DIC("P")="363.0011P",DIC("DR")=".02///"_1 D ^DIC
Q 1
;
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
;;DENTAL REIMB. INS.^17.66^S X=X+17.66
;;HUMANITARIAN^17.66^S X=X+17.66
;;HUMANITARIAN REIMB. INS.^17.66^S X=X+17.66
;;INELIGIBLE^17.66^S X=X+17.66
;;INTERAGENCY^17.66^S X=X+17.66
;;INELIGIBLE REIMB. INS.^17.66^S X=X+17.66
;;NO FAULT INS.^17.66^S X=X+17.66
;;REIMBURSABLE INS.^17.66^S X=X+17.66
;;TORT FEASOR^17.66^S X=X+17.66
;;WORKERS' COMP.^17.66^S X=X+17.66
;;TRICARE^14.73^S X=X+14.73
;;TRICARE REIMB. INS.^14.73^S X=X+14.73
;;Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIB20P632 3012 printed Nov 22, 2024@17:14:19 Page 2
IB20P632 ;ALB/CXW - UPDATE RX ADMINISTRATIVE FEE FOR CY2019;09/03/2018
+1 ;;2.0;INTEGRATED BILLING;**632**;21-MAR-94;Build 2
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 QUIT
POST ;
+1 ; Update pharmacy administrative fee for CY19 in Rate Schedule file 363
+2 NEW IBA,U
SET U="^"
+3 DO MSG("IB*2.0*632 Post-Install starts.....")
+4 DO TRXAF
+5 DO MSG("IB*2.0*632 Post-Install is complete.")
+6 QUIT
+7 ;
TRXAF ; Rate Schedule
+1 NEW IBCT,IBI,IBT,IBX,IBRS,IBRSIN,IBRATY,IBEFFDT,IBADFE,IBDISP,IBADJUST
+2 DO MSG("")
+3 DO MSG(" >>>Effect. JAN 01, 2019 of RX Rate Schedule Adjustment for the Rate Type:")
DO MSG("")
+4 SET IBADFE=""
SET IBEFFDT="3190101"
SET IBDRX="DTR-RX"
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 IF IBRATY="DENTAL REIMB. INS."
IF '$ORDER(^IBE(363,"B",IBDRX,0))
IF '$$DENT(IBRSIN,IBDRX)
DO MSG(" "_IBRATY_" not added")
QUIT
+14 SET IBDISP=$PIECE(IBT,U,2)
+15 SET IBADJUST=$PIECE(IBT,U,3)
+16 ; inactivate rx entry for cy2018 and add new rx entry for cy2019
+17 DO ENT^IB3PSOU(IBRATY,IBEFFDT,IBADFE,IBDISP,IBADJUST)
+18 ; double check
+19 IF '$$RSEXIST(IBEFFDT,IBRSIN)
DO MSG(" "_IBRATY_" not added")
QUIT
+20 SET IBCT=IBCT+1
DO MSG(" "_IBRATY_" added")
End DoDot:1
+21 DO MSG("")
+22 DO MSG(" Total "_IBCT_$SELECT(IBCT>1:" entries",1:" entry")_" added to the Rate Schedule file (#363)")
+23 DO MSG("")
+24 QUIT
DENT(IBRSIN,IBDRX) ; return 1 if initial cs added for dental reim. ins.
+1 NEW IBCS,DA,DLAYGO,DIC,DIE,DR,X,Y
+2 SET IBCS="RX COST"
+3 IF '$ORDER(^IBE(363.1,"B",IBCS,0))
QUIT 0
+4 SET DLAYGO=363
SET (DIC,DIE)="^IBE(363,"
SET DIC(0)="L"
SET X=IBDRX
DO FILE^DICN
+5 IF Y<1
QUIT 0
+6 SET DA=+Y
SET DR=".02///"_IBRSIN_";.03///"_"OUTPATIENT"_";.05///3180101"
DO ^DIE
+7 ; charge set
+8 SET DA(1)=DA
SET DIC="^IBE(363,"_DA(1)_",11,"
SET X=IBCS
SET DIC(0)="L"
SET DIC("P")="363.0011P"
SET DIC("DR")=".02///"_1
DO ^DIC
+9 QUIT 1
+10 ;
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 ;;DENTAL REIMB. INS.^17.66^S X=X+17.66
+2 ;;HUMANITARIAN^17.66^S X=X+17.66
+3 ;;HUMANITARIAN REIMB. INS.^17.66^S X=X+17.66
+4 ;;INELIGIBLE^17.66^S X=X+17.66
+5 ;;INTERAGENCY^17.66^S X=X+17.66
+6 ;;INELIGIBLE REIMB. INS.^17.66^S X=X+17.66
+7 ;;NO FAULT INS.^17.66^S X=X+17.66
+8 ;;REIMBURSABLE INS.^17.66^S X=X+17.66
+9 ;;TORT FEASOR^17.66^S X=X+17.66
+10 ;;WORKERS' COMP.^17.66^S X=X+17.66
+11 ;;TRICARE^14.73^S X=X+14.73
+12 ;;TRICARE REIMB. INS.^14.73^S X=X+14.73
+13 ;;Q
+14 ;
