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

IBCEF73.m

Go to the documentation of this file.
  1. 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
  1. ;;Per VA Directive 6402, this routine should not be modified.
  1. ;
  1. ;check qualifier
  1. ;IBFRM 0-both, 1=UB,2=1500, 7=J430D
  1. ;IBPROV - function in #399 (1-referring, 2-operating,etc)
  1. ;IBTYPE - "C"-current insurance, "O"-other insurance
  1. ;IBVAL - value to check
  1. CHCKSEC(IBFRM,IBPROV,IBTYPE,IBVAL) ;
  1. I IBFRM=0 Q:$$CHSEC(1,IBPROV,IBTYPE,IBVAL) 1 Q $$CHSEC(2,IBPROV,IBTYPE,IBVAL)
  1. Q $$CHSEC(IBFRM,IBPROV,IBTYPE,IBVAL)
  1. ;
  1. CHSEC(IBFRM,IBPROV,IBTYPE,IBVAL) ;
  1. N IBSTR S IBSTR=""
  1. ;referring
  1. I IBPROV=1 S IBSTR=$S(IBTYPE="C":$$OPR5(IBFRM),IBTYPE="O":$$OP4(IBFRM),1:"")
  1. ;operating
  1. I IBPROV=2 S IBSTR=$S(IBTYPE="C":$$OPR3(IBFRM),IBTYPE="O":$$OP2(IBFRM),1:"")
  1. ;rendering
  1. I IBPROV=3 S IBSTR=$S(IBTYPE="C":$$OPR2(IBFRM),IBTYPE="O":$$OP1(IBFRM),1:"")
  1. ;attending
  1. I IBPROV=4 S IBSTR=$S(IBTYPE="C":$$OPR2(IBFRM),IBTYPE="O":$$OP1(IBFRM),1:"")
  1. ;supervising
  1. I IBPROV=5 S IBSTR=$S(IBTYPE="C":$$OPR8(IBFRM),IBTYPE="O":$$OP8(IBFRM),1:"")
  1. ;JWS;IB*2.0*592;assistant surgeon Dental
  1. I IBPROV=6 S IBSTR=$S(IBTYPE="C":$$OPRB(IBFRM),IBTYPE="O":$$OPRB(IBFRM),1:"")
  1. ;other
  1. I IBPROV=9 S IBSTR=$S(IBTYPE="C":$$OPR4(IBFRM),IBTYPE="O":$$OP9(IBFRM),1:"")
  1. Q:IBPROV=0!(IBSTR="") 1 ;if "" or facility id always return 1
  1. Q IBSTR[("^"_IBVAL_"^")
  1. ;
  1. ;Filter invalid qualifier entries for records SUB1,SUB2,OP6,OP7,OP3
  1. ; Rebuild the IBXSAVE("PROVINF" or IBXSAVE("PROVINF_FAC" array with
  1. ; only ids that have valid qualifiers
  1. ;IBFRM 0-both, 1=UB,2=1500
  1. ;IBREC record ID whose ids are being filtered (SUB1,SUB2,etc)
  1. ;IBFAC - 1 if facility check, 0 if attending/rendering check
  1. ;IBTYPE - "C"-current insurance, "O"-other insurance
  1. ;IBXSAVE - the array of provider ids extracted, returned filtered -
  1. ; passed by reference
  1. CHCKSUB(IBFRM,IBREC,IBFAC,IBTYPE,IBXSAVE) ;
  1. N Z,Z0,Z1,Z2,CT,IBSAVE
  1. S Z="PROVINF"_$P("^_FAC",U,$G(IBFAC)+1)
  1. I '$G(IBXSAVE(Z,IBXIEN)) D
  1. . D F^IBCEF("N-ALL "_$S($G(IBFAC):"OUTSIDE FAC PROVIDER INF",1:"CUR/OTH PROVIDER INFO"))
  1. M IBSAVE(Z,IBXIEN,IBTYPE)=IBXSAVE(Z,IBXIEN,IBTYPE) K IBXSAVE(Z,IBXIEN,IBTYPE)
  1. 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
  1. . N IBVAL
  1. . S IBVAL=$P(IBSAVE(Z,IBXIEN,IBTYPE,Z0,Z1,Z2),U,3)
  1. . I IBFRM=0 D Q
  1. .. I $S($$CHSUB(1,IBREC,IBVAL):1,1:$$CHSUB(2,IBPROV,IBTYPE,IBVAL)) D
  1. ... S CT=CT+1,IBXSAVE(Z,IBXIEN,IBTYPE,Z0,Z1,CT)=IBSAVE(Z,IBXIEN,IBTYPE,Z0,Z1,Z2)
  1. ... I $G(IBXSAVE(Z,IBXIEN,IBTYPE,Z0))="",$G(IBSAVE(Z,IBXIEN,IBTYPE,Z0))'="" S IBXSAVE(Z,IBXIEN,IBTYPE,Z0)=IBSAVE(Z,IBXIEN,IBTYPE,Z0)
  1. . I $$CHSUB(IBFRM,IBREC,IBVAL) D
  1. .. S CT=CT+1,IBXSAVE(Z,IBXIEN,IBTYPE,Z0,Z1,CT)=IBSAVE(Z,IBXIEN,IBTYPE,Z0,Z1,Z2)
  1. .. I $G(IBXSAVE(Z,IBXIEN,IBTYPE,Z0))="",$G(IBSAVE(Z,IBXIEN,IBTYPE,Z0))'="" S IBXSAVE(Z,IBXIEN,IBTYPE,Z0)=IBSAVE(Z,IBXIEN,IBTYPE,Z0)
  1. Q
  1. ;
  1. ; Check if valid qualifier
  1. ;IBFRM 0-both, 1=UB,2=1500
  1. ;IBREC record ID whose ids are being filtered (SUB1,SUB2,etc)
  1. ;IBVAL - value to check
  1. CHSUB(IBFRM,IBREC,IBVAL) ;
  1. N IBSTR
  1. I IBREC="SUB1" S IBSTR=$$SUB1(IBFRM)
  1. I IBREC="SUB2" S IBSTR=$$SUB2(IBFRM)
  1. I IBREC="OP7" S IBSTR=$$OP7(IBFRM)
  1. I IBREC="OP3" S IBSTR=$$OP3(IBFRM)
  1. I IBREC="OP6" S IBSTR=$$OP6(IBFRM)
  1. Q:$G(IBSTR)="" 1 ;if "" always return 1
  1. Q IBSTR[("^"_IBVAL_"^")
  1. ;
  1. ;IBFRM 0-both, 1=UB,2=1500
  1. OPR2(IBFRM) ;
  1. Q:IBFRM=1 "^0B^1A^1B^1C^1D^1G^1H^EI^G2^LU^N5^SY^X5^"
  1. Q:IBFRM=2 "^0B^1B^1C^1D^1G^1H^EI^G2^LU^N5^SY^X5^"
  1. Q ""
  1. ;
  1. ;IBFRM 0-both, 1=UB,2=1500
  1. OP1(IBFRM) ;
  1. Q:IBFRM=1 "^1A^1B^1C^1D^1G^1H^EI^G2^LU^N5^"
  1. Q:IBFRM=2 "^1B^1C^1D^EI^G2^LU^N5^"
  1. Q ""
  1. ;
  1. ;IBFRM 0-both, 1=UB,2=1500
  1. OPR3(IBFRM) ;
  1. Q:IBFRM=1 "^0B^1A^1B^1C^1D^1G^1H^EI^G2^LU^N5^SY^X5^"
  1. Q ""
  1. ;
  1. ;IBFRM 0-both, 1=UB,2=1500
  1. OP2(IBFRM) ;
  1. Q:IBFRM=1 "^1A^1B^1C^1D^1G^1H^EI^G2^LU^N5^"
  1. Q ""
  1. ;
  1. ;IBFRM 0-both, 1=UB,2=1500
  1. SUB1(IBFRM) ;
  1. Q:IBFRM=1 "^0B^1A^1B^1C^1D^1G^1H^EI^G2^LU^N5^SY^X5^"
  1. Q:IBFRM=2 "^0B^1A^1B^1C^1D^1G^1H^EI^G2^LU^N5^U3^SY^X5^"
  1. Q ""
  1. ;
  1. ;IBFRM 0-both, 1=UB,2=1500
  1. OPR4(IBFRM) ;
  1. Q:IBFRM=1 "^0B^1A^1B^1C^1D^1G^1H^EI^G2^LU^N5^SY^X5^"
  1. Q ""
  1. ;
  1. ;IBFRM 0-both, 1=UB,2=1500
  1. OP9(IBFRM) ;
  1. Q:IBFRM=1 "^1A^1B^1C^1D^1G^1H^EI^G2^LU^N5^"
  1. Q ""
  1. ;
  1. ;IBFRM 0-both, 1=UB,2=1500
  1. SUB2(IBFRM) ;
  1. Q:IBFRM=1 "^0B^1A^1B^1C^1G^1H^1J^EI^FH^G2^G5^LU^N5^X5^TJ^B3^BQ^SY^U3^"
  1. Q:IBFRM=2 "^0B^X4^1A^1B^1C^1G^1H^G2^LU^X5^TJ^B3^BQ^SY^U3^"
  1. Q ""
  1. ;
  1. ;IBFRM 0-both, 1=UB,2=1500
  1. OP3(IBFRM) ;
  1. Q:IBFRM=1 "^1B^1C^EI^G2^LU^N5^"
  1. Q ""
  1. ;
  1. ;IBFRM 0-both, 1=UB,2=1500
  1. OPR5(IBFRM) ;
  1. Q:IBFRM=2 "^0B^1B^1C^1D^1G^1H^EI^G2^LU^N5^SY^X5^"
  1. Q ""
  1. ;
  1. ;IBFRM 0-both, 1=UB,2=1500
  1. OPR8(IBFRM) ;
  1. Q:IBFRM=2 "^0B^1B^1C^1D^1G^1H^EI^G2^LU^N5^SY^X5^"
  1. Q ""
  1. ;
  1. ;IBFRM 0-both, 1=UB,2=1500
  1. OP4(IBFRM) ;
  1. Q:IBFRM=2 "^1B^1C^1D^EI^G2^LU^N5^"
  1. Q ""
  1. ;
  1. ;IBFRM 0-both, 1=UB,2=1500
  1. OP8(IBFRM) ;
  1. Q:IBFRM=2 "^1B^1C^1D^EI^G2^N5^"
  1. Q ""
  1. ;
  1. ;IBFRM 0-both, 1=UB,2=1500
  1. OP6(IBFRM) ;
  1. Q:IBFRM=2 "^1A^1B^1C^G2^LU^N5^"
  1. Q ""
  1. ;
  1. ;IBFRM 0-both, 1=UB,2=1500
  1. OP7(IBFRM) ;
  1. Q:IBFRM=2 "^1A^1B^1C^G2^LU^N5^"
  1. Q ""
  1. ;
  1. ;IBFRM 0-both, 1=UB,2=1500
  1. OPRB(IBFRM) ;
  1. Q:IBFRM=4 "^0B^1G^G2^LU^"
  1. Q ""
  1. ;
  1. ;check qualifier for PRV1
  1. ;IBFRM 0-both, 1=UB,2=1500
  1. ;IBVAL - value to check
  1. CHCKPRV1(IBFRM,IBVAL) ;
  1. I IBFRM=0 Q:$$CHPRV1(1,IBVAL) 1 Q $$CHPRV1(2,IBVAL)
  1. Q $$CHPRV1(IBFRM,IBVAL)
  1. ;IBFRM 0-both, 1=UB,2=1500
  1. CHPRV1(IBFRM,IBVAL) ;
  1. N IBSTR S IBSTR=""
  1. S IBSTR=$$PRV1(IBFRM)
  1. Q:IBSTR="" 1
  1. Q IBSTR[("^"_IBVAL_"^")
  1. ;
  1. PRV1(IBFRM) ;
  1. Q:IBFRM=1 "^1A^1C^1D^1G^1H^1J^B3^BQ^EI^FH^G2^G5^LU^SY^X5^"
  1. Q:IBFRM=2 "^1B^1C^1D^1G^1H^1J^B3^BQ^EI^FH^G2^G5^LU^U3^SY^X5^"
  1. Q ""
  1. ;
  1. 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
  1. ;from PT1 calls
  1. ;See if relationship to insured is 18 if not or if "" quit
  1. N IBZ
  1. D F^IBCEF("N-ALL INSURED PT RELATION","IBZ",,IBXIEN)
  1. S IBZ=$G(IBZ(+$$COBN^IBCEF(IBXIEN)))
  1. S IBZ=$$PRELCNV^IBCNSP1(IBZ,1)
  1. I IBZ'="18" S IBXDATA="" Q
  1. N IBZ D F^IBCEF("N-PATIENT STREET ADDRESS 1-3","IBZ",,IBXIEN)
  1. S IBXDATA="18"
  1. Q
  1. ;
  1. NOPUNCT(X,SPACE,EXC) ; Strip punctuation from data in X
  1. ; SPACE = flag if 1 strip SPACES
  1. ; EXC = list of punct not to strip
  1. ;
  1. N PUNCT,Z
  1. S PUNCT=".,-+(){}[]\/><:;?|=_*&%$#@!~`^'"""
  1. I $G(SPACE) S PUNCT=PUNCT_" "
  1. I $G(EXC)'="" S PUNCT=$TR(PUNCT,EXC)
  1. N L S L=""
  1. F S L=$O(X(L)) Q:L="" D
  1. . S X(L)=$TR(X(L),PUNCT)
  1. I $G(X)'="" D
  1. . S X=$TR(X,PUNCT)
  1. Q
  1. ;
  1. 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.
  1. ;we also need to provide the modifier for which value it is
  1. Q:+$G(IBXIEN)=0 ""
  1. S IBXSAVE("ID")=""
  1. S IBXSAVE=""
  1. S IBXSAVE=$$PROVSSN^IBCEF7(IBXIEN)
  1. N I
  1. F I=1:1:9 D
  1. . I $P(IBXSAVE,"^",I)]"" S $P(IBXSAVE("ID"),U,I)="34"
  1. ;If no ibxdata go look in 355.97 for 24
  1. N IBRETVAL S IBRETVAL=""
  1. N IBPTR,IBFT
  1. F IBFT=1:1:9 D
  1. . Q:$P(IBXSAVE,U,IBFT)]""
  1. . S IBPTR=$$PROVPTR^IBCEF7(IBXIEN,IBFT)
  1. . S $P(IBRETVAL,"^",IBFT)=$$TAX3559(IBPTR)
  1. . I $P(IBRETVAL,U,IBFT)]"" D
  1. . . S $P(IBXSAVE,U,IBFT)=$P(IBRETVAL,U,IBFT)
  1. . . S $P(IBXSAVE("ID"),U,IBFT)="24"
  1. Q IBXSAVE
  1. ;
  1. TAX3559(IBPROV) ;
  1. I $P(IBPROV,";",2)'["IBA(355.9" Q ""
  1. N IB2,IB3559,IBIDTYP,IBID,IBQFL
  1. S (IB3559,IBQFL)=0
  1. S IBID=""
  1. Q:+$G(IBPROV)=0 ""
  1. F IB2=1:1 S IB3559=$O(^IBA(355.9,"B",IBPROV,IB3559)) Q:IB3559=""!IBQFL D
  1. . S IBIDTYP=+$P($G(^IBA(355.9,IB3559,0)),"^",6) ;provider ID type, ptr to #355.97
  1. . S IBIDTYP=$P($G(^IBE(355.97,IBIDTYP,0)),"^",3)
  1. . S:IBIDTYP="EI" IBID=$P($G(^IBA(355.9,IB3559,0)),"^",7),IBQFL=1
  1. ; if nothing found yet, look in file 355.93 for Facility Default ID
  1. I IBID="",IBPROV["IBA(355.93" D
  1. .N IB0,IBFID,IBQ
  1. .S IB0=$G(^IBA(355.93,+IBPROV,0)) Q:IB0=""!($P(IB0,U,2)'=1) ; not a facility - bail out
  1. .S IBFID=$P(IB0,U,9) Q:IBFID="" ; no default id on file - bail out
  1. .S IBQ=$P(IB0,U,13) I +IBQ>0,$P($G(^IBE(355.97,IBQ,0)),U,3)=24 S IBID=IBFID
  1. .Q
  1. Q $$NOPUNCT^IBCEF(IBID)
  1. ;
  1. ;IBFULL-full name
  1. ;IBEL - Name element : "FAMILY","GIVEN","MIDDLE","SUFFIX"
  1. ;
  1. SSN200(IBPTR) ;
  1. I $P(IBPTR,";",2)'="VA(200," Q ""
  1. Q $$NOPUNCT^IBCEF($$GET1^DIQ(200,+$P(IBPTR,";")_",",9))
  1. ;
  1. ;Input:
  1. ; IBIEN399 - ien in #399
  1. ;Output:
  1. ; returns a string with "^" delimiters that contains SSNs (if any)
  1. ; in the position that equal to FUNCTION number
  1. ; i.e. if RENDERING function # is 3 then SSN will be
  1. ; in $P(return value,"^",3), etc.
  1. ;
  1. SSN3559(IBPROV) ;
  1. N IB2,IB3559,IBIDTYP,IBID,IBQFL
  1. S (IB3559,IBQFL)=0
  1. S IBID=""
  1. Q:+$G(IBPROV)=0 ""
  1. F IB2=1:1 S IB3559=$O(^IBA(355.9,"B",IBPROV,IB3559)) Q:IB3559=""!IBQFL D
  1. . S IBIDTYP=+$P($G(^IBA(355.9,IB3559,0)),"^",6)
  1. . S IBIDTYP=$P($G(^IBE(355.97,IBIDTYP,0)),"^",3)
  1. . S:IBIDTYP="SY" IBID=$P($G(^IBA(355.9,IB3559,0)),"^",7),IBQFL=1
  1. Q $$NOPUNCT^IBCEF(IBID)
  1. ;
  1. ;IBIDTYP-provider ID type, ptr to #355.97
  1. ;IBFULL-full name
  1. ;IBEL - Name element : "FAMILY","GIVEN","MIDDLE","SUFFIX"
  1. ;
  1. PRV1FMT(P) ;FORMAT CODE FOR PRV1 SEGMENT THAT WON'T FIT ON LINE
  1. K IBXDATA
  1. S:'$D(IBXSAVE("BIL-PROV-SEC")) IBXSAVE("BIL-PROV-SEC")=$$PRV1^IBCEF7(IBXIEN)
  1. S IBXDATA=$P($G(IBXSAVE("BIL-PROV-SEC")),"^",P)
  1. I $G(IBXDATA)'="" S IBXDATA=$$NOPUNCT^IBCEF(IBXDATA,1)
  1. Q
  1. ;