IB20P613 ;ALB/CXW - UPDATE MCCR UTILITY FILE ;01/02/2017
;;2.0;INTEGRATED BILLING;**613**;21-MAR-94;Build 28
;;Per VA Directive 6402, this routine should not be modified.
Q
POST ;
; 2018 Update condition/occurrence/value codes in #399.1
N IBZ,U S U="^"
D MSG(" IB*2.0*613 Post-Install starts .....")
D MCR
D MSG(" IB*2.0*613 Post-Install is complete.")
Q
;
MCR ; 3 types of codes
N IBCNT,IBCOD,IBPE,IBFD,IBI,IBX
S IBCNT=0
; Condition code flag in field #.22/piece 15
S IBPE=15,IBFD=.22
D MSG(""),MSG(" >>>Condition Code")
F IBI=1:1 S IBX=$P($T(CONU+IBI),";;",2) Q:IBX="Q" D MFILE
; Remove A7 or A8 pointer in field #.01/subfile #399.04/file #399
D RMCON
;
; Occurrence code flag in field #.11/piece 4
S IBPE=4,IBFD=.11
D MSG(""),MSG(" >>>Occurrence Code")
F IBI=1:1 S IBX=$P($T(OCCPU+IBI),";;",2) Q:IBX="Q" D MFILE
;
; Value code flag 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("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,DIK,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",IBC=2:"removed",1:"added")
S IBY=" #"_IBA_" "_IBB
S IBFN=+$$EXCODE(IBA,IBPE)
I 'IBFN,IBC=2 D MSG(IBY_" already removed") Q
I IBFN D Q:'IBFN
. S DA=IBFN
. S IBX3=$G(^DGCR(399.1,IBFN,0))
. S IBX2=IBB_U_IBA
. I IBC'=2,$P(IBX3,U,1,2)=IBX2 S IBFN=0 D MSG(IBY_" already exists") Q
. I IBC=1 Q
. S IBCOD(IBFN)="",DIK="^DGCR(399.1," D ^DIK
. S IBFN=0,IBCNT=IBCNT+1
. D MSG(IBY_" "_IBMS)
;
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",IBPE=15:"Condition",1:"Occurrence")_" Code #"_IBA_" to the #399.1 file, Log a ticket!") Q
. S DA=+Y
; add value code amount by override flag
S DIE="^DGCR(399.1,",DR=".01///"_IBB_";.02///"_IBA_";"_IBFD_"///1"
S:IBPE=11 DR=DR_";.19////1" D ^DIE
S IBCNT=IBCNT+1
D MSG(IBY_" "_IBMS)
Q
;
RMCON ; Remove A7 or A8 pointer on bill entry
; - bill# & pointer store in xtmp for 30 days for tracking purpose
; - xtmp(patch#,0)=purge dt^today dt^patch#^total bill
; - xtmp(patch#,file#,ibien,conien)=bill#^pointer
N IB613,IBC,IBI,IBFN,IBMS,IBX,IBY,DIE,DR,DT,X,X1,X2,Y
S IBI=0,IB613="IB20P613"
S DT=$$DT^XLFDT,X1=DT,X2=30 D C^%DTC
K ^XTMP(IB613)
S ^XTMP(IB613,0)=X_U_DT_U_"IB*2.0*613 POST-INIT"_U_0
I $O(IBCOD(0))="" G RMCONQ
S IBX=0 F S IBX=$O(^DGCR(399,IBX)) Q:'IBX D
. S IBMS=$G(^DGCR(399,IBX,0)) Q:IBMS=""
. ; effective date 03/16/2011 of a7 & a8 with name
. Q:$P(IBMS,U,3)<3110316
. S (IBFN,IBY)=0 F S IBY=$O(^DGCR(399,IBX,"CC",IBY)) Q:'IBY D
.. S IBC=$G(^DGCR(399,IBX,"CC",IBY,0)) Q:'IBC
.. Q:'$D(IBCOD(IBC))
.. S DA(1)=IBX,DA=IBY,IBFN=1
.. S DIK="^DGCR(399,"_DA(1)_","_"""CC"""_"," D ^DIK
.. S ^XTMP(IB613,399,IBX,IBY)=$P($G(^DGCR(399,IBX,0)),U,1)_U_IBC
. S:IBFN IBI=IBI+1
S $P(^XTMP(IB613,0),U,4)=IBI
RMCONQ D MSG(" Note: #A7 or #A8 removed on total "_IBI_" bill"_$S(IBI'=1:"s",1:"")_" of the BILL/CLAIMS (#399) file")
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
;
CONU ; Condition code (5)^name^update or remove
;;30^QUALIFY CLINICAL TRIALS^1
;;A7^RZD FOR NATIONAL ASSIGNMENT^2
;;A8^RZD FOR NATIONAL ASSIGNMENT^2
;;M3^SNF 3 DAY STAY BYPASS FOR NG/PIONEER ACD WAIVER
;;MG^GRANDFATHERED TRIBAL FQHC (MEDICARE ONLY CODE)
;;Q
;
OCCPU ; Occurrence code (1)^name^update
;;56^ORIGINAL HOSPICE ELECTION OR REVOCATION DATE^1
;;Q
;
VALU ; Value code (4)^name
;;62^HHA VISITS - PART A
;;63^HHA VISITS - PART B
;;64^HHA REIMBURSEMENT - PART A
;;65^HHA REIMBURSEMENT - PART B
;;Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIB20P613 4102 printed Dec 13, 2024@02:04:04 Page 2
IB20P613 ;ALB/CXW - UPDATE MCCR UTILITY FILE ;01/02/2017
+1 ;;2.0;INTEGRATED BILLING;**613**;21-MAR-94;Build 28
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 QUIT
POST ;
+1 ; 2018 Update condition/occurrence/value codes in #399.1
+2 NEW IBZ,U
SET U="^"
+3 DO MSG(" IB*2.0*613 Post-Install starts .....")
+4 DO MCR
+5 DO MSG(" IB*2.0*613 Post-Install is complete.")
+6 QUIT
+7 ;
MCR ; 3 types of codes
+1 NEW IBCNT,IBCOD,IBPE,IBFD,IBI,IBX
+2 SET IBCNT=0
+3 ; Condition code flag in field #.22/piece 15
+4 SET IBPE=15
SET IBFD=.22
+5 DO MSG("")
DO MSG(" >>>Condition Code")
+6 FOR IBI=1:1
SET IBX=$PIECE($TEXT(CONU+IBI),";;",2)
if IBX="Q"
QUIT
DO MFILE
+7 ; Remove A7 or A8 pointer in field #.01/subfile #399.04/file #399
+8 DO RMCON
+9 ;
+10 ; Occurrence code flag in field #.11/piece 4
+11 SET IBPE=4
SET IBFD=.11
+12 DO MSG("")
DO MSG(" >>>Occurrence Code")
+13 FOR IBI=1:1
SET IBX=$PIECE($TEXT(OCCPU+IBI),";;",2)
if IBX="Q"
QUIT
DO MFILE
+14 ;
+15 ; Value code flag in field #.18/piece 11
+16 SET IBPE=11
SET IBFD=.18
+17 DO MSG("")
DO MSG(" >>>Value Code")
+18 FOR IBI=1:1
SET IBX=$PIECE($TEXT(VALU+IBI),";;",2)
if IBX="Q"
QUIT
DO MFILE
+19 DO MSG("Total "_IBCNT_" code"_$SELECT(IBCNT'=1:"s",1:"")_" updated in the MCCR UTILITY (#399.1) file")
+20 DO MSG("")
+21 QUIT
+22 ;
MFILE ; Update to the mccr utility file
+1 NEW IBA,IBB,IBC,IBFN,IBMS,IBX2,IBX3,IBY,DLAYGO,DIC,DIE,DIK,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",IBC=2:"removed",1:"added")
+4 SET IBY=" #"_IBA_" "_IBB
+5 SET IBFN=+$$EXCODE(IBA,IBPE)
+6 IF 'IBFN
IF IBC=2
DO MSG(IBY_" already removed")
QUIT
+7 IF IBFN
Begin DoDot:1
+8 SET DA=IBFN
+9 SET IBX3=$GET(^DGCR(399.1,IBFN,0))
+10 SET IBX2=IBB_U_IBA
+11 IF IBC'=2
IF $PIECE(IBX3,U,1,2)=IBX2
SET IBFN=0
DO MSG(IBY_" already exists")
QUIT
+12 IF IBC=1
QUIT
+13 SET IBCOD(IBFN)=""
SET DIK="^DGCR(399.1,"
DO ^DIK
+14 SET IBFN=0
SET IBCNT=IBCNT+1
+15 DO MSG(IBY_" "_IBMS)
End DoDot:1
if 'IBFN
QUIT
+16 ;
+17 IF 'IBFN
Begin DoDot:1
+18 SET DLAYGO=399.1
SET DIC="^DGCR(399.1,"
SET DIC(0)="L"
SET X=IBB
DO FILE^DICN
+19 IF Y<1
DO MSG(" >> ERROR when adding "_$SELECT(IBPE=11:"Value",IBPE=15:"Condition",1:"Occurrence")_" Code #"_IBA_" to the #399.1 file, Log a ticket!")
QUIT
+20 SET DA=+Y
End DoDot:1
if Y<1
QUIT
+21 ; add value code amount by override flag
+22 SET DIE="^DGCR(399.1,"
SET DR=".01///"_IBB_";.02///"_IBA_";"_IBFD_"///1"
+23 if IBPE=11
SET DR=DR_";.19////1"
DO ^DIE
+24 SET IBCNT=IBCNT+1
+25 DO MSG(IBY_" "_IBMS)
+26 QUIT
+27 ;
RMCON ; Remove A7 or A8 pointer on bill entry
+1 ; - bill# & pointer store in xtmp for 30 days for tracking purpose
+2 ; - xtmp(patch#,0)=purge dt^today dt^patch#^total bill
+3 ; - xtmp(patch#,file#,ibien,conien)=bill#^pointer
+4 NEW IB613,IBC,IBI,IBFN,IBMS,IBX,IBY,DIE,DR,DT,X,X1,X2,Y
+5 SET IBI=0
SET IB613="IB20P613"
+6 SET DT=$$DT^XLFDT
SET X1=DT
SET X2=30
DO C^%DTC
+7 KILL ^XTMP(IB613)
+8 SET ^XTMP(IB613,0)=X_U_DT_U_"IB*2.0*613 POST-INIT"_U_0
+9 IF $ORDER(IBCOD(0))=""
GOTO RMCONQ
+10 SET IBX=0
FOR
SET IBX=$ORDER(^DGCR(399,IBX))
if 'IBX
QUIT
Begin DoDot:1
+11 SET IBMS=$GET(^DGCR(399,IBX,0))
if IBMS=""
QUIT
+12 ; effective date 03/16/2011 of a7 & a8 with name
+13 if $PIECE(IBMS,U,3)<3110316
QUIT
+14 SET (IBFN,IBY)=0
FOR
SET IBY=$ORDER(^DGCR(399,IBX,"CC",IBY))
if 'IBY
QUIT
Begin DoDot:2
+15 SET IBC=$GET(^DGCR(399,IBX,"CC",IBY,0))
if 'IBC
QUIT
+16 if '$DATA(IBCOD(IBC))
QUIT
+17 SET DA(1)=IBX
SET DA=IBY
SET IBFN=1
+18 SET DIK="^DGCR(399,"_DA(1)_","_"""CC"""_","
DO ^DIK
+19 SET ^XTMP(IB613,399,IBX,IBY)=$PIECE($GET(^DGCR(399,IBX,0)),U,1)_U_IBC
End DoDot:2
+20 if IBFN
SET IBI=IBI+1
End DoDot:1
+21 SET $PIECE(^XTMP(IB613,0),U,4)=IBI
RMCONQ DO MSG(" Note: #A7 or #A8 removed on total "_IBI_" bill"_$SELECT(IBI'=1:"s",1:"")_" of the BILL/CLAIMS (#399) file")
+1 QUIT
+2 ;
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 ;
CONU ; Condition code (5)^name^update or remove
+1 ;;30^QUALIFY CLINICAL TRIALS^1
+2 ;;A7^RZD FOR NATIONAL ASSIGNMENT^2
+3 ;;A8^RZD FOR NATIONAL ASSIGNMENT^2
+4 ;;M3^SNF 3 DAY STAY BYPASS FOR NG/PIONEER ACD WAIVER
+5 ;;MG^GRANDFATHERED TRIBAL FQHC (MEDICARE ONLY CODE)
+6 ;;Q
+7 ;
OCCPU ; Occurrence code (1)^name^update
+1 ;;56^ORIGINAL HOSPICE ELECTION OR REVOCATION DATE^1
+2 ;;Q
+3 ;
VALU ; Value code (4)^name
+1 ;;62^HHA VISITS - PART A
+2 ;;63^HHA VISITS - PART B
+3 ;;64^HHA REIMBURSEMENT - PART A
+4 ;;65^HHA REIMBURSEMENT - PART B
+5 ;;Q
+6 ;
