IB20P580 ;ALB/CXW - IB*2*580 POST INIT:COST-BASED/INTERAGENCY FIX ;11-07-2016
;;2.0;INTEGRATED BILLING;**580**;21-MAR-94;Build 38
;;Per VA Directive 6402, this routine should not be modified.
;
;
; Cost Based/Interagency Rate fix for Polytrauma in Charge Item (363.2)
Q
POST ;
N IBEFFDT,IBA,U S U="^"
D MSG(" IB*2.0*580 Post-Install .....")
S IBEFFDT=3160707 ; effective date of 07/07/2016
D UPDTCI(IBEFFDT) ; update Charge Items (363.2) with 4 rates
D MSG(" IB*2.0*580 Post-Install Complete")
Q
;
UPDTCI(IBEFFDT) ; Update Charge Items (363.2) needs Charge Sets, pass in the effective date of the new charges
N IBC,IBCHG,IBCNT,IBCNT1,IBC,IBCI,IBCS,IBDFLTDT,IBDT,IBI,IBLN,IBPE,IBRVCD,IBX,IBXRF,IBZ,DA,DIE,DR,X,Y
;
D MSG("")
S IBCNT=0,IBDFLTDT=+$G(IBEFFDT)
I 'IBDFLTDT D MSG("** Error: No Effective Date, No Charges Updated") G CIQ
;
F IBI=1:1 S IBLN=$P($T(CIF+IBI),";;",2) Q:+IBLN!(IBLN="") I $E(IBLN)?1A D SETCI
;
CIQ D MSG(">> "_IBCNT_" Cost Based/Interagency for Polytrauma/PM&RS charge items updated (#363.2).")
D MSG("")
Q
;
SETCI ; set Charge Item (duplicates based on item, CS, eff dt, rev cd)
;
S IBCS=$P(IBLN,U,2),IBCS=+$O(^IBE(363.1,"B",IBCS,0)) I 'IBCS D MSG("** Error: Charge Set "_$P(IBLN,U,2)_" undefined") Q
S IBCI=+$$MCCRUTL($P(IBLN,U,1),5) I 'IBCI D MSG("** Error: Bed Section "_$P(IBLN,U,2)_" undefined") Q
S IBDT=IBDFLTDT I +$P(IBLN,U,3) S IBDT=+$P(IBLN,U,3)
S IBRVCD=$$RVCD($P(IBLN,U,4))
S IBCHG=+$P(IBLN,U,5)
S IBXRF="AIVDTS"_IBCS
; check for duplicate charge items
S IBCNT1=0
;
S IBX=0 F S IBX=$O(^IBA(363.2,IBXRF,IBCI,-IBDT,IBX)) Q:'IBX S IBZ=$G(^IBA(363.2,IBX,0)) I $P(IBZ,U,6)=IBRVCD D
. S IBCNT1=IBCNT1+1
. I +$P(IBZ,U,5)=IBCHG D MSG(" "_$P(IBLN,U,2)_" with $"_IBCHG_" charge item already exists") Q
. S DIE="^IBA(363.2,",DA=+IBX,DR=".05///"_IBCHG D ^DIE K DIE,DA,DR,X,Y
. S IBCNT=IBCNT+1
I IBCNT1>1 D MSG("** Error: "_$P(IBLN,U,2)_" duplicate charge items on 07/07/2016")
Q
;
MCCRUTL(IBC,IBPE) ; returns IEN in 399.1 if Name is found and piece P is true
N IBX,IBY S IBY=""
I $G(IBC)'="" S IBX=0 F S IBX=$O(^DGCR(399.1,"B",IBC,IBX)) Q:'IBX I $P($G(^DGCR(399.1,IBX,0)),U,+$G(IBPE)) S IBY=IBX
Q IBY
;
RVCD(IBRVCD) ; returns IFN if revenue code is valid and active
N IBX,IBY S IBY=""
I +$G(IBRVCD) S IBX=$G(^DGCR(399.2,+IBRVCD,0)) I +$P(IBX,U,3) S IBY=+IBRVCD
Q IBY
;
MSG(IBA) ;
D MES^XPDUTL(IBA)
Q
;
CIF ; 4 Charge Items (363.2): Bedsection ^ Charge Set ^Effective Date ^ Revenue Code ^ Charge
;;
TORT ;; Cost Based (Tortiously Liable) for outpatient care
;;PM&RS OUTPATIENT VISIT^TL-OPT VST PM&RS^^^212
;;POLYTRAUMA OUTPATIENT VISIT^TL-OPT VST POLYTRAUMA^^^537
;;
IA ;; Interagency for outpatient care
;;PM&RS OUTPATIENT VISIT^IA-OPT VST PM&RS^^^199
;;POLYTRAUMA OUTPATIENT VISIT^IA-OPT VST POLYTRAUMA^^^510
;;
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIB20P580 2911 printed Nov 22, 2024@17:13:59 Page 2
IB20P580 ;ALB/CXW - IB*2*580 POST INIT:COST-BASED/INTERAGENCY FIX ;11-07-2016
+1 ;;2.0;INTEGRATED BILLING;**580**;21-MAR-94;Build 38
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ;
+5 ; Cost Based/Interagency Rate fix for Polytrauma in Charge Item (363.2)
+6 QUIT
POST ;
+1 NEW IBEFFDT,IBA,U
SET U="^"
+2 DO MSG(" IB*2.0*580 Post-Install .....")
+3 ; effective date of 07/07/2016
SET IBEFFDT=3160707
+4 ; update Charge Items (363.2) with 4 rates
DO UPDTCI(IBEFFDT)
+5 DO MSG(" IB*2.0*580 Post-Install Complete")
+6 QUIT
+7 ;
UPDTCI(IBEFFDT) ; Update Charge Items (363.2) needs Charge Sets, pass in the effective date of the new charges
+1 NEW IBC,IBCHG,IBCNT,IBCNT1,IBC,IBCI,IBCS,IBDFLTDT,IBDT,IBI,IBLN,IBPE,IBRVCD,IBX,IBXRF,IBZ,DA,DIE,DR,X,Y
+2 ;
+3 DO MSG("")
+4 SET IBCNT=0
SET IBDFLTDT=+$GET(IBEFFDT)
+5 IF 'IBDFLTDT
DO MSG("** Error: No Effective Date, No Charges Updated")
GOTO CIQ
+6 ;
+7 FOR IBI=1:1
SET IBLN=$PIECE($TEXT(CIF+IBI),";;",2)
if +IBLN!(IBLN="")
QUIT
IF $EXTRACT(IBLN)?1A
DO SETCI
+8 ;
CIQ DO MSG(">> "_IBCNT_" Cost Based/Interagency for Polytrauma/PM&RS charge items updated (#363.2).")
+1 DO MSG("")
+2 QUIT
+3 ;
SETCI ; set Charge Item (duplicates based on item, CS, eff dt, rev cd)
+1 ;
+2 SET IBCS=$PIECE(IBLN,U,2)
SET IBCS=+$ORDER(^IBE(363.1,"B",IBCS,0))
IF 'IBCS
DO MSG("** Error: Charge Set "_$PIECE(IBLN,U,2)_" undefined")
QUIT
+3 SET IBCI=+$$MCCRUTL($PIECE(IBLN,U,1),5)
IF 'IBCI
DO MSG("** Error: Bed Section "_$PIECE(IBLN,U,2)_" undefined")
QUIT
+4 SET IBDT=IBDFLTDT
IF +$PIECE(IBLN,U,3)
SET IBDT=+$PIECE(IBLN,U,3)
+5 SET IBRVCD=$$RVCD($PIECE(IBLN,U,4))
+6 SET IBCHG=+$PIECE(IBLN,U,5)
+7 SET IBXRF="AIVDTS"_IBCS
+8 ; check for duplicate charge items
+9 SET IBCNT1=0
+10 ;
+11 SET IBX=0
FOR
SET IBX=$ORDER(^IBA(363.2,IBXRF,IBCI,-IBDT,IBX))
if 'IBX
QUIT
SET IBZ=$GET(^IBA(363.2,IBX,0))
IF $PIECE(IBZ,U,6)=IBRVCD
Begin DoDot:1
+12 SET IBCNT1=IBCNT1+1
+13 IF +$PIECE(IBZ,U,5)=IBCHG
DO MSG(" "_$PIECE(IBLN,U,2)_" with $"_IBCHG_" charge item already exists")
QUIT
+14 SET DIE="^IBA(363.2,"
SET DA=+IBX
SET DR=".05///"_IBCHG
DO ^DIE
KILL DIE,DA,DR,X,Y
+15 SET IBCNT=IBCNT+1
End DoDot:1
+16 IF IBCNT1>1
DO MSG("** Error: "_$PIECE(IBLN,U,2)_" duplicate charge items on 07/07/2016")
+17 QUIT
+18 ;
MCCRUTL(IBC,IBPE) ; returns IEN in 399.1 if Name is found and piece P is true
+1 NEW IBX,IBY
SET IBY=""
+2 IF $GET(IBC)'=""
SET IBX=0
FOR
SET IBX=$ORDER(^DGCR(399.1,"B",IBC,IBX))
if 'IBX
QUIT
IF $PIECE($GET(^DGCR(399.1,IBX,0)),U,+$GET(IBPE))
SET IBY=IBX
+3 QUIT IBY
+4 ;
RVCD(IBRVCD) ; returns IFN if revenue code is valid and active
+1 NEW IBX,IBY
SET IBY=""
+2 IF +$GET(IBRVCD)
SET IBX=$GET(^DGCR(399.2,+IBRVCD,0))
IF +$PIECE(IBX,U,3)
SET IBY=+IBRVCD
+3 QUIT IBY
+4 ;
MSG(IBA) ;
+1 DO MES^XPDUTL(IBA)
+2 QUIT
+3 ;
CIF ; 4 Charge Items (363.2): Bedsection ^ Charge Set ^Effective Date ^ Revenue Code ^ Charge
+1 ;;
TORT ;; Cost Based (Tortiously Liable) for outpatient care
+1 ;;PM&RS OUTPATIENT VISIT^TL-OPT VST PM&RS^^^212
+2 ;;POLYTRAUMA OUTPATIENT VISIT^TL-OPT VST POLYTRAUMA^^^537
+3 ;;
IA ;; Interagency for outpatient care
+1 ;;PM&RS OUTPATIENT VISIT^IA-OPT VST PM&RS^^^199
+2 ;;POLYTRAUMA OUTPATIENT VISIT^IA-OPT VST POLYTRAUMA^^^510
+3 ;;
+4 QUIT
