- IBCEF74 ;WOIFO/SS - FORMATTER/EXTRACT BILL FUNCTIONS ;31-JUL-03
- ;;2.0;INTEGRATED BILLING;**232,280,155,290,291,320,358,343,374,432,592,718,727**;21-MAR-94;Build 34
- ;;Per VA Directive 6402, this routine should not be modified.
- ;
- SORT(IBPRNUM,IBPRTYP,IB399,IBSRC,IBDST,IBN,IBEXC,IBSEQ,IBLIMIT) ;
- D SORT^IBCEF77($G(IBPRNUM),$G(IBPRTYP),$G(IB399),.IBSRC,.IBDST,$G(IBN),$G(IBEXC),$G(IBSEQ),$G(IBLIMIT))
- Q
- ;
- ;-- PROVINF --
- ;Create array with prov info
- ;Input:
- ; IB399 - ien #399
- ; IBPRNUM - 1=prim ins, 2= sec, 3 -tert
- ; IBRES - for results
- ; IBSORT - to sort OTHER INSURANCE data
- ; if PROVINF is called for "C" mode of PROVIDER subroutine then
- ; IBSORT can be any (say 1)
- ; if PROVINF is called for "O" mode then can be more than set of data
- ; - need to sort array to use it (like IBXDATA(1) and IBXDATA(2))
- ; for mode "O" it should be 1 or 2 (see PROVIDER section)
- ;IBINSTP - "C" -current ins, "O"-other
- ;Output:
- ; IBRES(PRNUM,PRTYPE,SEQ#)=PROV^INSUR^IDTYPE^ID^FORMTYP^CARETYP
- ; where:(see PROVIDER)
- PROVINF(IB399,IBPRNUM,IBRES,IBSORT,IBINSTP) ;
- I $G(IB399)="" Q
- I +$G(IBSORT)=0 S IBSORT=$G(IBPRNUM)
- N IBPRTYP,IBINSCO,IBPROV,IBFRMTYP,IBCARE,IB35591,IBN,IBCURR,IBEXC,IBLIMIT
- S IBN=0
- S IBINSCO=+$P($G(^DGCR(399,IB399,"M")),"^",IBPRNUM)
- ;JRA IB*2.0*592 Modify for Dental form 7 - treat the same as CMS-1500
- ;S IBFRMTYP=$$FT^IBCEF(IB399),IBFRMTYP=$S(IBFRMTYP=2:2,IBFRMTYP=3:1,1:0) ;JRA IB*2.0*592 ';'
- S IBFRMTYP=$$FT^IBCEF(IB399),IBFRMTYP=$S(IBFRMTYP=2:2,IBFRMTYP=7:7,IBFRMTYP=3:1,1:0) ;JWS 8/30/17;IB*2.0*592;JRA IB*2.0*592
- S IBCARE=$S($$ISRX^IBCEF1(IB399):3,1:0) ;if an Rx refill bill
- S:IBCARE=0 IBCARE=$$INPAT^IBCEF(IB399,1) S:'IBCARE IBCARE=2 ;1-inp,2-out
- S IBLIMIT=$S($G(IBINSTP)="C":5,1:3) ; Limits on secondary IDs
- F IBPRTYP=1:1:9 D
- . N Z,IB355OV
- . S IBPROV=$$PROVPTR^IBCEF7(IB399,IBPRTYP)
- . Q:+IBPROV=0
- . ;don't create anything if form type not CMS-1500 or UB
- . Q:IBFRMTYP=0
- . N IBRETARR S IBRETARR=0
- . D PRACT^IBCEF71(IBINSCO,IBFRMTYP,IBCARE,IBPROV,.IBRETARR,IBPRTYP,$G(IBINSTP))
- . S IB355OV="",IBEXC=""
- . S Z=$O(^DGCR(399,IB399,"PRV","B",IBPRTYP,0))
- . I Z S Z=$G(^DGCR(399,IB399,"PRV",Z,0)) D
- .. I $P(Z,U,IBPRNUM+4)'="",$P(Z,U,IBPRNUM+11)'="" S IB355OV=$P(Z,U,IBPRNUM+4)_U_$P(Z,U,IBPRNUM+11)
- . S IBCURR=$$COB^IBCEF(IB399)
- . S IBN=0,IB35591=$$CH35591^IBCEF72(IBINSCO,IBFRMTYP,IBCARE)
- . ;JRA IB*2.0*592 Modify for Dental form 7 - treat the same as CMS-1500
- . I $G(IBINSTP)="C",$G(IBPRNUM)=1,"34"[$G(IBPRTYP),"P"[$G(IBCURR),($G(IBFRMTYP)=2!($G(IBFRMTYP)=7)),$$MCRONBIL^IBEFUNC(IB399) S IB355OV=$$MCR24K^IBCEU3(IB399)_"^12" ;JRA IB*2.0*592
- . ;Calculate MEDICARE (WNR) specific provider qualifier and ID for CMS-1500 secondary claim ;JRA IB*2.0*592
- . I $G(IBINSTP)="O","34"[$G(IBPRTYP),"ST"[$G(IBCURR),($G(IBFRMTYP)=2!($G(IBFRMTYP)=7)),$$MCRONBIL^IBEFUNC(IB399) S IB355OV=$$MCR24K^IBCEU3(IB399)_"^12"
- . I $P(IB355OV,U,2) D
- .. I $$CHCKSEC^IBCEF73(IBFRMTYP,IBPRTYP,$G(IBINSTP),$P($G(^IBE(355.97,+$P(IB355OV,U,2),0)),U,3)) D
- ... S IBEXC=$P(IB355OV,U,2),IBN=IBN+1,IBRES(IBSORT,IBPRTYP,IBN)="OVERRIDE^"_IBINSCO_U_$P($G(^IBE(355.97,+IBEXC,0)),U,3)_U_$P(IB355OV,U)_"^^^^^"_+IBEXC
- . I IB35591'="",IBEXC'=$P(IB35591,U,3) S:$$CHCKSEC^IBCEF73(IBFRMTYP,IBPRTYP,$G(IBINSTP),$P(IB35591,"^")) IBN=IBN+1,IBRES(IBSORT,IBPRTYP,IBN)="DEFAULT^"_IBINSCO_"^"_IB35591_"^^",$P(IBRES(IBSORT,IBPRTYP,IBN),U,9)=$P(IB35591,U,3)
- . D SORT(IBSORT,IBPRTYP,IB399,.IBRETARR,.IBRES,IBN,IBEXC,IBPRNUM,IBLIMIT)
- . S IBRES(IBSORT,IBPRTYP)=IBPROV
- S IBRES(IBSORT)=$S(IBPRNUM=3:"T",IBPRNUM=2:"S",1:"P")
- Q
- ;
- SECIDCK(IBIFN,IBSEQ,IBTYP,IBIFN1) ; Function returns 1 if ID type ptr in
- ; IBTYP is valid X12 code for the claim/prov function (IBPROVF)
- ; as a sec id
- ; IBSEQ = COB seq being checked
- ; IBIFN1 = entry # in PRV multiple being checked
- ; Called from input transform of fields .12-.14, subfile 399.0222
- I $G(IBIFN)="" Q
- N IBOK,IBFRM,IBCOBN,IBX12,IBPROVF
- S IBPROVF=+$G(^DGCR(399,IBIFN,"PRV",IBIFN1,0))
- S IBFRM=$$FT^IBCEF(IBIFN),IBFRM=$S(IBFRM=3:1,1:2) ; Form type
- S IBCOBN=$$COBN^IBCEF(IBIFN) S:'IBCOBN IBCOBN=1 ; Current COB seq
- S IBX12=$P($G(^IBE(355.97,+IBTYP,0)),U,3) ; X12 code for prov id typ
- Q $$CHSEC^IBCEF73(IBFRM,IBPROVF,$S(IBSEQ=IBCOBN:"C",1:"O"),IBX12)
- ;
- DEFID(IBIFN,IBPRV) ;
- ; IBIFN = ien of bill
- ; IBPRV = ien of entry subfile 399.0222
- ; Function returns default ids: prim id def^sec id def^tert id def
- ; SSN cannot be the default ID
- I $G(IBIFN)="" Q ""
- N Z,Z1,ID,IBZ,IBINS,IBINS4,IBUB
- S IBZ=""
- S IBUB=($$FT^IBCEF(IBIFN)=3)
- D F^IBCEF("N-ALL ATT/REND PROV SSN/EI","IBZ","",IBIFN)
- S Z=$G(^DGCR(399,IBIFN,"PRV",IBPRV,0)),ID=$P(Z,U,5,7)
- F Z1=1:1:3 I $P(ID,U,Z1)="" D
- . Q:'$G(^DGCR(399,IBIFN,"I"_Z1)) S IBINS=+^("I"_Z1)
- . S $P(ID,U,Z1)=$$GETID^IBCEP2(IBIFN,2,$P(Z,U,2),Z1)
- . ; Set default if null
- . I $P(ID,U,Z1)="" S $P(ID,U,Z1)="VAD000"
- Q ID
- ;
- DISPID(IBXIEN) ; Display list of all prov and fac ids that will
- ; extract for this bill if transmitted electronically
- I $G(IBXIEN)="" Q
- N IBID,IBID1,IBZ,IBCT,IBFRM,IBCOBN,IBQUIT,IBTYP,DIR,IBIFN,X,Y,Z,Z0,Z1,CO,IBN,IBCODE
- S IBIFN=IBXIEN
- S IBFRM=$$FT^IBCEF(IBIFN),IBCOBN=$$COBN^IBCEF(IBIFN)
- W @IOF
- ;;JWS;IB*2.0*718v10;display message that NPIs are removed for Medicare 837s
- ;;JWS;IB*2.0*727v9;display message that secondary provider IDs will be removed for Medicare claims, except with 1G qualifiers
- W !,"If this bill is transmitted electronically, the following IDs will be sent:"
- W !,"Note: For Medicare:",!," 1) All NPIs will be removed from the claim prior to submission."
- W !," 2) All Provider IDs other than 'UPIN' will be removed from the claim prior to",!?4,"submission.",!
- ; Returns all prov sec ids to be transmitted in indicated segments
- S Z=+$G(^DGCR(399,IBIFN,"I1")) I Z W !," Primary Ins Co: ",$$EXTERNAL^DILFD(399,101,"",Z) I IBCOBN=1 W ?54,"<<<Current Ins"
- S Z=+$G(^DGCR(399,IBIFN,"I2")) I Z W !,"Secondary Ins Co: ",$$EXTERNAL^DILFD(399,101,"",Z) I IBCOBN=2 W ?54,"<<<Current Ins"
- S Z=+$G(^DGCR(399,IBIFN,"I3")) I Z W !," Tertiary Ins Co: ",$$EXTERNAL^DILFD(399,101,"",Z) I IBCOBN=3 W ?54,"<<<Current Ins"
- ;JWS;IB*2.0*592;added Assistant Surgeon records to header display
- W !!,"Provider IDs: (VistA Records OP1,OP2,OP4,OP8,OP9,OP10,OPR,OPR1,OPR2,OPR3,OPR4,",!?29,"OPR5,OPR7,OPR8,OPR9,OPRA,OPRB,OPRC):"
- ;F Z=1:1:3 I $G(^DGCR(399,IBIFN,"I"_Z)) D PROVINF(IBIFN,Z,.IBID,"",$S(IBCOBN=Z:"C",1:"O"))
- ;*432/TAZ - Added call to gather line providers and apply business rules
- D ALLIDS^IBCEFP(IBIFN,.IBID)
- ;*432/TAZ - Rewrote following code to take info from the IBID array instead of File 399. This allows changes from the application of the business rules.
- S IBQUIT=0
- ;
- ;JWS;IB*2.0*592; added assistant surgeon
- F IBPRV=4,3,1,2,5,6,9 D ; Process providers in order: Attending, Rendering, Referring, Operating, Supervising, and Other Operating if they exist
- . I '$D(IBID("PROVINF",IBIFN,"C",1,IBPRV)) Q
- . I ($Y+5)>IOSL S IBQUIT=$$NOMORE() Q:IBQUIT
- . W !!?5,$$EXTERNAL^DILFD(399.0222,.01,"",IBPRV),": "_$$EXTERNAL^DILFD(399.0222,.02,"",$P(IBID("PROVINF",IBIFN,"C",1,IBPRV),U))
- . W !?8,"NPI: ",?40,$S($P($G(IBID("PROVINF",IBIFN,"C",1,IBPRV,0)),U,4)]"":$P(IBID("PROVINF",IBIFN,"C",1,IBPRV,0),U,4),1:"***MISSING***")
- . K IBTYP
- . F CO="C","O" D
- .. F IBN=1,2 I $D(IBID("PROVINF",IBIFN,CO,IBN,IBPRV)) D
- ... F Z0=1:1 Q:'$D(IBID("PROVINF",IBIFN,CO,IBN,IBPRV,Z0))!IBQUIT D
- .... S IBCODE=+$P(IBID("PROVINF",IBIFN,CO,IBN,IBPRV,Z0),U,9)
- .... Q:$D(IBTYP(IBCODE)) ;1st of each type transmits
- .... I ($Y+5)>IOSL S IBQUIT=$$NOMORE() Q:IBQUIT
- .... S IBTYP(IBCODE)=""
- .... W !,?8,"(",IBID("PROVINF",IBIFN,CO,IBN),") ",$$EXTERNAL^DILFD(36,4.01,"",IBCODE),?40,$P(IBID("PROVINF",IBIFN,CO,IBN,IBPRV,Z0),U,4)
- ;
- I IBQUIT G DISPIDX
- ;
- ; IB*2*320 - display additional IDs for ?ID
- D EN^IBCEF74A(IBIFN,.IBQUIT,.IBID)
- ;
- DISPIDX ;
- I '$G(IBQUIT) S DIR(0)="EA",DIR("A")="Press RETURN to continue " W ! D ^DIR K DIR
- Q
- ;
- NOMORE() ;
- S DIR(0)="EA",DIR("A")="Press RETURN for more IDs or '^' to exit: " W ! D ^DIR
- W @IOF
- Q (Y'=1)
- ;
- DEFSEC(IBIFN,IBARR) ; Returns array in IBARR for default prov sec ids for ien IBIFN
- ; IBARR if passed by ref is returned IBARR(prov function,COBN)=def id
- I $G(IBIFN)=""
- N IBCAR,IBCOBN,IBPC,IBINS,IBARRX,Q,Z,Z0,ZINS,X
- K IBARR
- S ZINS="",IBCOBN=$$COBN^IBCEF(IBIFN),IBPC=$S($$FT^IBCEF(IBIFN)=3:2,1:1)
- S IBCAR=$$INPAT^IBCEF(IBIFN,1),IBCAR=$S('IBCAR:2,1:1)
- F Z=1:1:3 S ZINS=ZINS_+$G(^DGCR(399,IBIFN,"I"_Z))_U
- F Z=1:1:3 I $P(ZINS,U,Z),'$P($G(^DIC(36,+$P(ZINS,U,Z),4)),U,IBPC) S $P(ZINS,U,Z)=""
- S Z=0 F S Z=$O(^DGCR(399,IBIFN,"PRV",Z)) Q:'Z S Z0=$G(^(Z,0)) D
- . F Q=1:1:3 D
- .. I $P(Z0,U,Q+4)'="" S IBARR(+Z0,Q)=$P(Z0,U,Q+4) Q ; Override
- .. S IBINS=$P(ZINS,U,Q)
- .. Q:'IBINS
- .. S X=$$IDFIND^IBCEP2(IBIFN,"",$P(Z0,U,2),Q,1)
- .. I X'="" S IBARR(+Z0,Q)=X
- Q
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCEF74 8910 printed Jan 18, 2025@03:11:28 Page 2
- IBCEF74 ;WOIFO/SS - FORMATTER/EXTRACT BILL FUNCTIONS ;31-JUL-03
- +1 ;;2.0;INTEGRATED BILLING;**232,280,155,290,291,320,358,343,374,432,592,718,727**;21-MAR-94;Build 34
- +2 ;;Per VA Directive 6402, this routine should not be modified.
- +3 ;
- SORT(IBPRNUM,IBPRTYP,IB399,IBSRC,IBDST,IBN,IBEXC,IBSEQ,IBLIMIT) ;
- +1 DO SORT^IBCEF77($GET(IBPRNUM),$GET(IBPRTYP),$GET(IB399),.IBSRC,.IBDST,$GET(IBN),$GET(IBEXC),$GET(IBSEQ),$GET(IBLIMIT))
- +2 QUIT
- +3 ;
- +4 ;-- PROVINF --
- +5 ;Create array with prov info
- +6 ;Input:
- +7 ; IB399 - ien #399
- +8 ; IBPRNUM - 1=prim ins, 2= sec, 3 -tert
- +9 ; IBRES - for results
- +10 ; IBSORT - to sort OTHER INSURANCE data
- +11 ; if PROVINF is called for "C" mode of PROVIDER subroutine then
- +12 ; IBSORT can be any (say 1)
- +13 ; if PROVINF is called for "O" mode then can be more than set of data
- +14 ; - need to sort array to use it (like IBXDATA(1) and IBXDATA(2))
- +15 ; for mode "O" it should be 1 or 2 (see PROVIDER section)
- +16 ;IBINSTP - "C" -current ins, "O"-other
- +17 ;Output:
- +18 ; IBRES(PRNUM,PRTYPE,SEQ#)=PROV^INSUR^IDTYPE^ID^FORMTYP^CARETYP
- +19 ; where:(see PROVIDER)
- PROVINF(IB399,IBPRNUM,IBRES,IBSORT,IBINSTP) ;
- +1 IF $GET(IB399)=""
- QUIT
- +2 IF +$GET(IBSORT)=0
- SET IBSORT=$GET(IBPRNUM)
- +3 NEW IBPRTYP,IBINSCO,IBPROV,IBFRMTYP,IBCARE,IB35591,IBN,IBCURR,IBEXC,IBLIMIT
- +4 SET IBN=0
- +5 SET IBINSCO=+$PIECE($GET(^DGCR(399,IB399,"M")),"^",IBPRNUM)
- +6 ;JRA IB*2.0*592 Modify for Dental form 7 - treat the same as CMS-1500
- +7 ;S IBFRMTYP=$$FT^IBCEF(IB399),IBFRMTYP=$S(IBFRMTYP=2:2,IBFRMTYP=3:1,1:0) ;JRA IB*2.0*592 ';'
- +8 ;JWS 8/30/17;IB*2.0*592;JRA IB*2.0*592
- SET IBFRMTYP=$$FT^IBCEF(IB399)
- SET IBFRMTYP=$SELECT(IBFRMTYP=2:2,IBFRMTYP=7:7,IBFRMTYP=3:1,1:0)
- +9 ;if an Rx refill bill
- SET IBCARE=$SELECT($$ISRX^IBCEF1(IB399):3,1:0)
- +10 ;1-inp,2-out
- if IBCARE=0
- SET IBCARE=$$INPAT^IBCEF(IB399,1)
- if 'IBCARE
- SET IBCARE=2
- +11 ; Limits on secondary IDs
- SET IBLIMIT=$SELECT($GET(IBINSTP)="C":5,1:3)
- +12 FOR IBPRTYP=1:1:9
- Begin DoDot:1
- +13 NEW Z,IB355OV
- +14 SET IBPROV=$$PROVPTR^IBCEF7(IB399,IBPRTYP)
- +15 if +IBPROV=0
- QUIT
- +16 ;don't create anything if form type not CMS-1500 or UB
- +17 if IBFRMTYP=0
- QUIT
- +18 NEW IBRETARR
- SET IBRETARR=0
- +19 DO PRACT^IBCEF71(IBINSCO,IBFRMTYP,IBCARE,IBPROV,.IBRETARR,IBPRTYP,$GET(IBINSTP))
- +20 SET IB355OV=""
- SET IBEXC=""
- +21 SET Z=$ORDER(^DGCR(399,IB399,"PRV","B",IBPRTYP,0))
- +22 IF Z
- SET Z=$GET(^DGCR(399,IB399,"PRV",Z,0))
- Begin DoDot:2
- +23 IF $PIECE(Z,U,IBPRNUM+4)'=""
- IF $PIECE(Z,U,IBPRNUM+11)'=""
- SET IB355OV=$PIECE(Z,U,IBPRNUM+4)_U_$PIECE(Z,U,IBPRNUM+11)
- End DoDot:2
- +24 SET IBCURR=$$COB^IBCEF(IB399)
- +25 SET IBN=0
- SET IB35591=$$CH35591^IBCEF72(IBINSCO,IBFRMTYP,IBCARE)
- +26 ;JRA IB*2.0*592 Modify for Dental form 7 - treat the same as CMS-1500
- +27 ;JRA IB*2.0*592
- IF $GET(IBINSTP)="C"
- IF $GET(IBPRNUM)=1
- IF "34"[$GET(IBPRTYP)
- IF "P"[$GET(IBCURR)
- IF ($GET(IBFRMTYP)=2!($GET(IBFRMTYP)=7))
- IF $$MCRONBIL^IBEFUNC(IB399)
- SET IB355OV=$$MCR24K^IBCEU3(IB399)_"^12"
- +28 ;Calculate MEDICARE (WNR) specific provider qualifier and ID for CMS-1500 secondary claim ;JRA IB*2.0*592
- +29 IF $GET(IBINSTP)="O"
- IF "34"[$GET(IBPRTYP)
- IF "ST"[$GET(IBCURR)
- IF ($GET(IBFRMTYP)=2!($GET(IBFRMTYP)=7))
- IF $$MCRONBIL^IBEFUNC(IB399)
- SET IB355OV=$$MCR24K^IBCEU3(IB399)_"^12"
- +30 IF $PIECE(IB355OV,U,2)
- Begin DoDot:2
- +31 IF $$CHCKSEC^IBCEF73(IBFRMTYP,IBPRTYP,$GET(IBINSTP),$PIECE($GET(^IBE(355.97,+$PIECE(IB355OV,U,2),0)),U,3))
- Begin DoDot:3
- +32 SET IBEXC=$PIECE(IB355OV,U,2)
- SET IBN=IBN+1
- SET IBRES(IBSORT,IBPRTYP,IBN)="OVERRIDE^"_IBINSCO_U_$PIECE($GET(^IBE(355.97,+IBEXC,0)),U,3)_U_$PIECE(IB355OV,U)_"^^^^^"_+IBEXC
- End DoDot:3
- End DoDot:2
- +33 IF IB35591'=""
- IF IBEXC'=$PIECE(IB35591,U,3)
- if $$CHCKSEC^IBCEF73(IBFRMTYP,IBPRTYP,$GET(IBINSTP),$PIECE(IB35591,"^"))
- SET IBN=IBN+1
- SET IBRES(IBSORT,IBPRTYP,IBN)="DEFAULT^"_IBINSCO_"^"_IB35591_"^^"
- SET $PIECE(IBRES(IBSORT,IBPRTYP,IBN),U,9)=$PIECE(IB35591,U,3)
- +34 DO SORT(IBSORT,IBPRTYP,IB399,.IBRETARR,.IBRES,IBN,IBEXC,IBPRNUM,IBLIMIT)
- +35 SET IBRES(IBSORT,IBPRTYP)=IBPROV
- End DoDot:1
- +36 SET IBRES(IBSORT)=$SELECT(IBPRNUM=3:"T",IBPRNUM=2:"S",1:"P")
- +37 QUIT
- +38 ;
- SECIDCK(IBIFN,IBSEQ,IBTYP,IBIFN1) ; Function returns 1 if ID type ptr in
- +1 ; IBTYP is valid X12 code for the claim/prov function (IBPROVF)
- +2 ; as a sec id
- +3 ; IBSEQ = COB seq being checked
- +4 ; IBIFN1 = entry # in PRV multiple being checked
- +5 ; Called from input transform of fields .12-.14, subfile 399.0222
- +6 IF $GET(IBIFN)=""
- QUIT
- +7 NEW IBOK,IBFRM,IBCOBN,IBX12,IBPROVF
- +8 SET IBPROVF=+$GET(^DGCR(399,IBIFN,"PRV",IBIFN1,0))
- +9 ; Form type
- SET IBFRM=$$FT^IBCEF(IBIFN)
- SET IBFRM=$SELECT(IBFRM=3:1,1:2)
- +10 ; Current COB seq
- SET IBCOBN=$$COBN^IBCEF(IBIFN)
- if 'IBCOBN
- SET IBCOBN=1
- +11 ; X12 code for prov id typ
- SET IBX12=$PIECE($GET(^IBE(355.97,+IBTYP,0)),U,3)
- +12 QUIT $$CHSEC^IBCEF73(IBFRM,IBPROVF,$SELECT(IBSEQ=IBCOBN:"C",1:"O"),IBX12)
- +13 ;
- DEFID(IBIFN,IBPRV) ;
- +1 ; IBIFN = ien of bill
- +2 ; IBPRV = ien of entry subfile 399.0222
- +3 ; Function returns default ids: prim id def^sec id def^tert id def
- +4 ; SSN cannot be the default ID
- +5 IF $GET(IBIFN)=""
- QUIT ""
- +6 NEW Z,Z1,ID,IBZ,IBINS,IBINS4,IBUB
- +7 SET IBZ=""
- +8 SET IBUB=($$FT^IBCEF(IBIFN)=3)
- +9 DO F^IBCEF("N-ALL ATT/REND PROV SSN/EI","IBZ","",IBIFN)
- +10 SET Z=$GET(^DGCR(399,IBIFN,"PRV",IBPRV,0))
- SET ID=$PIECE(Z,U,5,7)
- +11 FOR Z1=1:1:3
- IF $PIECE(ID,U,Z1)=""
- Begin DoDot:1
- +12 if '$GET(^DGCR(399,IBIFN,"I"_Z1))
- QUIT
- SET IBINS=+^("I"_Z1)
- +13 SET $PIECE(ID,U,Z1)=$$GETID^IBCEP2(IBIFN,2,$PIECE(Z,U,2),Z1)
- +14 ; Set default if null
- +15 IF $PIECE(ID,U,Z1)=""
- SET $PIECE(ID,U,Z1)="VAD000"
- End DoDot:1
- +16 QUIT ID
- +17 ;
- DISPID(IBXIEN) ; Display list of all prov and fac ids that will
- +1 ; extract for this bill if transmitted electronically
- +2 IF $GET(IBXIEN)=""
- QUIT
- +3 NEW IBID,IBID1,IBZ,IBCT,IBFRM,IBCOBN,IBQUIT,IBTYP,DIR,IBIFN,X,Y,Z,Z0,Z1,CO,IBN,IBCODE
- +4 SET IBIFN=IBXIEN
- +5 SET IBFRM=$$FT^IBCEF(IBIFN)
- SET IBCOBN=$$COBN^IBCEF(IBIFN)
- +6 WRITE @IOF
- +7 ;;JWS;IB*2.0*718v10;display message that NPIs are removed for Medicare 837s
- +8 ;;JWS;IB*2.0*727v9;display message that secondary provider IDs will be removed for Medicare claims, except with 1G qualifiers
- +9 WRITE !,"If this bill is transmitted electronically, the following IDs will be sent:"
- +10 WRITE !,"Note: For Medicare:",!," 1) All NPIs will be removed from the claim prior to submission."
- +11 WRITE !," 2) All Provider IDs other than 'UPIN' will be removed from the claim prior to",!?4,"submission.",!
- +12 ; Returns all prov sec ids to be transmitted in indicated segments
- +13 SET Z=+$GET(^DGCR(399,IBIFN,"I1"))
- IF Z
- WRITE !," Primary Ins Co: ",$$EXTERNAL^DILFD(399,101,"",Z)
- IF IBCOBN=1
- WRITE ?54,"<<<Current Ins"
- +14 SET Z=+$GET(^DGCR(399,IBIFN,"I2"))
- IF Z
- WRITE !,"Secondary Ins Co: ",$$EXTERNAL^DILFD(399,101,"",Z)
- IF IBCOBN=2
- WRITE ?54,"<<<Current Ins"
- +15 SET Z=+$GET(^DGCR(399,IBIFN,"I3"))
- IF Z
- WRITE !," Tertiary Ins Co: ",$$EXTERNAL^DILFD(399,101,"",Z)
- IF IBCOBN=3
- WRITE ?54,"<<<Current Ins"
- +16 ;JWS;IB*2.0*592;added Assistant Surgeon records to header display
- +17 WRITE !!,"Provider IDs: (VistA Records OP1,OP2,OP4,OP8,OP9,OP10,OPR,OPR1,OPR2,OPR3,OPR4,",!?29,"OPR5,OPR7,OPR8,OPR9,OPRA,OPRB,OPRC):"
- +18 ;F Z=1:1:3 I $G(^DGCR(399,IBIFN,"I"_Z)) D PROVINF(IBIFN,Z,.IBID,"",$S(IBCOBN=Z:"C",1:"O"))
- +19 ;*432/TAZ - Added call to gather line providers and apply business rules
- +20 DO ALLIDS^IBCEFP(IBIFN,.IBID)
- +21 ;*432/TAZ - Rewrote following code to take info from the IBID array instead of File 399. This allows changes from the application of the business rules.
- +22 SET IBQUIT=0
- +23 ;
- +24 ;JWS;IB*2.0*592; added assistant surgeon
- +25 ; Process providers in order: Attending, Rendering, Referring, Operating, Supervising, and Other Operating if they exist
- FOR IBPRV=4,3,1,2,5,6,9
- Begin DoDot:1
- +26 IF '$DATA(IBID("PROVINF",IBIFN,"C",1,IBPRV))
- QUIT
- +27 IF ($Y+5)>IOSL
- SET IBQUIT=$$NOMORE()
- if IBQUIT
- QUIT
- +28 WRITE !!?5,$$EXTERNAL^DILFD(399.0222,.01,"",IBPRV),": "_$$EXTERNAL^DILFD(399.0222,.02,"",$PIECE(IBID("PROVINF",IBIFN,"C",1,IBPRV),U))
- +29 WRITE !?8,"NPI: ",?40,$SELECT($PIECE($GET(IBID("PROVINF",IBIFN,"C",1,IBPRV,0)),U,4)]"":$PIECE(IBID("PROVINF",IBIFN,"C",1,IBPRV,0),U,4),1:"***MISSING***")
- +30 KILL IBTYP
- +31 FOR CO="C","O"
- Begin DoDot:2
- +32 FOR IBN=1,2
- IF $DATA(IBID("PROVINF",IBIFN,CO,IBN,IBPRV))
- Begin DoDot:3
- +33 FOR Z0=1:1
- if '$DATA(IBID("PROVINF",IBIFN,CO,IBN,IBPRV,Z0))!IBQUIT
- QUIT
- Begin DoDot:4
- +34 SET IBCODE=+$PIECE(IBID("PROVINF",IBIFN,CO,IBN,IBPRV,Z0),U,9)
- +35 ;1st of each type transmits
- if $DATA(IBTYP(IBCODE))
- QUIT
- +36 IF ($Y+5)>IOSL
- SET IBQUIT=$$NOMORE()
- if IBQUIT
- QUIT
- +37 SET IBTYP(IBCODE)=""
- +38 WRITE !,?8,"(",IBID("PROVINF",IBIFN,CO,IBN),") ",$$EXTERNAL^DILFD(36,4.01,"",IBCODE),?40,$PIECE(IBID("PROVINF",IBIFN,CO,IBN,IBPRV,Z0),U,4)
- End DoDot:4
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +39 ;
- +40 IF IBQUIT
- GOTO DISPIDX
- +41 ;
- +42 ; IB*2*320 - display additional IDs for ?ID
- +43 DO EN^IBCEF74A(IBIFN,.IBQUIT,.IBID)
- +44 ;
- DISPIDX ;
- +1 IF '$GET(IBQUIT)
- SET DIR(0)="EA"
- SET DIR("A")="Press RETURN to continue "
- WRITE !
- DO ^DIR
- KILL DIR
- +2 QUIT
- +3 ;
- NOMORE() ;
- +1 SET DIR(0)="EA"
- SET DIR("A")="Press RETURN for more IDs or '^' to exit: "
- WRITE !
- DO ^DIR
- +2 WRITE @IOF
- +3 QUIT (Y'=1)
- +4 ;
- DEFSEC(IBIFN,IBARR) ; Returns array in IBARR for default prov sec ids for ien IBIFN
- +1 ; IBARR if passed by ref is returned IBARR(prov function,COBN)=def id
- +2 IF $GET(IBIFN)=""
- +3 NEW IBCAR,IBCOBN,IBPC,IBINS,IBARRX,Q,Z,Z0,ZINS,X
- +4 KILL IBARR
- +5 SET ZINS=""
- SET IBCOBN=$$COBN^IBCEF(IBIFN)
- SET IBPC=$SELECT($$FT^IBCEF(IBIFN)=3:2,1:1)
- +6 SET IBCAR=$$INPAT^IBCEF(IBIFN,1)
- SET IBCAR=$SELECT('IBCAR:2,1:1)
- +7 FOR Z=1:1:3
- SET ZINS=ZINS_+$GET(^DGCR(399,IBIFN,"I"_Z))_U
- +8 FOR Z=1:1:3
- IF $PIECE(ZINS,U,Z)
- IF '$PIECE($GET(^DIC(36,+$PIECE(ZINS,U,Z),4)),U,IBPC)
- SET $PIECE(ZINS,U,Z)=""
- +9 SET Z=0
- FOR
- SET Z=$ORDER(^DGCR(399,IBIFN,"PRV",Z))
- if 'Z
- QUIT
- SET Z0=$GET(^(Z,0))
- Begin DoDot:1
- +10 FOR Q=1:1:3
- Begin DoDot:2
- +11 ; Override
- IF $PIECE(Z0,U,Q+4)'=""
- SET IBARR(+Z0,Q)=$PIECE(Z0,U,Q+4)
- QUIT
- +12 SET IBINS=$PIECE(ZINS,U,Q)
- +13 if 'IBINS
- QUIT
- +14 SET X=$$IDFIND^IBCEP2(IBIFN,"",$PIECE(Z0,U,2),Q,1)
- +15 IF X'=""
- SET IBARR(+Z0,Q)=X
- End DoDot:2
- End DoDot:1
- +16 QUIT
- +17 ;