Routine: IBYPPD

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.

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

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

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)

BSF ;  Bedsections (399.1,.12):  name ^ abbreviation

;;

 ;;PRRTP^PRRTP

;;

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBYPPD   1899     printed  Mar 13, 2025@21:41:38                                                                                                                                                                                                      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

IBYPPD.m