- 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 Jan 18, 2025@03:04 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