IB20P418 ;ALB/CXW - IB*2*418 POST INIT: ADD TORT/INTERAGENCY RATES JULY 2011;07-11-2011
;;2.0;INTEGRATED BILLING;**418**;21-MAR-94;Build 16
;;Per VHA Directive 2004-038, this routine should not be modified.
;
;
; Add JULY 2011 Tort and Interagency Charges to the Charge Master, 68 Charge Items
Q
POST ;
N IBEFFDT
D MSG(" IB*2*418 Post-Install .....")
S IBEFFDT=3110711 ; effective date of Tort July 11th, 2011
D ADDBS ; add Billable Events (399.1, .21)
D ADDCS ; add Charge Sets (363.1)
D ADDCI(IBEFFDT) ; add Charge Items (363.2) with new Tort Liable and Interagency charges or and Reasonable Charges
D ADDRS ; add Rate Schedules (363)
;
D MSG(" IB*2*418 Post-Install Complete")
D MSG("")
Q
;
ADDBS ; Add new bedsections (399.1, .12)
N IBA,IBCNT,IBI,IBLN,IBRB,IBFN,DD,DO,DLAYGO,DIC,DIE,DA,DR,X,Y
S IBCNT=0
;
F IBI=1:1 S IBLN=$P($T(BSF+IBI),";;",2) Q:+IBLN!(IBLN="") I $E(IBLN)?1A D
. ;
. I +$$MCCRUTL($P(IBLN,U,1),5) Q
. ;
. S IBRB=$P(IBLN,U,3) I IBRB'="" S IBRB=$$MCCRUTL(IBRB,13) D Q:'IBRB
.. I 'IBRB D MSG(" *** Billable Service "_$P(IBLN,U,3)_" not defined, BS "_$P(IBLN,U,1)_" not created")
. ;
. K DD,DO S DLAYGO=399.1,DIC="^DGCR(399.1,",DIC(0)="L",X=$P(IBLN,U,1) D FILE^DICN K DIC I Y<1 K X,Y Q
. S IBFN=+Y,IBCNT=IBCNT+1
. ;
. S DR=".03///"_$P(IBLN,U,2)_";.12///"_1 I +IBRB S DR=DR_";.25///"_IBRB
. S DIE="^DGCR(399.1,",DA=+IBFN D ^DIE K DIE,DA,DR,X,Y
. ;
;
BSQ D MSG(" >> "_IBCNT_" Bedsection added (399.1).")
D MSG("")
Q
;
ADDCS ; Add Charge Sets (363.1)
N IBA,IBCNT,IBI,IBLN,IBFN,IBBR,IBBE,IBRVCD,DD,DO,DLAYGO,DIC,DIE,DA,DR,X,Y S IBCNT=0
;
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 IBRVCD=$$RVCD($P(IBLN,U,5))
. ;
. K DD,DO S DLAYGO=363.1,DIC="^IBE(363.1,",DIC(0)="L",X=$P(IBLN,U,1) D FILE^DICN K DIC I Y<1 K X,Y Q
. S IBFN=+Y,IBCNT=IBCNT+1
. ;
. S DR=".02///"_IBBR_";.03///"_IBBE
. I +$P(IBLN,U,4) S DR=DR_";.04///"_$P(IBLN,U,4)
. I +IBRVCD S DR=DR_";.05///"_IBRVCD
. S DIE="^IBE(363.1,",DA=+IBFN D ^DIE K DIE,DA,DR,X,Y
;
CSQ D MSG(" >> "_IBCNT_" Charge Sets added (363.1).")
D MSG("")
Q
;
;
ADDCI(IBEFFDT) ; Add Charge Items (363.2) needs Charge Sets, pass in the effective date of the new charges
N IBA,IBCNT,IBCNT1,IBI,IBLN,IBFN,IBCS,IBXRF,IBCI,IBRVCD,IBCHG,DD,DO,DLAYGO,DIC,DIE,DA,DR,X,Y,IBX,IBZ,IBDFLTDT,IBDT S (IBCNT,IBCNT1)=0
;
S IBDFLTDT=+$G(IBEFFDT) I 'IBDFLTDT D MSG("** Error: No Date, No Charges Added") G CIQ
;
F IBI=1:1 S IBLN=$P($T(CIF+IBI),";;",2) Q:+IBLN!(IBLN="") I $E(IBLN)?1A D SETCI
;
I +IBCNT1 D MSG(IBCNT1_" Duplicate Charge Items already exist, not re-added")
;
CIQ D MSG(" >> "_IBCNT_" Tort/Interagency Charge Items added (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: CS "_$P(IBLN,U,2)_" undefined") Q
S IBCI=+$$MCCRUTL($P(IBLN,U,1),5) I 'IBCI D MSG("** Error: BS "_$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 I +$P(IBZ,U,5)'=IBCHG D MSG("** Error: Item exists, wrong charge: "_IBLN)
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 I Y<1 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 Rate Schedules (363)
; add new charge sets to the link if TL/IA-OPT VST exists
N IBCSFN,IBI,IBJ,IBK,IBCNT,IBLN,IBOTH,IBTLIA,IBRSC,IBRSN,DLAYGO,DIC,DIE,DA,DR,X,Y
S IBI="",IBCNT=0
F S IBI=$O(^IBE(363,"B",IBI)) Q:IBI="" I IBI["OPT" D
. ; the latest entry
. S IBRSN=$O(^IBE(363,"B",IBI,99999),-1)
. ; no CS added if inactive
. I $P($G(^IBE(363,+IBRSN,0)),U,6)'="" Q
. S IBTLIA=""
. ;
A . S IBRSC=0 F S IBRSC=$O(^IBE(363,IBRSN,11,IBRSC)) Q:'IBRSC!(IBTLIA'="") D
.. S IBLN=+$G(^IBE(363,IBRSN,11,IBRSC,0))
.. S IBOTH=$P(^IBE(363.1,IBLN,0),U)
.. S:IBOTH="TL-OPT VST" IBTLIA="TL-OPT VST PM&RS;TL-OPT VST POLYTRAUMA"
.. S:IBOTH="IA-OPT VST" IBTLIA="IA-OPT VST PM&RS;IA-OPT VST POLYTRAUMA"
.. Q:IBTLIA=""
.. ; charge sets (multiple)
.. F IBJ=1:1 S IBK=$P(IBTLIA,";",IBJ) Q:IBK="" D
... S IBCSFN=$O(^IBE(363.1,"B",IBK,0)) Q:'IBCSFN
... I $O(^IBE(363,IBRSN,11,"B",IBCSFN,0)) Q
... K DD,DO S DLAYGO=363,DA(1)=IBRSN,DIC="^IBE(363,"_DA(1)_",11,",DIC(0)="L",X=IBCSFN D FILE^DICN K X,DD,DO,DLAYGO,DIC
... ; S DIC("DR")=".02///"_1 ;no auto added
... S:IBJ=1 IBCNT=IBCNT+1
;
RSQ ;
D MSG(" >> "_IBCNT_" Tort/Interagency Rate Schedules linked (#363) to Reasonable Charges updated.")
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(X) ;
D MES^XPDUTL(X)
Q
;
;
BSF ; Bedsections (399.1, .12): Name ^ Abbreviation
;;POLYTRAUMA INPATIENT^POYLTRAUMA INPT
;;PM&RS OUTPATIENT VISIT^PM&RS OPT VISIT
;;POLYTRAUMA OUTPATIENT VISIT^OPT POLYTRI/TBI
;
;
CSF ; Charge Sets (363.1): Name ^ Billing Rate ^ Billable Event ^^ Default Revenue Code
;;TL-OPT VST PM&RS^TORTIOUSLY LIABLE^OUTPATIENT VISIT DATE^^500
;;TL-OPT VST POLYTRAUMA^TORTIOUSLY LIABLE^OUTPATIENT VISIT DATE^^500
;;IA-OPT VST PM&RS^INTERAGENCY^OUTPATIENT VISIT DATE^^500
;;IA-OPT VST POLYTRAUMA^INTERAGENCY^OUTPATIENT VISIT DATE^^500
;
;
CIF ; Charge Items (363.2): Bedsection ^ Charge Set ^Effective Date ^ Revenue Code ^ Charge
;;
TORT ;; 2011 Tortiously Liable All Inclusive
;;
;;ALCOHOL AND DRUG TREATMENT^TL-INPT (INCLUSIVE)^^^1154
;;BLIND REHABILITATION^TL-INPT (INCLUSIVE)^^^1240
;;GENERAL MEDICAL CARE^TL-INPT (INCLUSIVE)^^^2384
;;INTERMEDIATE CARE^TL-INPT (INCLUSIVE)^^^1920
;;NEUROLOGY^TL-INPT (INCLUSIVE)^^^3899
;;NURSING HOME CARE^TL-INPT (INCLUSIVE)^^^993
;;POLYTRAUMA INPATIENT^TL-INPT (INCLUSIVE)^^^3391
;;PRRTP^TL-INPT (INCLUSIVE)^^^577
;;PSYCHIATRIC CARE^TL-INPT (INCLUSIVE)^^^801
;;REHABILITATION MEDICINE^TL-INPT (INCLUSIVE)^^^2122
;;SPINAL CORD INJURY CARE^TL-INPT (INCLUSIVE)^^^1756
;;SURGICAL CARE^TL-INPT (INCLUSIVE)^^^4533
;;
;; Tortiously Liable Non-Professional
;;ALCOHOL AND DRUG TREATMENT^TL-INPT (NPF)^^101^777
;;ALCOHOL AND DRUG TREATMENT^TL-INPT (NPF)^^240^267
;;BLIND REHABILITATION^TL-INPT (NPF)^^101^524
;;BLIND REHABILITATION^TL-INPT (NPF)^^240^616
;;GENERAL MEDICAL CARE^TL-INPT (NPF)^^101^1478
;;GENERAL MEDICAL CARE^TL-INPT (NPF)^^240^621
;;INTERMEDIATE CARE^TL-INPT (NPF)^^101^1544
;;INTERMEDIATE CARE^TL-INPT (NPF)^^240^282
;;NEUROLOGY^TL-INPT (NPF)^^101^2299
;;NEUROLOGY^TL-INPT (NPF)^^240^1029
;;NURSING HOME CARE^TL-INPT (NPF)^^101^828
;;NURSING HOME CARE^TL-INPT (NPF)^^240^134
;;POLYTRAUMA INPATIENT^TL-INPT (NPF)^^101^1970
;;POLYTRAUMA INPATIENT^TL-INPT (NPF)^^240^1036
;;PRRTP^TL-INPT (NPF)^^101^480
;;PRRTP^TL-INPT (NPF)^^240^61
;;PSYCHIATRIC CARE^TL-INPT (NPF)^^101^599
;;PSYCHIATRIC CARE^TL-INPT (NPF)^^240^126
;;REHABILITATION MEDICINE^TL-INPT (NPF)^^101^1233
;;REHABILITATION MEDICINE^TL-INPT (NPF)^^240^648
;;SPINAL CORD INJURY CARE^TL-INPT (NPF)^^101^1096
;;SPINAL CORD INJURY CARE^TL-INPT (NPF)^^240^442
;;SURGICAL CARE^TL-INPT (NPF)^^101^2658
;;SURGICAL CARE^TL-INPT (NPF)^^240^1375
;;
;; Tortiously Liable Professional
;;ALCOHOL AND DRUG TREATMENT^TL-INPT (PF)^^^110
;;BLIND REHABILITATION^TL-INPT (PF)^^^100
;;GENERAL MEDICAL CARE^TL-INPT (PF)^^^285
;;INTERMEDIATE CARE^TL-INPT (PF)^^^94
;;NEUROLOGY^TL-INPT (PF)^^^571
;;NURSING HOME CARE^TL-INPT (PF)^^^31
;;POLYTRAUMA INPATIENT^TL-INPT (PF)^^^385
;;PRRTP^TL-INPT (PF)^^^36
;;PSYCHIATRIC CARE^TL-INPT (PF)^^^76
;;REHABILITATION MEDICINE^TL-INPT (PF)^^^241
;;SPINAL CORD INJURY CARE^TL-INPT (PF)^^^218
;;SURGICAL CARE^TL-INPT (PF)^^^500
;;
;; Tortiously Liable Other
;;OUTPATIENT VISIT^TL-OPT VST^^^231
;;OUTPATIENT DENTAL^TL-OPT DENTAL^^^487
;;PM&RS OUTPATIENT VISIT^TL-OPT VST PM&RS^^^430
;;POLYTRAUMA OUTPATIENT VISIT^TL-OPT VST POLYTRAUMA^^^573
;;
;;
IA ;; 2011 Interagency
;;
;;ALCOHOL AND DRUG TREATMENT^IA-INPT^^^1081
;;BLIND REHABILITATION^IA-INPT^^^1161
;;GENERAL MEDICAL CARE^IA-INPT^^^2232
;;INTERMEDIATE CARE^IA-INPT^^^1796
;;NEUROLOGY^IA-INPT^^^3648
;;NURSING HOME CARE^IA-INPT^^^929
;;POLYTRAUMA INPATIENT^IA-INPT^^^3197
;;PRRTP^IA-INPT^^^540
;;PSYCHIATRIC CARE^IA-INPT^^^749
;;REHABILITATION MEDICINE^IA-INPT^^^1992
;;SPINAL CORD INJURY CARE^IA-INPT^^^1644
;;SURGICAL CARE^IA-INPT^^^4248
;;
;;OUTPATIENT VISIT^IA-OPT VST^^^214
;;OUTPATIENT DENTAL^IA-OPT DENTAL^^^416
;;PM&RS OUTPATIENT VISIT^IA-OPT VST PM&RS^^^401
;;POLYTRAUMA OUTPATIENT VISIT^IA-OPT VST POLYTRAUMA^^^535
;;
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIB20P418 9606 printed Dec 13, 2024@02:02:47 Page 2
IB20P418 ;ALB/CXW - IB*2*418 POST INIT: ADD TORT/INTERAGENCY RATES JULY 2011;07-11-2011
+1 ;;2.0;INTEGRATED BILLING;**418**;21-MAR-94;Build 16
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 ;
+5 ; Add JULY 2011 Tort and Interagency Charges to the Charge Master, 68 Charge Items
+6 QUIT
POST ;
+1 NEW IBEFFDT
+2 DO MSG(" IB*2*418 Post-Install .....")
+3 ; effective date of Tort July 11th, 2011
SET IBEFFDT=3110711
+4 ; add Billable Events (399.1, .21)
DO ADDBS
+5 ; add Charge Sets (363.1)
DO ADDCS
+6 ; add Charge Items (363.2) with new Tort Liable and Interagency charges or and Reasonable Charges
DO ADDCI(IBEFFDT)
+7 ; add Rate Schedules (363)
DO ADDRS
+8 ;
+9 DO MSG(" IB*2*418 Post-Install Complete")
+10 DO MSG("")
+11 QUIT
+12 ;
ADDBS ; Add new bedsections (399.1, .12)
+1 NEW IBA,IBCNT,IBI,IBLN,IBRB,IBFN,DD,DO,DLAYGO,DIC,DIE,DA,DR,X,Y
+2 SET IBCNT=0
+3 ;
+4 FOR IBI=1:1
SET IBLN=$PIECE($TEXT(BSF+IBI),";;",2)
if +IBLN!(IBLN="")
QUIT
IF $EXTRACT(IBLN)?1A
Begin DoDot:1
+5 ;
+6 IF +$$MCCRUTL($PIECE(IBLN,U,1),5)
QUIT
+7 ;
+8 SET IBRB=$PIECE(IBLN,U,3)
IF IBRB'=""
SET IBRB=$$MCCRUTL(IBRB,13)
Begin DoDot:2
+9 IF 'IBRB
DO MSG(" *** Billable Service "_$PIECE(IBLN,U,3)_" not defined, BS "_$PIECE(IBLN,U,1)_" not created")
End DoDot:2
if 'IBRB
QUIT
+10 ;
+11 KILL DD,DO
SET DLAYGO=399.1
SET DIC="^DGCR(399.1,"
SET DIC(0)="L"
SET X=$PIECE(IBLN,U,1)
DO FILE^DICN
KILL DIC
IF Y<1
KILL X,Y
QUIT
+12 SET IBFN=+Y
SET IBCNT=IBCNT+1
+13 ;
+14 SET DR=".03///"_$PIECE(IBLN,U,2)_";.12///"_1
IF +IBRB
SET DR=DR_";.25///"_IBRB
+15 SET DIE="^DGCR(399.1,"
SET DA=+IBFN
DO ^DIE
KILL DIE,DA,DR,X,Y
+16 ;
End DoDot:1
+17 ;
BSQ DO MSG(" >> "_IBCNT_" Bedsection added (399.1).")
+1 DO MSG("")
+2 QUIT
+3 ;
ADDCS ; Add Charge Sets (363.1)
+1 NEW IBA,IBCNT,IBI,IBLN,IBFN,IBBR,IBBE,IBRVCD,DD,DO,DLAYGO,DIC,DIE,DA,DR,X,Y
SET IBCNT=0
+2 ;
+3 FOR IBI=1:1
SET IBLN=$PIECE($TEXT(CSF+IBI),";;",2)
if +IBLN!(IBLN="")
QUIT
IF $EXTRACT(IBLN)?1A
Begin DoDot:1
+4 ;
+5 IF $ORDER(^IBE(363.1,"B",$PIECE(IBLN,U,1),0))
QUIT
+6 SET IBBR=$PIECE(IBLN,U,2)
SET IBBR=$ORDER(^IBE(363.3,"B",IBBR,0))
IF 'IBBR
QUIT
+7 SET IBBE=$$MCCRUTL($PIECE(IBLN,U,3),14)
if 'IBBE
QUIT
+8 SET IBRVCD=$$RVCD($PIECE(IBLN,U,5))
+9 ;
+10 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
IF Y<1
KILL X,Y
QUIT
+11 SET IBFN=+Y
SET IBCNT=IBCNT+1
+12 ;
+13 SET DR=".02///"_IBBR_";.03///"_IBBE
+14 IF +$PIECE(IBLN,U,4)
SET DR=DR_";.04///"_$PIECE(IBLN,U,4)
+15 IF +IBRVCD
SET DR=DR_";.05///"_IBRVCD
+16 SET DIE="^IBE(363.1,"
SET DA=+IBFN
DO ^DIE
KILL DIE,DA,DR,X,Y
End DoDot:1
+17 ;
CSQ DO MSG(" >> "_IBCNT_" Charge Sets added (363.1).")
+1 DO MSG("")
+2 QUIT
+3 ;
+4 ;
ADDCI(IBEFFDT) ; Add Charge Items (363.2) needs Charge Sets, pass in the effective date of the new charges
+1 NEW IBA,IBCNT,IBCNT1,IBI,IBLN,IBFN,IBCS,IBXRF,IBCI,IBRVCD,IBCHG,DD,DO,DLAYGO,DIC,DIE,DA,DR,X,Y,IBX,IBZ,IBDFLTDT,IBDT
SET (IBCNT,IBCNT1)=0
+2 ;
+3 SET IBDFLTDT=+$GET(IBEFFDT)
IF 'IBDFLTDT
DO MSG("** Error: No Date, No Charges Added")
GOTO CIQ
+4 ;
+5 FOR IBI=1:1
SET IBLN=$PIECE($TEXT(CIF+IBI),";;",2)
if +IBLN!(IBLN="")
QUIT
IF $EXTRACT(IBLN)?1A
DO SETCI
+6 ;
+7 IF +IBCNT1
DO MSG(IBCNT1_" Duplicate Charge Items already exist, not re-added")
+8 ;
CIQ DO MSG(" >> "_IBCNT_" Tort/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 IBCS=$PIECE(IBLN,U,2)
SET IBCS=+$ORDER(^IBE(363.1,"B",IBCS,0))
IF 'IBCS
DO MSG("** Error: CS "_$PIECE(IBLN,U,2)_" undefined")
QUIT
+3 SET IBCI=+$$MCCRUTL($PIECE(IBLN,U,1),5)
IF 'IBCI
DO MSG("** Error: BS "_$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
IF +$PIECE(IBZ,U,5)'=IBCHG
DO MSG("** Error: Item exists, wrong charge: "_IBLN)
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
IF Y<1
KILL X,Y
QUIT
+14 SET IBFN=+Y
SET IBCNT=IBCNT+1
+15 ;
+16 SET DR=".02///"_IBCS_";.03///"_IBDT_";.05///"_IBCHG
IF +IBRVCD
SET DR=DR_";.06///"_IBRVCD
+17 SET DIE="^IBA(363.2,"
SET DA=+IBFN
DO ^DIE
KILL DIE,DA,DR,X,Y
+18 QUIT
+19 ;
ADDRS ; add Rate Schedules (363)
+1 ; add new charge sets to the link if TL/IA-OPT VST exists
+2 NEW IBCSFN,IBI,IBJ,IBK,IBCNT,IBLN,IBOTH,IBTLIA,IBRSC,IBRSN,DLAYGO,DIC,DIE,DA,DR,X,Y
+3 SET IBI=""
SET IBCNT=0
+4 FOR
SET IBI=$ORDER(^IBE(363,"B",IBI))
if IBI=""
QUIT
IF IBI["OPT"
Begin DoDot:1
+5 ; the latest entry
+6 SET IBRSN=$ORDER(^IBE(363,"B",IBI,99999),-1)
+7 ; no CS added if inactive
+8 IF $PIECE($GET(^IBE(363,+IBRSN,0)),U,6)'=""
QUIT
+9 SET IBTLIA=""
+10 ;
A SET IBRSC=0
FOR
SET IBRSC=$ORDER(^IBE(363,IBRSN,11,IBRSC))
if 'IBRSC!(IBTLIA'="")
QUIT
Begin DoDot:2
+1 SET IBLN=+$GET(^IBE(363,IBRSN,11,IBRSC,0))
+2 SET IBOTH=$PIECE(^IBE(363.1,IBLN,0),U)
+3 if IBOTH="TL-OPT VST"
SET IBTLIA="TL-OPT VST PM&RS;TL-OPT VST POLYTRAUMA"
+4 if IBOTH="IA-OPT VST"
SET IBTLIA="IA-OPT VST PM&RS;IA-OPT VST POLYTRAUMA"
+5 if IBTLIA=""
QUIT
+6 ; charge sets (multiple)
+7 FOR IBJ=1:1
SET IBK=$PIECE(IBTLIA,";",IBJ)
if IBK=""
QUIT
Begin DoDot:3
+8 SET IBCSFN=$ORDER(^IBE(363.1,"B",IBK,0))
if 'IBCSFN
QUIT
+9 IF $ORDER(^IBE(363,IBRSN,11,"B",IBCSFN,0))
QUIT
+10 KILL DD,DO
SET DLAYGO=363
SET DA(1)=IBRSN
SET DIC="^IBE(363,"_DA(1)_",11,"
SET DIC(0)="L"
SET X=IBCSFN
DO FILE^DICN
KILL X,DD,DO,DLAYGO,DIC
+11 ; S DIC("DR")=".02///"_1 ;no auto added
+12 if IBJ=1
SET IBCNT=IBCNT+1
End DoDot:3
End DoDot:2
End DoDot:1
+13 ;
RSQ ;
+1 DO MSG(" >> "_IBCNT_" Tort/Interagency Rate Schedules linked (#363) to Reasonable Charges updated.")
+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(X) ;
+1 DO MES^XPDUTL(X)
+2 QUIT
+3 ;
+4 ;
BSF ; Bedsections (399.1, .12): Name ^ Abbreviation
+1 ;;POLYTRAUMA INPATIENT^POYLTRAUMA INPT
+2 ;;PM&RS OUTPATIENT VISIT^PM&RS OPT VISIT
+3 ;;POLYTRAUMA OUTPATIENT VISIT^OPT POLYTRI/TBI
+4 ;
+5 ;
CSF ; Charge Sets (363.1): Name ^ Billing Rate ^ Billable Event ^^ Default Revenue Code
+1 ;;TL-OPT VST PM&RS^TORTIOUSLY LIABLE^OUTPATIENT VISIT DATE^^500
+2 ;;TL-OPT VST POLYTRAUMA^TORTIOUSLY LIABLE^OUTPATIENT VISIT DATE^^500
+3 ;;IA-OPT VST PM&RS^INTERAGENCY^OUTPATIENT VISIT DATE^^500
+4 ;;IA-OPT VST POLYTRAUMA^INTERAGENCY^OUTPATIENT VISIT DATE^^500
+5 ;
+6 ;
CIF ; Charge Items (363.2): Bedsection ^ Charge Set ^Effective Date ^ Revenue Code ^ Charge
+1 ;;
TORT ;; 2011 Tortiously Liable All Inclusive
+1 ;;
+2 ;;ALCOHOL AND DRUG TREATMENT^TL-INPT (INCLUSIVE)^^^1154
+3 ;;BLIND REHABILITATION^TL-INPT (INCLUSIVE)^^^1240
+4 ;;GENERAL MEDICAL CARE^TL-INPT (INCLUSIVE)^^^2384
+5 ;;INTERMEDIATE CARE^TL-INPT (INCLUSIVE)^^^1920
+6 ;;NEUROLOGY^TL-INPT (INCLUSIVE)^^^3899
+7 ;;NURSING HOME CARE^TL-INPT (INCLUSIVE)^^^993
+8 ;;POLYTRAUMA INPATIENT^TL-INPT (INCLUSIVE)^^^3391
+9 ;;PRRTP^TL-INPT (INCLUSIVE)^^^577
+10 ;;PSYCHIATRIC CARE^TL-INPT (INCLUSIVE)^^^801
+11 ;;REHABILITATION MEDICINE^TL-INPT (INCLUSIVE)^^^2122
+12 ;;SPINAL CORD INJURY CARE^TL-INPT (INCLUSIVE)^^^1756
+13 ;;SURGICAL CARE^TL-INPT (INCLUSIVE)^^^4533
+14 ;;
+15 ;; Tortiously Liable Non-Professional
+16 ;;ALCOHOL AND DRUG TREATMENT^TL-INPT (NPF)^^101^777
+17 ;;ALCOHOL AND DRUG TREATMENT^TL-INPT (NPF)^^240^267
+18 ;;BLIND REHABILITATION^TL-INPT (NPF)^^101^524
+19 ;;BLIND REHABILITATION^TL-INPT (NPF)^^240^616
+20 ;;GENERAL MEDICAL CARE^TL-INPT (NPF)^^101^1478
+21 ;;GENERAL MEDICAL CARE^TL-INPT (NPF)^^240^621
+22 ;;INTERMEDIATE CARE^TL-INPT (NPF)^^101^1544
+23 ;;INTERMEDIATE CARE^TL-INPT (NPF)^^240^282
+24 ;;NEUROLOGY^TL-INPT (NPF)^^101^2299
+25 ;;NEUROLOGY^TL-INPT (NPF)^^240^1029
+26 ;;NURSING HOME CARE^TL-INPT (NPF)^^101^828
+27 ;;NURSING HOME CARE^TL-INPT (NPF)^^240^134
+28 ;;POLYTRAUMA INPATIENT^TL-INPT (NPF)^^101^1970
+29 ;;POLYTRAUMA INPATIENT^TL-INPT (NPF)^^240^1036
+30 ;;PRRTP^TL-INPT (NPF)^^101^480
+31 ;;PRRTP^TL-INPT (NPF)^^240^61
+32 ;;PSYCHIATRIC CARE^TL-INPT (NPF)^^101^599
+33 ;;PSYCHIATRIC CARE^TL-INPT (NPF)^^240^126
+34 ;;REHABILITATION MEDICINE^TL-INPT (NPF)^^101^1233
+35 ;;REHABILITATION MEDICINE^TL-INPT (NPF)^^240^648
+36 ;;SPINAL CORD INJURY CARE^TL-INPT (NPF)^^101^1096
+37 ;;SPINAL CORD INJURY CARE^TL-INPT (NPF)^^240^442
+38 ;;SURGICAL CARE^TL-INPT (NPF)^^101^2658
+39 ;;SURGICAL CARE^TL-INPT (NPF)^^240^1375
+40 ;;
+41 ;; Tortiously Liable Professional
+42 ;;ALCOHOL AND DRUG TREATMENT^TL-INPT (PF)^^^110
+43 ;;BLIND REHABILITATION^TL-INPT (PF)^^^100
+44 ;;GENERAL MEDICAL CARE^TL-INPT (PF)^^^285
+45 ;;INTERMEDIATE CARE^TL-INPT (PF)^^^94
+46 ;;NEUROLOGY^TL-INPT (PF)^^^571
+47 ;;NURSING HOME CARE^TL-INPT (PF)^^^31
+48 ;;POLYTRAUMA INPATIENT^TL-INPT (PF)^^^385
+49 ;;PRRTP^TL-INPT (PF)^^^36
+50 ;;PSYCHIATRIC CARE^TL-INPT (PF)^^^76
+51 ;;REHABILITATION MEDICINE^TL-INPT (PF)^^^241
+52 ;;SPINAL CORD INJURY CARE^TL-INPT (PF)^^^218
+53 ;;SURGICAL CARE^TL-INPT (PF)^^^500
+54 ;;
+55 ;; Tortiously Liable Other
+56 ;;OUTPATIENT VISIT^TL-OPT VST^^^231
+57 ;;OUTPATIENT DENTAL^TL-OPT DENTAL^^^487
+58 ;;PM&RS OUTPATIENT VISIT^TL-OPT VST PM&RS^^^430
+59 ;;POLYTRAUMA OUTPATIENT VISIT^TL-OPT VST POLYTRAUMA^^^573
+60 ;;
+61 ;;
IA ;; 2011 Interagency
+1 ;;
+2 ;;ALCOHOL AND DRUG TREATMENT^IA-INPT^^^1081
+3 ;;BLIND REHABILITATION^IA-INPT^^^1161
+4 ;;GENERAL MEDICAL CARE^IA-INPT^^^2232
+5 ;;INTERMEDIATE CARE^IA-INPT^^^1796
+6 ;;NEUROLOGY^IA-INPT^^^3648
+7 ;;NURSING HOME CARE^IA-INPT^^^929
+8 ;;POLYTRAUMA INPATIENT^IA-INPT^^^3197
+9 ;;PRRTP^IA-INPT^^^540
+10 ;;PSYCHIATRIC CARE^IA-INPT^^^749
+11 ;;REHABILITATION MEDICINE^IA-INPT^^^1992
+12 ;;SPINAL CORD INJURY CARE^IA-INPT^^^1644
+13 ;;SURGICAL CARE^IA-INPT^^^4248
+14 ;;
+15 ;;OUTPATIENT VISIT^IA-OPT VST^^^214
+16 ;;OUTPATIENT DENTAL^IA-OPT DENTAL^^^416
+17 ;;PM&RS OUTPATIENT VISIT^IA-OPT VST PM&RS^^^401
+18 ;;POLYTRAUMA OUTPATIENT VISIT^IA-OPT VST POLYTRAUMA^^^535
+19 ;;
+20 QUIT
