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.
;
Q
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
Q
;
;
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)
Q
;
;
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)
Q
;
;
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)
Q
;
;
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)
Q
;
;
MSG(X) ;
N IBX S IBX=$O(IBA(999999),-1) S:'IBX IBX=1 S IBX=IBX+1
S IBA(IBX)=$G(X)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIB20P339 3846 printed Apr 09, 2024@21:29:14 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
