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