IB20P383 ;OAK/ELZ - IB*2.0*383 CHECK/POST INSTALL ;11/15/07 09:47
;;2.0;INTEGRATED BILLING;**383**;21-MAR-94;Build 11
;;Per VHA Directive 2004-038, this routine should not be modified.
;
;
CHECK ; - pre-install check
;
N IBI,IBLN,IBX,IBRT
;
; - check for rate types that must be defined
; get active list
F IBI=1:1 S IBLN=$P($T(RTF+IBI),";;",2) Q:+IBLN!(IBLN="") S IBX=$O(^DGCR(399.3,"B",IBLN,0)) I IBX,'$P($G(^DGCR(399.3,IBX,0)),"^",3) S IBRT(IBLN,+IBX)=""
;
; do i have what i need?
F IBI=1:1 S IBLN=$P($T(RTF+IBI),";;",2) Q:+IBLN!(IBLN="")!($G(XPDABORT)) D
. S IBX=$O(IBRT(IBLN,0))
. I 'IBX W !," *** Rate Type ",IBLN," does not exist or is not active." S XPDABORT=1 Q
. I $O(IBRT(IBLN,IBX)) W !," *** Rate Type ",IBLN," has an active duplicate." S XPDABORT=1
I $G(XPDABORT) W !!,"The rate type(s) must exist and be active before you can install."
;
Q
;
POST ; - post-install
N IBA,IBCS,IBNCS,IBDT
;
S IBDT=3060101
;
S IBA(1)="",IBA(2)=" e-Pharmacy Tricare Support Post-Install .....",IBA(3)="" D MES^XPDUTL(.IBA) K IBA
;
D CLEANCS(.IBCS) ; clean up local charge sets
D ADDCS(.IBCS,.IBNCS) ; add charge sets
D OLDRS($$FMADD^XLFDT(IBDT,-1),.IBNCS) ; inactivate old rate schedules
D ADDRS(IBDT) ; add rate schedules
;
S IBA(1)="",IBA(2)=" e-Pharmacy Tricare Support Post-Install Complete",IBA(3)="" D MES^XPDUTL(.IBA)
;
Q
;
CLEANCS(IBCS) ; cleans up locally defined charge sets (if any) for VA Cost
; saves data in IBCS(billable event,old ien)=old revenue code
;
N IBI,IBBR,IBZ,DIK,DA
;
D MSG(" Cleaning up old local Charge Sets")
S IBBR=$O(^IBE(363.3,"B","VA COST",0)) I 'IBBR D MSG(" *** Missing Billing Rate VA COST !!!") Q
I '$O(^IBE(363.1,"C",IBBR,999)) D MSG(" - No Charge Sets to clean up...ok") Q
S IBI=999 F S IBI=$O(^IBE(363.1,"C",IBBR,IBI)) Q:'IBI D
. S IBZ=$G(^IBE(363.1,IBI,0))
. D MSG(" - Deleting Charge Set "_$P(IBZ,"^")_"...ok")
. I $P(IBZ,"^",3),$P(IBZ,"^",5) S IBCS($P(IBZ,"^",3),IBI)=$P(IBZ,"^",5)
. S DIK="^IBE(363.1,",DA=IBI D ^DIK
;
D MSG(" Done cleaning up old local Charge Sets")
;
Q
;
;
ADDCS(IBCS,IBNCS) ; Add Charge Set (363.1)
; puts data in IBNCS(ien)="" for new charge sets added
;
N IBCNT,IBI,IBLN,IBFN,IBBR,IBBE,IBRVCD,DD,DO,DLAYGO,DIC,DIE,DA,DR,X,Y,IBORVCD,IBY,IBZ,DINUM,IBJ
S IBCNT=0
;
D MSG(" Adding new National Charge Sets")
F IBI=1:1 S IBLN=$P($T(CSF+IBI),";;",2) Q:+IBLN!(IBLN="") I $E(IBLN)?1A D
. ;
. I $O(^IBE(363.1,"B",$P(IBLN,U,1),0)) Q
. S IBBR=$P(IBLN,U,2),IBBR=$O(^IBE(363.3,"B",IBBR,0)) I 'IBBR Q
. S IBBE=$$MCCRUTL($P(IBLN,U,3),14) Q:'IBBE
. S IBORVCD=+$G(IBCS(IBBE,+$O(IBCS(IBBE,999))))
. S IBRVCD=+$$RVCD($P(IBLN,U,5))
. F IBJ=1:1 I $G(^IBE(363.1,IBJ,0))="" S DINUM=IBJ Q
. ;
. K DD,DO S DLAYGO=363.1,DIC="^IBE(363.1,",DIC(0)="L",X=$P(IBLN,U,1) D FILE^DICN K DIC,DINUM I Y<1 K X,Y Q
. D MSG(" Charge Set "_$P(IBLN,U,1)_" added...ok")
. S IBFN=+Y,IBCNT=IBCNT+1,IBNCS(IBFN)=""
. ;
. S DR=".02////"_IBBR_";.03////"_IBBE
. I IBORVCD D MSG(" - Using old Revenue Code...ok")
. I IBRVCD!(IBORVCD) S DR=DR_";.05////"_$S(IBORVCD:IBORVCD,1:IBRVCD)
. D MSG(" - Assigning Bed Section...")
. S DR=DR_";.06////"_$$MCCRUTL($P(IBLN,U,6),5)
. S DIE="^IBE(363.1,",DA=+IBFN D ^DIE K DIE,DA,DR,X,Y
. Q:'$O(IBCS(IBBE,999))
. D MSG(" - Resetting pointers from old Charge Sets...ok")
. S IBCS=0 F S IBCS=$O(IBCS(IBBE,IBCS)) Q:'IBCS D
.. ; possible pointer stored in 350.9 for old RNA sites
.. I $P($G(^IBE(350.9,1,9)),"^",12)=IBCS D K DIE,DA,DR,X,Y
... S DIE="^IBE(350.9,",DA=1,DR="9.12////^S X=+IBFN" D ^DIE
.. ; fix Rate Schedules with pointers
.. S IBY=0 F S IBY=$O(^IBE(363,"C",IBCS,IBY)) Q:'IBY S IBZ=0 F S IBZ=$O(^IBE(363,"C",IBCS,IBY,IBZ)) Q:'IBZ D K DIE,DA,DR,X,Y
... S DIE="^IBE(363,"_IBY_",11,",DA(1)=IBY,DA=IBZ,DR=".01////^S X=+IBFN" D ^DIE
.. ; fix Billing Special Groups with pointers
.. S IBZ=0 F S IBZ=$O(^IBE(363.32,IBZ)) Q:'IBZ S IBY=0 F S IBY=$O(^IBE(363.32,IBZ,11,IBY)) Q:'IBY I $P($G(^IBE(363.32,IBZ,11,IBY,0)),"^",2)=IBCS D K DIE,DA,DR,X,Y
... S DIE="^IBE(363.32,"_IBZ_",11,",DA(1)=IBZ,DA=IBY,DR=".02////^S X=+IBFN" D ^DIE
;
CSQ ;
D MSG(" >> "_IBCNT_" Charge Sets added (363.1)...")
;
Q
;
OLDRS(IBDT,IBNCS) ; inactivate old rate schedules
;
D MSG(" Inactivating old Rate Schedules")
;
N IBY,IBX,IBZ,IBC,IBD,IBCNT,DA,DIE,DIK,DR,X,Y S IBCNT=0
;
S IBNCS=0 F S IBNCS=$O(IBNCS(IBNCS)) Q:'IBNCS S IBY=0 F S IBY=$O(^IBE(363,"C",IBNCS,IBY)) Q:'IBY S IBZ=999 F S IBZ=$O(^IBE(363,"C",IBNCS,IBY,IBZ)) Q:'IBZ D
. S IBD=$G(^IBE(363,IBY,0))
. Q:$P(IBD,"^",6)
. Q:$G(^DGCR(399.3,+$P(IBD,"^",2),0))'["TRICARE"
. S (IBC,IBX)=0 F S IBX=$O(^IBE(363,IBZ,11,IBX)) Q:'IBX S IBC=IBC+1
. I IBC>1 D Q
.. D MSG(" - Rate Schedule "_$P(IBD,"^")_" has multiple Charge Sets")
.. D MSG(" removing "_$P($G(^IBE(363.1,IBNCS,0)),"^")_" Charge Set but leaving active.")
.. S DIK="^IBE(363,"_IBY_",11,",DA(1)=IBY,DA=IBZ D ^DIK K DIK,DA
. D MSG(" - Inactivating Rate Schedule "_$P(IBD,"^"))
. S DIE="^IBE(363,",DA=IBY,DR=".06////^S X=IBDT" D ^DIE K DIE,DA,X,Y
;
D MSG(" Done inactivating old Rate Schedules...")
;
Q
;
ADDRS(IBDT) ; add Rate Schedule (363) (needs billable service and charge sets)
N IBX,IBCNT,IBI,IBLN,IBFN,IBRT,IBBS,IBJ,IBLNCS,IBCS,IBCSFN,DD,DO,DLAYGO,DIC,DIE,DA,DR,X,Y,IBAJ,DINUM S IBCNT=0
;
D MSG(" Adding new National Rate Schedules")
;
F IBI=1:1 S IBLN=$P($T(RSF+IBI),";",3),IBAJ=$P($T(RSF+IBI),";",4) Q:+IBLN!(IBLN="") I $E(IBLN)?1A D
. ;
. I $O(^IBE(363,"B",$P(IBLN,U,1),0)) Q
. S IBBS=$P(IBLN,U,4) I IBBS'="" S IBBS=$$MCCRUTL(IBBS,13) I 'IBBS D Q
.. D MSG("*** Billable Service "_$P(IBLN,U,4)_" NOT FOUND, Rate Schedule "_$P(IBLN,"^")_" not created!!!")
. S IBRT=$P(IBLN,U,2),IBRT=$O(^DGCR(399.3,"B",IBRT,0)) D Q:'IBRT
.. I 'IBRT D MSG("**** Rate Type "_$P(IBLN,U,2)_" not defined, Rate Schedule "_$P(IBLN,U,1)_" NOT created!!!")
.. I $P($G(^DGCR(399.3,+IBRT,0)),U,3) S (IBRT,IBX)=0 F S IBX=$O(^DGCR(399.3,"B",$P(IBLN,U,2),IBX)) Q:'IBX I '$P($G(^DGCR(399.3,+IBX,0)),U,3) S IBRT=+IBX Q
.. I $P($G(^DGCR(399.3,+IBRT,0)),U,3) S IBRT=0 D MSG("**** Rate Type "_$P(IBLN,U,2)_" not Active, RS "_$P(IBLN,U,1)_" not created!!!")
. F IBJ=1:1 I $G(^IBE(363,IBJ,0))="" S DINUM=IBJ Q
. ;
. K DD,DO S DLAYGO=363,DIC="^IBE(363,",DIC(0)="L",X=$P(IBLN,U,1) D FILE^DICN K DIC,DINUM,DLAYGO I Y<1 K X,Y Q
. S IBFN=+Y,IBCNT=IBCNT+1
. ;
. S DR=".02////"_IBRT_";.03////"_$P(IBLN,U,3)_";.05////"_IBDT_";.04////"_IBBS
. I $L(IBAJ) D
.. F IBJ=1,2 S:$L($P(IBAJ,U,IBJ)) DR=DR_";1.0"_IBJ_"////"_$P(IBAJ,U,IBJ)
.. I $L($P(IBAJ,U,3)) S DR=DR_";10////^S X=$P(IBAJ,U,3)"
. ;
. S DIE="^IBE(363,",DA=IBFN D ^DIE K DIE,DA,DR,X,Y
. ;
. ; charge sets (multiple)
. S IBLNCS=$P(IBLN,":",2,999) F IBJ=1:1 S IBCS=$P(IBLNCS,":",IBJ) Q:IBCS="" D
.. S IBCSFN=$O(^IBE(363.1,"B",IBCS,0)) Q:'IBCSFN
.. ;
.. S DLAYGO=363,DA(1)=+IBFN,DIC="^IBE(363,"_DA(1)_",11,",DIC(0)="L",X=IBCS,DIC("DR")=".02////"_1,DIC("P")="363.0011P" D ^DIC K DIC,DIE
;
;
RSQ D MSG(" >> "_IBCNT_" Rate Schedules added (363)...")
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(X) ;
D MES^XPDUTL(X)
Q
;
CSF ; Charge Set (363.1)
;;RX COST^VA COST^PRESCRIPTION FILL^^250^PRESCRIPTION
;;PI COST^VA COST^PROSTHETICS ITEM^^274^OUTPATIENT VISIT
;;1
;
RSF ; Rate Schedules (363)
;;TR-RX^TRICARE^3^PRESCRIPTION^^^:RX COST;8^^S X=X+8
;;TRRI-RX^TRICARE REIMB. INS.^3^PRESCRIPTION^^^:RX COST;8^^S X=X+8
;;1
;
RTF ; Rate Types (399.3) that must exist
;;TRICARE
;;TRICARE REIMB. INS.
;;1
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIB20P383 8030 printed Nov 22, 2024@17:12:35 Page 2
IB20P383 ;OAK/ELZ - IB*2.0*383 CHECK/POST INSTALL ;11/15/07 09:47
+1 ;;2.0;INTEGRATED BILLING;**383**;21-MAR-94;Build 11
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 ;
CHECK ; - pre-install check
+1 ;
+2 NEW IBI,IBLN,IBX,IBRT
+3 ;
+4 ; - check for rate types that must be defined
+5 ; get active list
+6 FOR IBI=1:1
SET IBLN=$PIECE($TEXT(RTF+IBI),";;",2)
if +IBLN!(IBLN="")
QUIT
SET IBX=$ORDER(^DGCR(399.3,"B",IBLN,0))
IF IBX
IF '$PIECE($GET(^DGCR(399.3,IBX,0)),"^",3)
SET IBRT(IBLN,+IBX)=""
+7 ;
+8 ; do i have what i need?
+9 FOR IBI=1:1
SET IBLN=$PIECE($TEXT(RTF+IBI),";;",2)
if +IBLN!(IBLN="")!($GET(XPDABORT))
QUIT
Begin DoDot:1
+10 SET IBX=$ORDER(IBRT(IBLN,0))
+11 IF 'IBX
WRITE !," *** Rate Type ",IBLN," does not exist or is not active."
SET XPDABORT=1
QUIT
+12 IF $ORDER(IBRT(IBLN,IBX))
WRITE !," *** Rate Type ",IBLN," has an active duplicate."
SET XPDABORT=1
End DoDot:1
+13 IF $GET(XPDABORT)
WRITE !!,"The rate type(s) must exist and be active before you can install."
+14 ;
+15 QUIT
+16 ;
POST ; - post-install
+1 NEW IBA,IBCS,IBNCS,IBDT
+2 ;
+3 SET IBDT=3060101
+4 ;
+5 SET IBA(1)=""
SET IBA(2)=" e-Pharmacy Tricare Support Post-Install ....."
SET IBA(3)=""
DO MES^XPDUTL(.IBA)
KILL IBA
+6 ;
+7 ; clean up local charge sets
DO CLEANCS(.IBCS)
+8 ; add charge sets
DO ADDCS(.IBCS,.IBNCS)
+9 ; inactivate old rate schedules
DO OLDRS($$FMADD^XLFDT(IBDT,-1),.IBNCS)
+10 ; add rate schedules
DO ADDRS(IBDT)
+11 ;
+12 SET IBA(1)=""
SET IBA(2)=" e-Pharmacy Tricare Support Post-Install Complete"
SET IBA(3)=""
DO MES^XPDUTL(.IBA)
+13 ;
+14 QUIT
+15 ;
CLEANCS(IBCS) ; cleans up locally defined charge sets (if any) for VA Cost
+1 ; saves data in IBCS(billable event,old ien)=old revenue code
+2 ;
+3 NEW IBI,IBBR,IBZ,DIK,DA
+4 ;
+5 DO MSG(" Cleaning up old local Charge Sets")
+6 SET IBBR=$ORDER(^IBE(363.3,"B","VA COST",0))
IF 'IBBR
DO MSG(" *** Missing Billing Rate VA COST !!!")
QUIT
+7 IF '$ORDER(^IBE(363.1,"C",IBBR,999))
DO MSG(" - No Charge Sets to clean up...ok")
QUIT
+8 SET IBI=999
FOR
SET IBI=$ORDER(^IBE(363.1,"C",IBBR,IBI))
if 'IBI
QUIT
Begin DoDot:1
+9 SET IBZ=$GET(^IBE(363.1,IBI,0))
+10 DO MSG(" - Deleting Charge Set "_$PIECE(IBZ,"^")_"...ok")
+11 IF $PIECE(IBZ,"^",3)
IF $PIECE(IBZ,"^",5)
SET IBCS($PIECE(IBZ,"^",3),IBI)=$PIECE(IBZ,"^",5)
+12 SET DIK="^IBE(363.1,"
SET DA=IBI
DO ^DIK
End DoDot:1
+13 ;
+14 DO MSG(" Done cleaning up old local Charge Sets")
+15 ;
+16 QUIT
+17 ;
+18 ;
ADDCS(IBCS,IBNCS) ; Add Charge Set (363.1)
+1 ; puts data in IBNCS(ien)="" for new charge sets added
+2 ;
+3 NEW IBCNT,IBI,IBLN,IBFN,IBBR,IBBE,IBRVCD,DD,DO,DLAYGO,DIC,DIE,DA,DR,X,Y,IBORVCD,IBY,IBZ,DINUM,IBJ
+4 SET IBCNT=0
+5 ;
+6 DO MSG(" Adding new National Charge Sets")
+7 FOR IBI=1:1
SET IBLN=$PIECE($TEXT(CSF+IBI),";;",2)
if +IBLN!(IBLN="")
QUIT
IF $EXTRACT(IBLN)?1A
Begin DoDot:1
+8 ;
+9 IF $ORDER(^IBE(363.1,"B",$PIECE(IBLN,U,1),0))
QUIT
+10 SET IBBR=$PIECE(IBLN,U,2)
SET IBBR=$ORDER(^IBE(363.3,"B",IBBR,0))
IF 'IBBR
QUIT
+11 SET IBBE=$$MCCRUTL($PIECE(IBLN,U,3),14)
if 'IBBE
QUIT
+12 SET IBORVCD=+$GET(IBCS(IBBE,+$ORDER(IBCS(IBBE,999))))
+13 SET IBRVCD=+$$RVCD($PIECE(IBLN,U,5))
+14 FOR IBJ=1:1
IF $GET(^IBE(363.1,IBJ,0))=""
SET DINUM=IBJ
QUIT
+15 ;
+16 KILL DD,DO
SET DLAYGO=363.1
SET DIC="^IBE(363.1,"
SET DIC(0)="L"
SET X=$PIECE(IBLN,U,1)
DO FILE^DICN
KILL DIC,DINUM
IF Y<1
KILL X,Y
QUIT
+17 DO MSG(" Charge Set "_$PIECE(IBLN,U,1)_" added...ok")
+18 SET IBFN=+Y
SET IBCNT=IBCNT+1
SET IBNCS(IBFN)=""
+19 ;
+20 SET DR=".02////"_IBBR_";.03////"_IBBE
+21 IF IBORVCD
DO MSG(" - Using old Revenue Code...ok")
+22 IF IBRVCD!(IBORVCD)
SET DR=DR_";.05////"_$SELECT(IBORVCD:IBORVCD,1:IBRVCD)
+23 DO MSG(" - Assigning Bed Section...")
+24 SET DR=DR_";.06////"_$$MCCRUTL($PIECE(IBLN,U,6),5)
+25 SET DIE="^IBE(363.1,"
SET DA=+IBFN
DO ^DIE
KILL DIE,DA,DR,X,Y
+26 if '$ORDER(IBCS(IBBE,999))
QUIT
+27 DO MSG(" - Resetting pointers from old Charge Sets...ok")
+28 SET IBCS=0
FOR
SET IBCS=$ORDER(IBCS(IBBE,IBCS))
if 'IBCS
QUIT
Begin DoDot:2
+29 ; possible pointer stored in 350.9 for old RNA sites
+30 IF $PIECE($GET(^IBE(350.9,1,9)),"^",12)=IBCS
Begin DoDot:3
+31 SET DIE="^IBE(350.9,"
SET DA=1
SET DR="9.12////^S X=+IBFN"
DO ^DIE
End DoDot:3
KILL DIE,DA,DR,X,Y
+32 ; fix Rate Schedules with pointers
+33 SET IBY=0
FOR
SET IBY=$ORDER(^IBE(363,"C",IBCS,IBY))
if 'IBY
QUIT
SET IBZ=0
FOR
SET IBZ=$ORDER(^IBE(363,"C",IBCS,IBY,IBZ))
if 'IBZ
QUIT
Begin DoDot:3
+34 SET DIE="^IBE(363,"_IBY_",11,"
SET DA(1)=IBY
SET DA=IBZ
SET DR=".01////^S X=+IBFN"
DO ^DIE
End DoDot:3
KILL DIE,DA,DR,X,Y
+35 ; fix Billing Special Groups with pointers
+36 SET IBZ=0
FOR
SET IBZ=$ORDER(^IBE(363.32,IBZ))
if 'IBZ
QUIT
SET IBY=0
FOR
SET IBY=$ORDER(^IBE(363.32,IBZ,11,IBY))
if 'IBY
QUIT
IF $PIECE($GET(^IBE(363.32,IBZ,11,IBY,0)),"^",2)=IBCS
Begin DoDot:3
+37 SET DIE="^IBE(363.32,"_IBZ_",11,"
SET DA(1)=IBZ
SET DA=IBY
SET DR=".02////^S X=+IBFN"
DO ^DIE
End DoDot:3
KILL DIE,DA,DR,X,Y
End DoDot:2
End DoDot:1
+38 ;
CSQ ;
+1 DO MSG(" >> "_IBCNT_" Charge Sets added (363.1)...")
+2 ;
+3 QUIT
+4 ;
OLDRS(IBDT,IBNCS) ; inactivate old rate schedules
+1 ;
+2 DO MSG(" Inactivating old Rate Schedules")
+3 ;
+4 NEW IBY,IBX,IBZ,IBC,IBD,IBCNT,DA,DIE,DIK,DR,X,Y
SET IBCNT=0
+5 ;
+6 SET IBNCS=0
FOR
SET IBNCS=$ORDER(IBNCS(IBNCS))
if 'IBNCS
QUIT
SET IBY=0
FOR
SET IBY=$ORDER(^IBE(363,"C",IBNCS,IBY))
if 'IBY
QUIT
SET IBZ=999
FOR
SET IBZ=$ORDER(^IBE(363,"C",IBNCS,IBY,IBZ))
if 'IBZ
QUIT
Begin DoDot:1
+7 SET IBD=$GET(^IBE(363,IBY,0))
+8 if $PIECE(IBD,"^",6)
QUIT
+9 if $GET(^DGCR(399.3,+$PIECE(IBD,"^",2),0))'["TRICARE"
QUIT
+10 SET (IBC,IBX)=0
FOR
SET IBX=$ORDER(^IBE(363,IBZ,11,IBX))
if 'IBX
QUIT
SET IBC=IBC+1
+11 IF IBC>1
Begin DoDot:2
+12 DO MSG(" - Rate Schedule "_$PIECE(IBD,"^")_" has multiple Charge Sets")
+13 DO MSG(" removing "_$PIECE($GET(^IBE(363.1,IBNCS,0)),"^")_" Charge Set but leaving active.")
+14 SET DIK="^IBE(363,"_IBY_",11,"
SET DA(1)=IBY
SET DA=IBZ
DO ^DIK
KILL DIK,DA
End DoDot:2
QUIT
+15 DO MSG(" - Inactivating Rate Schedule "_$PIECE(IBD,"^"))
+16 SET DIE="^IBE(363,"
SET DA=IBY
SET DR=".06////^S X=IBDT"
DO ^DIE
KILL DIE,DA,X,Y
End DoDot:1
+17 ;
+18 DO MSG(" Done inactivating old Rate Schedules...")
+19 ;
+20 QUIT
+21 ;
ADDRS(IBDT) ; add Rate Schedule (363) (needs billable service and charge sets)
+1 NEW IBX,IBCNT,IBI,IBLN,IBFN,IBRT,IBBS,IBJ,IBLNCS,IBCS,IBCSFN,DD,DO,DLAYGO,DIC,DIE,DA,DR,X,Y,IBAJ,DINUM
SET IBCNT=0
+2 ;
+3 DO MSG(" Adding new National Rate Schedules")
+4 ;
+5 FOR IBI=1:1
SET IBLN=$PIECE($TEXT(RSF+IBI),";",3)
SET IBAJ=$PIECE($TEXT(RSF+IBI),";",4)
if +IBLN!(IBLN="")
QUIT
IF $EXTRACT(IBLN)?1A
Begin DoDot:1
+6 ;
+7 IF $ORDER(^IBE(363,"B",$PIECE(IBLN,U,1),0))
QUIT
+8 SET IBBS=$PIECE(IBLN,U,4)
IF IBBS'=""
SET IBBS=$$MCCRUTL(IBBS,13)
IF 'IBBS
Begin DoDot:2
+9 DO MSG("*** Billable Service "_$PIECE(IBLN,U,4)_" NOT FOUND, Rate Schedule "_$PIECE(IBLN,"^")_" not created!!!")
End DoDot:2
QUIT
+10 SET IBRT=$PIECE(IBLN,U,2)
SET IBRT=$ORDER(^DGCR(399.3,"B",IBRT,0))
Begin DoDot:2
+11 IF 'IBRT
DO MSG("**** Rate Type "_$PIECE(IBLN,U,2)_" not defined, Rate Schedule "_$PIECE(IBLN,U,1)_" NOT created!!!")
+12 IF $PIECE($GET(^DGCR(399.3,+IBRT,0)),U,3)
SET (IBRT,IBX)=0
FOR
SET IBX=$ORDER(^DGCR(399.3,"B",$PIECE(IBLN,U,2),IBX))
if 'IBX
QUIT
IF '$PIECE($GET(^DGCR(399.3,+IBX,0)),U,3)
SET IBRT=+IBX
QUIT
+13 IF $PIECE($GET(^DGCR(399.3,+IBRT,0)),U,3)
SET IBRT=0
DO MSG("**** Rate Type "_$PIECE(IBLN,U,2)_" not Active, RS "_$PIECE(IBLN,U,1)_" not created!!!")
End DoDot:2
if 'IBRT
QUIT
+14 FOR IBJ=1:1
IF $GET(^IBE(363,IBJ,0))=""
SET DINUM=IBJ
QUIT
+15 ;
+16 KILL DD,DO
SET DLAYGO=363
SET DIC="^IBE(363,"
SET DIC(0)="L"
SET X=$PIECE(IBLN,U,1)
DO FILE^DICN
KILL DIC,DINUM,DLAYGO
IF Y<1
KILL X,Y
QUIT
+17 SET IBFN=+Y
SET IBCNT=IBCNT+1
+18 ;
+19 SET DR=".02////"_IBRT_";.03////"_$PIECE(IBLN,U,3)_";.05////"_IBDT_";.04////"_IBBS
+20 IF $LENGTH(IBAJ)
Begin DoDot:2
+21 FOR IBJ=1,2
if $LENGTH($PIECE(IBAJ,U,IBJ))
SET DR=DR_";1.0"_IBJ_"////"_$PIECE(IBAJ,U,IBJ)
+22 IF $LENGTH($PIECE(IBAJ,U,3))
SET DR=DR_";10////^S X=$P(IBAJ,U,3)"
End DoDot:2
+23 ;
+24 SET DIE="^IBE(363,"
SET DA=IBFN
DO ^DIE
KILL DIE,DA,DR,X,Y
+25 ;
+26 ; charge sets (multiple)
+27 SET IBLNCS=$PIECE(IBLN,":",2,999)
FOR IBJ=1:1
SET IBCS=$PIECE(IBLNCS,":",IBJ)
if IBCS=""
QUIT
Begin DoDot:2
+28 SET IBCSFN=$ORDER(^IBE(363.1,"B",IBCS,0))
if 'IBCSFN
QUIT
+29 ;
+30 SET DLAYGO=363
SET DA(1)=+IBFN
SET DIC="^IBE(363,"_DA(1)_",11,"
SET DIC(0)="L"
SET X=IBCS
SET DIC("DR")=".02////"_1
SET DIC("P")="363.0011P"
DO ^DIC
KILL DIC,DIE
End DoDot:2
End DoDot:1
+31 ;
+32 ;
RSQ DO MSG(" >> "_IBCNT_" Rate Schedules added (363)...")
+1 QUIT
+2 ;
+3 ;
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(X) ;
+1 DO MES^XPDUTL(X)
+2 QUIT
+3 ;
CSF ; Charge Set (363.1)
+1 ;;RX COST^VA COST^PRESCRIPTION FILL^^250^PRESCRIPTION
+2 ;;PI COST^VA COST^PROSTHETICS ITEM^^274^OUTPATIENT VISIT
+3 ;;1
+4 ;
RSF ; Rate Schedules (363)
+1 ;;TR-RX^TRICARE^3^PRESCRIPTION^^^:RX COST;8^^S X=X+8
+2 ;;TRRI-RX^TRICARE REIMB. INS.^3^PRESCRIPTION^^^:RX COST;8^^S X=X+8
+3 ;;1
+4 ;
RTF ; Rate Types (399.3) that must exist
+1 ;;TRICARE
+2 ;;TRICARE REIMB. INS.
+3 ;;1
+4 ;
