Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: IB20P558

IB20P558.m

Go to the documentation of this file. 
  1. IB20P558 ;ALB/CXW - UPDATE POS & TRICARE RX ADMINISTRATIVE FEE; 11/23/2015
  1.  ;;2.0;INTEGRATED BILLING;**558**;21-MAR-94;Build 32
  1.  ;;Per VA Directive 6402, this routine should not be modified.
  1.  Q
  1. POST ; 
  1.  ; Update pos code in place of service file 353.1
  1.  ; Update tricare pharmacy administrative fee in Rate Schedule file 363
  1.  N IBA,U S U="^"
  1.  D MSG("IB*2.0*558 Post-Install starts.....")
  1.  D TRXAF,POS
  1.  D MSG("IB*2.0*558 Post-Install is complete.")
  1.  Q
  1.  ;
  1. POS ; Place Of Service
  1.  N IBCNT,IBI,IBX,IBY,IBZ,DA,DD,DO,DLAYGO,DIC,DIE,DR,X,Y
  1.  S IBCNT=0
  1.  D MSG(" >>>Place of Service Code")
  1.  F IBI=1:1 S IBX=$P($T(POSU+IBI),";;",2) Q:IBX="Q"  D
  1.  . S IBY=$P(IBX,U,1)
  1.  . S IBZ=$P(IBX,U,1)_" "_$P(IBX,U,2)
  1.  . S IBY=$O(^IBE(353.1,"B",IBY,0))
  1.  . I 'IBY D  Q
  1.  .. S DLAYGO=353.1,DIC="^IBE(353.1,",DIC(0)="L",X=$P(IBX,U,1) D FILE^DICN
  1.  .. I Y<1 K X,Y D MSG(" >>>ERROR when adding #"_IBZ_" to the file, Log a Remedy ticket!") Q
  1.  .. S DA=+Y,DIE=DIC,DR=".02///"_$P(IBX,U,2)_";.03///"_$P(IBX,U,3) D ^DIE
  1.  .. D MSG("    "_IBZ_" added")
  1.  .. S IBCNT=IBCNT+1
  1.  . I $G(^IBE(353.1,IBY,0))=$P(IBX,U,1,3) D MSG("    "_IBZ_" already exists, no change") Q
  1.  . S DA=IBY,DIE="^IBE(353.1,",DR=".02///"_$P(IBX,U,2)_";.03///"_$P(IBX,U,3) D ^DIE
  1.  . D MSG("    "_IBZ_" updated")
  1.  . S IBCNT=IBCNT+1
  1.  D MSG(" Total "_IBCNT_" code"_$S(IBCNT>1:"s",1:"")_" updated in the Place of Service file (#353.1)")
  1.  D MSG("")
  1.  Q
  1.  ;
  1. TRXAF ; Rate Schedule
  1.  N IBCT,IBI,IBT,IBMSG,IBX,IBRS,IBRSIN,IBRATY,IBEFFDT,IBADFE,IBDISP,IBADJUST
  1.  D MSG(""),MSG(" >>>Rate Schedule")
  1.  S IBMSG="Rx Administrative Fee "
  1.  S IBADFE="",IBEFFDT="3160101",IBCT=0
  1.  F IBX=1:1 S IBT=$P($T(RSF+IBX),";;",2) Q:IBT="Q"  D
  1.  . S IBRATY=$P(IBT,U)
  1.  . S IBRSIN=$O(^DGCR(399.3,"B",IBRATY,0))
  1.  . I 'IBRSIN D MSG("    "_IBRATY_" Rate Type not defined, the "_IBMSG_"not added") Q
  1.  . ; latest entry
  1.  . S IBRSIN=$O(^DGCR(399.3,"B",IBRATY,99999),-1)
  1.  . I $P($G(^DGCR(399.3,+IBRSIN,0)),U,3) D MSG("    "_IBRATY_" Rate Type not active, the "_IBMSG_" not added") Q
  1.  . I $$RSEXIST(IBEFFDT,IBRSIN) D MSG("    CY2016 "_IBRATY_" "_IBMSG_"already exists, no change") Q
  1.  . S IBDISP=$P(IBT,U,2)
  1.  . S IBADJUST=$P(IBT,U,3)
  1.  . ; procedure of outpatient rx administrative fee update
  1.  . D ENT^IB3PSOU(IBRATY,IBEFFDT,IBADFE,IBDISP,IBADJUST)
  1.  . ; double check
  1.  . I $$RSEXIST(IBEFFDT,IBRSIN) S IBCT=IBCT+1 D MSG("    CY2016 "_IBRATY_" "_IBMSG_"added")
  1.  D MSG(" Total "_IBCT_$S(IBCT>1:" entries",1:" entry")_" updated in the Rate Schedule file (#363)")
  1.  D MSG("")
  1.  Q
  1.  ;
  1. RSEXIST(IBEFFDT,IBRSIN) ; return RS IFN if Rate Schedule exists for Effective Date
  1.  N IBX,IBRSFN,IBRS0 S IBX=0
  1.  S IBRSFN=0 F  S IBRSFN=$O(^IBE(363,IBRSFN))  Q:'IBRSFN  D  I IBX Q
  1.  . S IBRS0=$G(^IBE(363,IBRSFN,0))
  1.  . I $P(IBRS0,U,2)=IBRSIN,$P(IBRS0,U,5)=IBEFFDT S IBX=IBRSFN
  1.  Q IBX
  1.  ;
  1. MSG(IBA) ;
  1.  D MES^XPDUTL(IBA)
  1.  Q
  1.  ;
  1. POSU ; Place of Service code^name^abbreviation
  1.  ;;17^WALK-IN RETAIL HEALTH CLINIC^WLK-IN RET HLTH CL
  1.  ;;19^OFF CAMPUS-OUTPATIENT HOSPITAL^OFF CAMP OP HOSP
  1.  ;;22^ON CAMPUS-OUTPATIENT HOSPITAL^ON CAMP OP HOSP
  1.  ;;Q
  1.  ;
  1. RSF ; Rate type^dispensing fee^adjustment
  1.  ;;TRICARE REIMB. INS.^12.19^S X=X+12.19
  1.  ;;TRICARE^12.19^S X=X+12.19
  1.  ;;Q
  1.  ;