IBY461PO ;ALB/DEM/JAS - IB*2*461 POST-INSTALL - ICD10 ;23-JAN-2012
;;2.0;INTEGRATED BILLING;**461**;21-MAR-94;Build 58
;;Per VHA Directive 2004-038, this routine should not be modified.
;
;
N IBA S IBA(2)="IB*2*461 IB-ICD10 Post-Install...",(IBA(1),IBA(3))=" " D MES^XPDUTL(.IBA) K IBA
;
D RIT,CONV,ADDERR,UPDERR
;
S IBA(2)="IB*2*461 IB-ICD10 Post-Install Complete.",(IBA(1),IBA(3))=" " D MES^XPDUTL(.IBA)
Q
;
RIT ; Recompile File #399 Input Templates
N IBMAX,IBIEN,IBRTN,DMAX,X,Y
S IBMAX=$$ROUSIZE^DILF
;
D MES^XPDUTL(">> Compiling Billing Screen 4 [IB SCREEN4] Input Template")
S IBIEN=$O(^DIE("B","IB SCREEN4",0)) Q:'IBIEN
S IBRTN=$P($G(^DIE(IBIEN,"ROUOLD")),U) Q:IBRTN=""
S X=IBRTN,Y=IBIEN,DMAX=IBMAX
D EN^DIEZ
;
D MES^XPDUTL(">> Compiling Billing Screen 5 [IB SCREEN5] Input Template")
S IBIEN=$O(^DIE("B","IB SCREEN5",0)) Q:'IBIEN
S IBRTN=$P($G(^DIE(IBIEN,"ROUOLD")),U) Q:IBRTN=""
S X=IBRTN,Y=IBIEN,DMAX=IBMAX
D EN^DIEZ
;
Q
CONV ; Add value to new DEFAULT RX REFILL DX ICD-10 field (#350.9, 7.05)
; set to 569361 - Z76.0 - Encounter for issue of repeat prescription
N DIE,DIC,DA,DR,X
;
I +$P($G(^IBE(350.9,1,7)),U,5) D MES^XPDUTL(">> DEFAULT RX REFILL DX ICD-10 Site Parameter (#350.9,7.05) has value, no change") Q
;
S DIE="^IBE(350.9,",DA=1,DR="7.05////569361" D ^DIE K DIE,DIC,DA,DR
D MES^XPDUTL(">> Set DEFAULT RX REFILL DX ICD-10 Site Parameter (#350.9, 7.05) to Z76.0")
;
Q
;
UPDERR ; Update existing error code message for 350.8
N IBCODE,IBMESN,IBIEN,DIE,DIC,DA,DR,X,Y
;
S IBCODE="IB071",IBMESN="A claim must contain an ICD diagnosis."
S IBIEN=$O(^IBE(350.8,"C",IBCODE,0)) I 'IBIEN D MES^XPDUTL(">> IB ERROR (#350.8) IB071 - Not Found, Error") Q
;
S DIE="^IBE(350.8,",DA=IBIEN,DR=".02////"_IBMESN D ^DIE K DIE,DIC,DA,DR
D MES^XPDUTL(">> Updated IB ERROR (#350.8) Code IB071")
;
Q
;
ADDERR ; Add new error code records to 350.8
N IBI,IBTXT,IBCODE,DIE,DIC,DR,DA,DD,DO,X,Y,DLAYGO S DLAYGO=350.8
;
F IBI=1:1 S IBTXT=$P($T(TXTERR+IBI),";;",2,999) Q:IBTXT="" D
. S IBCODE=$P(IBTXT,U,1)
. I $O(^IBE(350.8,"AC",IBCODE,0)) D MES^XPDUTL(">> IB ERROR (#350.8) Code "_IBCODE_" already exists, no change") Q
. ;
. S DIC="^IBE(350.8,",DIC("DR")=".02////"_$P(IBTXT,U,2)_";.03////"_IBCODE_";.04////1;.05////1"
. S DIC(0)="L",X=IBCODE D FILE^DICN K DIC I Y<1 K X,Y Q
. D MES^XPDUTL(">> Added IB ERROR (#350.8) Code "_IBCODE)
;
Q
;
;
TXTERR ; New IB ERROR (#350.8) Codes: Name=Error Code ^ Message
;;IB354^Statement Covers To date cannot span into ICD-10 effective period.
;;IB355^The Principal (first-entered) diagnosis cannot begin with a V, W, X or Y.
;;IB356^ICD Code Set Version does not correspond to Statement Covers To Date.
;;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBY461PO 2767 printed Sep 23, 2025@20:10:37 Page 2
IBY461PO ;ALB/DEM/JAS - IB*2*461 POST-INSTALL - ICD10 ;23-JAN-2012
+1 ;;2.0;INTEGRATED BILLING;**461**;21-MAR-94;Build 58
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 ;
+5 NEW IBA
SET IBA(2)="IB*2*461 IB-ICD10 Post-Install..."
SET (IBA(1),IBA(3))=" "
DO MES^XPDUTL(.IBA)
KILL IBA
+6 ;
+7 DO RIT
DO CONV
DO ADDERR
DO UPDERR
+8 ;
+9 SET IBA(2)="IB*2*461 IB-ICD10 Post-Install Complete."
SET (IBA(1),IBA(3))=" "
DO MES^XPDUTL(.IBA)
+10 QUIT
+11 ;
RIT ; Recompile File #399 Input Templates
+1 NEW IBMAX,IBIEN,IBRTN,DMAX,X,Y
+2 SET IBMAX=$$ROUSIZE^DILF
+3 ;
+4 DO MES^XPDUTL(">> Compiling Billing Screen 4 [IB SCREEN4] Input Template")
+5 SET IBIEN=$ORDER(^DIE("B","IB SCREEN4",0))
if 'IBIEN
QUIT
+6 SET IBRTN=$PIECE($GET(^DIE(IBIEN,"ROUOLD")),U)
if IBRTN=""
QUIT
+7 SET X=IBRTN
SET Y=IBIEN
SET DMAX=IBMAX
+8 DO EN^DIEZ
+9 ;
+10 DO MES^XPDUTL(">> Compiling Billing Screen 5 [IB SCREEN5] Input Template")
+11 SET IBIEN=$ORDER(^DIE("B","IB SCREEN5",0))
if 'IBIEN
QUIT
+12 SET IBRTN=$PIECE($GET(^DIE(IBIEN,"ROUOLD")),U)
if IBRTN=""
QUIT
+13 SET X=IBRTN
SET Y=IBIEN
SET DMAX=IBMAX
+14 DO EN^DIEZ
+15 ;
+16 QUIT
CONV ; Add value to new DEFAULT RX REFILL DX ICD-10 field (#350.9, 7.05)
+1 ; set to 569361 - Z76.0 - Encounter for issue of repeat prescription
+2 NEW DIE,DIC,DA,DR,X
+3 ;
+4 IF +$PIECE($GET(^IBE(350.9,1,7)),U,5)
DO MES^XPDUTL(">> DEFAULT RX REFILL DX ICD-10 Site Parameter (#350.9,7.05) has value, no change")
QUIT
+5 ;
+6 SET DIE="^IBE(350.9,"
SET DA=1
SET DR="7.05////569361"
DO ^DIE
KILL DIE,DIC,DA,DR
+7 DO MES^XPDUTL(">> Set DEFAULT RX REFILL DX ICD-10 Site Parameter (#350.9, 7.05) to Z76.0")
+8 ;
+9 QUIT
+10 ;
UPDERR ; Update existing error code message for 350.8
+1 NEW IBCODE,IBMESN,IBIEN,DIE,DIC,DA,DR,X,Y
+2 ;
+3 SET IBCODE="IB071"
SET IBMESN="A claim must contain an ICD diagnosis."
+4 SET IBIEN=$ORDER(^IBE(350.8,"C",IBCODE,0))
IF 'IBIEN
DO MES^XPDUTL(">> IB ERROR (#350.8) IB071 - Not Found, Error")
QUIT
+5 ;
+6 SET DIE="^IBE(350.8,"
SET DA=IBIEN
SET DR=".02////"_IBMESN
DO ^DIE
KILL DIE,DIC,DA,DR
+7 DO MES^XPDUTL(">> Updated IB ERROR (#350.8) Code IB071")
+8 ;
+9 QUIT
+10 ;
ADDERR ; Add new error code records to 350.8
+1 NEW IBI,IBTXT,IBCODE,DIE,DIC,DR,DA,DD,DO,X,Y,DLAYGO
SET DLAYGO=350.8
+2 ;
+3 FOR IBI=1:1
SET IBTXT=$PIECE($TEXT(TXTERR+IBI),";;",2,999)
if IBTXT=""
QUIT
Begin DoDot:1
+4 SET IBCODE=$PIECE(IBTXT,U,1)
+5 IF $ORDER(^IBE(350.8,"AC",IBCODE,0))
DO MES^XPDUTL(">> IB ERROR (#350.8) Code "_IBCODE_" already exists, no change")
QUIT
+6 ;
+7 SET DIC="^IBE(350.8,"
SET DIC("DR")=".02////"_$PIECE(IBTXT,U,2)_";.03////"_IBCODE_";.04////1;.05////1"
+8 SET DIC(0)="L"
SET X=IBCODE
DO FILE^DICN
KILL DIC
IF Y<1
KILL X,Y
QUIT
+9 DO MES^XPDUTL(">> Added IB ERROR (#350.8) Code "_IBCODE)
End DoDot:1
+10 ;
+11 QUIT
+12 ;
+13 ;
TXTERR ; New IB ERROR (#350.8) Codes: Name=Error Code ^ Message
+1 ;;IB354^Statement Covers To date cannot span into ICD-10 effective period.
+2 ;;IB355^The Principal (first-entered) diagnosis cannot begin with a V, W, X or Y.
+3 ;;IB356^ICD Code Set Version does not correspond to Statement Covers To Date.
+4 ;;
