- IBCEF73 ;WOIFO/SS - FORMATTER AND EXTRACTOR SPECIFIC BILL FUNCTIONS ;8/6/03 10:56am
- ;;2.0;INTEGRATED BILLING;**232,320,358,349,377,592**;21-MAR-94;Build 58
- ;;Per VA Directive 6402, this routine should not be modified.
- ;
- ;check qualifier
- ;IBFRM 0-both, 1=UB,2=1500, 7=J430D
- ;IBPROV - function in #399 (1-referring, 2-operating,etc)
- ;IBTYPE - "C"-current insurance, "O"-other insurance
- ;IBVAL - value to check
- CHCKSEC(IBFRM,IBPROV,IBTYPE,IBVAL) ;
- I IBFRM=0 Q:$$CHSEC(1,IBPROV,IBTYPE,IBVAL) 1 Q $$CHSEC(2,IBPROV,IBTYPE,IBVAL)
- Q $$CHSEC(IBFRM,IBPROV,IBTYPE,IBVAL)
- ;
- CHSEC(IBFRM,IBPROV,IBTYPE,IBVAL) ;
- N IBSTR S IBSTR=""
- ;referring
- I IBPROV=1 S IBSTR=$S(IBTYPE="C":$$OPR5(IBFRM),IBTYPE="O":$$OP4(IBFRM),1:"")
- ;operating
- I IBPROV=2 S IBSTR=$S(IBTYPE="C":$$OPR3(IBFRM),IBTYPE="O":$$OP2(IBFRM),1:"")
- ;rendering
- I IBPROV=3 S IBSTR=$S(IBTYPE="C":$$OPR2(IBFRM),IBTYPE="O":$$OP1(IBFRM),1:"")
- ;attending
- I IBPROV=4 S IBSTR=$S(IBTYPE="C":$$OPR2(IBFRM),IBTYPE="O":$$OP1(IBFRM),1:"")
- ;supervising
- I IBPROV=5 S IBSTR=$S(IBTYPE="C":$$OPR8(IBFRM),IBTYPE="O":$$OP8(IBFRM),1:"")
- ;JWS;IB*2.0*592;assistant surgeon Dental
- I IBPROV=6 S IBSTR=$S(IBTYPE="C":$$OPRB(IBFRM),IBTYPE="O":$$OPRB(IBFRM),1:"")
- ;other
- I IBPROV=9 S IBSTR=$S(IBTYPE="C":$$OPR4(IBFRM),IBTYPE="O":$$OP9(IBFRM),1:"")
- Q:IBPROV=0!(IBSTR="") 1 ;if "" or facility id always return 1
- Q IBSTR[("^"_IBVAL_"^")
- ;
- ;Filter invalid qualifier entries for records SUB1,SUB2,OP6,OP7,OP3
- ; Rebuild the IBXSAVE("PROVINF" or IBXSAVE("PROVINF_FAC" array with
- ; only ids that have valid qualifiers
- ;IBFRM 0-both, 1=UB,2=1500
- ;IBREC record ID whose ids are being filtered (SUB1,SUB2,etc)
- ;IBFAC - 1 if facility check, 0 if attending/rendering check
- ;IBTYPE - "C"-current insurance, "O"-other insurance
- ;IBXSAVE - the array of provider ids extracted, returned filtered -
- ; passed by reference
- CHCKSUB(IBFRM,IBREC,IBFAC,IBTYPE,IBXSAVE) ;
- N Z,Z0,Z1,Z2,CT,IBSAVE
- S Z="PROVINF"_$P("^_FAC",U,$G(IBFAC)+1)
- I '$G(IBXSAVE(Z,IBXIEN)) D
- . D F^IBCEF("N-ALL "_$S($G(IBFAC):"OUTSIDE FAC PROVIDER INF",1:"CUR/OTH PROVIDER INFO"))
- M IBSAVE(Z,IBXIEN,IBTYPE)=IBXSAVE(Z,IBXIEN,IBTYPE) K IBXSAVE(Z,IBXIEN,IBTYPE)
- S Z0=0 F S Z0=$O(IBSAVE(Z,IBXIEN,IBTYPE,Z0)) Q:'Z0 S Z1="" F S Z1=$O(IBSAVE(Z,IBXIEN,IBTYPE,Z0,Z1)) Q:Z1="" S (Z2,CT)=0 F S Z2=$O(IBSAVE(Z,IBXIEN,IBTYPE,Z0,Z1,Z2)) Q:'Z2 D
- . N IBVAL
- . S IBVAL=$P(IBSAVE(Z,IBXIEN,IBTYPE,Z0,Z1,Z2),U,3)
- . I IBFRM=0 D Q
- .. I $S($$CHSUB(1,IBREC,IBVAL):1,1:$$CHSUB(2,IBPROV,IBTYPE,IBVAL)) D
- ... S CT=CT+1,IBXSAVE(Z,IBXIEN,IBTYPE,Z0,Z1,CT)=IBSAVE(Z,IBXIEN,IBTYPE,Z0,Z1,Z2)
- ... I $G(IBXSAVE(Z,IBXIEN,IBTYPE,Z0))="",$G(IBSAVE(Z,IBXIEN,IBTYPE,Z0))'="" S IBXSAVE(Z,IBXIEN,IBTYPE,Z0)=IBSAVE(Z,IBXIEN,IBTYPE,Z0)
- . I $$CHSUB(IBFRM,IBREC,IBVAL) D
- .. S CT=CT+1,IBXSAVE(Z,IBXIEN,IBTYPE,Z0,Z1,CT)=IBSAVE(Z,IBXIEN,IBTYPE,Z0,Z1,Z2)
- .. I $G(IBXSAVE(Z,IBXIEN,IBTYPE,Z0))="",$G(IBSAVE(Z,IBXIEN,IBTYPE,Z0))'="" S IBXSAVE(Z,IBXIEN,IBTYPE,Z0)=IBSAVE(Z,IBXIEN,IBTYPE,Z0)
- Q
- ;
- ; Check if valid qualifier
- ;IBFRM 0-both, 1=UB,2=1500
- ;IBREC record ID whose ids are being filtered (SUB1,SUB2,etc)
- ;IBVAL - value to check
- CHSUB(IBFRM,IBREC,IBVAL) ;
- N IBSTR
- I IBREC="SUB1" S IBSTR=$$SUB1(IBFRM)
- I IBREC="SUB2" S IBSTR=$$SUB2(IBFRM)
- I IBREC="OP7" S IBSTR=$$OP7(IBFRM)
- I IBREC="OP3" S IBSTR=$$OP3(IBFRM)
- I IBREC="OP6" S IBSTR=$$OP6(IBFRM)
- Q:$G(IBSTR)="" 1 ;if "" always return 1
- Q IBSTR[("^"_IBVAL_"^")
- ;
- ;IBFRM 0-both, 1=UB,2=1500
- OPR2(IBFRM) ;
- Q:IBFRM=1 "^0B^1A^1B^1C^1D^1G^1H^EI^G2^LU^N5^SY^X5^"
- Q:IBFRM=2 "^0B^1B^1C^1D^1G^1H^EI^G2^LU^N5^SY^X5^"
- Q ""
- ;
- ;IBFRM 0-both, 1=UB,2=1500
- OP1(IBFRM) ;
- Q:IBFRM=1 "^1A^1B^1C^1D^1G^1H^EI^G2^LU^N5^"
- Q:IBFRM=2 "^1B^1C^1D^EI^G2^LU^N5^"
- Q ""
- ;
- ;IBFRM 0-both, 1=UB,2=1500
- OPR3(IBFRM) ;
- Q:IBFRM=1 "^0B^1A^1B^1C^1D^1G^1H^EI^G2^LU^N5^SY^X5^"
- Q ""
- ;
- ;IBFRM 0-both, 1=UB,2=1500
- OP2(IBFRM) ;
- Q:IBFRM=1 "^1A^1B^1C^1D^1G^1H^EI^G2^LU^N5^"
- Q ""
- ;
- ;IBFRM 0-both, 1=UB,2=1500
- SUB1(IBFRM) ;
- Q:IBFRM=1 "^0B^1A^1B^1C^1D^1G^1H^EI^G2^LU^N5^SY^X5^"
- Q:IBFRM=2 "^0B^1A^1B^1C^1D^1G^1H^EI^G2^LU^N5^U3^SY^X5^"
- Q ""
- ;
- ;IBFRM 0-both, 1=UB,2=1500
- OPR4(IBFRM) ;
- Q:IBFRM=1 "^0B^1A^1B^1C^1D^1G^1H^EI^G2^LU^N5^SY^X5^"
- Q ""
- ;
- ;IBFRM 0-both, 1=UB,2=1500
- OP9(IBFRM) ;
- Q:IBFRM=1 "^1A^1B^1C^1D^1G^1H^EI^G2^LU^N5^"
- Q ""
- ;
- ;IBFRM 0-both, 1=UB,2=1500
- SUB2(IBFRM) ;
- Q:IBFRM=1 "^0B^1A^1B^1C^1G^1H^1J^EI^FH^G2^G5^LU^N5^X5^TJ^B3^BQ^SY^U3^"
- Q:IBFRM=2 "^0B^X4^1A^1B^1C^1G^1H^G2^LU^X5^TJ^B3^BQ^SY^U3^"
- Q ""
- ;
- ;IBFRM 0-both, 1=UB,2=1500
- OP3(IBFRM) ;
- Q:IBFRM=1 "^1B^1C^EI^G2^LU^N5^"
- Q ""
- ;
- ;IBFRM 0-both, 1=UB,2=1500
- OPR5(IBFRM) ;
- Q:IBFRM=2 "^0B^1B^1C^1D^1G^1H^EI^G2^LU^N5^SY^X5^"
- Q ""
- ;
- ;IBFRM 0-both, 1=UB,2=1500
- OPR8(IBFRM) ;
- Q:IBFRM=2 "^0B^1B^1C^1D^1G^1H^EI^G2^LU^N5^SY^X5^"
- Q ""
- ;
- ;IBFRM 0-both, 1=UB,2=1500
- OP4(IBFRM) ;
- Q:IBFRM=2 "^1B^1C^1D^EI^G2^LU^N5^"
- Q ""
- ;
- ;IBFRM 0-both, 1=UB,2=1500
- OP8(IBFRM) ;
- Q:IBFRM=2 "^1B^1C^1D^EI^G2^N5^"
- Q ""
- ;
- ;IBFRM 0-both, 1=UB,2=1500
- OP6(IBFRM) ;
- Q:IBFRM=2 "^1A^1B^1C^G2^LU^N5^"
- Q ""
- ;
- ;IBFRM 0-both, 1=UB,2=1500
- OP7(IBFRM) ;
- Q:IBFRM=2 "^1A^1B^1C^G2^LU^N5^"
- Q ""
- ;
- ;IBFRM 0-both, 1=UB,2=1500
- OPRB(IBFRM) ;
- Q:IBFRM=4 "^0B^1G^G2^LU^"
- Q ""
- ;
- ;check qualifier for PRV1
- ;IBFRM 0-both, 1=UB,2=1500
- ;IBVAL - value to check
- CHCKPRV1(IBFRM,IBVAL) ;
- I IBFRM=0 Q:$$CHPRV1(1,IBVAL) 1 Q $$CHPRV1(2,IBVAL)
- Q $$CHPRV1(IBFRM,IBVAL)
- ;IBFRM 0-both, 1=UB,2=1500
- CHPRV1(IBFRM,IBVAL) ;
- N IBSTR S IBSTR=""
- S IBSTR=$$PRV1(IBFRM)
- Q:IBSTR="" 1
- Q IBSTR[("^"_IBVAL_"^")
- ;
- PRV1(IBFRM) ;
- Q:IBFRM=1 "^1A^1C^1D^1G^1H^1J^B3^BQ^EI^FH^G2^G5^LU^SY^X5^"
- Q:IBFRM=2 "^1B^1C^1D^1G^1H^1J^B3^BQ^EI^FH^G2^G5^LU^U3^SY^X5^"
- Q ""
- ;
- PTSELF ;This tag is for the CI2 segment. If the IBXSAVE("IADR") is empty
- ;check to see if the relationship to pt is 18 (self) if so pull info
- ;from PT1 calls
- ;See if relationship to insured is 18 if not or if "" quit
- N IBZ
- D F^IBCEF("N-ALL INSURED PT RELATION","IBZ",,IBXIEN)
- S IBZ=$G(IBZ(+$$COBN^IBCEF(IBXIEN)))
- S IBZ=$$PRELCNV^IBCNSP1(IBZ,1)
- I IBZ'="18" S IBXDATA="" Q
- N IBZ D F^IBCEF("N-PATIENT STREET ADDRESS 1-3","IBZ",,IBXIEN)
- S IBXDATA="18"
- Q
- ;
- NOPUNCT(X,SPACE,EXC) ; Strip punctuation from data in X
- ; SPACE = flag if 1 strip SPACES
- ; EXC = list of punct not to strip
- ;
- N PUNCT,Z
- S PUNCT=".,-+(){}[]\/><:;?|=_*&%$#@!~`^'"""
- I $G(SPACE) S PUNCT=PUNCT_" "
- I $G(EXC)'="" S PUNCT=$TR(PUNCT,EXC)
- N L S L=""
- F S L=$O(X(L)) Q:L="" D
- . S X(L)=$TR(X(L),PUNCT)
- I $G(X)'="" D
- . S X=$TR(X,PUNCT)
- Q
- ;
- PROVID(IBXIEN) ;This modified version of prov id call is to acquire the SSN
- ;first, if the ssn is not available then we need to get the tax id.
- ;we also need to provide the modifier for which value it is
- Q:+$G(IBXIEN)=0 ""
- S IBXSAVE("ID")=""
- S IBXSAVE=""
- S IBXSAVE=$$PROVSSN^IBCEF7(IBXIEN)
- N I
- F I=1:1:9 D
- . I $P(IBXSAVE,"^",I)]"" S $P(IBXSAVE("ID"),U,I)="34"
- ;If no ibxdata go look in 355.97 for 24
- N IBRETVAL S IBRETVAL=""
- N IBPTR,IBFT
- F IBFT=1:1:9 D
- . Q:$P(IBXSAVE,U,IBFT)]""
- . S IBPTR=$$PROVPTR^IBCEF7(IBXIEN,IBFT)
- . S $P(IBRETVAL,"^",IBFT)=$$TAX3559(IBPTR)
- . I $P(IBRETVAL,U,IBFT)]"" D
- . . S $P(IBXSAVE,U,IBFT)=$P(IBRETVAL,U,IBFT)
- . . S $P(IBXSAVE("ID"),U,IBFT)="24"
- Q IBXSAVE
- ;
- TAX3559(IBPROV) ;
- I $P(IBPROV,";",2)'["IBA(355.9" Q ""
- N IB2,IB3559,IBIDTYP,IBID,IBQFL
- S (IB3559,IBQFL)=0
- S IBID=""
- Q:+$G(IBPROV)=0 ""
- F IB2=1:1 S IB3559=$O(^IBA(355.9,"B",IBPROV,IB3559)) Q:IB3559=""!IBQFL D
- . S IBIDTYP=+$P($G(^IBA(355.9,IB3559,0)),"^",6) ;provider ID type, ptr to #355.97
- . S IBIDTYP=$P($G(^IBE(355.97,IBIDTYP,0)),"^",3)
- . S:IBIDTYP="EI" IBID=$P($G(^IBA(355.9,IB3559,0)),"^",7),IBQFL=1
- ; if nothing found yet, look in file 355.93 for Facility Default ID
- I IBID="",IBPROV["IBA(355.93" D
- .N IB0,IBFID,IBQ
- .S IB0=$G(^IBA(355.93,+IBPROV,0)) Q:IB0=""!($P(IB0,U,2)'=1) ; not a facility - bail out
- .S IBFID=$P(IB0,U,9) Q:IBFID="" ; no default id on file - bail out
- .S IBQ=$P(IB0,U,13) I +IBQ>0,$P($G(^IBE(355.97,IBQ,0)),U,3)=24 S IBID=IBFID
- .Q
- Q $$NOPUNCT^IBCEF(IBID)
- ;
- ;IBFULL-full name
- ;IBEL - Name element : "FAMILY","GIVEN","MIDDLE","SUFFIX"
- ;
- SSN200(IBPTR) ;
- I $P(IBPTR,";",2)'="VA(200," Q ""
- Q $$NOPUNCT^IBCEF($$GET1^DIQ(200,+$P(IBPTR,";")_",",9))
- ;
- ;Input:
- ; IBIEN399 - ien in #399
- ;Output:
- ; returns a string with "^" delimiters that contains SSNs (if any)
- ; in the position that equal to FUNCTION number
- ; i.e. if RENDERING function # is 3 then SSN will be
- ; in $P(return value,"^",3), etc.
- ;
- SSN3559(IBPROV) ;
- N IB2,IB3559,IBIDTYP,IBID,IBQFL
- S (IB3559,IBQFL)=0
- S IBID=""
- Q:+$G(IBPROV)=0 ""
- F IB2=1:1 S IB3559=$O(^IBA(355.9,"B",IBPROV,IB3559)) Q:IB3559=""!IBQFL D
- . S IBIDTYP=+$P($G(^IBA(355.9,IB3559,0)),"^",6)
- . S IBIDTYP=$P($G(^IBE(355.97,IBIDTYP,0)),"^",3)
- . S:IBIDTYP="SY" IBID=$P($G(^IBA(355.9,IB3559,0)),"^",7),IBQFL=1
- Q $$NOPUNCT^IBCEF(IBID)
- ;
- ;IBIDTYP-provider ID type, ptr to #355.97
- ;IBFULL-full name
- ;IBEL - Name element : "FAMILY","GIVEN","MIDDLE","SUFFIX"
- ;
- PRV1FMT(P) ;FORMAT CODE FOR PRV1 SEGMENT THAT WON'T FIT ON LINE
- K IBXDATA
- S:'$D(IBXSAVE("BIL-PROV-SEC")) IBXSAVE("BIL-PROV-SEC")=$$PRV1^IBCEF7(IBXIEN)
- S IBXDATA=$P($G(IBXSAVE("BIL-PROV-SEC")),"^",P)
- I $G(IBXDATA)'="" S IBXDATA=$$NOPUNCT^IBCEF(IBXDATA,1)
- Q
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCEF73 9414 printed Jan 18, 2025@03:11:26 Page 2
- IBCEF73 ;WOIFO/SS - FORMATTER AND EXTRACTOR SPECIFIC BILL FUNCTIONS ;8/6/03 10:56am
- +1 ;;2.0;INTEGRATED BILLING;**232,320,358,349,377,592**;21-MAR-94;Build 58
- +2 ;;Per VA Directive 6402, this routine should not be modified.
- +3 ;
- +4 ;check qualifier
- +5 ;IBFRM 0-both, 1=UB,2=1500, 7=J430D
- +6 ;IBPROV - function in #399 (1-referring, 2-operating,etc)
- +7 ;IBTYPE - "C"-current insurance, "O"-other insurance
- +8 ;IBVAL - value to check
- CHCKSEC(IBFRM,IBPROV,IBTYPE,IBVAL) ;
- +1 IF IBFRM=0
- if $$CHSEC(1,IBPROV,IBTYPE,IBVAL)
- QUIT 1
- QUIT $$CHSEC(2,IBPROV,IBTYPE,IBVAL)
- +2 QUIT $$CHSEC(IBFRM,IBPROV,IBTYPE,IBVAL)
- +3 ;
- CHSEC(IBFRM,IBPROV,IBTYPE,IBVAL) ;
- +1 NEW IBSTR
- SET IBSTR=""
- +2 ;referring
- +3 IF IBPROV=1
- SET IBSTR=$SELECT(IBTYPE="C":$$OPR5(IBFRM),IBTYPE="O":$$OP4(IBFRM),1:"")
- +4 ;operating
- +5 IF IBPROV=2
- SET IBSTR=$SELECT(IBTYPE="C":$$OPR3(IBFRM),IBTYPE="O":$$OP2(IBFRM),1:"")
- +6 ;rendering
- +7 IF IBPROV=3
- SET IBSTR=$SELECT(IBTYPE="C":$$OPR2(IBFRM),IBTYPE="O":$$OP1(IBFRM),1:"")
- +8 ;attending
- +9 IF IBPROV=4
- SET IBSTR=$SELECT(IBTYPE="C":$$OPR2(IBFRM),IBTYPE="O":$$OP1(IBFRM),1:"")
- +10 ;supervising
- +11 IF IBPROV=5
- SET IBSTR=$SELECT(IBTYPE="C":$$OPR8(IBFRM),IBTYPE="O":$$OP8(IBFRM),1:"")
- +12 ;JWS;IB*2.0*592;assistant surgeon Dental
- +13 IF IBPROV=6
- SET IBSTR=$SELECT(IBTYPE="C":$$OPRB(IBFRM),IBTYPE="O":$$OPRB(IBFRM),1:"")
- +14 ;other
- +15 IF IBPROV=9
- SET IBSTR=$SELECT(IBTYPE="C":$$OPR4(IBFRM),IBTYPE="O":$$OP9(IBFRM),1:"")
- +16 ;if "" or facility id always return 1
- if IBPROV=0!(IBSTR="")
- QUIT 1
- +17 QUIT IBSTR[("^"_IBVAL_"^")
- +18 ;
- +19 ;Filter invalid qualifier entries for records SUB1,SUB2,OP6,OP7,OP3
- +20 ; Rebuild the IBXSAVE("PROVINF" or IBXSAVE("PROVINF_FAC" array with
- +21 ; only ids that have valid qualifiers
- +22 ;IBFRM 0-both, 1=UB,2=1500
- +23 ;IBREC record ID whose ids are being filtered (SUB1,SUB2,etc)
- +24 ;IBFAC - 1 if facility check, 0 if attending/rendering check
- +25 ;IBTYPE - "C"-current insurance, "O"-other insurance
- +26 ;IBXSAVE - the array of provider ids extracted, returned filtered -
- +27 ; passed by reference
- CHCKSUB(IBFRM,IBREC,IBFAC,IBTYPE,IBXSAVE) ;
- +1 NEW Z,Z0,Z1,Z2,CT,IBSAVE
- +2 SET Z="PROVINF"_$PIECE("^_FAC",U,$GET(IBFAC)+1)
- +3 IF '$GET(IBXSAVE(Z,IBXIEN))
- Begin DoDot:1
- +4 DO F^IBCEF("N-ALL "_$SELECT($GET(IBFAC):"OUTSIDE FAC PROVIDER INF",1:"CUR/OTH PROVIDER INFO"))
- End DoDot:1
- +5 MERGE IBSAVE(Z,IBXIEN,IBTYPE)=IBXSAVE(Z,IBXIEN,IBTYPE)
- KILL IBXSAVE(Z,IBXIEN,IBTYPE)
- +6 SET Z0=0
- FOR
- SET Z0=$ORDER(IBSAVE(Z,IBXIEN,IBTYPE,Z0))
- if 'Z0
- QUIT
- SET Z1=""
- FOR
- SET Z1=$ORDER(IBSAVE(Z,IBXIEN,IBTYPE,Z0,Z1))
- if Z1=""
- QUIT
- SET (Z2,CT)=0
- FOR
- SET Z2=$ORDER(IBSAVE(Z,IBXIEN,IBTYPE,Z0,Z1,Z2))
- if 'Z2
- QUIT
- Begin DoDot:1
- +7 NEW IBVAL
- +8 SET IBVAL=$PIECE(IBSAVE(Z,IBXIEN,IBTYPE,Z0,Z1,Z2),U,3)
- +9 IF IBFRM=0
- Begin DoDot:2
- +10 IF $SELECT($$CHSUB(1,IBREC,IBVAL):1,1:$$CHSUB(2,IBPROV,IBTYPE,IBVAL))
- Begin DoDot:3
- +11 SET CT=CT+1
- SET IBXSAVE(Z,IBXIEN,IBTYPE,Z0,Z1,CT)=IBSAVE(Z,IBXIEN,IBTYPE,Z0,Z1,Z2)
- +12 IF $GET(IBXSAVE(Z,IBXIEN,IBTYPE,Z0))=""
- IF $GET(IBSAVE(Z,IBXIEN,IBTYPE,Z0))'=""
- SET IBXSAVE(Z,IBXIEN,IBTYPE,Z0)=IBSAVE(Z,IBXIEN,IBTYPE,Z0)
- End DoDot:3
- End DoDot:2
- QUIT
- +13 IF $$CHSUB(IBFRM,IBREC,IBVAL)
- Begin DoDot:2
- +14 SET CT=CT+1
- SET IBXSAVE(Z,IBXIEN,IBTYPE,Z0,Z1,CT)=IBSAVE(Z,IBXIEN,IBTYPE,Z0,Z1,Z2)
- +15 IF $GET(IBXSAVE(Z,IBXIEN,IBTYPE,Z0))=""
- IF $GET(IBSAVE(Z,IBXIEN,IBTYPE,Z0))'=""
- SET IBXSAVE(Z,IBXIEN,IBTYPE,Z0)=IBSAVE(Z,IBXIEN,IBTYPE,Z0)
- End DoDot:2
- End DoDot:1
- +16 QUIT
- +17 ;
- +18 ; Check if valid qualifier
- +19 ;IBFRM 0-both, 1=UB,2=1500
- +20 ;IBREC record ID whose ids are being filtered (SUB1,SUB2,etc)
- +21 ;IBVAL - value to check
- CHSUB(IBFRM,IBREC,IBVAL) ;
- +1 NEW IBSTR
- +2 IF IBREC="SUB1"
- SET IBSTR=$$SUB1(IBFRM)
- +3 IF IBREC="SUB2"
- SET IBSTR=$$SUB2(IBFRM)
- +4 IF IBREC="OP7"
- SET IBSTR=$$OP7(IBFRM)
- +5 IF IBREC="OP3"
- SET IBSTR=$$OP3(IBFRM)
- +6 IF IBREC="OP6"
- SET IBSTR=$$OP6(IBFRM)
- +7 ;if "" always return 1
- if $GET(IBSTR)=""
- QUIT 1
- +8 QUIT IBSTR[("^"_IBVAL_"^")
- +9 ;
- +10 ;IBFRM 0-both, 1=UB,2=1500
- OPR2(IBFRM) ;
- +1 if IBFRM=1
- QUIT "^0B^1A^1B^1C^1D^1G^1H^EI^G2^LU^N5^SY^X5^"
- +2 if IBFRM=2
- QUIT "^0B^1B^1C^1D^1G^1H^EI^G2^LU^N5^SY^X5^"
- +3 QUIT ""
- +4 ;
- +5 ;IBFRM 0-both, 1=UB,2=1500
- OP1(IBFRM) ;
- +1 if IBFRM=1
- QUIT "^1A^1B^1C^1D^1G^1H^EI^G2^LU^N5^"
- +2 if IBFRM=2
- QUIT "^1B^1C^1D^EI^G2^LU^N5^"
- +3 QUIT ""
- +4 ;
- +5 ;IBFRM 0-both, 1=UB,2=1500
- OPR3(IBFRM) ;
- +1 if IBFRM=1
- QUIT "^0B^1A^1B^1C^1D^1G^1H^EI^G2^LU^N5^SY^X5^"
- +2 QUIT ""
- +3 ;
- +4 ;IBFRM 0-both, 1=UB,2=1500
- OP2(IBFRM) ;
- +1 if IBFRM=1
- QUIT "^1A^1B^1C^1D^1G^1H^EI^G2^LU^N5^"
- +2 QUIT ""
- +3 ;
- +4 ;IBFRM 0-both, 1=UB,2=1500
- SUB1(IBFRM) ;
- +1 if IBFRM=1
- QUIT "^0B^1A^1B^1C^1D^1G^1H^EI^G2^LU^N5^SY^X5^"
- +2 if IBFRM=2
- QUIT "^0B^1A^1B^1C^1D^1G^1H^EI^G2^LU^N5^U3^SY^X5^"
- +3 QUIT ""
- +4 ;
- +5 ;IBFRM 0-both, 1=UB,2=1500
- OPR4(IBFRM) ;
- +1 if IBFRM=1
- QUIT "^0B^1A^1B^1C^1D^1G^1H^EI^G2^LU^N5^SY^X5^"
- +2 QUIT ""
- +3 ;
- +4 ;IBFRM 0-both, 1=UB,2=1500
- OP9(IBFRM) ;
- +1 if IBFRM=1
- QUIT "^1A^1B^1C^1D^1G^1H^EI^G2^LU^N5^"
- +2 QUIT ""
- +3 ;
- +4 ;IBFRM 0-both, 1=UB,2=1500
- SUB2(IBFRM) ;
- +1 if IBFRM=1
- QUIT "^0B^1A^1B^1C^1G^1H^1J^EI^FH^G2^G5^LU^N5^X5^TJ^B3^BQ^SY^U3^"
- +2 if IBFRM=2
- QUIT "^0B^X4^1A^1B^1C^1G^1H^G2^LU^X5^TJ^B3^BQ^SY^U3^"
- +3 QUIT ""
- +4 ;
- +5 ;IBFRM 0-both, 1=UB,2=1500
- OP3(IBFRM) ;
- +1 if IBFRM=1
- QUIT "^1B^1C^EI^G2^LU^N5^"
- +2 QUIT ""
- +3 ;
- +4 ;IBFRM 0-both, 1=UB,2=1500
- OPR5(IBFRM) ;
- +1 if IBFRM=2
- QUIT "^0B^1B^1C^1D^1G^1H^EI^G2^LU^N5^SY^X5^"
- +2 QUIT ""
- +3 ;
- +4 ;IBFRM 0-both, 1=UB,2=1500
- OPR8(IBFRM) ;
- +1 if IBFRM=2
- QUIT "^0B^1B^1C^1D^1G^1H^EI^G2^LU^N5^SY^X5^"
- +2 QUIT ""
- +3 ;
- +4 ;IBFRM 0-both, 1=UB,2=1500
- OP4(IBFRM) ;
- +1 if IBFRM=2
- QUIT "^1B^1C^1D^EI^G2^LU^N5^"
- +2 QUIT ""
- +3 ;
- +4 ;IBFRM 0-both, 1=UB,2=1500
- OP8(IBFRM) ;
- +1 if IBFRM=2
- QUIT "^1B^1C^1D^EI^G2^N5^"
- +2 QUIT ""
- +3 ;
- +4 ;IBFRM 0-both, 1=UB,2=1500
- OP6(IBFRM) ;
- +1 if IBFRM=2
- QUIT "^1A^1B^1C^G2^LU^N5^"
- +2 QUIT ""
- +3 ;
- +4 ;IBFRM 0-both, 1=UB,2=1500
- OP7(IBFRM) ;
- +1 if IBFRM=2
- QUIT "^1A^1B^1C^G2^LU^N5^"
- +2 QUIT ""
- +3 ;
- +4 ;IBFRM 0-both, 1=UB,2=1500
- OPRB(IBFRM) ;
- +1 if IBFRM=4
- QUIT "^0B^1G^G2^LU^"
- +2 QUIT ""
- +3 ;
- +4 ;check qualifier for PRV1
- +5 ;IBFRM 0-both, 1=UB,2=1500
- +6 ;IBVAL - value to check
- CHCKPRV1(IBFRM,IBVAL) ;
- +1 IF IBFRM=0
- if $$CHPRV1(1,IBVAL)
- QUIT 1
- QUIT $$CHPRV1(2,IBVAL)
- +2 QUIT $$CHPRV1(IBFRM,IBVAL)
- +3 ;IBFRM 0-both, 1=UB,2=1500
- CHPRV1(IBFRM,IBVAL) ;
- +1 NEW IBSTR
- SET IBSTR=""
- +2 SET IBSTR=$$PRV1(IBFRM)
- +3 if IBSTR=""
- QUIT 1
- +4 QUIT IBSTR[("^"_IBVAL_"^")
- +5 ;
- PRV1(IBFRM) ;
- +1 if IBFRM=1
- QUIT "^1A^1C^1D^1G^1H^1J^B3^BQ^EI^FH^G2^G5^LU^SY^X5^"
- +2 if IBFRM=2
- QUIT "^1B^1C^1D^1G^1H^1J^B3^BQ^EI^FH^G2^G5^LU^U3^SY^X5^"
- +3 QUIT ""
- +4 ;
- PTSELF ;This tag is for the CI2 segment. If the IBXSAVE("IADR") is empty
- +1 ;check to see if the relationship to pt is 18 (self) if so pull info
- +2 ;from PT1 calls
- +3 ;See if relationship to insured is 18 if not or if "" quit
- +4 NEW IBZ
- +5 DO F^IBCEF("N-ALL INSURED PT RELATION","IBZ",,IBXIEN)
- +6 SET IBZ=$GET(IBZ(+$$COBN^IBCEF(IBXIEN)))
- +7 SET IBZ=$$PRELCNV^IBCNSP1(IBZ,1)
- +8 IF IBZ'="18"
- SET IBXDATA=""
- QUIT
- +9 NEW IBZ
- DO F^IBCEF("N-PATIENT STREET ADDRESS 1-3","IBZ",,IBXIEN)
- +10 SET IBXDATA="18"
- +11 QUIT
- +12 ;
- NOPUNCT(X,SPACE,EXC) ; Strip punctuation from data in X
- +1 ; SPACE = flag if 1 strip SPACES
- +2 ; EXC = list of punct not to strip
- +3 ;
- +4 NEW PUNCT,Z
- +5 SET PUNCT=".,-+(){}[]\/><:;?|=_*&%$#@!~`^'"""
- +6 IF $GET(SPACE)
- SET PUNCT=PUNCT_" "
- +7 IF $GET(EXC)'=""
- SET PUNCT=$TRANSLATE(PUNCT,EXC)
- +8 NEW L
- SET L=""
- +9 FOR
- SET L=$ORDER(X(L))
- if L=""
- QUIT
- Begin DoDot:1
- +10 SET X(L)=$TRANSLATE(X(L),PUNCT)
- End DoDot:1
- +11 IF $GET(X)'=""
- Begin DoDot:1
- +12 SET X=$TRANSLATE(X,PUNCT)
- End DoDot:1
- +13 QUIT
- +14 ;
- PROVID(IBXIEN) ;This modified version of prov id call is to acquire the SSN
- +1 ;first, if the ssn is not available then we need to get the tax id.
- +2 ;we also need to provide the modifier for which value it is
- +3 if +$GET(IBXIEN)=0
- QUIT ""
- +4 SET IBXSAVE("ID")=""
- +5 SET IBXSAVE=""
- +6 SET IBXSAVE=$$PROVSSN^IBCEF7(IBXIEN)
- +7 NEW I
- +8 FOR I=1:1:9
- Begin DoDot:1
- +9 IF $PIECE(IBXSAVE,"^",I)]""
- SET $PIECE(IBXSAVE("ID"),U,I)="34"
- End DoDot:1
- +10 ;If no ibxdata go look in 355.97 for 24
- +11 NEW IBRETVAL
- SET IBRETVAL=""
- +12 NEW IBPTR,IBFT
- +13 FOR IBFT=1:1:9
- Begin DoDot:1
- +14 if $PIECE(IBXSAVE,U,IBFT)]""
- QUIT
- +15 SET IBPTR=$$PROVPTR^IBCEF7(IBXIEN,IBFT)
- +16 SET $PIECE(IBRETVAL,"^",IBFT)=$$TAX3559(IBPTR)
- +17 IF $PIECE(IBRETVAL,U,IBFT)]""
- Begin DoDot:2
- +18 SET $PIECE(IBXSAVE,U,IBFT)=$PIECE(IBRETVAL,U,IBFT)
- +19 SET $PIECE(IBXSAVE("ID"),U,IBFT)="24"
- End DoDot:2
- End DoDot:1
- +20 QUIT IBXSAVE
- +21 ;
- TAX3559(IBPROV) ;
- +1 IF $PIECE(IBPROV,";",2)'["IBA(355.9"
- QUIT ""
- +2 NEW IB2,IB3559,IBIDTYP,IBID,IBQFL
- +3 SET (IB3559,IBQFL)=0
- +4 SET IBID=""
- +5 if +$GET(IBPROV)=0
- QUIT ""
- +6 FOR IB2=1:1
- SET IB3559=$ORDER(^IBA(355.9,"B",IBPROV,IB3559))
- if IB3559=""!IBQFL
- QUIT
- Begin DoDot:1
- +7 ;provider ID type, ptr to #355.97
- SET IBIDTYP=+$PIECE($GET(^IBA(355.9,IB3559,0)),"^",6)
- +8 SET IBIDTYP=$PIECE($GET(^IBE(355.97,IBIDTYP,0)),"^",3)
- +9 if IBIDTYP="EI"
- SET IBID=$PIECE($GET(^IBA(355.9,IB3559,0)),"^",7)
- SET IBQFL=1
- End DoDot:1
- +10 ; if nothing found yet, look in file 355.93 for Facility Default ID
- +11 IF IBID=""
- IF IBPROV["IBA(355.93"
- Begin DoDot:1
- +12 NEW IB0,IBFID,IBQ
- +13 ; not a facility - bail out
- SET IB0=$GET(^IBA(355.93,+IBPROV,0))
- if IB0=""!($PIECE(IB0,U,2)'=1)
- QUIT
- +14 ; no default id on file - bail out
- SET IBFID=$PIECE(IB0,U,9)
- if IBFID=""
- QUIT
- +15 SET IBQ=$PIECE(IB0,U,13)
- IF +IBQ>0
- IF $PIECE($GET(^IBE(355.97,IBQ,0)),U,3)=24
- SET IBID=IBFID
- +16 QUIT
- End DoDot:1
- +17 QUIT $$NOPUNCT^IBCEF(IBID)
- +18 ;
- +19 ;IBFULL-full name
- +20 ;IBEL - Name element : "FAMILY","GIVEN","MIDDLE","SUFFIX"
- +21 ;
- SSN200(IBPTR) ;
- +1 IF $PIECE(IBPTR,";",2)'="VA(200,"
- QUIT ""
- +2 QUIT $$NOPUNCT^IBCEF($$GET1^DIQ(200,+$PIECE(IBPTR,";")_",",9))
- +3 ;
- +4 ;Input:
- +5 ; IBIEN399 - ien in #399
- +6 ;Output:
- +7 ; returns a string with "^" delimiters that contains SSNs (if any)
- +8 ; in the position that equal to FUNCTION number
- +9 ; i.e. if RENDERING function # is 3 then SSN will be
- +10 ; in $P(return value,"^",3), etc.
- +11 ;
- SSN3559(IBPROV) ;
- +1 NEW IB2,IB3559,IBIDTYP,IBID,IBQFL
- +2 SET (IB3559,IBQFL)=0
- +3 SET IBID=""
- +4 if +$GET(IBPROV)=0
- QUIT ""
- +5 FOR IB2=1:1
- SET IB3559=$ORDER(^IBA(355.9,"B",IBPROV,IB3559))
- if IB3559=""!IBQFL
- QUIT
- Begin DoDot:1
- +6 SET IBIDTYP=+$PIECE($GET(^IBA(355.9,IB3559,0)),"^",6)
- +7 SET IBIDTYP=$PIECE($GET(^IBE(355.97,IBIDTYP,0)),"^",3)
- +8 if IBIDTYP="SY"
- SET IBID=$PIECE($GET(^IBA(355.9,IB3559,0)),"^",7)
- SET IBQFL=1
- End DoDot:1
- +9 QUIT $$NOPUNCT^IBCEF(IBID)
- +10 ;
- +11 ;IBIDTYP-provider ID type, ptr to #355.97
- +12 ;IBFULL-full name
- +13 ;IBEL - Name element : "FAMILY","GIVEN","MIDDLE","SUFFIX"
- +14 ;
- PRV1FMT(P) ;FORMAT CODE FOR PRV1 SEGMENT THAT WON'T FIT ON LINE
- +1 KILL IBXDATA
- +2 if '$DATA(IBXSAVE("BIL-PROV-SEC"))
- SET IBXSAVE("BIL-PROV-SEC")=$$PRV1^IBCEF7(IBXIEN)
- +3 SET IBXDATA=$PIECE($GET(IBXSAVE("BIL-PROV-SEC")),"^",P)
- +4 IF $GET(IBXDATA)'=""
- SET IBXDATA=$$NOPUNCT^IBCEF(IBXDATA,1)
- +5 QUIT
- +6 ;