IBYPPD ;ALB/ARH - IB*2*175 POST INIT: TORT/INTERAGENCY RATES JAN 2004 ; 03/06/02
;;2.0;INTEGRATED BILLING;**175**;21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
Q
POST ;
N IBA,IBEFFDT
S IBA(1)="",IBA(2)=" IB*2*175 Post-Install .....",IBA(3)="" D MES^XPDUTL(.IBA) K IBA
;
S IBEFFDT=3040107 ; effective date of Tort Jan 2004
;
D ADDBS ; add Bedsection for PRRTP
D ADDCI^IBYPPD2(IBEFFDT) ; add new Tort Liable and Interagency charges
;
;
D ADDRSI^IBYPPD1(IBEFFDT) ; inactivate existing Tort Feasor Rate Schedules
D ADDRS^IBYPPD1(IBEFFDT) ; add new Rate Schedules linking Tort Feasor and Reasonable Charges
;
S IBA(1)="",IBA(2)=" IB*2*175 Post-Install Complete",IBA(3)="" D MES^XPDUTL(.IBA) K IBA
Q
;
;
ADDBS ; Add Bedsection (399.1, .12=1)
N IBA,IBCNT,IBI,IBLN,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) D MSG("No Change, Bedsection PRRTP already exists") Q
. ;
. 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 S DIE="^DGCR(399.1,",DA=+IBFN D ^DIE K DIE,DA,DR,X,Y
;
BSQ S IBA(1)=" >> "_IBCNT_" Bedsection PRRTP added (399.1)" D MES^XPDUTL(.IBA) K IBA
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
;
;
MSG(X) ;
N IBX S IBX=$O(IBA(999999),-1) S:'IBX IBX=1 S IBX=IBX+1
S IBA(IBX)=" "_$G(X)
Q
;
;
;
;
BSF ; Bedsections (399.1,.12): name ^ abbreviation
;;
;;PRRTP^PRRTP
;;
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBYPPD 1899 printed Dec 13, 2024@02:36:25 Page 2
IBYPPD ;ALB/ARH - IB*2*175 POST INIT: TORT/INTERAGENCY RATES JAN 2004 ; 03/06/02
+1 ;;2.0;INTEGRATED BILLING;**175**;21-MAR-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
+4 QUIT
POST ;
+1 NEW IBA,IBEFFDT
+2 SET IBA(1)=""
SET IBA(2)=" IB*2*175 Post-Install ....."
SET IBA(3)=""
DO MES^XPDUTL(.IBA)
KILL IBA
+3 ;
+4 ; effective date of Tort Jan 2004
SET IBEFFDT=3040107
+5 ;
+6 ; add Bedsection for PRRTP
DO ADDBS
+7 ; add new Tort Liable and Interagency charges
DO ADDCI^IBYPPD2(IBEFFDT)
+8 ;
+9 ;
+10 ; inactivate existing Tort Feasor Rate Schedules
DO ADDRSI^IBYPPD1(IBEFFDT)
+11 ; add new Rate Schedules linking Tort Feasor and Reasonable Charges
DO ADDRS^IBYPPD1(IBEFFDT)
+12 ;
+13 SET IBA(1)=""
SET IBA(2)=" IB*2*175 Post-Install Complete"
SET IBA(3)=""
DO MES^XPDUTL(.IBA)
KILL IBA
+14 QUIT
+15 ;
+16 ;
ADDBS ; Add Bedsection (399.1, .12=1)
+1 NEW IBA,IBCNT,IBI,IBLN,IBFN,DD,DO,DLAYGO,DIC,DIE,DA,DR,X,Y
SET IBCNT=0
+2 ;
+3 FOR IBI=1:1
SET IBLN=$PIECE($TEXT(BSF+IBI),";;",2)
if +IBLN!(IBLN="")
QUIT
IF $EXTRACT(IBLN)?1A
Begin DoDot:1
+4 ;
+5 IF +$$MCCRUTL($PIECE(IBLN,U,1),5)
DO MSG("No Change, Bedsection PRRTP already exists")
QUIT
+6 ;
+7 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
+8 SET IBFN=+Y
SET IBCNT=IBCNT+1
+9 ;
+10 SET DR=".03////"_$PIECE(IBLN,U,2)_";.12////"_1
SET DIE="^DGCR(399.1,"
SET DA=+IBFN
DO ^DIE
KILL DIE,DA,DR,X,Y
End DoDot:1
+11 ;
BSQ SET IBA(1)=" >> "_IBCNT_" Bedsection PRRTP added (399.1)"
DO MES^XPDUTL(.IBA)
KILL IBA
+1 QUIT
+2 ;
+3 ;
+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 ;
+5 ;
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 ;
+6 ;
+7 ;
BSF ; Bedsections (399.1,.12): name ^ abbreviation
+1 ;;
+2 ;;PRRTP^PRRTP
+3 ;;
+4 QUIT
