IB20P555 ;ALB/CXW - IB*2*555 POST INIT: DENTAL COST-BASED/INTERAGENCY RATE; 09/12/2015
;;2.0;INTEGRATED BILLING;**555**;21-MAR-94;Build 22
;;Per VA Directive 6402, this routine should not be modified.
;
;
; Add FY2015 Dental Cost Based and Interagency Charges to the Charge Master
Q
;
POST ;
N IBEFFDT,IBA,U S U="^"
D MSG(" IB*2.0*555 Post-Install .....")
S IBEFFDT=3141104 ; effective date of 11/04/2014
D ADDCI(IBEFFDT) ; add Charge Items (363.2) with new 2 dental rates
D ADDRS
D MSG(" IB*2*555 Post-Install Complete")
Q
;
ADDCI(IBEFFDT) ; Add Charge Items (363.2) needs Charge Sets, pass in the effective date of the new charges
N IBCHG,IBCHZ,IBCNT,IBCNT1,IBCI,IBCS0,IBCS,IBDFLTDT,IBDT,IBFN,IBI,IBLN,IBRVCD,IBX,IBXRF,IBZ,DD,DO,DLAYGO,DIC,DIE,DA,DR,X,Y
;
D MSG("")
S (IBCNT,IBCNT1)=0,IBDFLTDT=+$G(IBEFFDT)
I 'IBDFLTDT D MSG("** Error: No Effective Date, No Charges Added") G CIQ
;
F IBI=1:1 S IBLN=$P($T(CIF+IBI),";;",2) Q:IBLN="QUIT" D SETCI
;
CIQ D MSG(" >> "_IBCNT_" Dental for Cost Based/Interagency Charge Items added (#363.2)")
D MSG("")
Q
;
SETCI ; set Charge Item (duplicates based on item, CS, eff dt, rev cd)
;
S IBCS0=$P(IBLN,U,2),IBCS=+$O(^IBE(363.1,"B",IBCS0,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,1)_" 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
;
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 IBCI=0,IBCNT1=IBCNT1+1,IBCHZ=+$P(IBZ,U,5) D MSG("** "_$S(IBCHZ'=IBCHG:"Error: ",1:"")_"Charge Item "_IBCS0_" with "_$S(IBCHZ'=IBCHG:"wrong ",1:"")_"charge $"_$P(IBZ,U,5)_" already exists, not re-added")
Q:'IBCI
;
K DD,DO S DLAYGO=363.2,DIC="^IBA(363.2,",DIC(0)="L",X=IBCI_";DGCR(399.1," D FILE^DICN K DIC,DLAYGO
I Y<1 D MSG("** Error: when adding the charge item "_IBCS_" with rate "_IBCHG_" to the file, Log a Remedy ticket!") K X,Y Q
S IBFN=+Y,IBCNT=IBCNT+1
;
S DR=".02///"_IBCS_";.03///"_IBDT_";.05///"_IBCHG I +IBRVCD S DR=DR_";.06///"_IBRVCD
S DIE="^IBA(363.2,",DA=+IBFN D ^DIE K DIE,DA,DR,X,Y
Q
;
ADDRS ; add Charge Sets to Rate Schedules (363)
N IBCNT,IBCS,IBCSY,IBI,IBLN,IBRS,IBRSN,IBX,DA,DD,DO,DLAYGO,DIC,DIE,DR,X,Y
S IBCNT=0
F IBI=1:1 S IBLN=$P($T(RSF+IBI),";;",2) Q:IBLN="QUIT" D
. S IBRS=$P(IBLN,U)
. S IBCS=$P(IBLN,U,6)
. S IBCSY=$O(^IBE(363.1,"B",IBCS,0))
. I 'IBCSY D MSG("** Error: Charge Set "_IBCS_" undefined, not added") Q
. ; remove auto add for the old cs ia-opt vst
. S IBRSN=$O(^IBE(363,"B",IBRS,0))
. I $O(^IBE(363,"B",IBRS,IBRSN))'="" D
.. S IBX=$O(^IBE(363,IBRSN,11,"B",+$O(^IBE(363.1,"B","IA-OPT VST",0)),0)) Q:'IBX
.. S DA(1)=IBRSN,DA=IBX,DIE="^IBE(363,"_DA(1)_",11,"
.. S DR=".02///@" D ^DIE
. ; find the latest entry
. S IBRSN=+$O(^IBE(363,"B",IBRS,99999),-1)
. I 'IBRSN D MSG("** Error: Rate Schedule "_IBRS_" undefined, Charge Set "_IBCS_" not added") Q
. I $P($G(^IBE(363,IBRSN,0)),U,6)'="" D MSG("** Error: Rate Schedule "_IBRS_" inactivated, Charge Set "_IBCS_" not added") Q
. I $O(^IBE(363,IBRSN,11,"B",IBCSY,0)) D MSG("** Rate Schedule "_IBRS_" with "_IBCS_" already exists, not re-added") Q
. ;
. K DD,DO S DLAYGO=363,DA(1)=+IBRSN,DIC="^IBE(363,"_DA(1)_",11,",DIC(0)="L",X=+IBCSY,DIC("P")="363.0011P" D FILE^DICN K DIC,DA,DLAYGO
. I Y<1 D MSG("** Error: when adding the Charge Set "_IBCS_" to Rate Schedule "_IBRS_" in the file, Log a Remedy ticket!") K X,Y Q
. S IBCNT=IBCNT+1
RSQ ;
D MSG(" >> "_IBCNT_" Rate Schedules updated (#363)")
D MSG("")
Q
;
MCCRUTL(X,P) ; returns IFN of item in 399.1 if Name is found and piece P is true
N IBX,IBY S IBY=""
I $G(X)'="" S IBX=0 F S IBX=$O(^DGCR(399.1,"B",X,IBX)) Q:'IBX I $P($G(^DGCR(399.1,IBX,0)),U,+$G(P)) S IBY=IBX
Q IBY
;
RVCD(RVCD) ; returns IFN if revenue code is valid and active
N IBX,IBY S IBY=""
I +$G(RVCD) S IBX=$G(^DGCR(399.2,+RVCD,0)) I +$P(IBX,U,3) S IBY=+RVCD
Q IBY
;
MSG(IBA) ;
D MES^XPDUTL(IBA)
Q
;
CIF ; Dental Tortiously Liable/Interagency: Bedsection^Charge Set^Effective Date^Revenue Code^Charge
;;OUTPATIENT DENTAL^TL-OPT DENTAL^^^236
;;OUTPATIENT DENTAL^IA-OPT DENTAL^^^222
;;QUIT
Q
;
RSF ; Rate Schedule: Name^Rate Type^Bill Type^Effective Date^Inactive Date^Charge Set
;;DNTL-OPT DENTAL^DENTAL^OUTPATIENT^^^TL-OPT DENTAL
;;IA-OPT^INTERAGENCY^OUTPATIENT^^^IA-OPT DENTAL
;;QUIT
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIB20P555 4602 printed Apr 09, 2024@21:08:35 Page 2
IB20P555 ;ALB/CXW - IB*2*555 POST INIT: DENTAL COST-BASED/INTERAGENCY RATE; 09/12/2015
+1 ;;2.0;INTEGRATED BILLING;**555**;21-MAR-94;Build 22
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ;
+5 ; Add FY2015 Dental Cost Based and Interagency Charges to the Charge Master
+6 QUIT
+7 ;
POST ;
+1 NEW IBEFFDT,IBA,U
SET U="^"
+2 DO MSG(" IB*2.0*555 Post-Install .....")
+3 ; effective date of 11/04/2014
SET IBEFFDT=3141104
+4 ; add Charge Items (363.2) with new 2 dental rates
DO ADDCI(IBEFFDT)
+5 DO ADDRS
+6 DO MSG(" IB*2*555 Post-Install Complete")
+7 QUIT
+8 ;
ADDCI(IBEFFDT) ; Add Charge Items (363.2) needs Charge Sets, pass in the effective date of the new charges
+1 NEW IBCHG,IBCHZ,IBCNT,IBCNT1,IBCI,IBCS0,IBCS,IBDFLTDT,IBDT,IBFN,IBI,IBLN,IBRVCD,IBX,IBXRF,IBZ,DD,DO,DLAYGO,DIC,DIE,DA,DR,X,Y
+2 ;
+3 DO MSG("")
+4 SET (IBCNT,IBCNT1)=0
SET IBDFLTDT=+$GET(IBEFFDT)
+5 IF 'IBDFLTDT
DO MSG("** Error: No Effective Date, No Charges Added")
GOTO CIQ
+6 ;
+7 FOR IBI=1:1
SET IBLN=$PIECE($TEXT(CIF+IBI),";;",2)
if IBLN="QUIT"
QUIT
DO SETCI
+8 ;
CIQ DO MSG(" >> "_IBCNT_" Dental for Cost Based/Interagency Charge Items added (#363.2)")
+1 DO MSG("")
+2 QUIT
+3 ;
SETCI ; set Charge Item (duplicates based on item, CS, eff dt, rev cd)
+1 ;
+2 SET IBCS0=$PIECE(IBLN,U,2)
SET IBCS=+$ORDER(^IBE(363.1,"B",IBCS0,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,1)_" 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 ;
+9 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
+10 SET IBCI=0
SET IBCNT1=IBCNT1+1
SET IBCHZ=+$PIECE(IBZ,U,5)
DO MSG("** "_$SELECT(IBCHZ'=IBCHG:"Error: ",1:"")_"Charge Item "_IBCS0_" with "_$SELECT(IBCHZ'=IBCHG:"wrong ",1:"")_"charge $"_$PIECE(IBZ,U,5)_" already exists, not re-added")
End DoDot:1
+11 if 'IBCI
QUIT
+12 ;
+13 KILL DD,DO
SET DLAYGO=363.2
SET DIC="^IBA(363.2,"
SET DIC(0)="L"
SET X=IBCI_";DGCR(399.1,"
DO FILE^DICN
KILL DIC,DLAYGO
+14 IF Y<1
DO MSG("** Error: when adding the charge item "_IBCS_" with rate "_IBCHG_" to the file, Log a Remedy ticket!")
KILL X,Y
QUIT
+15 SET IBFN=+Y
SET IBCNT=IBCNT+1
+16 ;
+17 SET DR=".02///"_IBCS_";.03///"_IBDT_";.05///"_IBCHG
IF +IBRVCD
SET DR=DR_";.06///"_IBRVCD
+18 SET DIE="^IBA(363.2,"
SET DA=+IBFN
DO ^DIE
KILL DIE,DA,DR,X,Y
+19 QUIT
+20 ;
ADDRS ; add Charge Sets to Rate Schedules (363)
+1 NEW IBCNT,IBCS,IBCSY,IBI,IBLN,IBRS,IBRSN,IBX,DA,DD,DO,DLAYGO,DIC,DIE,DR,X,Y
+2 SET IBCNT=0
+3 FOR IBI=1:1
SET IBLN=$PIECE($TEXT(RSF+IBI),";;",2)
if IBLN="QUIT"
QUIT
Begin DoDot:1
+4 SET IBRS=$PIECE(IBLN,U)
+5 SET IBCS=$PIECE(IBLN,U,6)
+6 SET IBCSY=$ORDER(^IBE(363.1,"B",IBCS,0))
+7 IF 'IBCSY
DO MSG("** Error: Charge Set "_IBCS_" undefined, not added")
QUIT
+8 ; remove auto add for the old cs ia-opt vst
+9 SET IBRSN=$ORDER(^IBE(363,"B",IBRS,0))
+10 IF $ORDER(^IBE(363,"B",IBRS,IBRSN))'=""
Begin DoDot:2
+11 SET IBX=$ORDER(^IBE(363,IBRSN,11,"B",+$ORDER(^IBE(363.1,"B","IA-OPT VST",0)),0))
if 'IBX
QUIT
+12 SET DA(1)=IBRSN
SET DA=IBX
SET DIE="^IBE(363,"_DA(1)_",11,"
+13 SET DR=".02///@"
DO ^DIE
End DoDot:2
+14 ; find the latest entry
+15 SET IBRSN=+$ORDER(^IBE(363,"B",IBRS,99999),-1)
+16 IF 'IBRSN
DO MSG("** Error: Rate Schedule "_IBRS_" undefined, Charge Set "_IBCS_" not added")
QUIT
+17 IF $PIECE($GET(^IBE(363,IBRSN,0)),U,6)'=""
DO MSG("** Error: Rate Schedule "_IBRS_" inactivated, Charge Set "_IBCS_" not added")
QUIT
+18 IF $ORDER(^IBE(363,IBRSN,11,"B",IBCSY,0))
DO MSG("** Rate Schedule "_IBRS_" with "_IBCS_" already exists, not re-added")
QUIT
+19 ;
+20 KILL DD,DO
SET DLAYGO=363
SET DA(1)=+IBRSN
SET DIC="^IBE(363,"_DA(1)_",11,"
SET DIC(0)="L"
SET X=+IBCSY
SET DIC("P")="363.0011P"
DO FILE^DICN
KILL DIC,DA,DLAYGO
+21 IF Y<1
DO MSG("** Error: when adding the Charge Set "_IBCS_" to Rate Schedule "_IBRS_" in the file, Log a Remedy ticket!")
KILL X,Y
QUIT
+22 SET IBCNT=IBCNT+1
End DoDot:1
RSQ ;
+1 DO MSG(" >> "_IBCNT_" Rate Schedules updated (#363)")
+2 DO MSG("")
+3 QUIT
+4 ;
MCCRUTL(X,P) ; returns IFN of item in 399.1 if Name is found and piece P is true
+1 NEW IBX,IBY
SET IBY=""
+2 IF $GET(X)'=""
SET IBX=0
FOR
SET IBX=$ORDER(^DGCR(399.1,"B",X,IBX))
if 'IBX
QUIT
IF $PIECE($GET(^DGCR(399.1,IBX,0)),U,+$GET(P))
SET IBY=IBX
+3 QUIT IBY
+4 ;
RVCD(RVCD) ; returns IFN if revenue code is valid and active
+1 NEW IBX,IBY
SET IBY=""
+2 IF +$GET(RVCD)
SET IBX=$GET(^DGCR(399.2,+RVCD,0))
IF +$PIECE(IBX,U,3)
SET IBY=+RVCD
+3 QUIT IBY
+4 ;
MSG(IBA) ;
+1 DO MES^XPDUTL(IBA)
+2 QUIT
+3 ;
CIF ; Dental Tortiously Liable/Interagency: Bedsection^Charge Set^Effective Date^Revenue Code^Charge
+1 ;;OUTPATIENT DENTAL^TL-OPT DENTAL^^^236
+2 ;;OUTPATIENT DENTAL^IA-OPT DENTAL^^^222
+3 ;;QUIT
+4 QUIT
+5 ;
RSF ; Rate Schedule: Name^Rate Type^Bill Type^Effective Date^Inactive Date^Charge Set
+1 ;;DNTL-OPT DENTAL^DENTAL^OUTPATIENT^^^TL-OPT DENTAL
+2 ;;IA-OPT^INTERAGENCY^OUTPATIENT^^^IA-OPT DENTAL
+3 ;;QUIT
+4 QUIT
