IBCE837P ;EDE/JWS POST EXECUTE - OUTPUT FOR 837 TRANSMISSION - CONTINUED ;
;;2.0;INTEGRATED BILLING;**718,727,743,742,759**;21-MAR-94;Build 24
;;Per VA Directive 6402, this routine should not be modified.
;
Q
;
POST ;POST execute for 837, called by IBCE837A@POST
;FSC Work Arounds - moved from FSC to VistA
;
; WCJ;IB718v22;quit if flag is not set to do the post workarounds
Q:$G(IBXPOSTWA)'=1
;WCJ;IB718;SQA
N I,IBPID
;TPF;EBILL-2629;IB*2.0*718v20 remove EBILL-1641 (label 3 below) because of story implementation sequence issues
;JWS;EBILL-2517;IB*2.0*742; added 11 to 837 POST execute loop for PayerIDSwitches.exe VistA implementation
;JWS;EBILL-2517;IB*2.0*742; 11/1/2022: all subsequent FSC workarounds that modify PayerID MUST come after the call to 11^IBCE837Q.
; ; also, they must be performed in the documented specified order, as currently executed by FSC
F I=1,2,6,7,9,8,10 D @I
;JWS;IB*2.0*742;conditional call tag 11 to perform Payer ID switch based on value of field 8.23 in file 350.9. value of 1 is disabled
; *** NOTE: all workarounds after PayerID switches need to be performed conditionally on [23] of file 350.9
; including RemoveAB3, RemoveLCAS, RemoveAAA, SvcFacilityAddress
I '$P($G(^IBE(350.9,1,8)),"^",23) D
. N COB,IBOPID
. D 11^IBCE837Q ;Payer ID Switches implementation
. ;IB*2.0*742v6;IBPID was getting set before Payer ID Switch occurred, needed to be after.
. S IBPID=$G(^TMP("IBXDATA",$J,1,37,1,3))
. ;{start}IB*2.0*742;JWS;EBILL-1637;Remove adj reason codes AB3 on secondary Institutional claims with PayerID IPRNT
. S COB=$$COBN^IBCEF(IBXIEN)
. ; primary other payer will always be the 1st OI6 record.
. S IBOPID=$G(^TMP("IBXDATA",$J,1,114,1,4))
. I COB=2,$$FT^IBCEF(IBXIEN)=3,IBPID'="IPRNT",IBOPID="12M61",$D(^TMP("IBXDATA",$J,1,135,1,2)) D 4
. ;{end} IB*2.0*742;EBILL-1637
. ;IB*2.0*742;re-implement;IB*2.0*718;JWS;12/8/21;EBILL-1641;Incorporate FSC Override #3 - if PAYER PRIMARY ID (CI5-3) is not 'IPRNT' or 'PPRNT' and
. ; claim Adjustment Group Code (LCAS-3) is 'LQ', then delete LCAS segment
. I IBPID'="IPRNT",IBPID'="PPRNT",$D(^TMP("IBXDATA",$J,1,200,1,2)) D 3
. ;JWS;IB*2.0*742;EBILL-1645;Remove adj reason code AAA on secondary claims with PayerID not equal to IPRNT or PPRNT
. ;skip if not a secondary (Medicare Supplemental) claim and perform if there is at least 1 LCAS record
. I COB=2,IBPID'="IPRNT",IBPID'="PPRNT",$F(",12M61,SMTX1,SMDEV",","_IBOPID),$D(^TMP("IBXDATA",$J,1,200,1,2)) D 5
. ;JWS;IB*2.0*742;EBILL-2321;copy Billing Provider info to Service Facility data;this needs to be after the AB3, AAA and LCAS segment modes
. ; only perform this workaround for PPRNT and null payer ids
. I IBPID=""!(IBPID="PPRNT") D 12^IBCE837Q
. ;JWS;IB*2.0*742v7;moved DME prof claim workaround inside the PayerIdSwitches check above for testing purposes.
. ;JWS;IB*2.0*742;EBILL-2852;remove provider info from DME professional claims;
. I IBPID="SMDEV",$$FT^IBCEF(IBXIEN)=2 D 13^IBCE837Q
. Q
;
;JWS;IB*2.0*759;EBILL-2323; RemoveOtherPayerProviderInformation.exe
S IBPID=$G(^TMP("IBXDATA",$J,1,37,1,3))
;JWS;IB*2.0*759;EBILL-2324; as part of 2323 and 2324, added check of version number
I $P($P($G(^IBA(364.7,1015,1)),"IBXDATA=""",2),".")>742 D
. I IBPID="SMTX1"!(IBPID="12M61") D 14^IBCE837Q
. ;JWS;IB*2.0*759;EBILL-2324; RemoveSecondaryIDsFromClaims.exe
. I $F(",12B60,12B53,12B45,SB890,SB891,SB892,",","_IBPID_",") D 15^IBCE837Q
. ;JWS;IB*2.0*759;EBILL-3312; ClearOI14whenEqualOI23.exe
. D 16^IBCE837Q
Q
;
1 ;;IB*2.0*718;JWS;11/30/21;EBILL-1629;Incorporate FSC Override - clear PRF9 and PRF10 when there is an RX1 segment
;;for the same service line with a Service Date (refill)
N X1,X2,XLN
S X1=0 F S X1=$O(^TMP("IBXDATA",$J,1,180,X1)) Q:X1="" S XLN=$G(^TMP("IBXDATA",$J,1,180,X1,2)) I XLN D
. S X2=0 F S X2=$O(^TMP("IBXDATA",$J,1,190,X2)) Q:X2="" I XLN=$G(^TMP("IBXDATA",$J,1,190,X2,2)),$G(^TMP("IBXDATA",$J,1,190,X2,7))'="" D
.. K ^TMP("IBXDATA",$J,1,180,X1,9)
.. K ^TMP("IBXDATA",$J,1,180,X1,10)
.. Q
. Q
Q
;
2 ;;IB*2.0*718;JWS;12/8/21;EBILL-1633;Incorporate FSC Override - remove all NPIs when payer is Medicare
N IBPID,X1
S IBPID=$G(^TMP("IBXDATA",$J,1,37,1,3))
I IBPID="SMTX1"!(IBPID="12M61") D
. K ^TMP("IBXDATA",$J,1,15,1,9) ;PRV-9 : Billing Provider Primary ID
. K ^TMP("IBXDATA",$J,1,15,1,12) ;PRV-12 : Billing Provider Primary ID Qualifier
. K ^TMP("IBXDATA",$J,1,57,1,5) ;SUB2-5 : Lab/Facility Primary ID Qualifier
. K ^TMP("IBXDATA",$J,1,57,1,6) ;SUB2-6 : Lab/Facility Primary ID
. K ^TMP("IBXDATA",$J,1,97,1,2) ;OPR1-2 : Attending Prov Primary ID Qualifier
. K ^TMP("IBXDATA",$J,1,97,1,3) ;OPR1-3 : Attending Prov Primary ID
. K ^TMP("IBXDATA",$J,1,97,1,5) ;OPR1-5 : Other Operating Prov Primary ID Qualifier
. K ^TMP("IBXDATA",$J,1,97,1,6) ;OPR1-6 : Other Operating Provider Primary ID
. K ^TMP("IBXDATA",$J,1,97,1,8) ;OPR1-8 : Operating Phy Primary ID Qualifier
. K ^TMP("IBXDATA",$J,1,97,1,9) ;OPR1-9 : Operating Phy Primary ID
. K ^TMP("IBXDATA",$J,1,97,1,11) ;OPR1-11 : Referring Prov Primary ID Qualifier
. K ^TMP("IBXDATA",$J,1,97,1,12) ;OPR1-12 : Referring Provider Primary ID
. K ^TMP("IBXDATA",$J,1,103,1,6) ;OPR7-6 : Supervising Prov Primary ID Qualifier
. K ^TMP("IBXDATA",$J,1,103,1,7) ;OPR7-7 : Supervising Provider Primary ID
. K ^TMP("IBXDATA",$J,1,104.2,1,8) ;OPR9-8 : Rendering Provider Primary ID Qualifier
. K ^TMP("IBXDATA",$J,1,104.2,1,9) ;OPR9-9 : Rendering Provider Primary ID
. ;;K ^TMP("IBXDATA",$J,1,104.6,1,8) ;Asst Surgeon Primary ID Qualifier
. ;;K ^TMP("IBXDATA",$J,1,104.6,1,9) ;Asst Surgeon Primary ID
. S X1=0 F S X1=$O(^TMP("IBXDATA",$J,1,192,X1)) Q:X1="" D
.. K ^TMP("IBXDATA",$J,1,192,X1,8) ;LOPE-8 : Operating Physician Primary ID Qualifier
.. K ^TMP("IBXDATA",$J,1,192,X1,9) ;LOPE-9 : Operating Physician Primary ID
. S X1=0 F S X1=$O(^TMP("IBXDATA",$J,1,193,X1)) Q:X1="" D
.. K ^TMP("IBXDATA",$J,1,193,X1,8) ;LOP1-8 : Other Operating Provider Primary ID Qualifier
.. K ^TMP("IBXDATA",$J,1,193,X1,9) ;LOP1-9 : Other Operating Provider Primary ID
. S X1=0 F S X1=$O(^TMP("IBXDATA",$J,1,193.3,X1)) Q:X1="" D
.. K ^TMP("IBXDATA",$J,1,193.3,X1,8) ;LREN-8 : Rendering Provider Primary ID Qualifier
.. K ^TMP("IBXDATA",$J,1,193.3,X1,9) ;LREN-9 : Rendering Provider Primary ID
. S X1=0 F S X1=$O(^TMP("IBXDATA",$J,1,193.6,X1)) Q:X1="" D
.. K ^TMP("IBXDATA",$J,1,193.6,X1,4) ;LPUR-4 : Purchase Service Provider Primary ID Qualifier
.. K ^TMP("IBXDATA",$J,1,193.6,X1,5) ;LPUR-5 : Purchase Service Provider Primary ID
. S X1=0 F S X1=$O(^TMP("IBXDATA",$J,1,194,X1)) Q:X1="" D
.. K ^TMP("IBXDATA",$J,1,194,X1,8) ;LSUP-8 : Supervising Provider Primary ID Qualifier
.. K ^TMP("IBXDATA",$J,1,194,X1,9) ;LSUP-9 : Supervising Provider Primary ID
. S X1=0 F S X1=$O(^TMP("IBXDATA",$J,1,194.3,X1)) Q:X1="" D
.. K ^TMP("IBXDATA",$J,1,194.3,X1,8) ;LREF-8 : Referring Provider Primary ID Qualifier
.. K ^TMP("IBXDATA",$J,1,194.3,X1,9) ;LREF-9 : Referring Provider Primary ID
.. Q
. Q
Q
;
3 ;IB*2.0*718;JWS;12/8/21;EBILL-1641;Incorporate FSC Override #3 - if PAYER PRIMARY ID (CI5-3) is not 'IPRNT' or 'PPRNT' and claim
;;Adjustment Group Code (LCAS-3) is 'LQ', then delete LCAS segment
;;ref to var IBPID (IB Payer ID)
N X1,CNT,SEQTMP,IBLQ ;TPF;EBILL-2629;IB*2.0*718v20
S (IBLQ,CNT)=0
I $D(^TMP("IBXDATA",$J,1,200)) D
. S X1=0 F S X1=$O(^TMP("IBXDATA",$J,1,200,X1)) Q:X1="" D
.. I $G(^TMP("IBXDATA",$J,1,200,X1,3))="LQ" S IBLQ=1 K ^TMP("IBXDATA",$J,1,200,X1) Q ;TPF;EBILL-2629;IB*2.0*718v20
.. S CNT=CNT+1
.. M SEQTMP(CNT)=^TMP("IBXDATA",$J,1,200,X1)
.. Q
. Q
Q:'IBLQ
K ^TMP("IBXDATA",$J,1,200) ;TPF;EBILL-2629;IB*2.0*718v20
M ^TMP("IBXDATA",$J,1,200)=SEQTMP
Q
;
4 ;IB*2.0*742;JWS;11/15/22;EBILL-1637;remove adjustment reason code (AB3) and associated amounts when not submitted on a paper Medicare
; secondary claim. The AB3 value is used by HCCH for printing MRA files. It should only appear for IPRINT claims
N X1,I
S X1=0 F S X1=$O(^TMP("IBXDATA",$J,1,135,X1)) Q:X1="" D
. I $G(^TMP("IBXDATA",$J,1,135,X1,4))="AB3" D
.. K ^TMP("IBXDATA",$J,1,135,X1,4),^(5),^(6)
. I $G(^TMP("IBXDATA",$J,1,135,X1,7))="AB3" D
.. K ^TMP("IBXDATA",$J,1,135,X1,7),^(8),^(9)
. I $G(^TMP("IBXDATA",$J,1,135,X1,10))="AB3" D
.. K ^TMP("IBXDATA",$J,1,135,X1,10),^(11),^(12)
. I $G(^TMP("IBXDATA",$J,1,135,X1,13))="AB3" D
.. K ^TMP("IBXDATA",$J,1,135,X1,13),^(14),^(15)
. I $G(^TMP("IBXDATA",$J,1,135,X1,16))="AB3" D
.. K ^TMP("IBXDATA",$J,1,135,X1,16),^(17),^(18)
. I $G(^TMP("IBXDATA",$J,1,135,X1,19))="AB3" D
.. K ^TMP("IBXDATA",$J,1,135,X1,19),^(20),^(21)
. I $G(^TMP("IBXDATA",$J,1,135,X1,4))="",$G(^(7))="",$G(^(10))="",$G(^(13))="",$G(^(16))="",$G(^(19))="" K ^TMP("IBXDATA",$J,1,135,X1) Q
. I $G(^TMP("IBXDATA",$J,1,135,X1,4))="" D
.. F I=7,10,13,16,19 I $G(^TMP("IBXDATA",$J,1,135,X1,I))'="" D 41(4,I) Q
. I $G(^TMP("IBXDATA",$J,1,135,X1,7))="" D
.. F I=10,13,16,19 I $G(^TMP("IBXDATA",$J,1,135,X1,I))'="" D 41(7,I) Q
. I $G(^TMP("IBXDATA",$J,1,135,X1,10))="" D
.. F I=13,16,19 I $G(^TMP("IBXDATA",$J,1,135,X1,I))'="" D 41(10,I) Q
. I $G(^TMP("IBXDATA",$J,1,135,X1,13))="" D
.. F I=16,19 I $G(^TMP("IBXDATA",$J,1,135,X1,I))'="" D 41(13,I) Q
. I $G(^TMP("IBXDATA",$J,1,135,X1,16))="",$G(^TMP("IBXDATA",$J,1,135,X1,19))'="" D 41(16,19)
. Q
Q
;
41(XT,XF) ;shuffle adjustment reason codes
; XF = adj reason code field to be moved
; XT = field number of location to move the adj reason code info
S ^(XT)=^TMP("IBXDATA",$J,1,135,X1,XF),^(XT+1)=$G(^(XF+1)),^(XT+2)=$G(^(XF+2)) K ^(XF),^(XF+1),^(XF+2)
Q
;
5 ;IB*2.0*742;JWS;11/15/22;EBILL-1645;remove adjustment reason code (AAA) and associated amounts when not submitted on a paper Medicare
; secondary claim. The AAA value is used by HCCH for printing MRA files. It should only appear for IPRINT and PPRNT IDs
N X1,I
; seq=200 is LCAS segment
S X1=0 F S X1=$O(^TMP("IBXDATA",$J,1,200,X1)) Q:X1="" D
. I $G(^TMP("IBXDATA",$J,1,200,X1,4))="AAA" D
.. K ^TMP("IBXDATA",$J,1,200,X1,4),^(5),^(6)
. I $G(^TMP("IBXDATA",$J,1,200,X1,7))="AAA" D
.. K ^TMP("IBXDATA",$J,1,200,X1,7),^(8),^(9)
. I $G(^TMP("IBXDATA",$J,1,200,X1,10))="AAA" D
.. K ^TMP("IBXDATA",$J,1,200,X1,10),^(11),^(12)
. I $G(^TMP("IBXDATA",$J,1,200,X1,13))="AAA" D
.. K ^TMP("IBXDATA",$J,1,200,X1,13),^(14),^(15)
. I $G(^TMP("IBXDATA",$J,1,200,X1,16))="AAA" D
.. K ^TMP("IBXDATA",$J,1,200,X1,16),^(17),^(18)
. I $G(^TMP("IBXDATA",$J,1,200,X1,19))="AAA" D
.. K ^TMP("IBXDATA",$J,1,200,X1,19),^(20),^(21)
. I $G(^TMP("IBXDATA",$J,1,200,X1,4))="",$G(^(7))="",$G(^(10))="",$G(^(13))="",$G(^(16))="",$G(^(19))="" K ^TMP("IBXDATA",$J,1,200,X1) Q
. I $G(^TMP("IBXDATA",$J,1,200,X1,4))="" D
.. F I=7,10,13,16,19 I $G(^TMP("IBXDATA",$J,1,200,X1,I))'="" D 51(4,I) Q
. I $G(^TMP("IBXDATA",$J,1,200,X1,7))="" D
.. F I=10,13,16,19 I $G(^TMP("IBXDATA",$J,1,200,X1,I))'="" D 51(7,I) Q
. I $G(^TMP("IBXDATA",$J,1,200,X1,10))="" D
.. F I=13,16,19 I $G(^TMP("IBXDATA",$J,1,200,X1,I))'="" D 51(10,I) Q
. I $G(^TMP("IBXDATA",$J,1,200,X1,13))="" D
.. F I=16,19 I $G(^TMP("IBXDATA",$J,1,200,X1,I))'="" D 51(13,I) Q
. I $G(^TMP("IBXDATA",$J,1,200,X1,16))="",$G(^TMP("IBXDATA",$J,1,200,X1,19))'="" D 51(16,19) Q
. Q
Q
;
51(XT,XF) ;shuffle adjustment reason codes
; XF = adj reason code field to be moved
; XT = field number of location to move the adj reason code info
S ^(XT)=^TMP("IBXDATA",$J,1,200,X1,XF),^(XT+1)=$G(^(XF+1)),^(XT+2)=$G(^(XF+2)) K ^(XF),^(XF+1),^(XF+2)
Q
;
6 ;IB*2.0*727;JWS;12/14/21;EBILL-1649;remove Secondary ID and Qualifier when Second ID Qualifier = '2U' and payer is Medicare
;
N X1
S X1=0 F S X1=$O(^TMP("IBXDATA",$J,1,114,X1)) Q:X1="" D
. ;JWS;5/9/22;added payer ID 'SMDEV' (Medicare DME claims) to below list
. I $G(^TMP("IBXDATA",$J,1,114,X1,4))="12M61"!($G(^(4))="SMTX1")!($G(^(4))="SMDEV") D
.. I $G(^TMP("IBXDATA",$J,1,114,X1,5))="2U" K ^TMP("IBXDATA",$J,1,114,X1,5),^(6)
.. I $G(^TMP("IBXDATA",$J,1,114,X1,7))="2U" K ^TMP("IBXDATA",$J,1,114,X1,7),^(8)
.. Q
. Q
Q
;
7 ;IB*2.0*727;JWS;5/4/22;EBILL-1657;remove provider secondary ID and qualifer if Dest Payer is Medicare Part-A
; removes valid 5010 provider IDs that are not allowed by Medicare
N X1,X2,I
S X1=0
I $G(^TMP("IBXDATA",$J,1,37,1,3))="12M61" D ;Medicare Part A payer ID (changeHealth care)
. ;JWS;3/20/23;EBILL-3282;need to modify billing provider secondary id qualifier for Part A - just like Part B; workaround doc error
. I $G(^TMP("IBXDATA",$J,1,28,1,6))="1C" S ^(6)="G2" ;seq=28 : CI1A billing provider secondary id data
. F I=2,4,6,8 D 71(98,1,I) D ;seq=98 : OPR2 attending provider sec id
. D 72(98,1,2)
. F I=2,4,6,8 D 71(99,1,I) ;seq=99 : OPR3 operating provider sec id
. D 72(99,1,2)
. F I=2,4,6,8 D 71(100,1,I) ;seq=100 : OPR4 other operating provider sec id
. D 72(100,1,2)
. F I=2,4,6,8 D 71(104.4,1,I) ;seq=104.4 : OPRA rendering provider sec id
. D 72(104.4,1,2)
. F I=2,4,6 D 71(101,1,I) ;seq=101 : OPR5 referring provider sec id
. D 72(101,1,2)
. F I=7:1:12 K ^TMP("IBXDATA",$J,1,57,1,I) ;seq=57 : SUB2 service facility data
. S X2=0 F S X2=$O(^TMP("IBXDATA",$J,1,192,X2)) Q:X2="" D ;seq=192 : LOPE line operating physician data
.. F I=10,12,14 D 71(192,X2,I)
.. D 72(192,X2,10)
. S X2=0 F S X2=$O(^TMP("IBXDATA",$J,1,193,X2)) Q:X2="" D ;seq=193 : LOP1 line other operating physician data
.. F I=10,12,14 D 71(193,X2,I)
.. D 72(193,X2,10)
. S X2=0 F S X2=$O(^TMP("IBXDATA",$J,1,193.3,X2)) Q:X2="" D ;seq=193.3 : LREN line rendering provider data
.. F I=10,12,14 D 71(193.3,X2,I)
.. D 72(193.3,X2,10)
. S X2=0 F S X2=$O(^TMP("IBXDATA",$J,1,194.3,X2)) Q:X2="" D ;seq=194.3 : LREF line referring provider data
.. F I=10,12,14 D 71(194.3,X2,I)
.. D 72(194.3,X2,10)
. Q
Q
;
71(SEQ,REC,FLD) ;function to delete entries
I $G(^TMP("IBXDATA",$J,1,SEQ,REC,FLD))'="1G" K ^TMP("IBXDATA",$J,1,SEQ,REC,FLD),^(FLD+1)
Q
;
72(SEQ,REC,FLD) ;reshuffle entries to prevent any FSC issues; should not be necessary, but just incase it is.
I FLD=2 D
. I $G(^TMP("IBXDATA",$J,1,SEQ,REC,2))="" D
.. I $G(^TMP("IBXDATA",$J,1,SEQ,REC,4))'="" S ^(2)=^(4),^(3)=^(5) K ^(4),^(5) Q
.. I $G(^TMP("IBXDATA",$J,1,SEQ,REC,6))'="" S ^(2)=^(6),^(3)=^(7) K ^(6),^(7) Q
.. I $G(^TMP("IBXDATA",$J,1,SEQ,REC,8))'="" S ^(2)=^(8),^(3)=^(9) K ^(8),^(9) Q
. I $G(^TMP("IBXDATA",$J,1,SEQ,REC,4))="" D
.. I $G(^TMP("IBXDATA",$J,1,SEQ,REC,6))'="" S ^(4)=^(6),^(5)=^(7) K ^(6),^(7) Q
.. I $G(^TMP("IBXDATA",$J,1,SEQ,REC,8))'="" S ^(4)=^(8),^(5)=^(9) K ^(8),^(9) Q
. I SEQ=101 Q
. I $G(^TMP("IBXDATA",$J,1,SEQ,REC,6))="" D
.. I $G(^TMP("IBXDATA",$J,1,SEQ,REC,8))'="" S ^(6)=^(8),^(7)=^(9) K ^(8),^(9) Q
I FLD=10 D
. I $G(^TMP("IBXDATA",$J,1,SEQ,REC,10))="" D
.. I $G(^TMP("IBXDATA",$J,1,SEQ,REC,12))'="" S ^(10)=^(12),^(11)=^(13) K ^(12),^(13) Q
.. I $G(^TMP("IBXDATA",$J,1,SEQ,REC,14))'="" S ^(10)=^(14),^(11)=^(15) K ^(14),^(15) Q
. I $G(^TMP("IBXDATA",$J,1,SEQ,REC,12))="" D
.. I $G(^TMP("IBXDATA",$J,1,SEQ,REC,14))'="" S ^(12)=^(14),^(13)=^(15) K ^(14),^(15) Q
Q
;
8 ;TPF;IB*2.0*727;EBILL-1665;6/23/2022;Remove Remaining Patient Liability Amount and Other Payer Check Date when the Other Payer is a Primary or Secondary Payer
N X1,X2,LCOBPRIM,LCOBSEC
Q:'$D(^TMP("IBXDATA",$J,1,195)) ;NO LCOBs FOR THIS CLAIM
;GO THROUGH THE LCOB ENTRIES AND SEE IF ANY APPLY TO THESE SPECS. PROCESS ONLY ONE PRIMARY AND ONE SECONDARY LCOB
S (LCOBPRIM,LCOBSEC)=0
S X1=0 F S X1=$O(^TMP("IBXDATA",$J,1,195,X1)) Q:X1="" D Q:$G(LCOBPRIM)&(LCOBSEC) ;ONCE ONE SECONDARY AND ONE PRIMARY HAS BEEN PROCESSED QUIT
.;
.Q:$G(^TMP("IBXDATA",$J,1,195,X1,18))="T" ;DO NOT PROCESS TERTIARY LCOBS
.Q:$G(LCOBPRIM)&($G(^TMP("IBXDATA",$J,1,195,X1,18))="P") ;ALREADY PROCESSED A PRIMARY.
.Q:$G(LCOBSEC)&($G(^TMP("IBXDATA",$J,1,195,X1,18))="S") ;ALREADY PROCESSED A SECONDARY.
.S LCOBPRIM=$G(^TMP("IBXDATA",$J,1,195,X1,18))="P"
.S LCOBSEC=$G(^TMP("IBXDATA",$J,1,195,X1,18))="S"
.;seq=107 is OI1A record
.;seq=112 is OI4 record
.I LCOBPRIM D
..S X2=0 F S X2=$O(^TMP("IBXDATA",$J,1,107,X2)) Q:X2="" D
...I $G(^TMP("IBXDATA",$J,1,107,X2,2))="P" D Q
....S ^TMP("IBXDATA",$J,1,107,X2,6)=""
....S ^TMP("IBXDATA",$J,1,107,X2,7)=""
..;
..S X2=0 F S X2=$O(^TMP("IBXDATA",$J,1,112,X2)) Q:X2="" D
...I $G(^TMP("IBXDATA",$J,1,112,X2,2))="P" D Q
....S ^TMP("IBXDATA",$J,1,112,X2,8)=""
....S ^TMP("IBXDATA",$J,1,112,X2,9)=""
.;
.I LCOBSEC D
..S X2=0 F S X2=$O(^TMP("IBXDATA",$J,1,107,X2)) Q:X2="" D
...I $G(^TMP("IBXDATA",$J,1,107,X2,2))="S" D Q
....S ^TMP("IBXDATA",$J,1,107,X2,6)=""
....S ^TMP("IBXDATA",$J,1,107,X2,7)=""
..;
..S X2=0 F S X2=$O(^TMP("IBXDATA",$J,1,112,X2)) Q:X2="" D
...I $G(^TMP("IBXDATA",$J,1,112,X2,2))="S" D Q
....S ^TMP("IBXDATA",$J,1,112,X2,8)=""
....S ^TMP("IBXDATA",$J,1,112,X2,9)=""
Q
;
9 ; IB*2.0*727;JWS;5/4/22;EBILL-2602;remove or change provider secondary ID and qualifier if Dest Payer is Medicare Part B
N I,X1
I $G(^TMP("IBXDATA",$J,1,37,1,3))="SMTX1" D ;Medicare Part B payer ID (changeHealth care)
. I $G(^TMP("IBXDATA",$J,1,28,1,6))="1C" S ^(6)="G2" ;seq=28 : CI1A billing provider secondary id data
. F I=2,4,6 I $G(^TMP("IBXDATA",$J,1,101,1,I))'="1G",$G(^(I))'="0B" K ^(I),^(I+1) ;seq=101 : OPR5 referring provider secondary id
. F I=2,4,6,8 I $G(^TMP("IBXDATA",$J,1,104.4,1,I))="1C" S ^(I)="G2" ;seq=104.4 : OPRA rendering provider sec id
. F I=7:1:12 K ^TMP("IBXDATA",$J,1,57,1,I) ;seq=57 : SUB2 service facility data
. ; WCJ EBILL-3260;3/17/23;workaround documentation error, EI needed removed not changed to G2
. F I=2,4,6,8 I $G(^TMP("IBXDATA",$J,1,104,1,I))="EI" K ^(I),^(I+1) ;seq=104 : OPR8 supervising provider secondary id data
. S X1=0 F S X1=$O(^TMP("IBXDATA",$J,1,193.6,X1)) Q:X1="" D ;seq=193.6 : LPUR line purchase service provider data
.. ;JWS;8/15/22;IB*2.0*727v12;FSC workaround documentation was incorrect - Set LPUR-6 = "1G" and LPUR-7 = 'VAD001'
.. ;JWS;10/19/22;EBILL-2979;IB*2.0*727v14;should only set if LPUR line exists
.. I $G(^TMP("IBXDATA",$J,1,193.6,X1,2))'="" D
... S ^TMP("IBXDATA",$J,1,193.6,X1,6)="1G"
... S ^TMP("IBXDATA",$J,1,193.6,X1,7)="VAD001"
. S X1=0 F S X1=$O(^TMP("IBXDATA",$J,1,194,X1)) Q:X1="" D ;seq=194 : LSUP line supervising provider data
.. F I=10,12,14 I $G(^TMP("IBXDATA",$J,1,194,X1,I))="G2" K ^(I),^(I+1)
. S X1=0 F S X1=$O(^TMP("IBXDATA",$J,1,194.3,X1)) Q:X1="" D ;seq=194.3 : LREF line referring provider data
.. ;8/1/22;EBILL-2711;IB*270*727v10;JWS;was missing a not (') condition, so remove ID and qualifier if NOT = '1G'
.. F I=10,12,14 I $G(^TMP("IBXDATA",$J,1,194.3,X1,I))'="1G" K ^(I),^(I+1)
Q
;
10 ;IB*2.0*727;JWS;7/29/22;EBILL-1653;group DCx records by Diagnosis Type (DCx-3); ABK (BK) 1st, ABF (BF) 2nd grp, ABN (BN) last
; only perform this check/re-order for Institutional Claims
I $$FT^IBCEF(IBXIEN)'=3 Q
; if no DCx records, quit
I '$D(^TMP("IBXDATA",$J,1,90)) Q
; X1 is array of record 90 field values as entered by user
; X2 is entry counter
; X3 is array of Diagnosis Types by original line number
; IBDT is the Diagnosis Type found in DCx-3 (Code List Qualifier Code, i.e. ABK, ABF, ABN)
N X1,X2,X3,IBDT,XCT
M X1=^TMP("IBXDATA",$J,1,90)
S X2=1 F S X2=$O(X1(X2)) Q:X2="" S X3(X1(X2,3),X2)=""
K ^TMP("IBXDATA",$J,1,90)
M ^TMP("IBXDATA",$J,1,90,1)=X1(1)
; JWS;9/12/22;Changed to reverse $O because FSC wants External Injury codes before Other Diag codes
S IBDT="",XCT=1 F S IBDT=$O(X3(IBDT),-1) Q:IBDT="" S X2="" F S X2=$O(X3(IBDT,X2)) Q:X2="" S XCT=XCT+1,X1(X2,1)="DC"_XCT_" " M ^TMP("IBXDATA",$J,1,90,XCT)=X1(X2)
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCE837P 19930 printed Apr 09, 2024@21:27:16 Page 2
IBCE837P ;EDE/JWS POST EXECUTE - OUTPUT FOR 837 TRANSMISSION - CONTINUED ;
+1 ;;2.0;INTEGRATED BILLING;**718,727,743,742,759**;21-MAR-94;Build 24
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 QUIT
+5 ;
POST ;POST execute for 837, called by IBCE837A@POST
+1 ;FSC Work Arounds - moved from FSC to VistA
+2 ;
+3 ; WCJ;IB718v22;quit if flag is not set to do the post workarounds
+4 if $GET(IBXPOSTWA)'=1
QUIT
+5 ;WCJ;IB718;SQA
+6 NEW I,IBPID
+7 ;TPF;EBILL-2629;IB*2.0*718v20 remove EBILL-1641 (label 3 below) because of story implementation sequence issues
+8 ;JWS;EBILL-2517;IB*2.0*742; added 11 to 837 POST execute loop for PayerIDSwitches.exe VistA implementation
+9 ;JWS;EBILL-2517;IB*2.0*742; 11/1/2022: all subsequent FSC workarounds that modify PayerID MUST come after the call to 11^IBCE837Q.
+10 ; ; also, they must be performed in the documented specified order, as currently executed by FSC
+11 FOR I=1,2,6,7,9,8,10
DO @I
+12 ;JWS;IB*2.0*742;conditional call tag 11 to perform Payer ID switch based on value of field 8.23 in file 350.9. value of 1 is disabled
+13 ; *** NOTE: all workarounds after PayerID switches need to be performed conditionally on [23] of file 350.9
+14 ; including RemoveAB3, RemoveLCAS, RemoveAAA, SvcFacilityAddress
+15 IF '$PIECE($GET(^IBE(350.9,1,8)),"^",23)
Begin DoDot:1
+16 NEW COB,IBOPID
+17 ;Payer ID Switches implementation
DO 11^IBCE837Q
+18 ;IB*2.0*742v6;IBPID was getting set before Payer ID Switch occurred, needed to be after.
+19 SET IBPID=$GET(^TMP("IBXDATA",$JOB,1,37,1,3))
+20 ;{start}IB*2.0*742;JWS;EBILL-1637;Remove adj reason codes AB3 on secondary Institutional claims with PayerID IPRNT
+21 SET COB=$$COBN^IBCEF(IBXIEN)
+22 ; primary other payer will always be the 1st OI6 record.
+23 SET IBOPID=$GET(^TMP("IBXDATA",$JOB,1,114,1,4))
+24 IF COB=2
IF $$FT^IBCEF(IBXIEN)=3
IF IBPID'="IPRNT"
IF IBOPID="12M61"
IF $DATA(^TMP("IBXDATA",$JOB,1,135,1,2))
DO 4
+25 ;{end} IB*2.0*742;EBILL-1637
+26 ;IB*2.0*742;re-implement;IB*2.0*718;JWS;12/8/21;EBILL-1641;Incorporate FSC Override #3 - if PAYER PRIMARY ID (CI5-3) is not 'IPRNT' or 'PPRNT' and
+27 ; claim Adjustment Group Code (LCAS-3) is 'LQ', then delete LCAS segment
+28 IF IBPID'="IPRNT"
IF IBPID'="PPRNT"
IF $DATA(^TMP("IBXDATA",$JOB,1,200,1,2))
DO 3
+29 ;JWS;IB*2.0*742;EBILL-1645;Remove adj reason code AAA on secondary claims with PayerID not equal to IPRNT or PPRNT
+30 ;skip if not a secondary (Medicare Supplemental) claim and perform if there is at least 1 LCAS record
+31 IF COB=2
IF IBPID'="IPRNT"
IF IBPID'="PPRNT"
IF $FIND(",12M61,SMTX1,SMDEV",","_IBOPID)
IF $DATA(^TMP("IBXDATA",$JOB,1,200,1,2))
DO 5
+32 ;JWS;IB*2.0*742;EBILL-2321;copy Billing Provider info to Service Facility data;this needs to be after the AB3, AAA and LCAS segment modes
+33 ; only perform this workaround for PPRNT and null payer ids
+34 IF IBPID=""!(IBPID="PPRNT")
DO 12^IBCE837Q
+35 ;JWS;IB*2.0*742v7;moved DME prof claim workaround inside the PayerIdSwitches check above for testing purposes.
+36 ;JWS;IB*2.0*742;EBILL-2852;remove provider info from DME professional claims;
+37 IF IBPID="SMDEV"
IF $$FT^IBCEF(IBXIEN)=2
DO 13^IBCE837Q
+38 QUIT
End DoDot:1
+39 ;
+40 ;JWS;IB*2.0*759;EBILL-2323; RemoveOtherPayerProviderInformation.exe
+41 SET IBPID=$GET(^TMP("IBXDATA",$JOB,1,37,1,3))
+42 ;JWS;IB*2.0*759;EBILL-2324; as part of 2323 and 2324, added check of version number
+43 IF $PIECE($PIECE($GET(^IBA(364.7,1015,1)),"IBXDATA=""",2),".")>742
Begin DoDot:1
+44 IF IBPID="SMTX1"!(IBPID="12M61")
DO 14^IBCE837Q
+45 ;JWS;IB*2.0*759;EBILL-2324; RemoveSecondaryIDsFromClaims.exe
+46 IF $FIND(",12B60,12B53,12B45,SB890,SB891,SB892,",","_IBPID_",")
DO 15^IBCE837Q
+47 ;JWS;IB*2.0*759;EBILL-3312; ClearOI14whenEqualOI23.exe
+48 DO 16^IBCE837Q
End DoDot:1
+49 QUIT
+50 ;
1 ;;IB*2.0*718;JWS;11/30/21;EBILL-1629;Incorporate FSC Override - clear PRF9 and PRF10 when there is an RX1 segment
+1 ;;for the same service line with a Service Date (refill)
+2 NEW X1,X2,XLN
+3 SET X1=0
FOR
SET X1=$ORDER(^TMP("IBXDATA",$JOB,1,180,X1))
if X1=""
QUIT
SET XLN=$GET(^TMP("IBXDATA",$JOB,1,180,X1,2))
IF XLN
Begin DoDot:1
+4 SET X2=0
FOR
SET X2=$ORDER(^TMP("IBXDATA",$JOB,1,190,X2))
if X2=""
QUIT
IF XLN=$GET(^TMP("IBXDATA",$JOB,1,190,X2,2))
IF $GET(^TMP("IBXDATA",$JOB,1,190,X2,7))'=""
Begin DoDot:2
+5 KILL ^TMP("IBXDATA",$JOB,1,180,X1,9)
+6 KILL ^TMP("IBXDATA",$JOB,1,180,X1,10)
+7 QUIT
End DoDot:2
+8 QUIT
End DoDot:1
+9 QUIT
+10 ;
2 ;;IB*2.0*718;JWS;12/8/21;EBILL-1633;Incorporate FSC Override - remove all NPIs when payer is Medicare
+1 NEW IBPID,X1
+2 SET IBPID=$GET(^TMP("IBXDATA",$JOB,1,37,1,3))
+3 IF IBPID="SMTX1"!(IBPID="12M61")
Begin DoDot:1
+4 ;PRV-9 : Billing Provider Primary ID
KILL ^TMP("IBXDATA",$JOB,1,15,1,9)
+5 ;PRV-12 : Billing Provider Primary ID Qualifier
KILL ^TMP("IBXDATA",$JOB,1,15,1,12)
+6 ;SUB2-5 : Lab/Facility Primary ID Qualifier
KILL ^TMP("IBXDATA",$JOB,1,57,1,5)
+7 ;SUB2-6 : Lab/Facility Primary ID
KILL ^TMP("IBXDATA",$JOB,1,57,1,6)
+8 ;OPR1-2 : Attending Prov Primary ID Qualifier
KILL ^TMP("IBXDATA",$JOB,1,97,1,2)
+9 ;OPR1-3 : Attending Prov Primary ID
KILL ^TMP("IBXDATA",$JOB,1,97,1,3)
+10 ;OPR1-5 : Other Operating Prov Primary ID Qualifier
KILL ^TMP("IBXDATA",$JOB,1,97,1,5)
+11 ;OPR1-6 : Other Operating Provider Primary ID
KILL ^TMP("IBXDATA",$JOB,1,97,1,6)
+12 ;OPR1-8 : Operating Phy Primary ID Qualifier
KILL ^TMP("IBXDATA",$JOB,1,97,1,8)
+13 ;OPR1-9 : Operating Phy Primary ID
KILL ^TMP("IBXDATA",$JOB,1,97,1,9)
+14 ;OPR1-11 : Referring Prov Primary ID Qualifier
KILL ^TMP("IBXDATA",$JOB,1,97,1,11)
+15 ;OPR1-12 : Referring Provider Primary ID
KILL ^TMP("IBXDATA",$JOB,1,97,1,12)
+16 ;OPR7-6 : Supervising Prov Primary ID Qualifier
KILL ^TMP("IBXDATA",$JOB,1,103,1,6)
+17 ;OPR7-7 : Supervising Provider Primary ID
KILL ^TMP("IBXDATA",$JOB,1,103,1,7)
+18 ;OPR9-8 : Rendering Provider Primary ID Qualifier
KILL ^TMP("IBXDATA",$JOB,1,104.2,1,8)
+19 ;OPR9-9 : Rendering Provider Primary ID
KILL ^TMP("IBXDATA",$JOB,1,104.2,1,9)
+20 ;;K ^TMP("IBXDATA",$J,1,104.6,1,8) ;Asst Surgeon Primary ID Qualifier
+21 ;;K ^TMP("IBXDATA",$J,1,104.6,1,9) ;Asst Surgeon Primary ID
+22 SET X1=0
FOR
SET X1=$ORDER(^TMP("IBXDATA",$JOB,1,192,X1))
if X1=""
QUIT
Begin DoDot:2
+23 ;LOPE-8 : Operating Physician Primary ID Qualifier
KILL ^TMP("IBXDATA",$JOB,1,192,X1,8)
+24 ;LOPE-9 : Operating Physician Primary ID
KILL ^TMP("IBXDATA",$JOB,1,192,X1,9)
End DoDot:2
+25 SET X1=0
FOR
SET X1=$ORDER(^TMP("IBXDATA",$JOB,1,193,X1))
if X1=""
QUIT
Begin DoDot:2
+26 ;LOP1-8 : Other Operating Provider Primary ID Qualifier
KILL ^TMP("IBXDATA",$JOB,1,193,X1,8)
+27 ;LOP1-9 : Other Operating Provider Primary ID
KILL ^TMP("IBXDATA",$JOB,1,193,X1,9)
End DoDot:2
+28 SET X1=0
FOR
SET X1=$ORDER(^TMP("IBXDATA",$JOB,1,193.3,X1))
if X1=""
QUIT
Begin DoDot:2
+29 ;LREN-8 : Rendering Provider Primary ID Qualifier
KILL ^TMP("IBXDATA",$JOB,1,193.3,X1,8)
+30 ;LREN-9 : Rendering Provider Primary ID
KILL ^TMP("IBXDATA",$JOB,1,193.3,X1,9)
End DoDot:2
+31 SET X1=0
FOR
SET X1=$ORDER(^TMP("IBXDATA",$JOB,1,193.6,X1))
if X1=""
QUIT
Begin DoDot:2
+32 ;LPUR-4 : Purchase Service Provider Primary ID Qualifier
KILL ^TMP("IBXDATA",$JOB,1,193.6,X1,4)
+33 ;LPUR-5 : Purchase Service Provider Primary ID
KILL ^TMP("IBXDATA",$JOB,1,193.6,X1,5)
End DoDot:2
+34 SET X1=0
FOR
SET X1=$ORDER(^TMP("IBXDATA",$JOB,1,194,X1))
if X1=""
QUIT
Begin DoDot:2
+35 ;LSUP-8 : Supervising Provider Primary ID Qualifier
KILL ^TMP("IBXDATA",$JOB,1,194,X1,8)
+36 ;LSUP-9 : Supervising Provider Primary ID
KILL ^TMP("IBXDATA",$JOB,1,194,X1,9)
End DoDot:2
+37 SET X1=0
FOR
SET X1=$ORDER(^TMP("IBXDATA",$JOB,1,194.3,X1))
if X1=""
QUIT
Begin DoDot:2
+38 ;LREF-8 : Referring Provider Primary ID Qualifier
KILL ^TMP("IBXDATA",$JOB,1,194.3,X1,8)
+39 ;LREF-9 : Referring Provider Primary ID
KILL ^TMP("IBXDATA",$JOB,1,194.3,X1,9)
+40 QUIT
End DoDot:2
+41 QUIT
End DoDot:1
+42 QUIT
+43 ;
3 ;IB*2.0*718;JWS;12/8/21;EBILL-1641;Incorporate FSC Override #3 - if PAYER PRIMARY ID (CI5-3) is not 'IPRNT' or 'PPRNT' and claim
+1 ;;Adjustment Group Code (LCAS-3) is 'LQ', then delete LCAS segment
+2 ;;ref to var IBPID (IB Payer ID)
+3 ;TPF;EBILL-2629;IB*2.0*718v20
NEW X1,CNT,SEQTMP,IBLQ
+4 SET (IBLQ,CNT)=0
+5 IF $DATA(^TMP("IBXDATA",$JOB,1,200))
Begin DoDot:1
+6 SET X1=0
FOR
SET X1=$ORDER(^TMP("IBXDATA",$JOB,1,200,X1))
if X1=""
QUIT
Begin DoDot:2
+7 ;TPF;EBILL-2629;IB*2.0*718v20
IF $GET(^TMP("IBXDATA",$JOB,1,200,X1,3))="LQ"
SET IBLQ=1
KILL ^TMP("IBXDATA",$JOB,1,200,X1)
QUIT
+8 SET CNT=CNT+1
+9 MERGE SEQTMP(CNT)=^TMP("IBXDATA",$JOB,1,200,X1)
+10 QUIT
End DoDot:2
+11 QUIT
End DoDot:1
+12 if 'IBLQ
QUIT
+13 ;TPF;EBILL-2629;IB*2.0*718v20
KILL ^TMP("IBXDATA",$JOB,1,200)
+14 MERGE ^TMP("IBXDATA",$JOB,1,200)=SEQTMP
+15 QUIT
+16 ;
4 ;IB*2.0*742;JWS;11/15/22;EBILL-1637;remove adjustment reason code (AB3) and associated amounts when not submitted on a paper Medicare
+1 ; secondary claim. The AB3 value is used by HCCH for printing MRA files. It should only appear for IPRINT claims
+2 NEW X1,I
+3 SET X1=0
FOR
SET X1=$ORDER(^TMP("IBXDATA",$JOB,1,135,X1))
if X1=""
QUIT
Begin DoDot:1
+4 IF $GET(^TMP("IBXDATA",$JOB,1,135,X1,4))="AB3"
Begin DoDot:2
+5 KILL ^TMP("IBXDATA",$JOB,1,135,X1,4),^(5),^(6)
End DoDot:2
+6 IF $GET(^TMP("IBXDATA",$JOB,1,135,X1,7))="AB3"
Begin DoDot:2
+7 KILL ^TMP("IBXDATA",$JOB,1,135,X1,7),^(8),^(9)
End DoDot:2
+8 IF $GET(^TMP("IBXDATA",$JOB,1,135,X1,10))="AB3"
Begin DoDot:2
+9 KILL ^TMP("IBXDATA",$JOB,1,135,X1,10),^(11),^(12)
End DoDot:2
+10 IF $GET(^TMP("IBXDATA",$JOB,1,135,X1,13))="AB3"
Begin DoDot:2
+11 KILL ^TMP("IBXDATA",$JOB,1,135,X1,13),^(14),^(15)
End DoDot:2
+12 IF $GET(^TMP("IBXDATA",$JOB,1,135,X1,16))="AB3"
Begin DoDot:2
+13 KILL ^TMP("IBXDATA",$JOB,1,135,X1,16),^(17),^(18)
End DoDot:2
+14 IF $GET(^TMP("IBXDATA",$JOB,1,135,X1,19))="AB3"
Begin DoDot:2
+15 KILL ^TMP("IBXDATA",$JOB,1,135,X1,19),^(20),^(21)
End DoDot:2
+16 IF $GET(^TMP("IBXDATA",$JOB,1,135,X1,4))=""
IF $GET(^(7))=""
IF $GET(^(10))=""
IF $GET(^(13))=""
IF $GET(^(16))=""
IF $GET(^(19))=""
KILL ^TMP("IBXDATA",$JOB,1,135,X1)
QUIT
+17 IF $GET(^TMP("IBXDATA",$JOB,1,135,X1,4))=""
Begin DoDot:2
+18 FOR I=7,10,13,16,19
IF $GET(^TMP("IBXDATA",$JOB,1,135,X1,I))'=""
DO 41(4,I)
QUIT
End DoDot:2
+19 IF $GET(^TMP("IBXDATA",$JOB,1,135,X1,7))=""
Begin DoDot:2
+20 FOR I=10,13,16,19
IF $GET(^TMP("IBXDATA",$JOB,1,135,X1,I))'=""
DO 41(7,I)
QUIT
End DoDot:2
+21 IF $GET(^TMP("IBXDATA",$JOB,1,135,X1,10))=""
Begin DoDot:2
+22 FOR I=13,16,19
IF $GET(^TMP("IBXDATA",$JOB,1,135,X1,I))'=""
DO 41(10,I)
QUIT
End DoDot:2
+23 IF $GET(^TMP("IBXDATA",$JOB,1,135,X1,13))=""
Begin DoDot:2
+24 FOR I=16,19
IF $GET(^TMP("IBXDATA",$JOB,1,135,X1,I))'=""
DO 41(13,I)
QUIT
End DoDot:2
+25 IF $GET(^TMP("IBXDATA",$JOB,1,135,X1,16))=""
IF $GET(^TMP("IBXDATA",$JOB,1,135,X1,19))'=""
DO 41(16,19)
+26 QUIT
End DoDot:1
+27 QUIT
+28 ;
41(XT,XF) ;shuffle adjustment reason codes
+1 ; XF = adj reason code field to be moved
+2 ; XT = field number of location to move the adj reason code info
+3 SET ^(XT)=^TMP("IBXDATA",$JOB,1,135,X1,XF)
SET ^(XT+1)=$GET(^(XF+1))
SET ^(XT+2)=$GET(^(XF+2))
KILL ^(XF),^(XF+1),^(XF+2)
+4 QUIT
+5 ;
5 ;IB*2.0*742;JWS;11/15/22;EBILL-1645;remove adjustment reason code (AAA) and associated amounts when not submitted on a paper Medicare
+1 ; secondary claim. The AAA value is used by HCCH for printing MRA files. It should only appear for IPRINT and PPRNT IDs
+2 NEW X1,I
+3 ; seq=200 is LCAS segment
+4 SET X1=0
FOR
SET X1=$ORDER(^TMP("IBXDATA",$JOB,1,200,X1))
if X1=""
QUIT
Begin DoDot:1
+5 IF $GET(^TMP("IBXDATA",$JOB,1,200,X1,4))="AAA"
Begin DoDot:2
+6 KILL ^TMP("IBXDATA",$JOB,1,200,X1,4),^(5),^(6)
End DoDot:2
+7 IF $GET(^TMP("IBXDATA",$JOB,1,200,X1,7))="AAA"
Begin DoDot:2
+8 KILL ^TMP("IBXDATA",$JOB,1,200,X1,7),^(8),^(9)
End DoDot:2
+9 IF $GET(^TMP("IBXDATA",$JOB,1,200,X1,10))="AAA"
Begin DoDot:2
+10 KILL ^TMP("IBXDATA",$JOB,1,200,X1,10),^(11),^(12)
End DoDot:2
+11 IF $GET(^TMP("IBXDATA",$JOB,1,200,X1,13))="AAA"
Begin DoDot:2
+12 KILL ^TMP("IBXDATA",$JOB,1,200,X1,13),^(14),^(15)
End DoDot:2
+13 IF $GET(^TMP("IBXDATA",$JOB,1,200,X1,16))="AAA"
Begin DoDot:2
+14 KILL ^TMP("IBXDATA",$JOB,1,200,X1,16),^(17),^(18)
End DoDot:2
+15 IF $GET(^TMP("IBXDATA",$JOB,1,200,X1,19))="AAA"
Begin DoDot:2
+16 KILL ^TMP("IBXDATA",$JOB,1,200,X1,19),^(20),^(21)
End DoDot:2
+17 IF $GET(^TMP("IBXDATA",$JOB,1,200,X1,4))=""
IF $GET(^(7))=""
IF $GET(^(10))=""
IF $GET(^(13))=""
IF $GET(^(16))=""
IF $GET(^(19))=""
KILL ^TMP("IBXDATA",$JOB,1,200,X1)
QUIT
+18 IF $GET(^TMP("IBXDATA",$JOB,1,200,X1,4))=""
Begin DoDot:2
+19 FOR I=7,10,13,16,19
IF $GET(^TMP("IBXDATA",$JOB,1,200,X1,I))'=""
DO 51(4,I)
QUIT
End DoDot:2
+20 IF $GET(^TMP("IBXDATA",$JOB,1,200,X1,7))=""
Begin DoDot:2
+21 FOR I=10,13,16,19
IF $GET(^TMP("IBXDATA",$JOB,1,200,X1,I))'=""
DO 51(7,I)
QUIT
End DoDot:2
+22 IF $GET(^TMP("IBXDATA",$JOB,1,200,X1,10))=""
Begin DoDot:2
+23 FOR I=13,16,19
IF $GET(^TMP("IBXDATA",$JOB,1,200,X1,I))'=""
DO 51(10,I)
QUIT
End DoDot:2
+24 IF $GET(^TMP("IBXDATA",$JOB,1,200,X1,13))=""
Begin DoDot:2
+25 FOR I=16,19
IF $GET(^TMP("IBXDATA",$JOB,1,200,X1,I))'=""
DO 51(13,I)
QUIT
End DoDot:2
+26 IF $GET(^TMP("IBXDATA",$JOB,1,200,X1,16))=""
IF $GET(^TMP("IBXDATA",$JOB,1,200,X1,19))'=""
DO 51(16,19)
QUIT
+27 QUIT
End DoDot:1
+28 QUIT
+29 ;
51(XT,XF) ;shuffle adjustment reason codes
+1 ; XF = adj reason code field to be moved
+2 ; XT = field number of location to move the adj reason code info
+3 SET ^(XT)=^TMP("IBXDATA",$JOB,1,200,X1,XF)
SET ^(XT+1)=$GET(^(XF+1))
SET ^(XT+2)=$GET(^(XF+2))
KILL ^(XF),^(XF+1),^(XF+2)
+4 QUIT
+5 ;
6 ;IB*2.0*727;JWS;12/14/21;EBILL-1649;remove Secondary ID and Qualifier when Second ID Qualifier = '2U' and payer is Medicare
+1 ;
+2 NEW X1
+3 SET X1=0
FOR
SET X1=$ORDER(^TMP("IBXDATA",$JOB,1,114,X1))
if X1=""
QUIT
Begin DoDot:1
+4 ;JWS;5/9/22;added payer ID 'SMDEV' (Medicare DME claims) to below list
+5 IF $GET(^TMP("IBXDATA",$JOB,1,114,X1,4))="12M61"!($GET(^(4))="SMTX1")!($GET(^(4))="SMDEV")
Begin DoDot:2
+6 IF $GET(^TMP("IBXDATA",$JOB,1,114,X1,5))="2U"
KILL ^TMP("IBXDATA",$JOB,1,114,X1,5),^(6)
+7 IF $GET(^TMP("IBXDATA",$JOB,1,114,X1,7))="2U"
KILL ^TMP("IBXDATA",$JOB,1,114,X1,7),^(8)
+8 QUIT
End DoDot:2
+9 QUIT
End DoDot:1
+10 QUIT
+11 ;
7 ;IB*2.0*727;JWS;5/4/22;EBILL-1657;remove provider secondary ID and qualifer if Dest Payer is Medicare Part-A
+1 ; removes valid 5010 provider IDs that are not allowed by Medicare
+2 NEW X1,X2,I
+3 SET X1=0
+4 ;Medicare Part A payer ID (changeHealth care)
IF $GET(^TMP("IBXDATA",$JOB,1,37,1,3))="12M61"
Begin DoDot:1
+5 ;JWS;3/20/23;EBILL-3282;need to modify billing provider secondary id qualifier for Part A - just like Part B; workaround doc error
+6 ;seq=28 : CI1A billing provider secondary id data
IF $GET(^TMP("IBXDATA",$JOB,1,28,1,6))="1C"
SET ^(6)="G2"
+7 ;seq=98 : OPR2 attending provider sec id
FOR I=2,4,6,8
DO 71(98,1,I)
Begin DoDot:2
End DoDot:2
+8 DO 72(98,1,2)
+9 ;seq=99 : OPR3 operating provider sec id
FOR I=2,4,6,8
DO 71(99,1,I)
+10 DO 72(99,1,2)
+11 ;seq=100 : OPR4 other operating provider sec id
FOR I=2,4,6,8
DO 71(100,1,I)
+12 DO 72(100,1,2)
+13 ;seq=104.4 : OPRA rendering provider sec id
FOR I=2,4,6,8
DO 71(104.4,1,I)
+14 DO 72(104.4,1,2)
+15 ;seq=101 : OPR5 referring provider sec id
FOR I=2,4,6
DO 71(101,1,I)
+16 DO 72(101,1,2)
+17 ;seq=57 : SUB2 service facility data
FOR I=7:1:12
KILL ^TMP("IBXDATA",$JOB,1,57,1,I)
+18 ;seq=192 : LOPE line operating physician data
SET X2=0
FOR
SET X2=$ORDER(^TMP("IBXDATA",$JOB,1,192,X2))
if X2=""
QUIT
Begin DoDot:2
+19 FOR I=10,12,14
DO 71(192,X2,I)
+20 DO 72(192,X2,10)
End DoDot:2
+21 ;seq=193 : LOP1 line other operating physician data
SET X2=0
FOR
SET X2=$ORDER(^TMP("IBXDATA",$JOB,1,193,X2))
if X2=""
QUIT
Begin DoDot:2
+22 FOR I=10,12,14
DO 71(193,X2,I)
+23 DO 72(193,X2,10)
End DoDot:2
+24 ;seq=193.3 : LREN line rendering provider data
SET X2=0
FOR
SET X2=$ORDER(^TMP("IBXDATA",$JOB,1,193.3,X2))
if X2=""
QUIT
Begin DoDot:2
+25 FOR I=10,12,14
DO 71(193.3,X2,I)
+26 DO 72(193.3,X2,10)
End DoDot:2
+27 ;seq=194.3 : LREF line referring provider data
SET X2=0
FOR
SET X2=$ORDER(^TMP("IBXDATA",$JOB,1,194.3,X2))
if X2=""
QUIT
Begin DoDot:2
+28 FOR I=10,12,14
DO 71(194.3,X2,I)
+29 DO 72(194.3,X2,10)
End DoDot:2
+30 QUIT
End DoDot:1
+31 QUIT
+32 ;
71(SEQ,REC,FLD) ;function to delete entries
+1 IF $GET(^TMP("IBXDATA",$JOB,1,SEQ,REC,FLD))'="1G"
KILL ^TMP("IBXDATA",$JOB,1,SEQ,REC,FLD),^(FLD+1)
+2 QUIT
+3 ;
72(SEQ,REC,FLD) ;reshuffle entries to prevent any FSC issues; should not be necessary, but just incase it is.
+1 IF FLD=2
Begin DoDot:1
+2 IF $GET(^TMP("IBXDATA",$JOB,1,SEQ,REC,2))=""
Begin DoDot:2
+3 IF $GET(^TMP("IBXDATA",$JOB,1,SEQ,REC,4))'=""
SET ^(2)=^(4)
SET ^(3)=^(5)
KILL ^(4),^(5)
QUIT
+4 IF $GET(^TMP("IBXDATA",$JOB,1,SEQ,REC,6))'=""
SET ^(2)=^(6)
SET ^(3)=^(7)
KILL ^(6),^(7)
QUIT
+5 IF $GET(^TMP("IBXDATA",$JOB,1,SEQ,REC,8))'=""
SET ^(2)=^(8)
SET ^(3)=^(9)
KILL ^(8),^(9)
QUIT
End DoDot:2
+6 IF $GET(^TMP("IBXDATA",$JOB,1,SEQ,REC,4))=""
Begin DoDot:2
+7 IF $GET(^TMP("IBXDATA",$JOB,1,SEQ,REC,6))'=""
SET ^(4)=^(6)
SET ^(5)=^(7)
KILL ^(6),^(7)
QUIT
+8 IF $GET(^TMP("IBXDATA",$JOB,1,SEQ,REC,8))'=""
SET ^(4)=^(8)
SET ^(5)=^(9)
KILL ^(8),^(9)
QUIT
End DoDot:2
+9 IF SEQ=101
QUIT
+10 IF $GET(^TMP("IBXDATA",$JOB,1,SEQ,REC,6))=""
Begin DoDot:2
+11 IF $GET(^TMP("IBXDATA",$JOB,1,SEQ,REC,8))'=""
SET ^(6)=^(8)
SET ^(7)=^(9)
KILL ^(8),^(9)
QUIT
End DoDot:2
End DoDot:1
+12 IF FLD=10
Begin DoDot:1
+13 IF $GET(^TMP("IBXDATA",$JOB,1,SEQ,REC,10))=""
Begin DoDot:2
+14 IF $GET(^TMP("IBXDATA",$JOB,1,SEQ,REC,12))'=""
SET ^(10)=^(12)
SET ^(11)=^(13)
KILL ^(12),^(13)
QUIT
+15 IF $GET(^TMP("IBXDATA",$JOB,1,SEQ,REC,14))'=""
SET ^(10)=^(14)
SET ^(11)=^(15)
KILL ^(14),^(15)
QUIT
End DoDot:2
+16 IF $GET(^TMP("IBXDATA",$JOB,1,SEQ,REC,12))=""
Begin DoDot:2
+17 IF $GET(^TMP("IBXDATA",$JOB,1,SEQ,REC,14))'=""
SET ^(12)=^(14)
SET ^(13)=^(15)
KILL ^(14),^(15)
QUIT
End DoDot:2
End DoDot:1
+18 QUIT
+19 ;
8 ;TPF;IB*2.0*727;EBILL-1665;6/23/2022;Remove Remaining Patient Liability Amount and Other Payer Check Date when the Other Payer is a Primary or Secondary Payer
+1 NEW X1,X2,LCOBPRIM,LCOBSEC
+2 ;NO LCOBs FOR THIS CLAIM
if '$DATA(^TMP("IBXDATA",$JOB,1,195))
QUIT
+3 ;GO THROUGH THE LCOB ENTRIES AND SEE IF ANY APPLY TO THESE SPECS. PROCESS ONLY ONE PRIMARY AND ONE SECONDARY LCOB
+4 SET (LCOBPRIM,LCOBSEC)=0
+5 ;ONCE ONE SECONDARY AND ONE PRIMARY HAS BEEN PROCESSED QUIT
SET X1=0
FOR
SET X1=$ORDER(^TMP("IBXDATA",$JOB,1,195,X1))
if X1=""
QUIT
Begin DoDot:1
+6 ;
+7 ;DO NOT PROCESS TERTIARY LCOBS
if $GET(^TMP("IBXDATA",$JOB,1,195,X1,18))="T"
QUIT
+8 ;ALREADY PROCESSED A PRIMARY.
if $GET(LCOBPRIM)&($GET(^TMP("IBXDATA",$JOB,1,195,X1,18))="P")
QUIT
+9 ;ALREADY PROCESSED A SECONDARY.
if $GET(LCOBSEC)&($GET(^TMP("IBXDATA",$JOB,1,195,X1,18))="S")
QUIT
+10 SET LCOBPRIM=$GET(^TMP("IBXDATA",$JOB,1,195,X1,18))="P"
+11 SET LCOBSEC=$GET(^TMP("IBXDATA",$JOB,1,195,X1,18))="S"
+12 ;seq=107 is OI1A record
+13 ;seq=112 is OI4 record
+14 IF LCOBPRIM
Begin DoDot:2
+15 SET X2=0
FOR
SET X2=$ORDER(^TMP("IBXDATA",$JOB,1,107,X2))
if X2=""
QUIT
Begin DoDot:3
+16 IF $GET(^TMP("IBXDATA",$JOB,1,107,X2,2))="P"
Begin DoDot:4
+17 SET ^TMP("IBXDATA",$JOB,1,107,X2,6)=""
+18 SET ^TMP("IBXDATA",$JOB,1,107,X2,7)=""
End DoDot:4
QUIT
End DoDot:3
+19 ;
+20 SET X2=0
FOR
SET X2=$ORDER(^TMP("IBXDATA",$JOB,1,112,X2))
if X2=""
QUIT
Begin DoDot:3
+21 IF $GET(^TMP("IBXDATA",$JOB,1,112,X2,2))="P"
Begin DoDot:4
+22 SET ^TMP("IBXDATA",$JOB,1,112,X2,8)=""
+23 SET ^TMP("IBXDATA",$JOB,1,112,X2,9)=""
End DoDot:4
QUIT
End DoDot:3
End DoDot:2
+24 ;
+25 IF LCOBSEC
Begin DoDot:2
+26 SET X2=0
FOR
SET X2=$ORDER(^TMP("IBXDATA",$JOB,1,107,X2))
if X2=""
QUIT
Begin DoDot:3
+27 IF $GET(^TMP("IBXDATA",$JOB,1,107,X2,2))="S"
Begin DoDot:4
+28 SET ^TMP("IBXDATA",$JOB,1,107,X2,6)=""
+29 SET ^TMP("IBXDATA",$JOB,1,107,X2,7)=""
End DoDot:4
QUIT
End DoDot:3
+30 ;
+31 SET X2=0
FOR
SET X2=$ORDER(^TMP("IBXDATA",$JOB,1,112,X2))
if X2=""
QUIT
Begin DoDot:3
+32 IF $GET(^TMP("IBXDATA",$JOB,1,112,X2,2))="S"
Begin DoDot:4
+33 SET ^TMP("IBXDATA",$JOB,1,112,X2,8)=""
+34 SET ^TMP("IBXDATA",$JOB,1,112,X2,9)=""
End DoDot:4
QUIT
End DoDot:3
End DoDot:2
End DoDot:1
if $GET(LCOBPRIM)&(LCOBSEC)
QUIT
+35 QUIT
+36 ;
9 ; IB*2.0*727;JWS;5/4/22;EBILL-2602;remove or change provider secondary ID and qualifier if Dest Payer is Medicare Part B
+1 NEW I,X1
+2 ;Medicare Part B payer ID (changeHealth care)
IF $GET(^TMP("IBXDATA",$JOB,1,37,1,3))="SMTX1"
Begin DoDot:1
+3 ;seq=28 : CI1A billing provider secondary id data
IF $GET(^TMP("IBXDATA",$JOB,1,28,1,6))="1C"
SET ^(6)="G2"
+4 ;seq=101 : OPR5 referring provider secondary id
FOR I=2,4,6
IF $GET(^TMP("IBXDATA",$JOB,1,101,1,I))'="1G"
IF $GET(^(I))'="0B"
KILL ^(I),^(I+1)
+5 ;seq=104.4 : OPRA rendering provider sec id
FOR I=2,4,6,8
IF $GET(^TMP("IBXDATA",$JOB,1,104.4,1,I))="1C"
SET ^(I)="G2"
+6 ;seq=57 : SUB2 service facility data
FOR I=7:1:12
KILL ^TMP("IBXDATA",$JOB,1,57,1,I)
+7 ; WCJ EBILL-3260;3/17/23;workaround documentation error, EI needed removed not changed to G2
+8 ;seq=104 : OPR8 supervising provider secondary id data
FOR I=2,4,6,8
IF $GET(^TMP("IBXDATA",$JOB,1,104,1,I))="EI"
KILL ^(I),^(I+1)
+9 ;seq=193.6 : LPUR line purchase service provider data
SET X1=0
FOR
SET X1=$ORDER(^TMP("IBXDATA",$JOB,1,193.6,X1))
if X1=""
QUIT
Begin DoDot:2
+10 ;JWS;8/15/22;IB*2.0*727v12;FSC workaround documentation was incorrect - Set LPUR-6 = "1G" and LPUR-7 = 'VAD001'
+11 ;JWS;10/19/22;EBILL-2979;IB*2.0*727v14;should only set if LPUR line exists
+12 IF $GET(^TMP("IBXDATA",$JOB,1,193.6,X1,2))'=""
Begin DoDot:3
+13 SET ^TMP("IBXDATA",$JOB,1,193.6,X1,6)="1G"
+14 SET ^TMP("IBXDATA",$JOB,1,193.6,X1,7)="VAD001"
End DoDot:3
End DoDot:2
+15 ;seq=194 : LSUP line supervising provider data
SET X1=0
FOR
SET X1=$ORDER(^TMP("IBXDATA",$JOB,1,194,X1))
if X1=""
QUIT
Begin DoDot:2
+16 FOR I=10,12,14
IF $GET(^TMP("IBXDATA",$JOB,1,194,X1,I))="G2"
KILL ^(I),^(I+1)
End DoDot:2
+17 ;seq=194.3 : LREF line referring provider data
SET X1=0
FOR
SET X1=$ORDER(^TMP("IBXDATA",$JOB,1,194.3,X1))
if X1=""
QUIT
Begin DoDot:2
+18 ;8/1/22;EBILL-2711;IB*270*727v10;JWS;was missing a not (') condition, so remove ID and qualifier if NOT = '1G'
+19 FOR I=10,12,14
IF $GET(^TMP("IBXDATA",$JOB,1,194.3,X1,I))'="1G"
KILL ^(I),^(I+1)
End DoDot:2
End DoDot:1
+20 QUIT
+21 ;
10 ;IB*2.0*727;JWS;7/29/22;EBILL-1653;group DCx records by Diagnosis Type (DCx-3); ABK (BK) 1st, ABF (BF) 2nd grp, ABN (BN) last
+1 ; only perform this check/re-order for Institutional Claims
+2 IF $$FT^IBCEF(IBXIEN)'=3
QUIT
+3 ; if no DCx records, quit
+4 IF '$DATA(^TMP("IBXDATA",$JOB,1,90))
QUIT
+5 ; X1 is array of record 90 field values as entered by user
+6 ; X2 is entry counter
+7 ; X3 is array of Diagnosis Types by original line number
+8 ; IBDT is the Diagnosis Type found in DCx-3 (Code List Qualifier Code, i.e. ABK, ABF, ABN)
+9 NEW X1,X2,X3,IBDT,XCT
+10 MERGE X1=^TMP("IBXDATA",$JOB,1,90)
+11 SET X2=1
FOR
SET X2=$ORDER(X1(X2))
if X2=""
QUIT
SET X3(X1(X2,3),X2)=""
+12 KILL ^TMP("IBXDATA",$JOB,1,90)
+13 MERGE ^TMP("IBXDATA",$JOB,1,90,1)=X1(1)
+14 ; JWS;9/12/22;Changed to reverse $O because FSC wants External Injury codes before Other Diag codes
+15 SET IBDT=""
SET XCT=1
FOR
SET IBDT=$ORDER(X3(IBDT),-1)
if IBDT=""
QUIT
SET X2=""
FOR
SET X2=$ORDER(X3(IBDT,X2))
if X2=""
QUIT
SET XCT=XCT+1
SET X1(X2,1)="DC"_XCT_" "
MERGE ^TMP("IBXDATA",$JOB,1,90,XCT)=X1(X2)
+16 QUIT
+17 ;
