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 Oct 16, 2024@18:10:54 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 ;
