- IBCF23A ;ALB/ARH - HCFA 1500 19-90 DATA - Split from IBCF23 ;12-JUN-93
- ;;2.0;INTEGRATED BILLING;**51,432,516,547,577,592,608,623**;21-MAR-94;Build 70
- ;;Per VA Directive 6402, this routine should not be modified.
- ;
- ; $$INSTALDT^XPDUTL(IBPATCH,.IBARY) - ICR 10141
- ;
- B24 ; set individual entries in print array, external format
- ; IBAUX = additional data for EDI output
- ; IBRXF = array of RX procedures
- ;JWS;IB*2.0*592;US131
- ; IBDEN = Dental data for EDI output
- ; IBDEN1 = array of Dental data for EDI output
- N IBX,Z,IBD1,IBD2,IBCPLINK
- S IBI=IBI+1,IBPROC=$P(IBSS,U,2),IBD1=$$DATE^IBCF23(IBDT1),IBD2=$S(IBDT1'=IBDT2:$$DATE^IBCF23(IBDT2),1:"")
- I '$D(IBXIEN) S IBD1=$E(IBD1,5,8)_$E(IBD1,1,4),IBD2=$E(IBD2,5,8)_$E(IBD2,1,4)
- S IBFLD(24,IBI)=IBD1_U_IBD2_U_$P($G(^IBE(353.1,+$P(IBSS,U,6),0)),U)_U_$P($G(^IBE(353.2,+$P(IBSS,U,7),0)),U)
- I +IBPROC D
- . S IBFLD(24,IBI)=IBFLD(24,IBI)_U_$P($$PRCD^IBCEF1(IBPROC,1),U,2) S:$P(IBPROC,";",2)'["ICPT" IBFLD(24,IBI_"X")=""
- I 'IBPROC S IBFLD(24,IBI)=IBFLD(24,IBI)_U_$S('$D(IBXIEN):IBPROC,1:+IBREV),IBFLD(24,IBI_"A")=$P($G(^DGCR(399.2,+IBREV,0)),U,2)
- I $D(IBRXF),IBCHARG="" S IBFLD(24,IBI_"A")=$P($G(^DGCR(399.2,+IBREV,0)),U,2)
- S IBFLD(24,IBI)=IBFLD(24,IBI)_U_$P(IBSS,U,5)_U_IBCHARG_U_IBUNIT_U_$P(IBSS,U,8)_U_$G(IBPCHG)_U_$G(IBMIN)_U_$G(IBEMG)
- I $D(IBSS("L")) S Z=0 F S Z=$O(IBSS("L",Z)) Q:'Z S IBFLD(24,IBI,$P(IBSS("L",Z),U),$P(IBSS("L",Z),U,2))=$G(IBFLD(24,IBI,$P(IBSS("L",Z),U),$P(IBSS("L",Z),U,2)))+1
- S:$TR($G(IBAUX),U)'="" IBFLD(24,IBI,"AUX")=$G(IBAUX)
- S:$D(IBRXF) IBFLD(24,IBI,"RX")=IBRXF
- K IBPROC,IBSS("L")
- S IBCPLINK=$P(IBSS,U,$L(IBSS,U))
- S IBFLD(24,IBI)=IBFLD(24,IBI)_U_IBCPLINK
- ; MRD;IB*2.0*516 - Added NDC and Units to line level of claim.
- ;I IBCPLINK'="" S $P(IBFLD(24,IBI),U,14,15)=$TR($P($G(^DGCR(399,IBIFN,"CP",IBCPLINK,1)),U,7,8),"-")
- ; vd/Beginning of IB*2*577 - Added Unit/Basis of Measurment to line level of claim.
- I IBCPLINK'="" S $P(IBFLD(24,IBI),U,14,16)=$TR($P($G(^DGCR(399,IBIFN,"CP",IBCPLINK,1)),U,7,8),"-")_U_$P($G(^DGCR(399,IBIFN,"CP",IBCPLINK,2)),U)
- ; vd/End of IB*2*577
- ;JWS;IB*2.0*592;US131
- I $G(IBDEN)'="" S IBFLD(24,IBI,"DEN")=$G(IBDEN)
- I $D(IBDEN1) M IBFLD(24,IBI,"DEN1")=IBDEN1
- I $D(IBDEND) S IBFLD(24,IBI,"DEND")=$G(IBDEND)
- ;end ;JWS;IB*2.0*592;US131
- Q
- ;
- AUXOK(IBSS,IBSS1) ; Check all other flds are the same to combine procs
- ; IBSS = subscript of IBCP to check for dups to combine - pass by ref
- ; IBSS(IBSS,"AUX-X",n) = all the previously extracted line items for the
- ; same set of basic data, but having different "AUX" data
- ; IBSS1 = the "AUX" data of the current IBCP entry
- ;
- ; Returns entry # in IBSS array if match found, or 0 if no match
- ; Set the IBSS "AUX-X" node for no match
- N Z,Z0,Z1,XIEN
- S Z=0 F S Z=$O(IBSS(IBSS,"AUX-X",Z)) Q:'Z I IBSS1=IBSS(IBSS,"AUX-X",Z) Q
- ;JWS;IB*2.0*592;Dental fields to check for roll-up
- S XIEN=$G(IBSS(IBSS,1))
- I $D(IBCP(IBPO,"DEN"))!($D(IBCP(IBPO,"DEN1")))!($D(IBCP(IBPO,"DEND")))!($D(IBCP(XIEN,"DEN")))!($D(IBCP(XIEN,"DEN1")))!($D(IBCP(XIEN,"DEND"))) D
- . I $G(IBCP(IBPO,"DEN"))'=$G(IBCP(XIEN,"DEN")) S Z=0 Q
- . I $G(IBCP(IBPO,"DEND"))'=$G(IBCP(XIEN,"DEND")) S Z=0 Q
- . S Z1=0 F S Z1=$O(IBCP(IBPO,"DEN1",Z1)) Q:'Z1 I $G(IBCP(IBPO,"DEN1",Z1,0))'=$G(IBCP(XIEN,"DEN1",Z1,0)) S Z=0 Q
- I 'Z S Z0=+$O(IBSS(IBSS,"AUX-X",""),-1)+1,IBSS(IBSS,"AUX-X",Z0)=IBSS1
- Q +Z
- ;
- PRC ; Extract procedure data for HCFA 1500
- ; IBRC(IBSS) = #rev codes with same billing criteria (IBSS)
- ; IBLINK('CP' ien,'RC' ien) = IBSS including modifiers,rx seq in pc 7,8
- ; IBLINK1(IBSS, 'RC' ien) = auto (1)^ 'CP' ien (soft link)
- ;
- ; proc array w/chrg
- ;JWS;IB*2.0*592;US131; added IBLN1, IBDENLN
- ;IA# 3820
- N IBPR,IBP,IBDENLN,IBLN1
- ;JWS;6/24/19;IB*2.0*623;found orphan nodes leftover by FileMan, causing errors-added $G(^(IBI,0))
- S IBI=0 F S IBI=$O(^DGCR(399,IBIFN,"CP",IBI)) Q:'IBI K IBDENLN S IBLN=$G(^(IBI,0)),IBLN1=$G(^(1)),IBAUXLN=$G(^("AUX")),IBDENLN=$G(^("DEN")) D
- . I $O(^DGCR(399,IBIFN,"CP",IBI,"DEN1",0)) M IBDENLN("DEN1")=^DGCR(399,IBIFN,"CP",IBI,"DEN1")
- . ;end ;JWS;IB*2.0*592;US131
- . N Z,Z0,Z1,Q1
- . S IBPDT=$P(IBLN,U,2)
- . S IBSS=$$IBSS(IBI,.IBDXI,IBLN)
- . S IBPO=$S($P(IBLN,U,4):+$P(IBLN,U,4),1:IBI+1000) ;Set print order
- . S IBCP(IBPO)=IBPDT_"^"_IBSS,IBCP(IBPO,"AUX")=IBAUXLN
- . S IBCP(IBPO,"LNK")=IBI
- . ;JWS;IB*2.0*592;US131
- . I $G(IBLN1)'="" S IBCP(IBPO,"DEND")=IBLN1
- . I $G(IBDENLN)'="" S IBCP(IBPO,"DEN")=IBDENLN
- . I $O(IBDENLN("DEN1",0)) M IBCP(IBPO,"DEN1")=IBDENLN("DEN1")
- . ;end ;JWS;IB*2.0*592;US131
- . ; Rx
- . N IBZ,IBITEM
- . S IBZ=$S($P(IBSS,U):$P(IBSS,U),1:"")
- . I IBZ'="",$D(IBLINKRX(IBZ,IBI)) D Q:IBCHARG'=""
- .. S IBPO1=IBPO
- .. S IBITEM=+$O(IBLINKRX(IBZ,IBI,0)),IBRV=$G(IBLINKRX(IBZ,IBI,IBITEM))
- .. Q:$S(IBRV="":1,1:'$G(IBRC(IBRV)))
- .. S IBCHARG=$P(IBRV,U,6),IBRC(IBRV)=IBRC(IBRV)-1
- .. S $P(IBCP(IBPO1),U,9)=IBCHARG,IBCP(IBPO1,"RX")=IBITEM K IBLINKRX(IBZ,IBI,IBITEM)
- . ; find chrgs directly linked to proc
- . S IBK=0 F S IBK=$O(IBLINK(IBI,IBK)) Q:'IBK S IBRV1=IBLINK(IBI,IBK),IBRV=$P(IBRV1,U,1,6) I +IBRC(IBRV1) D
- .. S IBCHARG=$P(IBRV,U,6),IBRC(IBRV1)=IBRC(IBRV1)-1
- .. I IBCHARG'="" S $P(IBSS,U,8)=IBCHARG,IBCP(IBPO)=IBPDT_"^"_IBSS,IBPO=IBPO+.1
- ;
- ; add chrgs associated with a proc (not a direct link)
- ; find chrg associated with proc, if any (match proc,div,+/-basc)
- K IBP(0)
- F IBP=3,2 Q:$D(IBP(0)) S IBPO="" F S IBPO=$O(IBCP(IBPO)) Q:'IBPO I $P(IBCP(IBPO),U,9)="" D
- . S IBSS=$P(IBCP(IBPO),U,2,9)
- . S IBCHARG="",(IBRV,IBSS)=$P(IBSS,U,1,IBP) F S IBRV=$O(IBRC(IBRV)) Q:$P(IBRV,U,1,IBP)'=IBSS S IBP(0)=0 I +IBRC(IBRV) D Q
- .. S IBCHARG=$P(IBRV,U,6),IBRC(IBRV)=IBRC(IBRV)-1
- .. I IBRC(IBRV) S Z=0 F S Z=$O(IBCP(IBPO,Z)) Q:'Z S IBRC(IBRV)=IBRC(IBRV)-1
- . S $P(IBCP(IBPO),U,9)=IBCHARG
- . I IBCHARG'="" S Z=$O(IBLINK1(IBRV,0)) I Z S IBCP(IBPO,"L",Z)=IBLINK1(IBRV,Z) K IBLINK1(IBRV,Z)
- ;
- ; add chrgs not associated with a proc to first proc with no chrg
- ; Aggggh!!! TP
- S IBPO="" F S IBPO=$O(IBCP(IBPO)) Q:'IBPO I $P(IBCP(IBPO),U,9)="" D
- . S IBCHARG="",IBRV="^" F S IBRV=$O(IBRC(IBRV)) Q:IBRV=""!+IBRV I +IBRC(IBRV) D Q
- .. S IBCHARG=$P(IBRV,U,6),IBRC(IBRV)=IBRC(IBRV)-1
- .. S Z=$O(IBLINK1(IBRV,0)) I Z S IBCP(IBPO,"L",Z)=IBLINK1(IBRV,Z) K IBLINK1(IBRV,Z)
- . S $P(IBCP(IBPO),U,9)=IBCHARG
- ;
- Q
- IBSS(IBI,IBDXI,IBLN) ; Creates index sequence for procedure
- N IBPC,IBJ,IBSS,IBLPI,IBX,IBLPAR
- S (IBPC,IBLPI)=0
- F IBJ=1,6,5,0,9,10 S IBPC=IBPC+1 S:IBJ $P(IBSS,U,IBPC,IBPC+1)=($P(IBLN,U,IBJ)_U)
- S $P(IBSS,U,7)=($$GETMOD^IBEFUNC(IBIFN,IBI)_U) ;Modifiers
- ;IB*547/TAZ - IBDXI not defined, use internal DX pointer
- I '$G(IBNWPTCH) F IBJ=11:1:14 I $P(IBLN,U,IBJ) S $P(IBSS,U,4)=$P(IBSS,U,4)_$S(IBJ>11:",",1:"")_$G(IBDXI(+$P(IBLN,U,IBJ))) ; dx
- I $G(IBNWPTCH) F IBJ=11:1:14 S IBX=$P(IBLN,U,IBJ) I IBX S $P(IBSS,U,4)=$P(IBSS,U,4)_$S(IBJ>11:",",1:"")_$G(IBDXI(IBX),IBX) ; dx
- S $P(IBSS,U,10)=$P(IBLN,U,16),$P(IBSS,U,9)=$P(IBLN,U,19),$P(IBSS,U,11)=+$P(IBLN,U,17)
- G:'$G(IBNWPTCH) IBSSX
- ;IB*547/TAZ - Add additional fields for roll-up compare
- S $P(IBSS,U,21)=$$GET1^DIQ(399.0304,IBI_","_IBIFN_",","ASSOCIATED CLINIC","I")
- S $P(IBSS,U,22)=$$GET1^DIQ(399.0304,IBI_","_IBIFN_",","TYPE OF SERVICE","I")
- S $P(IBSS,U,23)=$$GET1^DIQ(399.0304,IBI_","_IBIFN_",","ATTACHMENT CONTROL NUMBER","I")
- S $P(IBSS,U,24)=$$GET1^DIQ(399.0304,IBI_","_IBIFN_",","NDC","I")
- S $P(IBSS,U,25)=$$GET1^DIQ(399.0304,IBI_","_IBIFN_",","PROCEDURE DESCRIPTION","I")
- S $P(IBSS,U,26)=$$GET1^DIQ(399.0304,IBI_","_IBIFN_",","ADDITIONAL OB MINUTES","I")
- ;JRA;IB*2.0*608 Put Certificate of Medical Necessity (CMN) info in pieces 30,31,32
- M IBLPAR=^DGCR(399,IBIFN,"CP",IBI)
- S $P(IBSS,U,30)=$TR($G(IBLPAR("CMN")),U,"~")
- S $P(IBSS,U,31)=$TR($G(IBLPAR("CMN-10126")),U,"~")
- S $P(IBSS,U,32)=$TR($G(IBLPAR("CMN-484")),U,"~")
- K IBLPAR
- ;Add Provider info in pieces 41-49
- M IBLPAR=^DGCR(399,IBIFN,"CP",IBI,"LNPRV")
- F S IBLPI=$O(IBLPAR(IBLPI)) Q:'IBLPI S IBX=IBLPAR(IBLPI,0),$P(IBSS,U,40+IBX)=$TR(IBX,"^","~")
- K IBLPAR
- IBSSX ;
- Q IBSS
- ;
- IBNWPTCH(IBIFN,IBPATCH) ;
- ;Checks the date the primary claim was 1st transmitted and returns 1 if the transmitted date is after the patch
- ;referenced in variable IBPATCH was released. This allows the MRA/EOBs returning to roll up procedures the same
- ;way as they went out. Otherwise the order changes and the MRA/EOB won't match up.
- ;
- N IBARY,IBIDT,IBPFN,IBEFN,IBBN,IBX,IBBDT
- S IBX=0
- I $$INSTALDT^XPDUTL(IBPATCH,.IBARY) D ;ICR 10141
- . S IBX=1
- . S IBIDT=$O(IBARY(""))
- . ; Get Primary Bill Number. This will insure COB data is consistent across all bills.
- . S IBPFN=$$GET1^DIQ(399,IBIFN_",","PRIMARY BILL #","I") I 'IBPFN S IBPFN=IBIFN
- . ; Find 1st Accepted Entry (A1, A2, or Z) of Primary Bill in EDI TRANSMIT BILL FILE (364) to determine Batch Number
- . S (IBEFN,IBBN)=0 F S IBEFN=$O(^IBA(364,"B",IBPFN,IBEFN)) Q:'IBEFN D I IBBN Q
- .. I ",A1,A2,Z,"'[(","_$$GET1^DIQ(364,IBEFN_",","TRANSMISSION STATUS","I")_",") Q
- .. S IBBN=$$GET1^DIQ(364,IBEFN_",","BATCH NUMBER","I")
- . ;Retrieve the date the batch was 1st sent. If IBBN="" IBBDT will be null
- . S IBBDT=$$GET1^DIQ(364.1,$$GET1^DIQ(364,IBBN_",","BATCH NUMBER","I")_",","DATE FIRST SENT","I")
- . I IBBDT,(IBBDT<IBIDT) S IBX=0
- Q IBX
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCF23A 9262 printed Jan 18, 2025@03:14:07 Page 2
- IBCF23A ;ALB/ARH - HCFA 1500 19-90 DATA - Split from IBCF23 ;12-JUN-93
- +1 ;;2.0;INTEGRATED BILLING;**51,432,516,547,577,592,608,623**;21-MAR-94;Build 70
- +2 ;;Per VA Directive 6402, this routine should not be modified.
- +3 ;
- +4 ; $$INSTALDT^XPDUTL(IBPATCH,.IBARY) - ICR 10141
- +5 ;
- B24 ; set individual entries in print array, external format
- +1 ; IBAUX = additional data for EDI output
- +2 ; IBRXF = array of RX procedures
- +3 ;JWS;IB*2.0*592;US131
- +4 ; IBDEN = Dental data for EDI output
- +5 ; IBDEN1 = array of Dental data for EDI output
- +6 NEW IBX,Z,IBD1,IBD2,IBCPLINK
- +7 SET IBI=IBI+1
- SET IBPROC=$PIECE(IBSS,U,2)
- SET IBD1=$$DATE^IBCF23(IBDT1)
- SET IBD2=$SELECT(IBDT1'=IBDT2:$$DATE^IBCF23(IBDT2),1:"")
- +8 IF '$DATA(IBXIEN)
- SET IBD1=$EXTRACT(IBD1,5,8)_$EXTRACT(IBD1,1,4)
- SET IBD2=$EXTRACT(IBD2,5,8)_$EXTRACT(IBD2,1,4)
- +9 SET IBFLD(24,IBI)=IBD1_U_IBD2_U_$PIECE($GET(^IBE(353.1,+$PIECE(IBSS,U,6),0)),U)_U_$PIECE($GET(^IBE(353.2,+$PIECE(IBSS,U,7),0)),U)
- +10 IF +IBPROC
- Begin DoDot:1
- +11 SET IBFLD(24,IBI)=IBFLD(24,IBI)_U_$PIECE($$PRCD^IBCEF1(IBPROC,1),U,2)
- if $PIECE(IBPROC,";",2)'["ICPT"
- SET IBFLD(24,IBI_"X")=""
- End DoDot:1
- +12 IF 'IBPROC
- SET IBFLD(24,IBI)=IBFLD(24,IBI)_U_$SELECT('$DATA(IBXIEN):IBPROC,1:+IBREV)
- SET IBFLD(24,IBI_"A")=$PIECE($GET(^DGCR(399.2,+IBREV,0)),U,2)
- +13 IF $DATA(IBRXF)
- IF IBCHARG=""
- SET IBFLD(24,IBI_"A")=$PIECE($GET(^DGCR(399.2,+IBREV,0)),U,2)
- +14 SET IBFLD(24,IBI)=IBFLD(24,IBI)_U_$PIECE(IBSS,U,5)_U_IBCHARG_U_IBUNIT_U_$PIECE(IBSS,U,8)_U_$GET(IBPCHG)_U_$GET(IBMIN)_U_$GET(IBEMG)
- +15 IF $DATA(IBSS("L"))
- SET Z=0
- FOR
- SET Z=$ORDER(IBSS("L",Z))
- if 'Z
- QUIT
- SET IBFLD(24,IBI,$PIECE(IBSS("L",Z),U),$PIECE(IBSS("L",Z),U,2))=$GET(IBFLD(24,IBI,$PIECE(IBSS("L",Z),U),$PIECE(IBSS("L",Z),U,2)))+1
- +16 if $TRANSLATE($GET(IBAUX),U)'=""
- SET IBFLD(24,IBI,"AUX")=$GET(IBAUX)
- +17 if $DATA(IBRXF)
- SET IBFLD(24,IBI,"RX")=IBRXF
- +18 KILL IBPROC,IBSS("L")
- +19 SET IBCPLINK=$PIECE(IBSS,U,$LENGTH(IBSS,U))
- +20 SET IBFLD(24,IBI)=IBFLD(24,IBI)_U_IBCPLINK
- +21 ; MRD;IB*2.0*516 - Added NDC and Units to line level of claim.
- +22 ;I IBCPLINK'="" S $P(IBFLD(24,IBI),U,14,15)=$TR($P($G(^DGCR(399,IBIFN,"CP",IBCPLINK,1)),U,7,8),"-")
- +23 ; vd/Beginning of IB*2*577 - Added Unit/Basis of Measurment to line level of claim.
- +24 IF IBCPLINK'=""
- SET $PIECE(IBFLD(24,IBI),U,14,16)=$TRANSLATE($PIECE($GET(^DGCR(399,IBIFN,"CP",IBCPLINK,1)),U,7,8),"-")_U_$PIECE($GET(^DGCR(399,IBIFN,"CP",IBCPLINK,2)),U)
- +25 ; vd/End of IB*2*577
- +26 ;JWS;IB*2.0*592;US131
- +27 IF $GET(IBDEN)'=""
- SET IBFLD(24,IBI,"DEN")=$GET(IBDEN)
- +28 IF $DATA(IBDEN1)
- MERGE IBFLD(24,IBI,"DEN1")=IBDEN1
- +29 IF $DATA(IBDEND)
- SET IBFLD(24,IBI,"DEND")=$GET(IBDEND)
- +30 ;end ;JWS;IB*2.0*592;US131
- +31 QUIT
- +32 ;
- AUXOK(IBSS,IBSS1) ; Check all other flds are the same to combine procs
- +1 ; IBSS = subscript of IBCP to check for dups to combine - pass by ref
- +2 ; IBSS(IBSS,"AUX-X",n) = all the previously extracted line items for the
- +3 ; same set of basic data, but having different "AUX" data
- +4 ; IBSS1 = the "AUX" data of the current IBCP entry
- +5 ;
- +6 ; Returns entry # in IBSS array if match found, or 0 if no match
- +7 ; Set the IBSS "AUX-X" node for no match
- +8 NEW Z,Z0,Z1,XIEN
- +9 SET Z=0
- FOR
- SET Z=$ORDER(IBSS(IBSS,"AUX-X",Z))
- if 'Z
- QUIT
- IF IBSS1=IBSS(IBSS,"AUX-X",Z)
- QUIT
- +10 ;JWS;IB*2.0*592;Dental fields to check for roll-up
- +11 SET XIEN=$GET(IBSS(IBSS,1))
- +12 IF $DATA(IBCP(IBPO,"DEN"))!($DATA(IBCP(IBPO,"DEN1")))!($DATA(IBCP(IBPO,"DEND")))!($DATA(IBCP(XIEN,"DEN")))!($DATA(IBCP(XIEN,"DEN1")))!($DATA(IBCP(XIEN,"DEND")))
- Begin DoDot:1
- +13 IF $GET(IBCP(IBPO,"DEN"))'=$GET(IBCP(XIEN,"DEN"))
- SET Z=0
- QUIT
- +14 IF $GET(IBCP(IBPO,"DEND"))'=$GET(IBCP(XIEN,"DEND"))
- SET Z=0
- QUIT
- +15 SET Z1=0
- FOR
- SET Z1=$ORDER(IBCP(IBPO,"DEN1",Z1))
- if 'Z1
- QUIT
- IF $GET(IBCP(IBPO,"DEN1",Z1,0))'=$GET(IBCP(XIEN,"DEN1",Z1,0))
- SET Z=0
- QUIT
- End DoDot:1
- +16 IF 'Z
- SET Z0=+$ORDER(IBSS(IBSS,"AUX-X",""),-1)+1
- SET IBSS(IBSS,"AUX-X",Z0)=IBSS1
- +17 QUIT +Z
- +18 ;
- PRC ; Extract procedure data for HCFA 1500
- +1 ; IBRC(IBSS) = #rev codes with same billing criteria (IBSS)
- +2 ; IBLINK('CP' ien,'RC' ien) = IBSS including modifiers,rx seq in pc 7,8
- +3 ; IBLINK1(IBSS, 'RC' ien) = auto (1)^ 'CP' ien (soft link)
- +4 ;
- +5 ; proc array w/chrg
- +6 ;JWS;IB*2.0*592;US131; added IBLN1, IBDENLN
- +7 ;IA# 3820
- +8 NEW IBPR,IBP,IBDENLN,IBLN1
- +9 ;JWS;6/24/19;IB*2.0*623;found orphan nodes leftover by FileMan, causing errors-added $G(^(IBI,0))
- +10 SET IBI=0
- FOR
- SET IBI=$ORDER(^DGCR(399,IBIFN,"CP",IBI))
- if 'IBI
- QUIT
- KILL IBDENLN
- SET IBLN=$GET(^(IBI,0))
- SET IBLN1=$GET(^(1))
- SET IBAUXLN=$GET(^("AUX"))
- SET IBDENLN=$GET(^("DEN"))
- Begin DoDot:1
- +11 IF $ORDER(^DGCR(399,IBIFN,"CP",IBI,"DEN1",0))
- MERGE IBDENLN("DEN1")=^DGCR(399,IBIFN,"CP",IBI,"DEN1")
- +12 ;end ;JWS;IB*2.0*592;US131
- +13 NEW Z,Z0,Z1,Q1
- +14 SET IBPDT=$PIECE(IBLN,U,2)
- +15 SET IBSS=$$IBSS(IBI,.IBDXI,IBLN)
- +16 ;Set print order
- SET IBPO=$SELECT($PIECE(IBLN,U,4):+$PIECE(IBLN,U,4),1:IBI+1000)
- +17 SET IBCP(IBPO)=IBPDT_"^"_IBSS
- SET IBCP(IBPO,"AUX")=IBAUXLN
- +18 SET IBCP(IBPO,"LNK")=IBI
- +19 ;JWS;IB*2.0*592;US131
- +20 IF $GET(IBLN1)'=""
- SET IBCP(IBPO,"DEND")=IBLN1
- +21 IF $GET(IBDENLN)'=""
- SET IBCP(IBPO,"DEN")=IBDENLN
- +22 IF $ORDER(IBDENLN("DEN1",0))
- MERGE IBCP(IBPO,"DEN1")=IBDENLN("DEN1")
- +23 ;end ;JWS;IB*2.0*592;US131
- +24 ; Rx
- +25 NEW IBZ,IBITEM
- +26 SET IBZ=$SELECT($PIECE(IBSS,U):$PIECE(IBSS,U),1:"")
- +27 IF IBZ'=""
- IF $DATA(IBLINKRX(IBZ,IBI))
- Begin DoDot:2
- +28 SET IBPO1=IBPO
- +29 SET IBITEM=+$ORDER(IBLINKRX(IBZ,IBI,0))
- SET IBRV=$GET(IBLINKRX(IBZ,IBI,IBITEM))
- +30 if $SELECT(IBRV=""
- QUIT
- +31 SET IBCHARG=$PIECE(IBRV,U,6)
- SET IBRC(IBRV)=IBRC(IBRV)-1
- +32 SET $PIECE(IBCP(IBPO1),U,9)=IBCHARG
- SET IBCP(IBPO1,"RX")=IBITEM
- KILL IBLINKRX(IBZ,IBI,IBITEM)
- End DoDot:2
- if IBCHARG'=""
- QUIT
- +33 ; find chrgs directly linked to proc
- +34 SET IBK=0
- FOR
- SET IBK=$ORDER(IBLINK(IBI,IBK))
- if 'IBK
- QUIT
- SET IBRV1=IBLINK(IBI,IBK)
- SET IBRV=$PIECE(IBRV1,U,1,6)
- IF +IBRC(IBRV1)
- Begin DoDot:2
- +35 SET IBCHARG=$PIECE(IBRV,U,6)
- SET IBRC(IBRV1)=IBRC(IBRV1)-1
- +36 IF IBCHARG'=""
- SET $PIECE(IBSS,U,8)=IBCHARG
- SET IBCP(IBPO)=IBPDT_"^"_IBSS
- SET IBPO=IBPO+.1
- End DoDot:2
- End DoDot:1
- +37 ;
- +38 ; add chrgs associated with a proc (not a direct link)
- +39 ; find chrg associated with proc, if any (match proc,div,+/-basc)
- +40 KILL IBP(0)
- +41 FOR IBP=3,2
- if $DATA(IBP(0))
- QUIT
- SET IBPO=""
- FOR
- SET IBPO=$ORDER(IBCP(IBPO))
- if 'IBPO
- QUIT
- IF $PIECE(IBCP(IBPO),U,9)=""
- Begin DoDot:1
- +42 SET IBSS=$PIECE(IBCP(IBPO),U,2,9)
- +43 SET IBCHARG=""
- SET (IBRV,IBSS)=$PIECE(IBSS,U,1,IBP)
- FOR
- SET IBRV=$ORDER(IBRC(IBRV))
- if $PIECE(IBRV,U,1,IBP)'=IBSS
- QUIT
- SET IBP(0)=0
- IF +IBRC(IBRV)
- Begin DoDot:2
- +44 SET IBCHARG=$PIECE(IBRV,U,6)
- SET IBRC(IBRV)=IBRC(IBRV)-1
- +45 IF IBRC(IBRV)
- SET Z=0
- FOR
- SET Z=$ORDER(IBCP(IBPO,Z))
- if 'Z
- QUIT
- SET IBRC(IBRV)=IBRC(IBRV)-1
- End DoDot:2
- QUIT
- +46 SET $PIECE(IBCP(IBPO),U,9)=IBCHARG
- +47 IF IBCHARG'=""
- SET Z=$ORDER(IBLINK1(IBRV,0))
- IF Z
- SET IBCP(IBPO,"L",Z)=IBLINK1(IBRV,Z)
- KILL IBLINK1(IBRV,Z)
- End DoDot:1
- +48 ;
- +49 ; add chrgs not associated with a proc to first proc with no chrg
- +50 ; Aggggh!!! TP
- +51 SET IBPO=""
- FOR
- SET IBPO=$ORDER(IBCP(IBPO))
- if 'IBPO
- QUIT
- IF $PIECE(IBCP(IBPO),U,9)=""
- Begin DoDot:1
- +52 SET IBCHARG=""
- SET IBRV="^"
- FOR
- SET IBRV=$ORDER(IBRC(IBRV))
- if IBRV=""!+IBRV
- QUIT
- IF +IBRC(IBRV)
- Begin DoDot:2
- +53 SET IBCHARG=$PIECE(IBRV,U,6)
- SET IBRC(IBRV)=IBRC(IBRV)-1
- +54 SET Z=$ORDER(IBLINK1(IBRV,0))
- IF Z
- SET IBCP(IBPO,"L",Z)=IBLINK1(IBRV,Z)
- KILL IBLINK1(IBRV,Z)
- End DoDot:2
- QUIT
- +55 SET $PIECE(IBCP(IBPO),U,9)=IBCHARG
- End DoDot:1
- +56 ;
- +57 QUIT
- IBSS(IBI,IBDXI,IBLN) ; Creates index sequence for procedure
- +1 NEW IBPC,IBJ,IBSS,IBLPI,IBX,IBLPAR
- +2 SET (IBPC,IBLPI)=0
- +3 FOR IBJ=1,6,5,0,9,10
- SET IBPC=IBPC+1
- if IBJ
- SET $PIECE(IBSS,U,IBPC,IBPC+1)=($PIECE(IBLN,U,IBJ)_U)
- +4 ;Modifiers
- SET $PIECE(IBSS,U,7)=($$GETMOD^IBEFUNC(IBIFN,IBI)_U)
- +5 ;IB*547/TAZ - IBDXI not defined, use internal DX pointer
- +6 ; dx
- IF '$GET(IBNWPTCH)
- FOR IBJ=11:1:14
- IF $PIECE(IBLN,U,IBJ)
- SET $PIECE(IBSS,U,4)=$PIECE(IBSS,U,4)_$SELECT(IBJ>11:",",1:"")_$GET(IBDXI(+$PIECE(IBLN,U,IBJ)))
- +7 ; dx
- IF $GET(IBNWPTCH)
- FOR IBJ=11:1:14
- SET IBX=$PIECE(IBLN,U,IBJ)
- IF IBX
- SET $PIECE(IBSS,U,4)=$PIECE(IBSS,U,4)_$SELECT(IBJ>11:",",1:"")_$GET(IBDXI(IBX),IBX)
- +8 SET $PIECE(IBSS,U,10)=$PIECE(IBLN,U,16)
- SET $PIECE(IBSS,U,9)=$PIECE(IBLN,U,19)
- SET $PIECE(IBSS,U,11)=+$PIECE(IBLN,U,17)
- +9 if '$GET(IBNWPTCH)
- GOTO IBSSX
- +10 ;IB*547/TAZ - Add additional fields for roll-up compare
- +11 SET $PIECE(IBSS,U,21)=$$GET1^DIQ(399.0304,IBI_","_IBIFN_",","ASSOCIATED CLINIC","I")
- +12 SET $PIECE(IBSS,U,22)=$$GET1^DIQ(399.0304,IBI_","_IBIFN_",","TYPE OF SERVICE","I")
- +13 SET $PIECE(IBSS,U,23)=$$GET1^DIQ(399.0304,IBI_","_IBIFN_",","ATTACHMENT CONTROL NUMBER","I")
- +14 SET $PIECE(IBSS,U,24)=$$GET1^DIQ(399.0304,IBI_","_IBIFN_",","NDC","I")
- +15 SET $PIECE(IBSS,U,25)=$$GET1^DIQ(399.0304,IBI_","_IBIFN_",","PROCEDURE DESCRIPTION","I")
- +16 SET $PIECE(IBSS,U,26)=$$GET1^DIQ(399.0304,IBI_","_IBIFN_",","ADDITIONAL OB MINUTES","I")
- +17 ;JRA;IB*2.0*608 Put Certificate of Medical Necessity (CMN) info in pieces 30,31,32
- +18 MERGE IBLPAR=^DGCR(399,IBIFN,"CP",IBI)
- +19 SET $PIECE(IBSS,U,30)=$TRANSLATE($GET(IBLPAR("CMN")),U,"~")
- +20 SET $PIECE(IBSS,U,31)=$TRANSLATE($GET(IBLPAR("CMN-10126")),U,"~")
- +21 SET $PIECE(IBSS,U,32)=$TRANSLATE($GET(IBLPAR("CMN-484")),U,"~")
- +22 KILL IBLPAR
- +23 ;Add Provider info in pieces 41-49
- +24 MERGE IBLPAR=^DGCR(399,IBIFN,"CP",IBI,"LNPRV")
- +25 FOR
- SET IBLPI=$ORDER(IBLPAR(IBLPI))
- if 'IBLPI
- QUIT
- SET IBX=IBLPAR(IBLPI,0)
- SET $PIECE(IBSS,U,40+IBX)=$TRANSLATE(IBX,"^","~")
- +26 KILL IBLPAR
- IBSSX ;
- +1 QUIT IBSS
- +2 ;
- IBNWPTCH(IBIFN,IBPATCH) ;
- +1 ;Checks the date the primary claim was 1st transmitted and returns 1 if the transmitted date is after the patch
- +2 ;referenced in variable IBPATCH was released. This allows the MRA/EOBs returning to roll up procedures the same
- +3 ;way as they went out. Otherwise the order changes and the MRA/EOB won't match up.
- +4 ;
- +5 NEW IBARY,IBIDT,IBPFN,IBEFN,IBBN,IBX,IBBDT
- +6 SET IBX=0
- +7 ;ICR 10141
- IF $$INSTALDT^XPDUTL(IBPATCH,.IBARY)
- Begin DoDot:1
- +8 SET IBX=1
- +9 SET IBIDT=$ORDER(IBARY(""))
- +10 ; Get Primary Bill Number. This will insure COB data is consistent across all bills.
- +11 SET IBPFN=$$GET1^DIQ(399,IBIFN_",","PRIMARY BILL #","I")
- IF 'IBPFN
- SET IBPFN=IBIFN
- +12 ; Find 1st Accepted Entry (A1, A2, or Z) of Primary Bill in EDI TRANSMIT BILL FILE (364) to determine Batch Number
- +13 SET (IBEFN,IBBN)=0
- FOR
- SET IBEFN=$ORDER(^IBA(364,"B",IBPFN,IBEFN))
- if 'IBEFN
- QUIT
- Begin DoDot:2
- +14 IF ",A1,A2,Z,"'[(","_$$GET1^DIQ(364,IBEFN_",","TRANSMISSION STATUS","I")_",")
- QUIT
- +15 SET IBBN=$$GET1^DIQ(364,IBEFN_",","BATCH NUMBER","I")
- End DoDot:2
- IF IBBN
- QUIT
- +16 ;Retrieve the date the batch was 1st sent. If IBBN="" IBBDT will be null
- +17 SET IBBDT=$$GET1^DIQ(364.1,$$GET1^DIQ(364,IBBN_",","BATCH NUMBER","I")_",","DATE FIRST SENT","I")
- +18 IF IBBDT
- IF (IBBDT<IBIDT)
- SET IBX=0
- End DoDot:1
- +19 QUIT IBX