Routine: IB20P339

IB20P339 ;ALB/ARH - IB*2.0*339 POST INIT: IB SHAD/SWA SUPPORT ; 02-JAN-2006

 ;;2.0;INTEGRATED BILLING;**339**;21-MAR-94;Build 2

 ;;Per VHA Directive 2004-038, this routine should not be modified.

POST ;

 N IBA S IBA(1)="",IBA(2)="    IB Support for SHAD/SWA Post-Install .....",IBA(3)="" D MES^XPDUTL(.IBA) K IBA

 D ADDRNB ; Add PROJECT 112/SHAD Reason Not Billable (#356.8)

 D ADDCRR ; Add PROJECT 112/SHAD Charge Removal Reason (#350.3)

 D UPDRNB ; Replace ENV. CONTAM. with SOUTHWEST ASIA Reason Not Billable (#356.8)

 D UPDCRR ; Replace ENV CONTAMINANT RELATED with SOUTHWEST ASIA RELATED Charge Removal Reason (#350.3)

 S IBA(1)="",IBA(2)="    IB Support for SHAD/SWA Post-Install Complete",IBA(3)="" D MES^XPDUTL(.IBA) K IBA

ADDRNB ; Add Reason Not Billable of PROJECT 112/SHAD (#356.8)

 N IBA,IBJ,IBNX,IBRNB,DD,DO,DINUM,DLAYGO,DIC,DIE,DA,DR,X,Y

 S IBRNB="PROJECT 112/SHAD"

 I $O(^IBE(356.8,"B",IBRNB,0)) S IBA(1)="    >>> "_IBRNB_" Reason Not Billable (#356.8) exists, not re-added." G ADDRNBQ

 F IBJ=32:1 S IBNX=$G(^IBE(356.8,IBJ,0)) I IBNX="" S DINUM=IBJ Q  ; find next available ien, before 999

 K DD,DO S DLAYGO=356.8,DIC="^IBE(356.8,",DIC(0)="L",X=IBRNB D FILE^DICN K DIC

 I Y<1 S IBA(1)="    >>> Unable to add "_IBRNB_" Reason Not Billable (#356.8), contact Support." G ADDRNBQ

 S IBA(1)="    >>> "_IBRNB_" Reason Not Billable (#356.8) Added."

ADDRNBQ D MES^XPDUTL(.IBA)

ADDCRR ; Add Charge Removal Reason of PROJECT 112/SHAD (#350.3)

 N IBA,IBJ,IBNX,IBCRR,IBABBR,IBLMT,IBFN,DD,DO,DINUM,DLAYGO,DIC,DIE,DA,DR,X,Y

 S IBCRR="PROJECT 112/SHAD",IBABBR="SHAD",IBLMT="GENERIC"

 I $O(^IBE(350.3,"B",IBCRR,0)) S IBA(1)="    >>> "_IBCRR_" Charge Removal Reason (#350.3) exists, not re-added." G ADDCRRQ

 F IBJ=46:1 S IBNX=$G(^IBE(350.3,IBJ,0)) I IBNX="" S DINUM=IBJ Q  ; find next available ien

 K DD,DO S DLAYGO=350.3,DIC="^IBE(350.3,",DIC(0)="L",X=IBCRR D FILE^DICN S IBFN=+Y

 I Y<1 S IBA(1)="    >>> Unable to add "_IBCRR_" Charge Removal Reason (#350.3), contact Support." G ADDCRRQ

 S DIE="^IBE(350.3,",DA=+IBFN,DR=".02///"_IBABBR_";.03///"_IBLMT D ^DIE

 S IBA(1)="    >>> "_IBCRR_" Charge Removal Reason (#350.3) Added."

ADDCRRQ D MES^XPDUTL(.IBA)

UPDRNB ; Update Reason Not Billable of ENV. CONTAM. with SOUTHWEST ASIA (#356.8)

 N IBA,IBFN,IBRNBO,IBRNBN,DD,DO,DINUM,DLAYGO,DIC,DIE,DA,DR,X,Y

 S IBRNBO="ENV. CONTAM."

 S IBRNBN="SOUTHWEST ASIA"

 I $O(^IBE(356.8,"B",IBRNBN,0)) S IBA(1)="    >>> "_IBRNBN_" Reason Not Billable (#356.8) exists, not re-added." G UPDRNBQ

 S IBFN=$O(^IBE(356.8,"B",IBRNBO,0)) I 'IBFN S IBA(1)="    >>> ERROR: "_IBRNBO_" Reason Not Billable (#356.8) not found, could not be replaced, contact support." G UPDRNBQ

 S DIE="^IBE(356.8,",DA=+IBFN,DR=".01///"_IBRNBN D ^DIE

 S IBA(1)="    >>> "_IBRNBO_" Reason Not Billable (#356.8) Replaced with "_IBRNBN

UPDRNBQ D MES^XPDUTL(.IBA)

UPDCRR ; Update Charge Removal Reason of ENV CONTAMINANT RELATED with SOUTHWEST ASIA RELATED (#350.3)

 N IBA,IBFN,IBCRRO,IBCRRN,DD,DO,DINUM,DLAYGO,DIC,DIE,DA,DR,X,Y

 S IBCRRO="ENV CONTAMINANT RELATED"

 S IBCRRN="SOUTHWEST ASIA RELATED"

 I $O(^IBE(350.3,"B",IBCRRN,0)) S IBA(1)="    >>> "_IBCRRN_" Charge Removal Reason (#350.3) exists, not re-added." G UPDCRRQ

 S IBFN=$O(^IBE(350.3,"B",IBCRRO,0)) I 'IBFN S IBA(1)="    >>> ERROR: "_IBCRRO_" Charge Removal Reason (#350.3) not found, could not be replaced, contact support." G UPDCRRQ

 S DIE="^IBE(350.3,",DA=+IBFN,DR=".01///"_IBCRRN_";.02///SWA" D ^DIE

 S IBA(1)="    >>> "_IBCRRO_" Charge Removal Reason (#350.3) Replaced with "_IBCRRN

UPDCRRQ D MES^XPDUTL(.IBA)

MSG(X) ;

 N IBX S IBX=$O(IBA(999999),-1) S:'IBX IBX=1 S IBX=IBX+1

 S IBA(IBX)=$G(X)

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIB20P339   3846     printed  Feb 18, 2025@23:28:37                                                                                                                                                                                                    Page 2

IB20P339  ;ALB/ARH - IB*2.0*339 POST INIT: IB SHAD/SWA SUPPORT ; 02-JAN-2006

 +1       ;;2.0;INTEGRATED BILLING;**339**;21-MAR-94;Build 2

 +2       ;;Per VHA Directive 2004-038, this routine should not be modified.

 +3       ;

 +4        QUIT

POST      ;

 +1        NEW IBA

           SET IBA(1)=""

           SET IBA(2)="    IB Support for SHAD/SWA Post-Install ....."

           SET IBA(3)=""

           DO MES^XPDUTL(.IBA)

           KILL IBA

 +2       ;

 +3       ; Add PROJECT 112/SHAD Reason Not Billable (#356.8)

           DO ADDRNB

 +4       ; Add PROJECT 112/SHAD Charge Removal Reason (#350.3)

           DO ADDCRR

 +5       ;

 +6       ; Replace ENV. CONTAM. with SOUTHWEST ASIA Reason Not Billable (#356.8)

           DO UPDRNB

 +7       ; Replace ENV CONTAMINANT RELATED with SOUTHWEST ASIA RELATED Charge Removal Reason (#350.3)

           DO UPDCRR

 +8       ;

 +9        SET IBA(1)=""

           SET IBA(2)="    IB Support for SHAD/SWA Post-Install Complete"

           SET IBA(3)=""

           DO MES^XPDUTL(.IBA)

           KILL IBA

 +10       QUIT

 +11      ;

 +12      ;

ADDRNB    ; Add Reason Not Billable of PROJECT 112/SHAD (#356.8)

 +1        NEW IBA,IBJ,IBNX,IBRNB,DD,DO,DINUM,DLAYGO,DIC,DIE,DA,DR,X,Y

 +2       ;

 +3        SET IBRNB="PROJECT 112/SHAD"

 +4       ;

 +5        IF $ORDER(^IBE(356.8,"B",IBRNB,0))

               SET IBA(1)="    >>> "_IBRNB_" Reason Not Billable (#356.8) exists, not re-added."

               GOTO ADDRNBQ

 +6       ;

 +7       ; find next available ien, before 999

           FOR IBJ=32:1

               SET IBNX=$GET(^IBE(356.8,IBJ,0))

               IF IBNX=""

                   SET DINUM=IBJ

                   QUIT

 +8       ;

 +9        KILL DD,DO

           SET DLAYGO=356.8

           SET DIC="^IBE(356.8,"

           SET DIC(0)="L"

           SET X=IBRNB

           DO FILE^DICN

           KILL DIC

 +10       IF Y<1

               SET IBA(1)="    >>> Unable to add "_IBRNB_" Reason Not Billable (#356.8), contact Support."

               GOTO ADDRNBQ

 +11      ;

 +12       SET IBA(1)="    >>> "_IBRNB_" Reason Not Billable (#356.8) Added."

 +13      ;

ADDRNBQ    DO MES^XPDUTL(.IBA)

 +1        QUIT

 +2       ;

 +3       ;

ADDCRR    ; Add Charge Removal Reason of PROJECT 112/SHAD (#350.3)

 +1        NEW IBA,IBJ,IBNX,IBCRR,IBABBR,IBLMT,IBFN,DD,DO,DINUM,DLAYGO,DIC,DIE,DA,DR,X,Y

 +2       ;

 +3        SET IBCRR="PROJECT 112/SHAD"

           SET IBABBR="SHAD"

           SET IBLMT="GENERIC"

 +4       ;

 +5        IF $ORDER(^IBE(350.3,"B",IBCRR,0))

               SET IBA(1)="    >>> "_IBCRR_" Charge Removal Reason (#350.3) exists, not re-added."

               GOTO ADDCRRQ

 +6       ;

 +7       ; find next available ien

           FOR IBJ=46:1

               SET IBNX=$GET(^IBE(350.3,IBJ,0))

               IF IBNX=""

                   SET DINUM=IBJ

                   QUIT

 +8       ;

 +9        KILL DD,DO

           SET DLAYGO=350.3

           SET DIC="^IBE(350.3,"

           SET DIC(0)="L"

           SET X=IBCRR

           DO FILE^DICN

           SET IBFN=+Y

 +10       IF Y<1

               SET IBA(1)="    >>> Unable to add "_IBCRR_" Charge Removal Reason (#350.3), contact Support."

               GOTO ADDCRRQ

 +11      ;

 +12       SET DIE="^IBE(350.3,"

           SET DA=+IBFN

           SET DR=".02///"_IBABBR_";.03///"_IBLMT

           DO ^DIE

 +13      ;

 +14       SET IBA(1)="    >>> "_IBCRR_" Charge Removal Reason (#350.3) Added."

 +15      ;

ADDCRRQ    DO MES^XPDUTL(.IBA)

 +1        QUIT

 +2       ;

 +3       ;

UPDRNB    ; Update Reason Not Billable of ENV. CONTAM. with SOUTHWEST ASIA (#356.8)

 +1        NEW IBA,IBFN,IBRNBO,IBRNBN,DD,DO,DINUM,DLAYGO,DIC,DIE,DA,DR,X,Y

 +2       ;

 +3        SET IBRNBO="ENV. CONTAM."

 +4        SET IBRNBN="SOUTHWEST ASIA"

 +5       ;

 +6        IF $ORDER(^IBE(356.8,"B",IBRNBN,0))

               SET IBA(1)="    >>> "_IBRNBN_" Reason Not Billable (#356.8) exists, not re-added."

               GOTO UPDRNBQ

 +7       ;

 +8        SET IBFN=$ORDER(^IBE(356.8,"B",IBRNBO,0))

           IF 'IBFN

               SET IBA(1)="    >>> ERROR: "_IBRNBO_" Reason Not Billable (#356.8) not found, could not be replaced, contact support."

               GOTO UPDRNBQ

 +9       ;

 +10       SET DIE="^IBE(356.8,"

           SET DA=+IBFN

           SET DR=".01///"_IBRNBN

           DO ^DIE

 +11      ;

 +12       SET IBA(1)="    >>> "_IBRNBO_" Reason Not Billable (#356.8) Replaced with "_IBRNBN

 +13      ;

UPDRNBQ    DO MES^XPDUTL(.IBA)

 +1        QUIT

 +2       ;

 +3       ;

UPDCRR    ; Update Charge Removal Reason of ENV CONTAMINANT RELATED with SOUTHWEST ASIA RELATED (#350.3)

 +1        NEW IBA,IBFN,IBCRRO,IBCRRN,DD,DO,DINUM,DLAYGO,DIC,DIE,DA,DR,X,Y

 +2       ;

 +3        SET IBCRRO="ENV CONTAMINANT RELATED"

 +4        SET IBCRRN="SOUTHWEST ASIA RELATED"

 +5       ;

 +6        IF $ORDER(^IBE(350.3,"B",IBCRRN,0))

               SET IBA(1)="    >>> "_IBCRRN_" Charge Removal Reason (#350.3) exists, not re-added."

               GOTO UPDCRRQ

 +7       ;

 +8        SET IBFN=$ORDER(^IBE(350.3,"B",IBCRRO,0))

           IF 'IBFN

               SET IBA(1)="    >>> ERROR: "_IBCRRO_" Charge Removal Reason (#350.3) not found, could not be replaced, contact support."

               GOTO UPDCRRQ

 +9       ;

 +10       SET DIE="^IBE(350.3,"

           SET DA=+IBFN

           SET DR=".01///"_IBCRRN_";.02///SWA"

           DO ^DIE

 +11      ;

 +12       SET IBA(1)="    >>> "_IBCRRO_" Charge Removal Reason (#350.3) Replaced with "_IBCRRN

 +13      ;

UPDCRRQ    DO MES^XPDUTL(.IBA)

 +1        QUIT

 +2       ;

 +3       ;

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

IB20P339.m