IB20P637 ;ALB/CXW - UPDATE MCCR UTILITY FILE ;01/16/2019
;;2.0;INTEGRATED BILLING;**637**;21-MAR-94;Build 29
;;Per VA Directive 6402, this routine should not be modified.
Q
POST ;
; 2019 Update occurrence span/value codes in #399.1
N IBZ,U S U="^"
D MSG(" IB*2.0*637 Post-Install starts .....")
D MCCR
D MSG(" IB*2.0*637 Post-Install is complete.")
Q
;
MCCR ; 2 types of codes
N IBCNT,IBCOD,IBPE,IBFD,IBFD2,IBI,IBX
S IBCNT=0
; Occurrence span code in fields #.11/piece 4, #.17/piece 10
S IBPE=4,IBFD=.11,IBFD2=.17
D MSG(""),MSG(" >>>Occurrence Span Code")
F IBI=1:1 S IBX=$P($T(OCSPU+IBI),";;",2) Q:IBX="Q" D MFILE
;
; Value code in field #.18/piece 11
S IBPE=11,IBFD=.18
D MSG(""),MSG(" >>>Value Code")
F IBI=1:1 S IBX=$P($T(VALU+IBI),";;",2) Q:IBX="Q" D MFILE
D MSG(""),MSG(" Total "_IBCNT_" code"_$S(IBCNT'=1:"s",1:"")_" updated in the MCCR UTILITY (#399.1) file")
D MSG("")
Q
;
MFILE ; Update to the mccr utility file
N IBA,IBB,IBC,IBFN,IBMS,IBX2,IBX3,IBY,DLAYGO,DIC,DIE,DA,DD,DO,DR,X,Y
S IBA=$P(IBX,U),IBB=$P(IBX,U,2),IBC=$P(IBX,U,3)
S IBMS=$S(IBC=1:"updated",1:"added")
S IBY=" #"_IBA_" "_IBB
S IBFN=+$$EXCODE(IBA,IBPE)
I IBFN D Q:'IBFN
. S DA=IBFN
. S IBX3=$G(^DGCR(399.1,IBFN,0))
. S IBX2=IBB_U_IBA
. I $P(IBX3,U,1,2)=IBX2 D MSG(IBY_" already exists") S IBFN=0 Q
;
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:"Occurrence Span")_" Code #"_IBA_" to the #399.1 file, Log a ticket!") Q
. S DA=+Y
; add override flag for new code if no found
S DIE="^DGCR(399.1,",DR=".01///"_IBB_";.02///"_IBA_";"_IBFD_"///1"
S:IBPE=11 DR=DR_";.19////1" S:IBPE=4 DR=DR_";"_IBFD2_"////1" D ^DIE
S IBCNT=IBCNT+1
D MSG(IBY_" "_IBMS)
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
;
MSG(IBZ) ;
D MES^XPDUTL(IBZ) Q
;
OCSPU ; Occurrence span code (2)^name^1 - update
;;72^FIRST/LAST DAY^1
;;74^LEAVE OF ABSENCE DATES^1
;;Q
;
VALU ; Value code (2)^name^1 - update
;;04^PROFESSIONAL COMPONENT CHARGES, COMBINED BILLED^1
;;Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIB20P637 2314 printed Oct 16, 2024@18:04:57 Page 2
IB20P637 ;ALB/CXW - UPDATE MCCR UTILITY FILE ;01/16/2019
+1 ;;2.0;INTEGRATED BILLING;**637**;21-MAR-94;Build 29
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 QUIT
POST ;
+1 ; 2019 Update occurrence span/value codes in #399.1
+2 NEW IBZ,U
SET U="^"
+3 DO MSG(" IB*2.0*637 Post-Install starts .....")
+4 DO MCCR
+5 DO MSG(" IB*2.0*637 Post-Install is complete.")
+6 QUIT
+7 ;
MCCR ; 2 types of codes
+1 NEW IBCNT,IBCOD,IBPE,IBFD,IBFD2,IBI,IBX
+2 SET IBCNT=0
+3 ; Occurrence span code in fields #.11/piece 4, #.17/piece 10
+4 SET IBPE=4
SET IBFD=.11
SET IBFD2=.17
+5 DO MSG("")
DO MSG(" >>>Occurrence Span Code")
+6 FOR IBI=1:1
SET IBX=$PIECE($TEXT(OCSPU+IBI),";;",2)
if IBX="Q"
QUIT
DO MFILE
+7 ;
+8 ; Value code in field #.18/piece 11
+9 SET IBPE=11
SET IBFD=.18
+10 DO MSG("")
DO MSG(" >>>Value Code")
+11 FOR IBI=1:1
SET IBX=$PIECE($TEXT(VALU+IBI),";;",2)
if IBX="Q"
QUIT
DO MFILE
+12 DO MSG("")
DO MSG(" Total "_IBCNT_" code"_$SELECT(IBCNT'=1:"s",1:"")_" updated in the MCCR UTILITY (#399.1) file")
+13 DO MSG("")
+14 QUIT
+15 ;
MFILE ; Update to the mccr utility file
+1 NEW IBA,IBB,IBC,IBFN,IBMS,IBX2,IBX3,IBY,DLAYGO,DIC,DIE,DA,DD,DO,DR,X,Y
+2 SET IBA=$PIECE(IBX,U)
SET IBB=$PIECE(IBX,U,2)
SET IBC=$PIECE(IBX,U,3)
+3 SET IBMS=$SELECT(IBC=1:"updated",1:"added")
+4 SET IBY=" #"_IBA_" "_IBB
+5 SET IBFN=+$$EXCODE(IBA,IBPE)
+6 IF IBFN
Begin DoDot:1
+7 SET DA=IBFN
+8 SET IBX3=$GET(^DGCR(399.1,IBFN,0))
+9 SET IBX2=IBB_U_IBA
+10 IF $PIECE(IBX3,U,1,2)=IBX2
DO MSG(IBY_" already exists")
SET IBFN=0
QUIT
End DoDot:1
if 'IBFN
QUIT
+11 ;
+12 IF 'IBFN
Begin DoDot:1
+13 SET DLAYGO=399.1
SET DIC="^DGCR(399.1,"
SET DIC(0)="L"
SET X=IBB
DO FILE^DICN
+14 IF Y<1
DO MSG(" >> ERROR when adding "_$SELECT(IBPE=11:"Value",1:"Occurrence Span")_" Code #"_IBA_" to the #399.1 file, Log a ticket!")
QUIT
+15 SET DA=+Y
End DoDot:1
if Y<1
QUIT
+16 ; add override flag for new code if no found
+17 SET DIE="^DGCR(399.1,"
SET DR=".01///"_IBB_";.02///"_IBA_";"_IBFD_"///1"
+18 if IBPE=11
SET DR=DR_";.19////1"
if IBPE=4
SET DR=DR_";"_IBFD2_"////1"
DO ^DIE
+19 SET IBCNT=IBCNT+1
+20 DO MSG(IBY_" "_IBMS)
+21 QUIT
+22 ;
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 ;
MSG(IBZ) ;
+1 DO MES^XPDUTL(IBZ)
QUIT
+2 ;
OCSPU ; Occurrence span code (2)^name^1 - update
+1 ;;72^FIRST/LAST DAY^1
+2 ;;74^LEAVE OF ABSENCE DATES^1
+3 ;;Q
+4 ;
VALU ; Value code (2)^name^1 - update
+1 ;;04^PROFESSIONAL COMPONENT CHARGES, COMBINED BILLED^1
+2 ;;Q
+3 ;
