IB20P787 ;ALB/JAB - UPDATE MCCR UTILITY & POS ; 02/15/2024
;;2.0;INTEGRATED BILLING;**787**;21-MAR-94;Build 3
;;Per VA Directive 6402, this routine should not be modified.
;
; This routine is used as a post-init in a KIDS build to
; update conditional codes in mccr utility file 399.1
; and place of service codes in service file 353.1.
;
; See previous patches for all the other types of files
; that can possibly be updated.
;
; Reference to FILE^DICN in ICR #10009
; Reference to ^DIE in ICR #10018
; Reference to $$FMADD^XLFDT in ICR #10103
; Reference to MES^XPDUTL in ICR #10141
;
Q
POST ;
D MSG("IB*2.0*787 Post-Install starts .....")
D MSG("")
N IBZ,U S U="^"
D MCR ; 3 conditional codes in mccr utility file 399.1
D POS ; 2 pos codes in service file 353.1
D MSG("IB*2.0*787 Post-Install is complete.")
D MSG("")
Q
;
MCR ;
; Condition code
N IBCNT,IBCOD,IBPE,IBFD,IBI,IBX
; condition code flag in field #.22/piece 15
S IBCNT=0,IBPE=15,IBFD=.22
D MSG(">>> 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")
D MSG("")
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
;
POS ;
; Place Of Service in fields #.01/piece 1, #.02/piece 2, #.03/piece 3
N IBA,IBB,IBC,IBCNT,IBD,IBF,IBI,IBMS,IBX,IBX3,IBY,DA,DIC,DIE,DLAYGO,DD,DO,DR,X,Y
S IBCNT=0
D MSG(">>> Place of Service Code")
F IBI=1:1 S IBX=$P($T(POSU+IBI),";;",2) Q:IBX="Q" D
. S IBA=$P(IBX,U,1),IBB=$P(IBX,U,2),IBC=$P(IBX,U,3)
. S IBY=" #"_IBA_" "_IBB,IBD=IBA_U_IBB_U_IBC
. S IBF=+$O(^IBE(353.1,"B",IBA,0))
. I IBF D Q:'IBF
.. S IBX3=$G(^IBE(353.1,IBF,0)),DA=IBF,IBMS="updated"
.. I $P(IBX3,U,1,3)=IBD D MSG(IBY_" already exists") S IBF=0
. I 'IBF D Q:Y<1
.. S DLAYGO=353.1,DIC="^IBE(353.1,",DIC(0)="L",X=IBA D FILE^DICN
.. I Y<1 D MSG(">>> ERROR when adding #"_IBA_" "_IBB_" to the #353.1 file, Log a ticket!") Q
.. S DA=+Y,IBMS="added"
. S DIE="^IBE(353.1,",DR=".02///"_IBB_";.03///"_IBC D ^DIE
. S IBCNT=IBCNT+1 D MSG(IBY_" "_IBMS)
D MSG(" Total "_IBCNT_" code"_$S(IBCNT'=1:"s",1:"")_" updated in the Place of Service (#353.1) file")
D MSG("")
Q
;
MSG(IBZ) ;
D MES^XPDUTL(IBZ) Q
;
CONU ; Condition code^name^update (3)
;;35^PACE Eligible Patient Disenrolls During an IP Admission
;;92^Intensive Outpatient Program (IOP)
;;45^Gender Incongruence^1
;;Q
;
POSU ; Place of Service code^name^abbreviation (1)
;;27^Outreach Site/Street
;;58^Non-residential Opioid Treatment Facility
;;Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIB20P787 3547 printed Sep 15, 2024@21:29:06 Page 2
IB20P787 ;ALB/JAB - UPDATE MCCR UTILITY & POS ; 02/15/2024
+1 ;;2.0;INTEGRATED BILLING;**787**;21-MAR-94;Build 3
+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 conditional codes in mccr utility file 399.1
+6 ; and place of service codes in service file 353.1.
+7 ;
+8 ; See previous patches for all the other types of files
+9 ; that can possibly be updated.
+10 ;
+11 ; Reference to FILE^DICN in ICR #10009
+12 ; Reference to ^DIE in ICR #10018
+13 ; Reference to $$FMADD^XLFDT in ICR #10103
+14 ; Reference to MES^XPDUTL in ICR #10141
+15 ;
+16 QUIT
POST ;
+1 DO MSG("IB*2.0*787 Post-Install starts .....")
+2 DO MSG("")
+3 NEW IBZ,U
SET U="^"
+4 ; 3 conditional codes in mccr utility file 399.1
DO MCR
+5 ; 2 pos codes in service file 353.1
DO POS
+6 DO MSG("IB*2.0*787 Post-Install is complete.")
+7 DO MSG("")
+8 QUIT
+9 ;
MCR ;
+1 ; Condition code
+2 NEW IBCNT,IBCOD,IBPE,IBFD,IBI,IBX
+3 ; condition code flag in field #.22/piece 15
+4 SET IBCNT=0
SET IBPE=15
SET IBFD=.22
+5 DO MSG(">>> Condition Code")
+6 FOR IBI=1:1
SET IBX=$PIECE($TEXT(CONU+IBI),";;",2)
if IBX="Q"
QUIT
DO MFILE
+7 ;
+8 DO MSG(" Total "_IBCNT_" code"_$SELECT(IBCNT'=1:"s",1:"")_" added to MCCR UTILITY (#399.1) file")
+9 DO MSG("")
+10 QUIT
+11 ;
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 ;
POS ;
+1 ; Place Of Service in fields #.01/piece 1, #.02/piece 2, #.03/piece 3
+2 NEW IBA,IBB,IBC,IBCNT,IBD,IBF,IBI,IBMS,IBX,IBX3,IBY,DA,DIC,DIE,DLAYGO,DD,DO,DR,X,Y
+3 SET IBCNT=0
+4 DO MSG(">>> Place of Service Code")
+5 FOR IBI=1:1
SET IBX=$PIECE($TEXT(POSU+IBI),";;",2)
if IBX="Q"
QUIT
Begin DoDot:1
+6 SET IBA=$PIECE(IBX,U,1)
SET IBB=$PIECE(IBX,U,2)
SET IBC=$PIECE(IBX,U,3)
+7 SET IBY=" #"_IBA_" "_IBB
SET IBD=IBA_U_IBB_U_IBC
+8 SET IBF=+$ORDER(^IBE(353.1,"B",IBA,0))
+9 IF IBF
Begin DoDot:2
+10 SET IBX3=$GET(^IBE(353.1,IBF,0))
SET DA=IBF
SET IBMS="updated"
+11 IF $PIECE(IBX3,U,1,3)=IBD
DO MSG(IBY_" already exists")
SET IBF=0
End DoDot:2
if 'IBF
QUIT
+12 IF 'IBF
Begin DoDot:2
+13 SET DLAYGO=353.1
SET DIC="^IBE(353.1,"
SET DIC(0)="L"
SET X=IBA
DO FILE^DICN
+14 IF Y<1
DO MSG(">>> ERROR when adding #"_IBA_" "_IBB_" to the #353.1 file, Log a ticket!")
QUIT
+15 SET DA=+Y
SET IBMS="added"
End DoDot:2
if Y<1
QUIT
+16 SET DIE="^IBE(353.1,"
SET DR=".02///"_IBB_";.03///"_IBC
DO ^DIE
+17 SET IBCNT=IBCNT+1
DO MSG(IBY_" "_IBMS)
End DoDot:1
+18 DO MSG(" Total "_IBCNT_" code"_$SELECT(IBCNT'=1:"s",1:"")_" updated in the Place of Service (#353.1) file")
+19 DO MSG("")
+20 QUIT
+21 ;
MSG(IBZ) ;
+1 DO MES^XPDUTL(IBZ)
QUIT
+2 ;
CONU ; Condition code^name^update (3)
+1 ;;35^PACE Eligible Patient Disenrolls During an IP Admission
+2 ;;92^Intensive Outpatient Program (IOP)
+3 ;;45^Gender Incongruence^1
+4 ;;Q
+5 ;
POSU ; Place of Service code^name^abbreviation (1)
+1 ;;27^Outreach Site/Street
+2 ;;58^Non-residential Opioid Treatment Facility
+3 ;;Q
+4 ;
