Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: IBCEF74

IBCEF74.m

Go to the documentation of this file.
  1. 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
  1. ;;Per VA Directive 6402, this routine should not be modified.
  1. ;
  1. SORT(IBPRNUM,IBPRTYP,IB399,IBSRC,IBDST,IBN,IBEXC,IBSEQ,IBLIMIT) ;
  1. D SORT^IBCEF77($G(IBPRNUM),$G(IBPRTYP),$G(IB399),.IBSRC,.IBDST,$G(IBN),$G(IBEXC),$G(IBSEQ),$G(IBLIMIT))
  1. Q
  1. ;
  1. ;-- PROVINF --
  1. ;Create array with prov info
  1. ;Input:
  1. ; IB399 - ien #399
  1. ; IBPRNUM - 1=prim ins, 2= sec, 3 -tert
  1. ; IBRES - for results
  1. ; IBSORT - to sort OTHER INSURANCE data
  1. ; if PROVINF is called for "C" mode of PROVIDER subroutine then
  1. ; IBSORT can be any (say 1)
  1. ; if PROVINF is called for "O" mode then can be more than set of data
  1. ; - need to sort array to use it (like IBXDATA(1) and IBXDATA(2))
  1. ; for mode "O" it should be 1 or 2 (see PROVIDER section)
  1. ;IBINSTP - "C" -current ins, "O"-other
  1. ;Output:
  1. ; IBRES(PRNUM,PRTYPE,SEQ#)=PROV^INSUR^IDTYPE^ID^FORMTYP^CARETYP
  1. ; where:(see PROVIDER)
  1. PROVINF(IB399,IBPRNUM,IBRES,IBSORT,IBINSTP) ;
  1. I $G(IB399)="" Q
  1. I +$G(IBSORT)=0 S IBSORT=$G(IBPRNUM)
  1. N IBPRTYP,IBINSCO,IBPROV,IBFRMTYP,IBCARE,IB35591,IBN,IBCURR,IBEXC,IBLIMIT
  1. S IBN=0
  1. S IBINSCO=+$P($G(^DGCR(399,IB399,"M")),"^",IBPRNUM)
  1. ;JRA IB*2.0*592 Modify for Dental form 7 - treat the same as CMS-1500
  1. ;S IBFRMTYP=$$FT^IBCEF(IB399),IBFRMTYP=$S(IBFRMTYP=2:2,IBFRMTYP=3:1,1:0) ;JRA IB*2.0*592 ';'
  1. 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
  1. S IBCARE=$S($$ISRX^IBCEF1(IB399):3,1:0) ;if an Rx refill bill
  1. S:IBCARE=0 IBCARE=$$INPAT^IBCEF(IB399,1) S:'IBCARE IBCARE=2 ;1-inp,2-out
  1. S IBLIMIT=$S($G(IBINSTP)="C":5,1:3) ; Limits on secondary IDs
  1. F IBPRTYP=1:1:9 D
  1. . N Z,IB355OV
  1. . S IBPROV=$$PROVPTR^IBCEF7(IB399,IBPRTYP)
  1. . Q:+IBPROV=0
  1. . ;don't create anything if form type not CMS-1500 or UB
  1. . Q:IBFRMTYP=0
  1. . N IBRETARR S IBRETARR=0
  1. . D PRACT^IBCEF71(IBINSCO,IBFRMTYP,IBCARE,IBPROV,.IBRETARR,IBPRTYP,$G(IBINSTP))
  1. . S IB355OV="",IBEXC=""
  1. . S Z=$O(^DGCR(399,IB399,"PRV","B",IBPRTYP,0))
  1. . I Z S Z=$G(^DGCR(399,IB399,"PRV",Z,0)) D
  1. .. I $P(Z,U,IBPRNUM+4)'="",$P(Z,U,IBPRNUM+11)'="" S IB355OV=$P(Z,U,IBPRNUM+4)_U_$P(Z,U,IBPRNUM+11)
  1. . S IBCURR=$$COB^IBCEF(IB399)
  1. . S IBN=0,IB35591=$$CH35591^IBCEF72(IBINSCO,IBFRMTYP,IBCARE)
  1. . ;JRA IB*2.0*592 Modify for Dental form 7 - treat the same as CMS-1500
  1. . 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
  1. . ;Calculate MEDICARE (WNR) specific provider qualifier and ID for CMS-1500 secondary claim ;JRA IB*2.0*592
  1. . 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"
  1. . I $P(IB355OV,U,2) D
  1. .. I $$CHCKSEC^IBCEF73(IBFRMTYP,IBPRTYP,$G(IBINSTP),$P($G(^IBE(355.97,+$P(IB355OV,U,2),0)),U,3)) D
  1. ... 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
  1. . 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)
  1. . D SORT(IBSORT,IBPRTYP,IB399,.IBRETARR,.IBRES,IBN,IBEXC,IBPRNUM,IBLIMIT)
  1. . S IBRES(IBSORT,IBPRTYP)=IBPROV
  1. S IBRES(IBSORT)=$S(IBPRNUM=3:"T",IBPRNUM=2:"S",1:"P")
  1. Q
  1. ;
  1. 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)
  1. ; as a sec id
  1. ; IBSEQ = COB seq being checked
  1. ; IBIFN1 = entry # in PRV multiple being checked
  1. ; Called from input transform of fields .12-.14, subfile 399.0222
  1. I $G(IBIFN)="" Q
  1. N IBOK,IBFRM,IBCOBN,IBX12,IBPROVF
  1. S IBPROVF=+$G(^DGCR(399,IBIFN,"PRV",IBIFN1,0))
  1. S IBFRM=$$FT^IBCEF(IBIFN),IBFRM=$S(IBFRM=3:1,1:2) ; Form type
  1. S IBCOBN=$$COBN^IBCEF(IBIFN) S:'IBCOBN IBCOBN=1 ; Current COB seq
  1. S IBX12=$P($G(^IBE(355.97,+IBTYP,0)),U,3) ; X12 code for prov id typ
  1. Q $$CHSEC^IBCEF73(IBFRM,IBPROVF,$S(IBSEQ=IBCOBN:"C",1:"O"),IBX12)
  1. ;
  1. DEFID(IBIFN,IBPRV) ;
  1. ; IBIFN = ien of bill
  1. ; IBPRV = ien of entry subfile 399.0222
  1. ; Function returns default ids: prim id def^sec id def^tert id def
  1. ; SSN cannot be the default ID
  1. I $G(IBIFN)="" Q ""
  1. N Z,Z1,ID,IBZ,IBINS,IBINS4,IBUB
  1. S IBZ=""
  1. S IBUB=($$FT^IBCEF(IBIFN)=3)
  1. D F^IBCEF("N-ALL ATT/REND PROV SSN/EI","IBZ","",IBIFN)
  1. S Z=$G(^DGCR(399,IBIFN,"PRV",IBPRV,0)),ID=$P(Z,U,5,7)
  1. F Z1=1:1:3 I $P(ID,U,Z1)="" D
  1. . Q:'$G(^DGCR(399,IBIFN,"I"_Z1)) S IBINS=+^("I"_Z1)
  1. . S $P(ID,U,Z1)=$$GETID^IBCEP2(IBIFN,2,$P(Z,U,2),Z1)
  1. . ; Set default if null
  1. . I $P(ID,U,Z1)="" S $P(ID,U,Z1)="VAD000"
  1. Q ID
  1. ;
  1. DISPID(IBXIEN) ; Display list of all prov and fac ids that will
  1. ; extract for this bill if transmitted electronically
  1. I $G(IBXIEN)="" Q
  1. N IBID,IBID1,IBZ,IBCT,IBFRM,IBCOBN,IBQUIT,IBTYP,DIR,IBIFN,X,Y,Z,Z0,Z1,CO,IBN,IBCODE
  1. S IBIFN=IBXIEN
  1. S IBFRM=$$FT^IBCEF(IBIFN),IBCOBN=$$COBN^IBCEF(IBIFN)
  1. W @IOF
  1. ;;JWS;IB*2.0*718v10;display message that NPIs are removed for Medicare 837s
  1. ;;JWS;IB*2.0*727v9;display message that secondary provider IDs will be removed for Medicare claims, except with 1G qualifiers
  1. W !,"If this bill is transmitted electronically, the following IDs will be sent:"
  1. W !,"Note: For Medicare:",!," 1) All NPIs will be removed from the claim prior to submission."
  1. W !," 2) All Provider IDs other than 'UPIN' will be removed from the claim prior to",!?4,"submission.",!
  1. ; Returns all prov sec ids to be transmitted in indicated segments
  1. 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"
  1. 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"
  1. 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"
  1. ;JWS;IB*2.0*592;added Assistant Surgeon records to header display
  1. W !!,"Provider IDs: (VistA Records OP1,OP2,OP4,OP8,OP9,OP10,OPR,OPR1,OPR2,OPR3,OPR4,",!?29,"OPR5,OPR7,OPR8,OPR9,OPRA,OPRB,OPRC):"
  1. ;F Z=1:1:3 I $G(^DGCR(399,IBIFN,"I"_Z)) D PROVINF(IBIFN,Z,.IBID,"",$S(IBCOBN=Z:"C",1:"O"))
  1. ;*432/TAZ - Added call to gather line providers and apply business rules
  1. D ALLIDS^IBCEFP(IBIFN,.IBID)
  1. ;*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.
  1. S IBQUIT=0
  1. ;
  1. ;JWS;IB*2.0*592; added assistant surgeon
  1. 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
  1. . I '$D(IBID("PROVINF",IBIFN,"C",1,IBPRV)) Q
  1. . I ($Y+5)>IOSL S IBQUIT=$$NOMORE() Q:IBQUIT
  1. . W !!?5,$$EXTERNAL^DILFD(399.0222,.01,"",IBPRV),": "_$$EXTERNAL^DILFD(399.0222,.02,"",$P(IBID("PROVINF",IBIFN,"C",1,IBPRV),U))
  1. . 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***")
  1. . K IBTYP
  1. . F CO="C","O" D
  1. .. F IBN=1,2 I $D(IBID("PROVINF",IBIFN,CO,IBN,IBPRV)) D
  1. ... F Z0=1:1 Q:'$D(IBID("PROVINF",IBIFN,CO,IBN,IBPRV,Z0))!IBQUIT D
  1. .... S IBCODE=+$P(IBID("PROVINF",IBIFN,CO,IBN,IBPRV,Z0),U,9)
  1. .... Q:$D(IBTYP(IBCODE)) ;1st of each type transmits
  1. .... I ($Y+5)>IOSL S IBQUIT=$$NOMORE() Q:IBQUIT
  1. .... S IBTYP(IBCODE)=""
  1. .... W !,?8,"(",IBID("PROVINF",IBIFN,CO,IBN),") ",$$EXTERNAL^DILFD(36,4.01,"",IBCODE),?40,$P(IBID("PROVINF",IBIFN,CO,IBN,IBPRV,Z0),U,4)
  1. ;
  1. I IBQUIT G DISPIDX
  1. ;
  1. ; IB*2*320 - display additional IDs for ?ID
  1. D EN^IBCEF74A(IBIFN,.IBQUIT,.IBID)
  1. ;
  1. DISPIDX ;
  1. I '$G(IBQUIT) S DIR(0)="EA",DIR("A")="Press RETURN to continue " W ! D ^DIR K DIR
  1. Q
  1. ;
  1. NOMORE() ;
  1. S DIR(0)="EA",DIR("A")="Press RETURN for more IDs or '^' to exit: " W ! D ^DIR
  1. W @IOF
  1. Q (Y'=1)
  1. ;
  1. 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
  1. I $G(IBIFN)=""
  1. N IBCAR,IBCOBN,IBPC,IBINS,IBARRX,Q,Z,Z0,ZINS,X
  1. K IBARR
  1. S ZINS="",IBCOBN=$$COBN^IBCEF(IBIFN),IBPC=$S($$FT^IBCEF(IBIFN)=3:2,1:1)
  1. S IBCAR=$$INPAT^IBCEF(IBIFN,1),IBCAR=$S('IBCAR:2,1:1)
  1. F Z=1:1:3 S ZINS=ZINS_+$G(^DGCR(399,IBIFN,"I"_Z))_U
  1. 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)=""
  1. S Z=0 F S Z=$O(^DGCR(399,IBIFN,"PRV",Z)) Q:'Z S Z0=$G(^(Z,0)) D
  1. . F Q=1:1:3 D
  1. .. I $P(Z0,U,Q+4)'="" S IBARR(+Z0,Q)=$P(Z0,U,Q+4) Q ; Override
  1. .. S IBINS=$P(ZINS,U,Q)
  1. .. Q:'IBINS
  1. .. S X=$$IDFIND^IBCEP2(IBIFN,"",$P(Z0,U,2),Q,1)
  1. .. I X'="" S IBARR(+Z0,Q)=X
  1. Q
  1. ;