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

IBCEF72.m

Go to the documentation of this file.
  1. IBCEF72 ;WOIFO/SS - FORMATTER AND EXTRACTOR SPECIFIC BILL FUNCTIONS ;8/6/03 10:56am
  1. ;;2.0;INTEGRATED BILLING;**232,320,349,432,516,592,623**;21-MAR-94;Build 70
  1. ;;Per VA Directive 6402, this routine should not be modified.
  1. ;
  1. ;
  1. ;Input:
  1. ;IBINSCO - ptr to #36
  1. ;IBFRMTYP 0=unknwn/both,1=UB,2=1500,7=J430D
  1. ;IBCARE - 0=unknwn or both inp/outp,1=inpatient, 2=outpatient, 3 -RX
  1. ;Output: X12 IDtype^ID^ID TYPE ptr to file 355.97
  1. CH35591(IBINSCO,IBFRMTYP,IBCARE) ;
  1. N IB35591,IBRET,IB1
  1. S IB35591=0,IBRET=""
  1. F S IB35591=$O(^IBA(355.91,"B",IBINSCO,IB35591)) Q:+IB35591=0 Q:IBRET'="" D
  1. . S IB1=$G(^IBA(355.91,IB35591,0))
  1. . I '($P(IB1,"^",4)=0!(IBFRMTYP=0)) Q:$P(IB1,"^",4)'=IBFRMTYP ;if wrong form type
  1. . I ($P(IB1,"^",5)=3)!(IBCARE=3) Q:IBCARE'=$P(IB1,"^",5) ;if not RX
  1. . ;JWS;IB*2.0*592 - if dental, no secondary id's
  1. . I IBFRMTYP=7 Q
  1. . I ($P(IB1,"^",5)=1)!($P(IB1,"^",5)=2) I (IBCARE=1)!(IBCARE=2) Q:$P(IB1,"^",5)'=IBCARE ;if wrong care type
  1. . S IBRET=$P($G(^IBE(355.97,+$P(IB1,"^",6),0)),"^",3)_"^"_$P(IB1,"^",7)_U_+$P(IB1,U,6)
  1. Q IBRET
  1. ;
  1. FINDEIN(IBXIEN,IBPROV,IBFAC,IBS) ; find EIN for facility/ SSN for person
  1. ; IBXIEN = ien of bill entry file 399
  1. ; IBFAC = 1 if facility, 0 if individual provider
  1. ; IBPROV = ien of provider (vp format)
  1. ; IBS = 1 if person's EIN should be returned if there, otherwise SSN
  1. ; FUNCTION RETURNS
  1. ; EIN or SSN ^ 24 for EIN, 34 for SSN or null if none found
  1. N Z,Z0,IBARR,IBEIN,IBSSN
  1. S (IBEIN,IBSSN)=""
  1. D ALLID^IBCEP8(IBPROV,"",.IBARR)
  1. S Z=0 F S Z=$O(IBARR(Z)) Q:'Z D Q:IBEIN'=""
  1. . I $G(IBFAC) Q:$P(IBARR(Z),U,7)'="EI" S IBEIN=$P(IBARR(Z),U,2)_U_24 Q
  1. . I $P(IBARR(Z),U,7)="SY" D Q
  1. .. I $G(IBS) S IBSSN=$P(IBARR(Z),U,2)_U_34 Q
  1. . S IBEIN=$P(IBARR(Z),U,2)_U_24
  1. . I $G(IBS),$P(IBARR(Z),U,7)="EI" S IBEIN=$P(IBARR(Z),U,2)_U_24
  1. I $G(IBS),IBEIN="" S IBEIN=IBSSN
  1. Q IBEIN
  1. ;
  1. ;
  1. NONVAID(IBXIEN,IBX,IBFAC,IBS) ; Find the non-VA provider default id
  1. ; IBXIEN = the ien of the bill (file 399)
  1. ; IBX = id data returned if passed by reference
  1. ; IBFAC = 1 if getting the id for the facility or 0 for rendering prov
  1. ; IBS = 1 if getting id for person, but need the EIN if there
  1. ; Function returns the id^type of id^person/facility flag:
  1. ; Type of id: 1 = SSN 2 = EIN 0 = not found
  1. ; person/facility: 1 = person 2 = facility
  1. N Z,IBXSAVE,IBU2,IBTYPE,IBZ,IBF,IBPROV,Q,Q0
  1. S IBTYPE=2,IBU2=$G(^DGCR(399,IBXIEN,"U2")),IBF=2,IBPROV=""
  1. ;
  1. S Z=$P(IBU2,U,10)
  1. I 'Z S IBX="",IBTYPE=0 G NONVAQ ; Not a non-VA facility
  1. S IBPROV=Z_";IBA(355.93,"
  1. ;
  1. ; Get EIN
  1. I $G(IBFAC) D G NONVAQ
  1. . S IBX=$P($$FINDEIN(IBXIEN,IBPROV,IBFAC),U),IBTYPE=2
  1. ;
  1. ; Get EIN/SSN
  1. I '$G(IBFAC) D G NONVAQ
  1. . S IBX="",IBF=1
  1. . S Q0=($$FT^IBCEF(IBXIEN)=3)+3 ; 3 for rendering/4 for attending
  1. . S Q=+$O(^DGCR(399,IBXIEN,"PRV","B",Q0,0))
  1. . S IBPROV=$P($G(^DGCR(399,IBXIEN,"PRV",Q,0)),U,2)
  1. . I IBPROV S IBX=$$FINDEIN(IBXIEN,IBPROV,IBFAC,$G(IBS)),IBTYPE=$S($P(IBX,U,2)=24:2,$P(IBX,U,2)=34:1,1:0),IBX=$P(IBX,U)
  1. ;
  1. NONVAQ I IBTYPE,IBX="",$P(IBU2,U,12)'="" S IBX=$P(IBU2,U,12) ; pull from 399
  1. S IBX=$G(IBX)
  1. Q IBX_U_IBTYPE_U_IBF
  1. ;----
  1. ;checks if there is data for OP* segments and
  1. ;then populates PROV COB SEQ
  1. ;Input:
  1. ;IBXIEN - ien in #399
  1. ;IBSAVE - "in" array (i.e. IBXSAVE)
  1. ;IBDATA - "out" array (i.e. IBXDATA)
  1. ;IBFUNC - FUNCTION from #399 (1-refering, 2 -operating, etc)
  1. ;IBSEGM - segment record ID, optional
  1. ;Output:
  1. ; IBDATA with formatted output
  1. PROVSEQ(IBXIEN,IBSAVE,IBDATA,IBFUNC,IBSEGM) ;
  1. N IB1,IBINS,IBFL
  1. ;S IBFL=$S(IBFUNC=3!(IBFUNC=4):1,1:0)
  1. F IB1=1,2 D
  1. . I '$$ISINSUR^IBCEF71($G(IBSAVE("PROVINF",IBXIEN,"O",IB1)),IBXIEN) Q ;don't create anything if there is no such insurance
  1. . ;*432/TAZ - Removed. Attending and Rendering can be on same bill now.
  1. . ;I IBFL S IBFUNC=$S($O(IBSAVE("PROVINF",IBXIEN,"O",IB1,3,0)):3,1:4)
  1. . I '$O(IBSAVE("PROVINF",IBXIEN,"O",IB1,IBFUNC,0)) Q
  1. . S IBDATA(IB1)=$G(IBSAVE("PROVINF",IBXIEN,"O",IB1))
  1. . I $G(IBSEGM)'="" D ID^IBCEF2(IB1,IBSEGM)
  1. Q
  1. ;
  1. OUTPRVID(IBXIEN,IBXSAVE) ; Extract the outside provider or facility ids
  1. ; into IBXSAVE array
  1. ; Function returns 1 if person or 2 if facility ids or "" if neither
  1. N Z,IBXDATA,IBPERSON,TAG
  1. ;WCJ;11/1/2005 Extract the first 3 chars of Z instead.
  1. S Z=$E($$PSPRV^IBCEF7(IBXIEN),1,3),IBPERSON=""
  1. ;EJK 8/23/05 IB*320 - CHANGED Z=101 TO Z=1010. Z WILL ALWAYS BE A 4 DIGIT #.
  1. ; WCJ 11/1/2005 ; Removed EJK's change and added above change
  1. I Z=111!(Z=101) S TAG=$S(Z=101:"OUTSIDE FAC PROVIDER INF",1:"CUR/OTH PROVIDER INFO") D F^IBCEF("N-ALL "_TAG) S IBPERSON=$S('$E(Z,2):2,1:1)
  1. Q IBPERSON
  1. ;
  1. OUTPRV(IBREC,IBXIEN,IBXSAVE) ; Extract the outside provider or facility ids
  1. ; into IBXSAVE array
  1. ; Function returns 1 if person or 2 if facility ids or "" if neither
  1. ; IBREC = the record whose ids should be returned
  1. N IBPERSON,IBFRM,IBTYPE,IBFAC
  1. I IBREC="SUB1"!(IBREC="OP6") D
  1. . K IBXSAVE("PROVINF",IBXIEN),IBXSAVE("PROVINF_FAC",IBXIEN)
  1. . S IBPERSON=$$OUTPRVID(IBXIEN,.IBXSAVE),IBFAC=$S(IBPERSON=1:0,1:1)
  1. E D
  1. . K IBXSAVE("PROVINF_FAC",IBXIEN)
  1. . D F^IBCEF("N-ALL OUTSIDE FAC PROVIDER INF")
  1. . S IBPERSON=2,IBFAC=1
  1. S IBFRM=$$FT^IBCEF(IBXIEN),IBFRM=$S(IBFRM=2:2,1:1)
  1. S IBTYPE=$S(IBREC["SUB":"C",1:"O")
  1. D CHCKSUB^IBCEF73(IBFRM,IBREC,IBFAC,IBTYPE,.IBXSAVE)
  1. Q IBPERSON
  1. ;
  1. ;get IENs in file #36 for other insurances
  1. OTHINS(IB399,IBRES) ;
  1. N IBFRMTYP,Z,Z1,Z2,Z4
  1. S Z=$$COBN^IBCEF(IB399),Z0=0
  1. F Z1=1:1:3 I Z1'=Z,$D(^DGCR(399,IB399,"I"_Z1)) D
  1. . S Z0=Z0+1
  1. . ; MRD;IB*2.0*516 - Added HPID as second piece.
  1. . ; vd - IB*2.0*623 - Added M2 as third piece.
  1. . ; JWS - IB*2.0*623 - needs $G around ^DGCR references
  1. . ;S IBRES(Z0)=+$G(^DGCR(399,IB399,"I"_Z1))_U_$P(^DGCR(399,IB399,"M1"),U,12+Z1)
  1. . S IBRES(Z0)=+$G(^DGCR(399,IB399,"I"_Z1))_U_$P($G(^DGCR(399,IB399,"M1")),U,12+Z1)_U_$P($G(^DGCR(399,IB399,"M2")),U,Z1*2)
  1. . Q
  1. Q
  1. ;
  1. ;get other insurance EDI ID NUMBERs
  1. OTHINSID(IB399,IBRES) ;insurance EDI
  1. N IBFRMTYP,IBZ,Z0,Z1,Z4
  1. ;JWS;IB*2.0*592;Dental form
  1. S IBFRMTYP=$$FT^IBCEF(IB399),IBFRMTYP=$S(IBFRMTYP=2:2,IBFRMTYP=3:1,IBFRMTYP=7:7,1:0)
  1. S Z4=$S(IBFRMTYP=1:4,IBFRMTYP=7:15,1:2) ;UB - piece4,DENTAL - piece 15, 1500 or BOTH -piece 2,
  1. D OTHINS(IB399,.IBZ)
  1. S Z1=0
  1. F Z0=1,2 I $G(IBZ(Z0)) D
  1. . S IBRES(Z0)=$S($$MCRWNR^IBEFUNC(+IBZ(Z0)):$S(IBFRMTYP=1:"12M61",1:"SMTX1"),1:$P($G(^DIC(36,+IBZ(Z0),3)),U,Z4))
  1. . ; vd - IB*2.0*623 - Added the following line for US4100.
  1. . I $P(IBZ(Z0),U,3)]"" S IBRES(Z0)=$P(IBZ(Z0),U,3) ; Return the correct Alternate ID from node "M2"
  1. . ; MRD;IB*2.0*516 - Added HPID as second piece.
  1. . S $P(IBRES(Z0),U,2)=$P(IBZ(Z0),U,2)
  1. . Q
  1. Q
  1. ;
  1. ;get other insurance addresses
  1. OTHINADR(IB399,IBRES,IBADDFLD) ;insurance EDI
  1. N IBZ,Z0,Z1,Z4
  1. D OTHINS(IB399,.IBZ)
  1. S Z1=0
  1. I IBADDFLD=18 D Q
  1. . F Z0=1:1:2 I $G(IBZ(Z0)) D
  1. . . S IBRES(Z0)=$P($G(^DIC(36,+IBZ(Z0),.11)),U,1)
  1. . . S IBRES(Z0)=$E(IBRES(Z0),1,55)
  1. I IBADDFLD=18.9 D Q
  1. . F Z0=1:1:2 I $G(IBZ(Z0)) D
  1. . . S IBRES(Z0)=$P($G(^DIC(36,+IBZ(Z0),.11)),U,1)
  1. . . S Z4=$P($G(^DIC(36,+IBZ(Z0),.11)),U,2) S:Z4'="" IBRES(Z0)=IBRES(Z0)_", "_Z4
  1. . . S Z4=$P($G(^DIC(36,+IBZ(Z0),.11)),U,3) S:Z4'="" IBRES(Z0)=IBRES(Z0)_", "_Z4
  1. . . S Z4=$P($G(^DIC(36,+IBZ(Z0),.11)),U,4) S:Z4'="" IBRES(Z0)=IBRES(Z0)_", "_Z4
  1. . . S Z4=$P($G(^DIC(5,+$P($G(^DIC(36,+IBZ(Z0),.11)),U,5),0)),U,2) S:Z4'="" IBRES(Z0)=IBRES(Z0)_", "_Z4
  1. . . S Z4=$P($G(^DIC(36,+IBZ(Z0),.11)),U,6) S:Z4'="" IBRES(Z0)=IBRES(Z0)_", "_Z4
  1. . . S IBRES(Z0)=$E(IBRES(Z0),1,157)
  1. I IBADDFLD=19 D Q
  1. . F Z0=1:1:2 I $G(IBZ(Z0)) D
  1. . . S IBRES(Z0)=$P($G(^DIC(36,+IBZ(Z0),.11)),U,2)
  1. . . S IBRES(Z0)=IBRES(Z0)_" "_$P($G(^DIC(36,+IBZ(Z0),.11)),U,3)
  1. . . S IBRES(Z0)=$E(IBRES(Z0),1,55)
  1. I IBADDFLD=20 D Q
  1. . F Z0=1:1:2 I $G(IBZ(Z0)) D
  1. . . S IBRES(Z0)=$P($G(^DIC(36,+IBZ(Z0),.11)),U,4)
  1. . . S IBRES(Z0)=$E(IBRES(Z0),1,30)
  1. I IBADDFLD=21 D Q
  1. . F Z0=1:1:2 I $G(IBZ(Z0)) D
  1. . . S IBRES(Z0)=$P($G(^DIC(5,+$P($G(^DIC(36,+IBZ(Z0),.11)),U,5),0)),U,2)
  1. . . S IBRES(Z0)=$E(IBRES(Z0),1,2)
  1. I IBADDFLD=22 D Q
  1. . F Z0=1:1:2 I $G(IBZ(Z0)) D
  1. . . S IBRES(Z0)=$P($G(^DIC(36,+IBZ(Z0),.11)),U,6)
  1. . . S IBRES(Z0)=$E(IBRES(Z0),1,15)
  1. Q
  1. ;
  1. SFIDQ(IBXIEN,IBXSAVE,IBXDATA) ; Find the service facility id qualifier for
  1. ; 837 record SUB2-5
  1. ;IBXIEN = ien of 399
  1. ;Pass by reference: IBXSAVE (input/output) IBXDATA (output)
  1. N B,Z
  1. K IBXSAVE("NVID")
  1. D ; protect IBXDATA
  1. . N IBXDATA
  1. . D F^IBCEF("N-RENDERING INSTITUTION")
  1. . S:IBXDATA'="" IBXSAVE("IBFAC")=IBXDATA
  1. I $P($G(IBXSAVE("IBFAC")),U,2)'=1 K IBXDATA Q
  1. S Z=$$PSPRV^IBCEF7(IBXIEN)
  1. ;WCJ 11/04/2005 If a Non-VA facility
  1. I $E(Z) D
  1. . S IBXSAVE("NVID")=$$NONVAID^IBCEF72(IBXIEN,.B,$E(Z),1)
  1. .; S IBXSAVE("NVID")=$$NONVAID^IBCEF72(IBXIEN,.B,'$E(Z,2),1)
  1. . S IBXDATA=$P("^34^24",U,$P(IBXSAVE("NVID"),U,2)+1)
  1. ;S Z=$$PSPRV^IBCEF7(IBXIEN),IBXSAVE("NVID")=$$NONVAID^IBCEF72(IBXIEN,.B,'$E(Z,2),1),IBXDATA=24
  1. Q
  1. ;
  1. OTHP36(IBXIEN,IBZOUT) ;
  1. N Z,Z0,Z1,IBZ
  1. D F^IBCEF("N-ALL INSURANCE CO 837 ID","IBZ")
  1. F Z=1,2,3 S IBZOUT(Z)=+$$POLICY^IBCEF(IBXIEN,1,$E("PST",Z))
  1. Q
  1. ;
  1. ;---------SORT-----------
  1. ;IBPRNUM - seq #
  1. ;IBPRTYP - type of provider (use FUNCTION value from file 399, fld 222)
  1. ;IB399 = ien file 399
  1. ;IBSRC,IBDST - source,destination arrays
  1. ;IBN - starting #
  1. ;Output:
  1. ; IBDST(1-primary/2-secondary provider,Provider type(FUNCTION),N)=
  1. ; =provider/VARIABLEPTR^Insurance PTR #36 or NONE^ID type^ID^Form type^Care type^state ptr #5 for state license #
  1. ; where N is numeration (1 for ID1, 2 for ID2, etc)
  1. GETSSN(IBPTR) ;look for SSN in #200 first and if not found then look at #355.9
  1. ;if in file #200
  1. I $P(IBPTR,";",2)="VA(200," Q $$SSN200^IBCEF73(IBPTR)
  1. ;if in 355.93 then use 355.9
  1. Q $$SSN3559^IBCEF73(IBPTR)
  1. ;--
  1. ;SSN3559
  1. ;Find SSN from 355.9
  1. ;Input:
  1. ; Variable pointer to ^VA(200 or ^IBA(355.93
  1. ;Output:
  1. ; SSN or null
  1. ;
  1. PADNDC(Z) ;PAD LEADING ZERO'S INTO A NON 5-4-2 FORMAT NDC NUMBER
  1. ;Z IS ITERATION, ONLY PAD CURRENT NDC NUMBER
  1. N NDC
  1. S NDC=$P(IBXSAVE("OUTPT",Z,"RX"),"^",3)
  1. Q:$L(NDC)=13
  1. I $L(NDC)=14 D Q
  1. . S $P(NDC,"-",1)=$E($P(NDC,"-",1),2,$L($P(NDC,"-",1)))
  1. . S $P(IBXSAVE("OUTPT",Z,"RX"),"^",3)=NDC
  1. I $L($P(NDC,"-",1))'=5 S $P(NDC,"-",1)="0"_$P(NDC,"-",1)
  1. I $L($P(NDC,"-",2))'=4 S $P(NDC,"-",2)="0"_$P(NDC,"-",2)
  1. I $L($P(NDC,"-",3))'=2 S $P(NDC,"-",3)="0"_$P(NDC,"-",3)
  1. S $P(IBXSAVE("OUTPT",Z,"RX"),"^",3)=NDC
  1. Q
  1. ;