IB20P847 ;ALB/JWB - UPDATE MCCR UTILITY VALUE/CONDITION CODES ; 03/25/2026
;;2.0;INTEGRATED BILLING;**847**;21-MAR-94;Build 2
;;Per VA Directive 6402, this routine should not be modified.
;
; This routine is used as a post-init in a KIDS build to
; update value and condition codes in MCCR utility file 399.1.
;
; Reference to FILE^DICN in ICR #10009
; Reference to ^DIE in ICR #10018
; Reference to MES^XPDUTL in ICR #10141
;
Q
POST ;
; Update value/condition codes effective 2025/2026 in file 399.1
N IBZ,U S U="^"
D BMSG(" IB*2.0*847 Post-Install starts .....")
D MCR
D BMSG(" IB*2.0*847 Post-Install is complete.")
Q
;
MCR ; Two types of codes
N IBCNT,IBPE,IBFD,IBI,IBX
;
; value code flag in field #.18/piece 11
S IBCNT=0,IBPE=11,IBFD=.18
D BMSG(" >> Adding Value Code")
F IBI=1:1 S IBX=$P($T(VALU+IBI),";;",2) Q:IBX="Q" D MFILE
;
; condition code flag in field #.22/piece 15
S IBPE=15,IBFD=.22
D BMSG(" >> Adding Condition Code")
F IBI=1:1 S IBX=$P($T(CONU+IBI),";;",2) Q:IBX="Q" D MFILE
;
D MSG("Total "_IBCNT_" code"_$S(IBCNT'=1:"s",1:"")_" added to MCCR UTILITY (#399.1) file")
Q
;
MFILE ; Store in fields
N IBA,IBB,IBC,IBFN,IBMS,IBX3,IBY,DLAYGO,DIC,DIE,DA,DD,DO,DR,X,Y
S IBA=$P(IBX,U),IBB=$P(IBX,U,2)
S IBY=" "_IBA_" "_IBB
S IBFN=+$$EXCODE(IBA,IBPE)
I IBFN D Q:'IBFN
. S IBX3=$G(^DGCR(399.1,IBFN,0)),IBC=IBB_U_IBA
. I $P(IBX3,U,1,2)=IBC S IBFN=0 D MSG(IBY_" not re-added") Q
. ; if new code already exists
. S DA=IBFN,IBMS="updated"
I 'IBFN D Q:Y<1
. S DLAYGO=399.1,DIC="^DGCR(399.1,",DIC(0)="L",X=IBB D FILE^DICN
. I Y<1 D MSG(" >> ERROR when adding "_$S(IBPE=11:"Value",1:"Condition")_" Code #"_IBA_" to the #399.1 file, Log a ticket!") Q
. S DA=+Y,IBMS=""
S DIE="^DGCR(399.1,",DR=".01///"_IBB_";.02///"_IBA_";"_IBFD_"///1" D ^DIE
S IBCNT=IBCNT+1 D MSG(IBY_$S(IBMS'="":" "_IBMS,1:""))
Q
;
EXCODE(IBCOD,IBPE) ; Returns IEN if code found in the IBPE piece
N IBX,IBY S IBY=""
I $G(IBCOD)'="" S IBX=0 F S IBX=$O(^DGCR(399.1,"C",IBCOD,IBX)) Q:'IBX I $P($G(^DGCR(399.1,IBX,0)),U,+$G(IBPE)) S IBY=IBX
Q IBY
;
BMSG(IBZ) ;
D BMES^XPDUTL(IBZ)
Q
;
MSG(IBZ) ;
D MES^XPDUTL(IBZ)
Q
;
VALU ; Value code^name (1)
;;92^DRG/BIOLGC INV CST
;;Q
CONU ; Condition code^name (2)
;;CA^CYBERATTACK OR OTHER SYSTEM OUTAGE
;;63^INCARCERATED BENEFICIARIES
;;Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIB20P847 2399 printed Jul 11, 2026@02:01:52 Page 2
IB20P847 ;ALB/JWB - UPDATE MCCR UTILITY VALUE/CONDITION CODES ; 03/25/2026
+1 ;;2.0;INTEGRATED BILLING;**847**;21-MAR-94;Build 2
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ; This routine is used as a post-init in a KIDS build to
+5 ; update value and condition codes in MCCR utility file 399.1.
+6 ;
+7 ; Reference to FILE^DICN in ICR #10009
+8 ; Reference to ^DIE in ICR #10018
+9 ; Reference to MES^XPDUTL in ICR #10141
+10 ;
+11 QUIT
POST ;
+1 ; Update value/condition codes effective 2025/2026 in file 399.1
+2 NEW IBZ,U
SET U="^"
+3 DO BMSG(" IB*2.0*847 Post-Install starts .....")
+4 DO MCR
+5 DO BMSG(" IB*2.0*847 Post-Install is complete.")
+6 QUIT
+7 ;
MCR ; Two types of codes
+1 NEW IBCNT,IBPE,IBFD,IBI,IBX
+2 ;
+3 ; value code flag in field #.18/piece 11
+4 SET IBCNT=0
SET IBPE=11
SET IBFD=.18
+5 DO BMSG(" >> Adding Value Code")
+6 FOR IBI=1:1
SET IBX=$PIECE($TEXT(VALU+IBI),";;",2)
if IBX="Q"
QUIT
DO MFILE
+7 ;
+8 ; condition code flag in field #.22/piece 15
+9 SET IBPE=15
SET IBFD=.22
+10 DO BMSG(" >> Adding Condition Code")
+11 FOR IBI=1:1
SET IBX=$PIECE($TEXT(CONU+IBI),";;",2)
if IBX="Q"
QUIT
DO MFILE
+12 ;
+13 DO MSG("Total "_IBCNT_" code"_$SELECT(IBCNT'=1:"s",1:"")_" added to MCCR UTILITY (#399.1) file")
+14 QUIT
+15 ;
MFILE ; Store in fields
+1 NEW IBA,IBB,IBC,IBFN,IBMS,IBX3,IBY,DLAYGO,DIC,DIE,DA,DD,DO,DR,X,Y
+2 SET IBA=$PIECE(IBX,U)
SET IBB=$PIECE(IBX,U,2)
+3 SET IBY=" "_IBA_" "_IBB
+4 SET IBFN=+$$EXCODE(IBA,IBPE)
+5 IF IBFN
Begin DoDot:1
+6 SET IBX3=$GET(^DGCR(399.1,IBFN,0))
SET IBC=IBB_U_IBA
+7 IF $PIECE(IBX3,U,1,2)=IBC
SET IBFN=0
DO MSG(IBY_" not re-added")
QUIT
+8 ; if new code already exists
+9 SET DA=IBFN
SET IBMS="updated"
End DoDot:1
if 'IBFN
QUIT
+10 IF 'IBFN
Begin DoDot:1
+11 SET DLAYGO=399.1
SET DIC="^DGCR(399.1,"
SET DIC(0)="L"
SET X=IBB
DO FILE^DICN
+12 IF Y<1
DO MSG(" >> ERROR when adding "_$SELECT(IBPE=11:"Value",1:"Condition")_" Code #"_IBA_" to the #399.1 file, Log a ticket!")
QUIT
+13 SET DA=+Y
SET IBMS=""
End DoDot:1
if Y<1
QUIT
+14 SET DIE="^DGCR(399.1,"
SET DR=".01///"_IBB_";.02///"_IBA_";"_IBFD_"///1"
DO ^DIE
+15 SET IBCNT=IBCNT+1
DO MSG(IBY_$SELECT(IBMS'="":" "_IBMS,1:""))
+16 QUIT
+17 ;
EXCODE(IBCOD,IBPE) ; Returns IEN if code found in the IBPE piece
+1 NEW IBX,IBY
SET IBY=""
+2 IF $GET(IBCOD)'=""
SET IBX=0
FOR
SET IBX=$ORDER(^DGCR(399.1,"C",IBCOD,IBX))
if 'IBX
QUIT
IF $PIECE($GET(^DGCR(399.1,IBX,0)),U,+$GET(IBPE))
SET IBY=IBX
+3 QUIT IBY
+4 ;
BMSG(IBZ) ;
+1 DO BMES^XPDUTL(IBZ)
+2 QUIT
+3 ;
MSG(IBZ) ;
+1 DO MES^XPDUTL(IBZ)
+2 QUIT
+3 ;
VALU ; Value code^name (1)
+1 ;;92^DRG/BIOLGC INV CST
+2 ;;Q
CONU ; Condition code^name (2)
+1 ;;CA^CYBERATTACK OR OTHER SYSTEM OUTAGE
+2 ;;63^INCARCERATED BENEFICIARIES
+3 ;;Q
