- 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 Apr 23, 2025@18:16:57 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 ;
