IB20P735 ;ALB/CXW - UPDATE MCCR UTILITY & REVENUE & POS ; 03/25/2022
;;2.0;INTEGRATED BILLING;**735**;21-MAR-94;Build 27
;;Per VA Directive 6402, this routine should not be modified.
; Reference to BMES^XPDUTL in ICR #10141
; Reference to ^DIE in ICR #10018
Q
POST ;
; 1 occurrence span code in mccr utility file 399.1
; 1 revenue code in revenue code file 399.2
; 1 pos code in place of service file 353.1
;
N IBZ,U S U="^"
D MSG(" IB*2.0*735 Post-Install starts .....")
D MCR,RVC,POS
D MSG(" IB*2.0*735 Post-Install is complete.")
Q
;
MCR ; Occurrence span code
N IBCNT,IBCOD,IBPE,IBFD,IBFD2,IBI,IBX
S IBCNT=0
; code flag 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(OCCPU+IBI),";;",2) Q:IBX="Q" D MFILE
D MSG("Total "_IBCNT_" code"_$S(IBCNT'=1:"s",1:"")_" updated in the MCCR Utility (#399.1) file")
Q
;
MFILE ; Store in mccr utility file
N IBA,IBB,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_" already exists") Q
. 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 Occurrence Span Code #)"_IBA_" to the #399.1 file, Log a ticket!") Q
. S DA=+Y,IBMS="added"
; 4 slashes to override the span flag
S DIE="^DGCR(399.1,",DR=".01///"_IBB_";.02///"_IBA_";"_IBFD_"///1"_";"_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
;
RVC ; Revenue code in fields #1/piece 2, #2/piece 3, #3/piece 4
N IBA,IBB,IBC,IBCNT,IBD,IBF,IBI,IBMS,IBX,IBY,IBX3,DA,DIE,DR,X,Y
S IBCNT=0
D MSG(""),MSG(" >>>Revenue Code")
F IBI=1:1 S IBX=$P($T(RVCU+IBI),";;",2) Q:IBX="Q" D
. S IBA=$P(IBX,U),IBB=$P(IBX,U,2),IBC=$P(IBX,U,3)
. S IBY=" #"_IBA_" "_IBC,IBD=IBA_U_IBB_U_1_U_IBC
. S IBF=+$O(^DGCR(399.2,"B",IBA,0)) Q:'IBF
. S IBX3=$G(^DGCR(399.2,IBF,0))
. I $P(IBX3,U,1,4)=IBD D MSG(IBY_" already exists") Q
. S IBMS=$S($P(IBX3,U,2)="*RESERVED":"added",1:"updated")
. ;4 slashes to override the letter '*'
. S DR="1////"_IBB_";3////"_IBC_";2///1"
. S DIE="^DGCR(399.2,",DA=+IBF D ^DIE
. S IBCNT=IBCNT+1 D MSG(IBY_" "_IBMS)
D MSG(" Total "_IBCNT_" code"_$S(IBCNT'=1:"s",1:"")_" updated in the Revenue (#399.2) file")
Q
;
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(""),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
;
RVCU ; Revenue code^standard abbreviation^description (1)
;;161^RM & BRD-OTHER-HOSP@HOME^RM AND BRD-OTHER-HOSPITAL@HOME
;;Q
;
OCCPU ; Occurrence Span code^name (1)
;;82^HOSP AT HOME CARE DATES
;;Q
;
POSU ; Place of Service code^name^abbreviation (1)
;;10^TELEHEALTH PROVIDED IN PATIENT'S HOME^TELEHEALTH PRVDD
;;Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIB20P735 4094 printed Apr 09, 2024@21:21:24 Page 2
IB20P735 ;ALB/CXW - UPDATE MCCR UTILITY & REVENUE & POS ; 03/25/2022
+1 ;;2.0;INTEGRATED BILLING;**735**;21-MAR-94;Build 27
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ; Reference to BMES^XPDUTL in ICR #10141
+4 ; Reference to ^DIE in ICR #10018
+5 QUIT
POST ;
+1 ; 1 occurrence span code in mccr utility file 399.1
+2 ; 1 revenue code in revenue code file 399.2
+3 ; 1 pos code in place of service file 353.1
+4 ;
+5 NEW IBZ,U
SET U="^"
+6 DO MSG(" IB*2.0*735 Post-Install starts .....")
+7 DO MCR
DO RVC
DO POS
+8 DO MSG(" IB*2.0*735 Post-Install is complete.")
+9 QUIT
+10 ;
MCR ; Occurrence span code
+1 NEW IBCNT,IBCOD,IBPE,IBFD,IBFD2,IBI,IBX
+2 SET IBCNT=0
+3 ; code flag 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(OCCPU+IBI),";;",2)
if IBX="Q"
QUIT
DO MFILE
+7 DO MSG("Total "_IBCNT_" code"_$SELECT(IBCNT'=1:"s",1:"")_" updated in the MCCR Utility (#399.1) file")
+8 QUIT
+9 ;
MFILE ; Store in mccr utility file
+1 NEW IBA,IBB,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_" already exists")
QUIT
+8 SET DA=IBFN
SET IBMS="updated"
End DoDot:1
if 'IBFN
QUIT
+9 ;
+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 Occurrence Span Code #)"_IBA_" to the #399.1 file, Log a ticket!")
QUIT
+13 SET DA=+Y
SET IBMS="added"
End DoDot:1
if Y<1
QUIT
+14 ; 4 slashes to override the span flag
+15 SET DIE="^DGCR(399.1,"
SET DR=".01///"_IBB_";.02///"_IBA_";"_IBFD_"///1"_";"_IBFD2_"////1"
DO ^DIE
+16 SET IBCNT=IBCNT+1
DO MSG(IBY_" "_IBMS)
+17 QUIT
+18 ;
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 ;
RVC ; Revenue code in fields #1/piece 2, #2/piece 3, #3/piece 4
+1 NEW IBA,IBB,IBC,IBCNT,IBD,IBF,IBI,IBMS,IBX,IBY,IBX3,DA,DIE,DR,X,Y
+2 SET IBCNT=0
+3 DO MSG("")
DO MSG(" >>>Revenue Code")
+4 FOR IBI=1:1
SET IBX=$PIECE($TEXT(RVCU+IBI),";;",2)
if IBX="Q"
QUIT
Begin DoDot:1
+5 SET IBA=$PIECE(IBX,U)
SET IBB=$PIECE(IBX,U,2)
SET IBC=$PIECE(IBX,U,3)
+6 SET IBY=" #"_IBA_" "_IBC
SET IBD=IBA_U_IBB_U_1_U_IBC
+7 SET IBF=+$ORDER(^DGCR(399.2,"B",IBA,0))
if 'IBF
QUIT
+8 SET IBX3=$GET(^DGCR(399.2,IBF,0))
+9 IF $PIECE(IBX3,U,1,4)=IBD
DO MSG(IBY_" already exists")
QUIT
+10 SET IBMS=$SELECT($PIECE(IBX3,U,2)="*RESERVED":"added",1:"updated")
+11 ;4 slashes to override the letter '*'
+12 SET DR="1////"_IBB_";3////"_IBC_";2///1"
+13 SET DIE="^DGCR(399.2,"
SET DA=+IBF
DO ^DIE
+14 SET IBCNT=IBCNT+1
DO MSG(IBY_" "_IBMS)
End DoDot:1
+15 DO MSG(" Total "_IBCNT_" code"_$SELECT(IBCNT'=1:"s",1:"")_" updated in the Revenue (#399.2) file")
+16 QUIT
+17 ;
POS ; Place Of Service in fields #.01/piece 1, #.02/piece 2, #.03/piece 3
+1 NEW IBA,IBB,IBC,IBCNT,IBD,IBF,IBI,IBMS,IBX,IBX3,IBY,DA,DIC,DIE,DLAYGO,DD,DO,DR,X,Y
+2 SET IBCNT=0
+3 DO MSG("")
DO MSG(" >>>Place of Service Code")
+4 FOR IBI=1:1
SET IBX=$PIECE($TEXT(POSU+IBI),";;",2)
if IBX="Q"
QUIT
Begin DoDot:1
+5 SET IBA=$PIECE(IBX,U,1)
SET IBB=$PIECE(IBX,U,2)
SET IBC=$PIECE(IBX,U,3)
+6 SET IBY=" #"_IBA_" "_IBB
SET IBD=IBA_U_IBB_U_IBC
+7 SET IBF=+$ORDER(^IBE(353.1,"B",IBA,0))
+8 IF IBF
Begin DoDot:2
+9 SET IBX3=$GET(^IBE(353.1,IBF,0))
SET DA=IBF
SET IBMS="updated"
+10 IF $PIECE(IBX3,U,1,3)=IBD
DO MSG(IBY_" already exists")
SET IBF=0
End DoDot:2
if 'IBF
QUIT
+11 IF 'IBF
Begin DoDot:2
+12 SET DLAYGO=353.1
SET DIC="^IBE(353.1,"
SET DIC(0)="L"
SET X=IBA
DO FILE^DICN
+13 IF Y<1
DO MSG(" >> ERROR when adding #"_IBA_" "_IBB_" to the #353.1 file, Log a ticket!")
QUIT
+14 SET DA=+Y
SET IBMS="added"
End DoDot:2
if Y<1
QUIT
+15 SET DIE="^IBE(353.1,"
SET DR=".02///"_IBB_";.03///"_IBC
DO ^DIE
+16 SET IBCNT=IBCNT+1
DO MSG(IBY_" "_IBMS)
End DoDot:1
+17 DO MSG(" Total "_IBCNT_" code"_$SELECT(IBCNT'=1:"s",1:"")_" updated in the Place of Service (#353.1) file")
+18 DO MSG("")
+19 QUIT
+20 ;
MSG(IBZ) ;
+1 DO MES^XPDUTL(IBZ)
QUIT
+2 ;
RVCU ; Revenue code^standard abbreviation^description (1)
+1 ;;161^RM & BRD-OTHER-HOSP@HOME^RM AND BRD-OTHER-HOSPITAL@HOME
+2 ;;Q
+3 ;
OCCPU ; Occurrence Span code^name (1)
+1 ;;82^HOSP AT HOME CARE DATES
+2 ;;Q
+3 ;
POSU ; Place of Service code^name^abbreviation (1)
+1 ;;10^TELEHEALTH PROVIDED IN PATIENT'S HOME^TELEHEALTH PRVDD
+2 ;;Q
+3 ;
