IBYPPM ;ALB/CXW,TJH - IB*2*333 POST INIT: ADD TORT/INTERAGENCY RATES NOV 2005 ; 11/23/05
;;2.0;INTEGRATED BILLING;**333**;21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
;
; Add OCT 2005 Tort and Interagency Charges to the Charge Master, 61 Charge Items
Q
POST ;
N IBA,IBEFFDT
S IBA(1)="",IBA(2)=" IB*2*333 Post-Install .....",IBA(3)="" D MES^XPDUTL(.IBA) K IBA
S IBEFFDT=3051103 ; effective date of Tort Nov 03, 2005
D ADDCI(IBEFFDT) ; add new Tort Liable and Interagency charges or and Reasonable Charges
;
S IBA(1)="",IBA(2)=" IB*2*333 Post-Install Complete",IBA(3)="" D MES^XPDUTL(.IBA) K IBA
Q
;
ADDCI(EFFDAT) ; 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(EFFDAT) 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 S IBA(1)=" >> "_IBCNT_" Tort/Interagency Charge Items added (363.2)" D MES^XPDUTL(.IBA) K IBA
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
;
;
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) ;
N IBX S IBX=$O(IBA(999999),-1) S:'IBX IBX=1 S IBX=IBX+1
S IBA(IBX)=" "_$G(X)
Q
;
;
CIF ; Charge Items (363.2): Bedsection ^ Charge Set ^Effective Date ^ Revenue Code ^ Charge
;;
TORT ;; 2005 Tortiously Liable All Inclusive
;;
;;ALCOHOL AND DRUG TREATMENT^TL-INPT (INCLUSIVE)^^^1952
;;BLIND REHABILITATION^TL-INPT (INCLUSIVE)^^^1178
;;GENERAL MEDICAL CARE^TL-INPT (INCLUSIVE)^^^2037
;;INTERMEDIATE CARE^TL-INPT (INCLUSIVE)^^^1324
;;NEUROLOGY^TL-INPT (INCLUSIVE)^^^2633
;;NURSING HOME CARE^TL-INPT (INCLUSIVE)^^^504
;;PRRTP^TL-INPT (INCLUSIVE)^^^293
;;PSYCHIATRIC CARE^TL-INPT (INCLUSIVE)^^^1211
;;REHABILITATION MEDICINE^TL-INPT (INCLUSIVE)^^^1670
;;SPINAL CORD INJURY CARE^TL-INPT (INCLUSIVE)^^^1383
;;SURGICAL CARE^TL-INPT (INCLUSIVE)^^^4117
;;
;; Tortiously Liable Non-Professional
;;ALCOHOL AND DRUG TREATMENT^TL-INPT (NPF)^^101^1314
;;ALCOHOL AND DRUG TREATMENT^TL-INPT (NPF)^^240^452
;;BLIND REHABILITATION^TL-INPT (NPF)^^101^498
;;BLIND REHABILITATION^TL-INPT (NPF)^^240^585
;;GENERAL MEDICAL CARE^TL-INPT (NPF)^^101^1262
;;GENERAL MEDICAL CARE^TL-INPT (NPF)^^240^531
;;INTERMEDIATE CARE^TL-INPT (NPF)^^101^1065
;;INTERMEDIATE CARE^TL-INPT (NPF)^^240^194
;;NEUROLOGY^TL-INPT (NPF)^^101^1553
;;NEUROLOGY^TL-INPT (NPF)^^240^695
;;NURSING HOME CARE^TL-INPT (NPF)^^101^420
;;NURSING HOME CARE^TL-INPT (NPF)^^240^68
;;PRRTP^TL-INPT (NPF)^^101^244
;;PRRTP^TL-INPT (NPF)^^240^31
;;PSYCHIATRIC CARE^TL-INPT (NPF)^^101^906
;;PSYCHIATRIC CARE^TL-INPT (NPF)^^240^191
;;REHABILITATION MEDICINE^TL-INPT (NPF)^^101^970
;;REHABILITATION MEDICINE^TL-INPT (NPF)^^240^510
;;SPINAL CORD INJURY CARE^TL-INPT (NPF)^^101^864
;;SPINAL CORD INJURY CARE^TL-INPT (NPF)^^240^348
;;SURGICAL CARE^TL-INPT (NPF)^^101^2414
;;SURGICAL CARE^TL-INPT (NPF)^^240^1249
;;
;; Tortiously Liable Professional
;;ALCOHOL AND DRUG TREATMENT^TL-INPT (PF)^^^186
;;BLIND REHABILITATION^TL-INPT (PF)^^^95
;;GENERAL MEDICAL CARE^TL-INPT (PF)^^^244
;;INTERMEDIATE CARE^TL-INPT (PF)^^^65
;;NEUROLOGY^TL-INPT (PF)^^^385
;;NURSING HOME CARE^TL-INPT (PF)^^^16
;;PRRTP^TL-INPT (PF)^^^18
;;PSYCHIATRIC CARE^TL-INPT (PF)^^^114
;;REHABILITATION MEDICINE^TL-INPT (PF)^^^190
;;SPINAL CORD INJURY CARE^TL-INPT (PF)^^^171
;;SURGICAL CARE^TL-INPT (PF)^^^454
;;
;; Tortiously Liable Other
;;OUTPATIENT VISIT^TL-OPT VST^^^298
;;PRESCRIPTION^TL-RX FILL^^^51
;;OUTPATIENT DENTAL^TL-OPT DENTAL^^^202
;;
;;
IA ;; 2005 Interagency
;;
;;ALCOHOL AND DRUG TREATMENT^IA-INPT^^^1832
;;BLIND REHABILITATION^IA-INPT^^^1112
;;GENERAL MEDICAL CARE^IA-INPT^^^1914
;;INTERMEDIATE CARE^IA-INPT^^^1241
;;NEUROLOGY^IA-INPT^^^2465
;;NURSING HOME CARE^IA-INPT^^^470
;;PRRTP^IA-INPT^^^273
;;PSYCHIATRIC CARE^IA-INPT^^^1132
;;REHABILITATION MEDICINE^IA-INPT^^^1564
;;SPINAL CORD INJURY CARE^IA-INPT^^^1292
;;SURGICAL CARE^IA-INPT^^^3894
;;
;;OUTPATIENT VISIT^IA-OPT VST^^^284
;;PRESCRIPTION^IA-RX FILL^^^51
;;OUTPATIENT DENTAL^IA-OPT DENTAL^^^188
;;
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBYPPM 5810 printed Dec 13, 2024@02:36:30 Page 2
IBYPPM ;ALB/CXW,TJH - IB*2*333 POST INIT: ADD TORT/INTERAGENCY RATES NOV 2005 ; 11/23/05
+1 ;;2.0;INTEGRATED BILLING;**333**;21-MAR-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
+4 ;
+5 ; Add OCT 2005 Tort and Interagency Charges to the Charge Master, 61 Charge Items
+6 QUIT
POST ;
+1 NEW IBA,IBEFFDT
+2 SET IBA(1)=""
SET IBA(2)=" IB*2*333 Post-Install ....."
SET IBA(3)=""
DO MES^XPDUTL(.IBA)
KILL IBA
+3 ; effective date of Tort Nov 03, 2005
SET IBEFFDT=3051103
+4 ; add new Tort Liable and Interagency charges or and Reasonable Charges
DO ADDCI(IBEFFDT)
+5 ;
+6 SET IBA(1)=""
SET IBA(2)=" IB*2*333 Post-Install Complete"
SET IBA(3)=""
DO MES^XPDUTL(.IBA)
KILL IBA
+7 QUIT
+8 ;
ADDCI(EFFDAT) ; 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(EFFDAT)
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 SET IBA(1)=" >> "_IBCNT_" Tort/Interagency Charge Items added (363.2)"
DO MES^XPDUTL(.IBA)
KILL IBA
+1 QUIT
+2 ;
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 ;
+20 ;
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 NEW IBX
SET IBX=$ORDER(IBA(999999),-1)
if 'IBX
SET IBX=1
SET IBX=IBX+1
+2 SET IBA(IBX)=" "_$GET(X)
+3 QUIT
+4 ;
+5 ;
CIF ; Charge Items (363.2): Bedsection ^ Charge Set ^Effective Date ^ Revenue Code ^ Charge
+1 ;;
TORT ;; 2005 Tortiously Liable All Inclusive
+1 ;;
+2 ;;ALCOHOL AND DRUG TREATMENT^TL-INPT (INCLUSIVE)^^^1952
+3 ;;BLIND REHABILITATION^TL-INPT (INCLUSIVE)^^^1178
+4 ;;GENERAL MEDICAL CARE^TL-INPT (INCLUSIVE)^^^2037
+5 ;;INTERMEDIATE CARE^TL-INPT (INCLUSIVE)^^^1324
+6 ;;NEUROLOGY^TL-INPT (INCLUSIVE)^^^2633
+7 ;;NURSING HOME CARE^TL-INPT (INCLUSIVE)^^^504
+8 ;;PRRTP^TL-INPT (INCLUSIVE)^^^293
+9 ;;PSYCHIATRIC CARE^TL-INPT (INCLUSIVE)^^^1211
+10 ;;REHABILITATION MEDICINE^TL-INPT (INCLUSIVE)^^^1670
+11 ;;SPINAL CORD INJURY CARE^TL-INPT (INCLUSIVE)^^^1383
+12 ;;SURGICAL CARE^TL-INPT (INCLUSIVE)^^^4117
+13 ;;
+14 ;; Tortiously Liable Non-Professional
+15 ;;ALCOHOL AND DRUG TREATMENT^TL-INPT (NPF)^^101^1314
+16 ;;ALCOHOL AND DRUG TREATMENT^TL-INPT (NPF)^^240^452
+17 ;;BLIND REHABILITATION^TL-INPT (NPF)^^101^498
+18 ;;BLIND REHABILITATION^TL-INPT (NPF)^^240^585
+19 ;;GENERAL MEDICAL CARE^TL-INPT (NPF)^^101^1262
+20 ;;GENERAL MEDICAL CARE^TL-INPT (NPF)^^240^531
+21 ;;INTERMEDIATE CARE^TL-INPT (NPF)^^101^1065
+22 ;;INTERMEDIATE CARE^TL-INPT (NPF)^^240^194
+23 ;;NEUROLOGY^TL-INPT (NPF)^^101^1553
+24 ;;NEUROLOGY^TL-INPT (NPF)^^240^695
+25 ;;NURSING HOME CARE^TL-INPT (NPF)^^101^420
+26 ;;NURSING HOME CARE^TL-INPT (NPF)^^240^68
+27 ;;PRRTP^TL-INPT (NPF)^^101^244
+28 ;;PRRTP^TL-INPT (NPF)^^240^31
+29 ;;PSYCHIATRIC CARE^TL-INPT (NPF)^^101^906
+30 ;;PSYCHIATRIC CARE^TL-INPT (NPF)^^240^191
+31 ;;REHABILITATION MEDICINE^TL-INPT (NPF)^^101^970
+32 ;;REHABILITATION MEDICINE^TL-INPT (NPF)^^240^510
+33 ;;SPINAL CORD INJURY CARE^TL-INPT (NPF)^^101^864
+34 ;;SPINAL CORD INJURY CARE^TL-INPT (NPF)^^240^348
+35 ;;SURGICAL CARE^TL-INPT (NPF)^^101^2414
+36 ;;SURGICAL CARE^TL-INPT (NPF)^^240^1249
+37 ;;
+38 ;; Tortiously Liable Professional
+39 ;;ALCOHOL AND DRUG TREATMENT^TL-INPT (PF)^^^186
+40 ;;BLIND REHABILITATION^TL-INPT (PF)^^^95
+41 ;;GENERAL MEDICAL CARE^TL-INPT (PF)^^^244
+42 ;;INTERMEDIATE CARE^TL-INPT (PF)^^^65
+43 ;;NEUROLOGY^TL-INPT (PF)^^^385
+44 ;;NURSING HOME CARE^TL-INPT (PF)^^^16
+45 ;;PRRTP^TL-INPT (PF)^^^18
+46 ;;PSYCHIATRIC CARE^TL-INPT (PF)^^^114
+47 ;;REHABILITATION MEDICINE^TL-INPT (PF)^^^190
+48 ;;SPINAL CORD INJURY CARE^TL-INPT (PF)^^^171
+49 ;;SURGICAL CARE^TL-INPT (PF)^^^454
+50 ;;
+51 ;; Tortiously Liable Other
+52 ;;OUTPATIENT VISIT^TL-OPT VST^^^298
+53 ;;PRESCRIPTION^TL-RX FILL^^^51
+54 ;;OUTPATIENT DENTAL^TL-OPT DENTAL^^^202
+55 ;;
+56 ;;
IA ;; 2005 Interagency
+1 ;;
+2 ;;ALCOHOL AND DRUG TREATMENT^IA-INPT^^^1832
+3 ;;BLIND REHABILITATION^IA-INPT^^^1112
+4 ;;GENERAL MEDICAL CARE^IA-INPT^^^1914
+5 ;;INTERMEDIATE CARE^IA-INPT^^^1241
+6 ;;NEUROLOGY^IA-INPT^^^2465
+7 ;;NURSING HOME CARE^IA-INPT^^^470
+8 ;;PRRTP^IA-INPT^^^273
+9 ;;PSYCHIATRIC CARE^IA-INPT^^^1132
+10 ;;REHABILITATION MEDICINE^IA-INPT^^^1564
+11 ;;SPINAL CORD INJURY CARE^IA-INPT^^^1292
+12 ;;SURGICAL CARE^IA-INPT^^^3894
+13 ;;
+14 ;;OUTPATIENT VISIT^IA-OPT VST^^^284
+15 ;;PRESCRIPTION^IA-RX FILL^^^51
+16 ;;OUTPATIENT DENTAL^IA-OPT DENTAL^^^188
+17 ;;
+18 QUIT
