- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEF73.m
r613 r623 1 IBCEF73 ;WOIFO/SS - FORMATTER AND EXTRACTOR SPECIFIC BILL FUNCTIONS ;8/6/03 10:56am 2 ;;2.0;INTEGRATED BILLING;**232,320,358,349,377**;21-MAR-94;Build 23 3 ;;Per VHA Directive 2004-038, this routine should not be modified. 4 ; 5 ;check qualifier 6 ;IBFRM 0-both, 1=UB,2=1500 7 ;IBPROV - function in #399 (1-referring, 2-operating,etc) 8 ;IBTYPE - "C"-current insurance, "O"-other insurance 9 ;IBVAL - value to check 10 CHCKSEC(IBFRM,IBPROV,IBTYPE,IBVAL) ; 11 I IBFRM=0 Q:$$CHSEC(1,IBPROV,IBTYPE,IBVAL) 1 Q $$CHSEC(2,IBPROV,IBTYPE,IBVAL) 12 Q $$CHSEC(IBFRM,IBPROV,IBTYPE,IBVAL) 13 ; 14 CHSEC(IBFRM,IBPROV,IBTYPE,IBVAL) ; 15 N IBSTR S IBSTR="" 16 ;referring 17 I IBPROV=1 S IBSTR=$S(IBTYPE="C":$$OPR5(IBFRM),IBTYPE="O":$$OP4(IBFRM),1:"") 18 ;operating 19 I IBPROV=2 S IBSTR=$S(IBTYPE="C":$$OPR3(IBFRM),IBTYPE="O":$$OP2(IBFRM),1:"") 20 ;rendering 21 I IBPROV=3 S IBSTR=$S(IBTYPE="C":$$OPR2(IBFRM),IBTYPE="O":$$OP1(IBFRM),1:"") 22 ;attending 23 I IBPROV=4 S IBSTR=$S(IBTYPE="C":$$OPR2(IBFRM),IBTYPE="O":$$OP1(IBFRM),1:"") 24 ;supervising 25 I IBPROV=5 S IBSTR=$S(IBTYPE="C":$$OPR8(IBFRM),IBTYPE="O":$$OP8(IBFRM),1:"") 26 ;other 27 I IBPROV=9 S IBSTR=$S(IBTYPE="C":$$OPR4(IBFRM),IBTYPE="O":$$OP9(IBFRM),1:"") 28 Q:IBPROV=0!(IBSTR="") 1 ;if "" or facility id always return 1 29 Q IBSTR[("^"_IBVAL_"^") 30 ; 31 ;Filter invalid qualifier entries for records SUB1,SUB2,OP6,OP7,OP3 32 ; Rebuild the IBXSAVE("PROVINF" or IBXSAVE("PROVINF_FAC" array with 33 ; only ids that have valid qualifiers 34 ;IBFRM 0-both, 1=UB,2=1500 35 ;IBREC record ID whose ids are being filtered (SUB1,SUB2,etc) 36 ;IBFAC - 1 if facility check, 0 if attending/rendering check 37 ;IBTYPE - "C"-current insurance, "O"-other insurance 38 ;IBXSAVE - the array of provider ids extracted, returned filtered - 39 ; passed by reference 40 CHCKSUB(IBFRM,IBREC,IBFAC,IBTYPE,IBXSAVE) ; 41 N Z,Z0,Z1,Z2,CT,IBSAVE 42 S Z="PROVINF"_$P("^_FAC",U,$G(IBFAC)+1) 43 I '$G(IBXSAVE(Z,IBXIEN)) D 44 . D F^IBCEF("N-ALL "_$S($G(IBFAC):"OUTSIDE FAC PROVIDER INF",1:"CUR/OTH PROVIDER INFO")) 45 M IBSAVE(Z,IBXIEN,IBTYPE)=IBXSAVE(Z,IBXIEN,IBTYPE) K IBXSAVE(Z,IBXIEN,IBTYPE) 46 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 47 . N IBVAL 48 . S IBVAL=$P(IBSAVE(Z,IBXIEN,IBTYPE,Z0,Z1,Z2),U,3) 49 . I IBFRM=0 D Q 50 .. I $S($$CHSUB(1,IBREC,IBVAL):1,1:$$CHSUB(2,IBPROV,IBTYPE,IBVAL)) D 51 ... S CT=CT+1,IBXSAVE(Z,IBXIEN,IBTYPE,Z0,Z1,CT)=IBSAVE(Z,IBXIEN,IBTYPE,Z0,Z1,Z2) 52 ... I $G(IBXSAVE(Z,IBXIEN,IBTYPE,Z0))="",$G(IBSAVE(Z,IBXIEN,IBTYPE,Z0))'="" S IBXSAVE(Z,IBXIEN,IBTYPE,Z0)=IBSAVE(Z,IBXIEN,IBTYPE,Z0) 53 . I $$CHSUB(IBFRM,IBREC,IBVAL) D 54 .. S CT=CT+1,IBXSAVE(Z,IBXIEN,IBTYPE,Z0,Z1,CT)=IBSAVE(Z,IBXIEN,IBTYPE,Z0,Z1,Z2) 55 .. I $G(IBXSAVE(Z,IBXIEN,IBTYPE,Z0))="",$G(IBSAVE(Z,IBXIEN,IBTYPE,Z0))'="" S IBXSAVE(Z,IBXIEN,IBTYPE,Z0)=IBSAVE(Z,IBXIEN,IBTYPE,Z0) 56 Q 57 ; 58 ; Check if valid qualifier 59 ;IBFRM 0-both, 1=UB,2=1500 60 ;IBREC record ID whose ids are being filtered (SUB1,SUB2,etc) 61 ;IBVAL - value to check 62 CHSUB(IBFRM,IBREC,IBVAL) ; 63 N IBSTR 64 I IBREC="SUB1" S IBSTR=$$SUB1(IBFRM) 65 I IBREC="SUB2" S IBSTR=$$SUB2(IBFRM) 66 I IBREC="OP7" S IBSTR=$$OP7(IBFRM) 67 I IBREC="OP3" S IBSTR=$$OP3(IBFRM) 68 I IBREC="OP6" S IBSTR=$$OP6(IBFRM) 69 Q:$G(IBSTR)="" 1 ;if "" always return 1 70 Q IBSTR[("^"_IBVAL_"^") 71 ; 72 ;IBFRM 0-both, 1=UB,2=1500 73 OPR2(IBFRM) ; 74 Q:IBFRM=1 "^0B^1A^1B^1C^1D^1G^1H^EI^G2^LU^N5^SY^X5^" 75 Q:IBFRM=2 "^0B^1B^1C^1D^1G^1H^EI^G2^LU^N5^SY^X5^" 76 Q "" 77 ; 78 ;IBFRM 0-both, 1=UB,2=1500 79 OP1(IBFRM) ; 80 Q:IBFRM=1 "^1A^1B^1C^1D^1G^1H^EI^G2^LU^N5^" 81 Q:IBFRM=2 "^1B^1C^1D^EI^G2^LU^N5^" 82 Q "" 83 ; 84 ;IBFRM 0-both, 1=UB,2=1500 85 OPR3(IBFRM) ; 86 Q:IBFRM=1 "^0B^1A^1B^1C^1D^1G^1H^EI^G2^LU^N5^SY^X5^" 87 Q "" 88 ; 89 ;IBFRM 0-both, 1=UB,2=1500 90 OP2(IBFRM) ; 91 Q:IBFRM=1 "^1A^1B^1C^1D^1G^1H^EI^G2^LU^N5^" 92 Q "" 93 ; 94 ;IBFRM 0-both, 1=UB,2=1500 95 SUB1(IBFRM) ; 96 Q:IBFRM=1 "^0B^1A^1B^1C^1D^1G^1H^EI^G2^LU^N5^SY^X5^" 97 Q:IBFRM=2 "^0B^1A^1B^1C^1D^1G^1H^EI^G2^LU^N5^U3^SY^X5^" 98 Q "" 99 ; 100 ;IBFRM 0-both, 1=UB,2=1500 101 OPR4(IBFRM) ; 102 Q:IBFRM=1 "^0B^1A^1B^1C^1D^1G^1H^EI^G2^LU^N5^SY^X5^" 103 Q "" 104 ; 105 ;IBFRM 0-both, 1=UB,2=1500 106 OP9(IBFRM) ; 107 Q:IBFRM=1 "^1A^1B^1C^1D^1G^1H^EI^G2^LU^N5^" 108 Q "" 109 ; 110 ;IBFRM 0-both, 1=UB,2=1500 111 SUB2(IBFRM) ; 112 Q:IBFRM=1 "^0B^1A^1B^1C^1G^1H^1J^EI^FH^G2^G5^LU^N5^X5^TJ^B3^BQ^SY^U3^" 113 Q:IBFRM=2 "^0B^X4^1A^1B^1C^1G^1H^G2^LU^X5^TJ^B3^BQ^SY^U3^" 114 Q "" 115 ; 116 ;IBFRM 0-both, 1=UB,2=1500 117 OP3(IBFRM) ; 118 Q:IBFRM=1 "^1B^1C^EI^G2^LU^N5^" 119 Q "" 120 ; 121 ;IBFRM 0-both, 1=UB,2=1500 122 OPR5(IBFRM) ; 123 Q:IBFRM=2 "^0B^1B^1C^1D^1G^1H^EI^G2^LU^N5^SY^X5^" 124 Q "" 125 ; 126 ;IBFRM 0-both, 1=UB,2=1500 127 OPR8(IBFRM) ; 128 Q:IBFRM=2 "^0B^1B^1C^1D^1G^1H^EI^G2^LU^N5^SY^X5^" 129 Q "" 130 ; 131 ;IBFRM 0-both, 1=UB,2=1500 132 OP4(IBFRM) ; 133 Q:IBFRM=2 "^1B^1C^1D^EI^G2^LU^N5^" 134 Q "" 135 ; 136 ;IBFRM 0-both, 1=UB,2=1500 137 OP8(IBFRM) ; 138 Q:IBFRM=2 "^1B^1C^1D^EI^G2^N5^" 139 Q "" 140 ; 141 ;IBFRM 0-both, 1=UB,2=1500 142 OP6(IBFRM) ; 143 Q:IBFRM=2 "^1A^1B^1C^G2^LU^N5^" 144 Q "" 145 ; 146 ;IBFRM 0-both, 1=UB,2=1500 147 OP7(IBFRM) ; 148 Q:IBFRM=2 "^1A^1B^1C^G2^LU^N5^" 149 Q "" 150 ; 151 ;check qualifier for PRV1 152 ;IBFRM 0-both, 1=UB,2=1500 153 ;IBVAL - value to check 154 CHCKPRV1(IBFRM,IBVAL) ; 155 I IBFRM=0 Q:$$CHPRV1(1,IBVAL) 1 Q $$CHPRV1(2,IBVAL) 156 Q $$CHPRV1(IBFRM,IBVAL) 157 ;IBFRM 0-both, 1=UB,2=1500 158 CHPRV1(IBFRM,IBVAL) ; 159 N IBSTR S IBSTR="" 160 S IBSTR=$$PRV1(IBFRM) 161 Q:IBSTR="" 1 162 Q IBSTR[("^"_IBVAL_"^") 163 ; 164 PRV1(IBFRM) ; 165 Q:IBFRM=1 "^1A^1C^1D^1G^1H^1J^B3^BQ^EI^FH^G2^G5^LU^SY^X5^" 166 Q:IBFRM=2 "^1B^1C^1D^1G^1H^1J^B3^BQ^EI^FH^G2^G5^LU^U3^SY^X5^" 167 Q "" 168 ; 169 PTSELF ;This tag is for the CI2 segment. If the IBXSAVE("IADR") is empty 170 ;check to see if the relationship to pt is 18 (self) if so pull info 171 ;from PT1 calls 172 ;See if relationship to insured is 18 if not or if "" quit 173 N IBZ 174 D F^IBCEF("N-ALL INSURED PT RELATION","IBZ",,IBXIEN) 175 S IBZ=$G(IBZ(+$$COBN^IBCEF(IBXIEN))) 176 S IBZ=$$PRELCNV^IBCNSP1(IBZ,1) 177 I IBZ'="18" S IBXDATA="" Q 178 N IBZ D F^IBCEF("N-PATIENT STREET ADDRESS 1-3","IBZ",,IBXIEN) 179 S IBXDATA="18" 180 Q 181 ; 182 NOPUNCT(X,SPACE,EXC) ; Strip punctuation from data in X 183 ; SPACE = flag if 1 strip SPACES 184 ; EXC = list of punct not to strip 185 ; 186 N PUNCT,Z 187 S PUNCT=".,-+(){}[]\/><:;?|=_*&%$#@!~`^'""" 188 I $G(SPACE) S PUNCT=PUNCT_" " 189 I $G(EXC)'="" S PUNCT=$TR(PUNCT,EXC) 190 N L S L="" 191 F S L=$O(X(L)) Q:L="" D 192 . S X(L)=$TR(X(L),PUNCT) 193 I $G(X)'="" D 194 . S X=$TR(X,PUNCT) 195 Q 196 ; 197 PROVID(IBXIEN) ;This modified version of prov id call is to acquire the SSN 198 ;first, if the ssn is not available then we need to get the tax id. 199 ;we also need to provide the modifier for which value it is 200 Q:+$G(IBXIEN)=0 "" 201 S IBXSAVE("ID")="" 202 S IBXSAVE="" 203 S IBXSAVE=$$PROVSSN^IBCEF7(IBXIEN) 204 N I 205 F I=1:1:9 D 206 . I $P(IBXSAVE,"^",I)]"" S $P(IBXSAVE("ID"),U,I)="34" 207 ;If no ibxdata go look in 355.97 for 24 208 N IBRETVAL S IBRETVAL="" 209 N IBPTR,IBFT 210 F IBFT=1:1:9 D 211 . Q:$P(IBXSAVE,U,IBFT)]"" 212 . S IBPTR=$$PROVPTR^IBCEF7(IBXIEN,IBFT) 213 . S $P(IBRETVAL,"^",IBFT)=$$TAX3559(IBPTR) 214 . I $P(IBRETVAL,U,IBFT)]"" D 215 . . S $P(IBXSAVE,U,IBFT)=$P(IBRETVAL,U,IBFT) 216 . . S $P(IBXSAVE("ID"),U,IBFT)="24" 217 Q IBXSAVE 218 ; 219 TAX3559(IBPROV) ; 220 I $P(IBPROV,";",2)'["IBA(355.9" Q "" 221 N IB2,IB3559,IBIDTYP,IBID,IBQFL 222 S (IB3559,IBQFL)=0 223 S IBID="" 224 Q:+$G(IBPROV)=0 "" 225 F IB2=1:1 S IB3559=$O(^IBA(355.9,"B",IBPROV,IB3559)) Q:IB3559=""!IBQFL D 226 . S IBIDTYP=+$P($G(^IBA(355.9,IB3559,0)),"^",6) ;provider ID type, ptr to #355.97 227 . S IBIDTYP=$P($G(^IBE(355.97,IBIDTYP,0)),"^",3) 228 . S:IBIDTYP="EI" IBID=$P($G(^IBA(355.9,IB3559,0)),"^",7),IBQFL=1 229 ; if nothing found yet, look in file 355.93 for Facility Default ID 230 I IBID="",IBPROV["IBA(355.93" D 231 .N IB0,IBFID,IBQ 232 .S IB0=$G(^IBA(355.93,+IBPROV,0)) Q:IB0=""!($P(IB0,U,2)'=1) ; not a facility - bail out 233 .S IBFID=$P(IB0,U,9) Q:IBFID="" ; no default id on file - bail out 234 .S IBQ=$P(IB0,U,13) I +IBQ>0,$P($G(^IBE(355.97,IBQ,0)),U,3)=24 S IBID=IBFID 235 .Q 236 Q $$NOPUNCT^IBCEF(IBID) 237 ; 238 ;IBFULL-full name 239 ;IBEL - Name element : "FAMILY","GIVEN","MIDDLE","SUFFIX" 240 ; 241 SSN200(IBPTR) ; 242 I $P(IBPTR,";",2)'="VA(200," Q "" 243 Q $$NOPUNCT^IBCEF($$GET1^DIQ(200,+$P(IBPTR,";")_",",9)) 244 ; 245 ;Input: 246 ; IBIEN399 - ien in #399 247 ;Output: 248 ; returns a string with "^" delimiters that contains SSNs (if any) 249 ; in the position that equal to FUNCTION number 250 ; i.e. if RENDERING function # is 3 then SSN will be 251 ; in $P(return value,"^",3), etc. 252 ; 253 SSN3559(IBPROV) ; 254 N IB2,IB3559,IBIDTYP,IBID,IBQFL 255 S (IB3559,IBQFL)=0 256 S IBID="" 257 Q:+$G(IBPROV)=0 "" 258 F IB2=1:1 S IB3559=$O(^IBA(355.9,"B",IBPROV,IB3559)) Q:IB3559=""!IBQFL D 259 . S IBIDTYP=+$P($G(^IBA(355.9,IB3559,0)),"^",6) 260 . S IBIDTYP=$P($G(^IBE(355.97,IBIDTYP,0)),"^",3) 261 . S:IBIDTYP="SY" IBID=$P($G(^IBA(355.9,IB3559,0)),"^",7),IBQFL=1 262 Q $$NOPUNCT^IBCEF(IBID) 263 ; 264 ;IBIDTYP-provider ID type, ptr to #355.97 265 ;IBFULL-full name 266 ;IBEL - Name element : "FAMILY","GIVEN","MIDDLE","SUFFIX" 267 ; 268 PRV1FMT(P) ;FORMAT CODE FOR PRV1 SEGMENT THAT WON'T FIT ON LINE 269 K IBXDATA 270 S:'$D(IBXSAVE("BIL-PROV-SEC")) IBXSAVE("BIL-PROV-SEC")=$$PRV1^IBCEF7(IBXIEN) 271 S IBXDATA=$P($G(IBXSAVE("BIL-PROV-SEC")),"^",P) 272 I $G(IBXDATA)'="" S IBXDATA=$$NOPUNCT^IBCEF(IBXDATA,1) 273 Q 274 ; 1 IBCEF73 ;WOIFO/SS - FORMATTER AND EXTRACTOR SPECIFIC BILL FUNCTIONS ;8/6/03 10:56am 2 ;;2.0;INTEGRATED BILLING;**232,320,358,349**;21-MAR-94;Build 46 3 ;;Per VHA Directive 2004-038, this routine should not be modified. 4 ; 5 ;check qualifier 6 ;IBFRM 0-both, 1=UB,2=1500 7 ;IBPROV - function in #399 (1-referring, 2-operating,etc) 8 ;IBTYPE - "C"-current insurance, "O"-other insurance 9 ;IBVAL - value to check 10 CHCKSEC(IBFRM,IBPROV,IBTYPE,IBVAL) ; 11 I IBFRM=0 Q:$$CHSEC(1,IBPROV,IBTYPE,IBVAL) 1 Q $$CHSEC(2,IBPROV,IBTYPE,IBVAL) 12 Q $$CHSEC(IBFRM,IBPROV,IBTYPE,IBVAL) 13 ; 14 CHSEC(IBFRM,IBPROV,IBTYPE,IBVAL) ; 15 N IBSTR S IBSTR="" 16 ;referring 17 I IBPROV=1 S IBSTR=$S(IBTYPE="C":$$OPR5(IBFRM),IBTYPE="O":$$OP4(IBFRM),1:"") 18 ;operating 19 I IBPROV=2 S IBSTR=$S(IBTYPE="C":$$OPR3(IBFRM),IBTYPE="O":$$OP2(IBFRM),1:"") 20 ;rendering 21 I IBPROV=3 S IBSTR=$S(IBTYPE="C":$$OPR2(IBFRM),IBTYPE="O":$$OP1(IBFRM),1:"") 22 ;attending 23 I IBPROV=4 S IBSTR=$S(IBTYPE="C":$$OPR2(IBFRM),IBTYPE="O":$$OP1(IBFRM),1:"") 24 ;supervising 25 I IBPROV=5 S IBSTR=$S(IBTYPE="C":$$OPR8(IBFRM),IBTYPE="O":$$OP8(IBFRM),1:"") 26 ;other 27 I IBPROV=9 S IBSTR=$S(IBTYPE="C":$$OPR4(IBFRM),IBTYPE="O":$$OP9(IBFRM),1:"") 28 Q:IBPROV=0!(IBSTR="") 1 ;if "" or facility id always return 1 29 Q IBSTR[("^"_IBVAL_"^") 30 ; 31 ;Filter invalid qualifier entries for records SUB1,SUB2,OP6,OP7,OP3 32 ; Rebuild the IBXSAVE("PROVINF" or IBXSAVE("PROVINF_FAC" array with 33 ; only ids that have valid qualifiers 34 ;IBFRM 0-both, 1=UB,2=1500 35 ;IBREC record ID whose ids are being filtered (SUB1,SUB2,etc) 36 ;IBFAC - 1 if facility check, 0 if attending/rendering check 37 ;IBTYPE - "C"-current insurance, "O"-other insurance 38 ;IBXSAVE - the array of provider ids extracted, returned filtered - 39 ; passed by reference 40 CHCKSUB(IBFRM,IBREC,IBFAC,IBTYPE,IBXSAVE) ; 41 N Z,Z0,Z1,Z2,CT,IBSAVE 42 S Z="PROVINF"_$P("^_FAC",U,$G(IBFAC)+1) 43 I '$G(IBXSAVE(Z,IBXIEN)) D 44 . D F^IBCEF("N-ALL "_$S($G(IBFAC):"OUTSIDE FAC PROVIDER INF",1:"CUR/OTH PROVIDER INFO")) 45 M IBSAVE(Z,IBXIEN,IBTYPE)=IBXSAVE(Z,IBXIEN,IBTYPE) K IBXSAVE(Z,IBXIEN,IBTYPE) 46 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 47 . N IBVAL 48 . S IBVAL=$P(IBSAVE(Z,IBXIEN,IBTYPE,Z0,Z1,Z2),U,3) 49 . I IBFRM=0 D Q 50 .. I $S($$CHSUB(1,IBREC,IBVAL):1,1:$$CHSUB(2,IBPROV,IBTYPE,IBVAL)) D 51 ... S CT=CT+1,IBXSAVE(Z,IBXIEN,IBTYPE,Z0,Z1,CT)=IBSAVE(Z,IBXIEN,IBTYPE,Z0,Z1,Z2) 52 ... I $G(IBXSAVE(Z,IBXIEN,IBTYPE,Z0))="",$G(IBSAVE(Z,IBXIEN,IBTYPE,Z0))'="" S IBXSAVE(Z,IBXIEN,IBTYPE,Z0)=IBSAVE(Z,IBXIEN,IBTYPE,Z0) 53 . I $$CHSUB(IBFRM,IBREC,IBVAL) D 54 .. S CT=CT+1,IBXSAVE(Z,IBXIEN,IBTYPE,Z0,Z1,CT)=IBSAVE(Z,IBXIEN,IBTYPE,Z0,Z1,Z2) 55 .. I $G(IBXSAVE(Z,IBXIEN,IBTYPE,Z0))="",$G(IBSAVE(Z,IBXIEN,IBTYPE,Z0))'="" S IBXSAVE(Z,IBXIEN,IBTYPE,Z0)=IBSAVE(Z,IBXIEN,IBTYPE,Z0) 56 Q 57 ; 58 ; Check if valid qualifier 59 ;IBFRM 0-both, 1=UB,2=1500 60 ;IBREC record ID whose ids are being filtered (SUB1,SUB2,etc) 61 ;IBVAL - value to check 62 CHSUB(IBFRM,IBREC,IBVAL) ; 63 N IBSTR 64 I IBREC="SUB1" S IBSTR=$$SUB1(IBFRM) 65 I IBREC="SUB2" S IBSTR=$$SUB2(IBFRM) 66 I IBREC="OP7" S IBSTR=$$OP7(IBFRM) 67 I IBREC="OP3" S IBSTR=$$OP3(IBFRM) 68 I IBREC="OP6" S IBSTR=$$OP6(IBFRM) 69 Q:$G(IBSTR)="" 1 ;if "" always return 1 70 Q IBSTR[("^"_IBVAL_"^") 71 ; 72 ;IBFRM 0-both, 1=UB,2=1500 73 OPR2(IBFRM) ; 74 Q:IBFRM=1 "^0B^1A^1B^1C^1D^1G^1H^EI^G2^LU^N5^SY^X5^" 75 Q:IBFRM=2 "^0B^1B^1C^1D^1G^1H^EI^G2^LU^N5^SY^X5^" 76 Q "" 77 ; 78 ;IBFRM 0-both, 1=UB,2=1500 79 OP1(IBFRM) ; 80 Q:IBFRM=1 "^1A^1B^1C^1D^1G^1H^EI^G2^LU^N5^" 81 Q:IBFRM=2 "^1B^1C^1D^EI^G2^LU^N5^" 82 Q "" 83 ; 84 ;IBFRM 0-both, 1=UB,2=1500 85 OPR3(IBFRM) ; 86 Q:IBFRM=1 "^0B^1A^1B^1C^1D^1G^1H^EI^G2^LU^N5^SY^X5^" 87 Q "" 88 ; 89 ;IBFRM 0-both, 1=UB,2=1500 90 OP2(IBFRM) ; 91 Q:IBFRM=1 "^1A^1B^1C^1D^1G^1H^EI^G2^LU^N5^" 92 Q "" 93 ; 94 ;IBFRM 0-both, 1=UB,2=1500 95 SUB1(IBFRM) ; 96 Q:IBFRM=1 "^0B^1A^1B^1C^1D^1G^1H^EI^G2^LU^N5^SY^X5^" 97 Q:IBFRM=2 "^0B^1A^1B^1C^1D^1G^1H^EI^G2^LU^N5^U3^SY^X5^" 98 Q "" 99 ; 100 ;IBFRM 0-both, 1=UB,2=1500 101 OPR4(IBFRM) ; 102 Q:IBFRM=1 "^0B^1A^1B^1C^1D^1G^1H^EI^G2^LU^N5^SY^X5^" 103 Q "" 104 ; 105 ;IBFRM 0-both, 1=UB,2=1500 106 OP9(IBFRM) ; 107 Q:IBFRM=1 "^1A^1B^1C^1D^1G^1H^EI^G2^LU^N5^" 108 Q "" 109 ; 110 ;IBFRM 0-both, 1=UB,2=1500 111 SUB2(IBFRM) ; 112 Q:IBFRM=1 "^0B^1A^1B^1C^1G^1H^1J^EI^FH^G2^G5^LU^N5^X5^TJ^B3^BQ^SY^U3^" 113 Q:IBFRM=2 "^0B^X4^1A^1B^1C^1G^1H^G2^LU^X5^TJ^B3^BQ^SY^U3^" 114 Q "" 115 ; 116 ;IBFRM 0-both, 1=UB,2=1500 117 OP3(IBFRM) ; 118 Q:IBFRM=1 "^1B^1C^EI^G2^LU^N5^" 119 Q "" 120 ; 121 ;IBFRM 0-both, 1=UB,2=1500 122 OPR5(IBFRM) ; 123 Q:IBFRM=2 "^0B^1B^1C^1D^1G^1H^EI^G2^LU^N5^SY^X5^" 124 Q "" 125 ; 126 ;IBFRM 0-both, 1=UB,2=1500 127 OPR8(IBFRM) ; 128 Q:IBFRM=2 "^0B^1B^1C^1D^1G^1H^EI^G2^LU^N5^SY^X5^" 129 Q "" 130 ; 131 ;IBFRM 0-both, 1=UB,2=1500 132 OP4(IBFRM) ; 133 Q:IBFRM=2 "^1B^1C^1D^EI^G2^LU^N5^" 134 Q "" 135 ; 136 ;IBFRM 0-both, 1=UB,2=1500 137 OP8(IBFRM) ; 138 Q:IBFRM=2 "^1B^1C^1D^EI^G2^N5^" 139 Q "" 140 ; 141 ;IBFRM 0-both, 1=UB,2=1500 142 OP6(IBFRM) ; 143 Q:IBFRM=2 "^1A^1B^1C^G2^LU^N5^" 144 Q "" 145 ; 146 ;IBFRM 0-both, 1=UB,2=1500 147 OP7(IBFRM) ; 148 Q:IBFRM=2 "^1A^1B^1C^G2^LU^N5^" 149 Q "" 150 ; 151 ;check qualifier for PRV1 152 ;IBFRM 0-both, 1=UB,2=1500 153 ;IBVAL - value to check 154 CHCKPRV1(IBFRM,IBVAL) ; 155 I IBFRM=0 Q:$$CHPRV1(1,IBVAL) 1 Q $$CHPRV1(2,IBVAL) 156 Q $$CHPRV1(IBFRM,IBVAL) 157 ;IBFRM 0-both, 1=UB,2=1500 158 CHPRV1(IBFRM,IBVAL) ; 159 N IBSTR S IBSTR="" 160 S IBSTR=$$PRV1(IBFRM) 161 Q:IBSTR="" 1 162 Q IBSTR[("^"_IBVAL_"^") 163 ; 164 PRV1(IBFRM) ; 165 Q:IBFRM=1 "^1A^1C^1D^1G^1H^1J^B3^BQ^EI^FH^G2^G5^LU^SY^X5^" 166 Q:IBFRM=2 "^1B^1C^1D^1G^1H^1J^B3^BQ^EI^FH^G2^G5^LU^U3^SY^X5^" 167 Q "" 168 ; 169 PTSELF ;This tag is for the CI2 segment. If the IBXSAVE("IADR") is empty 170 ;check to see if the relationship to pt is 18 (self) if so pull info 171 ;from PT1 calls 172 ;See if relationship to insured is 18 if not or if "" quit 173 N IBZ 174 D F^IBCEF("N-ALL INSURED PT RELATION","IBZ",,IBXIEN) 175 S IBZ=$G(IBZ(+$$COBN^IBCEF(IBXIEN))) 176 S IBZ=$$RELATION^IBCEFG1(IBZ) 177 I IBZ'="18" S IBXDATA="" Q 178 N IBZ D F^IBCEF("N-PATIENT STREET ADDRESS 1-3","IBZ",,IBXIEN) 179 S IBXDATA="18" 180 Q 181 ; 182 NOPUNCT(X,SPACE,EXC) ; Strip punctuation from data in X 183 ; SPACE = flag if 1 strip SPACES 184 ; EXC = list of punct not to strip 185 ; 186 N PUNCT,Z 187 S PUNCT=".,-+(){}[]\/><:;?|=_*&%$#@!~`^'""" 188 I $G(SPACE) S PUNCT=PUNCT_" " 189 I $G(EXC)'="" S PUNCT=$TR(PUNCT,EXC) 190 N L S L="" 191 F S L=$O(X(L)) Q:L="" D 192 . S X(L)=$TR(X(L),PUNCT) 193 I $G(X)'="" D 194 . S X=$TR(X,PUNCT) 195 Q 196 ; 197 PROVID(IBXIEN) ;This modified version of prov id call is to acquire the SSN 198 ;first, if the ssn is not available then we need to get the tax id. 199 ;we also need to provide the modifier for which value it is 200 Q:+$G(IBXIEN)=0 "" 201 S IBXSAVE("ID")="" 202 S IBXSAVE="" 203 S IBXSAVE=$$PROVSSN^IBCEF7(IBXIEN) 204 N I 205 F I=1:1:9 D 206 . I $P(IBXSAVE,"^",I)]"" S $P(IBXSAVE("ID"),U,I)="34" 207 ;If no ibxdata go look in 355.97 for 24 208 N IBRETVAL S IBRETVAL="" 209 N IBPTR,IBFT 210 F IBFT=1:1:9 D 211 . Q:$P(IBXSAVE,U,IBFT)]"" 212 . S IBPTR=$$PROVPTR^IBCEF7(IBXIEN,IBFT) 213 . S $P(IBRETVAL,"^",IBFT)=$$TAX3559(IBPTR) 214 . I $P(IBRETVAL,U,IBFT)]"" D 215 . . S $P(IBXSAVE,U,IBFT)=$P(IBRETVAL,U,IBFT) 216 . . S $P(IBXSAVE("ID"),U,IBFT)="24" 217 Q IBXSAVE 218 ; 219 TAX3559(IBPROV) ; 220 I $P(IBPROV,";",2)'["IBA(355.9" Q "" 221 N IB2,IB3559,IBIDTYP,IBID,IBQFL 222 S (IB3559,IBQFL)=0 223 S IBID="" 224 Q:+$G(IBPROV)=0 "" 225 F IB2=1:1 S IB3559=$O(^IBA(355.9,"B",IBPROV,IB3559)) Q:IB3559=""!IBQFL D 226 . S IBIDTYP=+$P($G(^IBA(355.9,IB3559,0)),"^",6) ;provider ID type, ptr to #355.97 227 . S IBIDTYP=$P($G(^IBE(355.97,IBIDTYP,0)),"^",3) 228 . S:IBIDTYP="EI" IBID=$P($G(^IBA(355.9,IB3559,0)),"^",7),IBQFL=1 229 Q $$NOPUNCT^IBCEF(IBID) 230 ; 231 ;IBFULL-full name 232 ;IBEL - Name element : "FAMILY","GIVEN","MIDDLE","SUFFIX" 233 ; 234 SSN200(IBPTR) ; 235 I $P(IBPTR,";",2)'="VA(200," Q "" 236 Q $$NOPUNCT^IBCEF($$GET1^DIQ(200,+$P(IBPTR,";")_",",9)) 237 ; 238 ;Input: 239 ; IBIEN399 - ien in #399 240 ;Output: 241 ; returns a string with "^" delimiters that contains SSNs (if any) 242 ; in the position that equal to FUNCTION number 243 ; i.e. if RENDERING function # is 3 then SSN will be 244 ; in $P(return value,"^",3), etc. 245 ; 246 SSN3559(IBPROV) ; 247 N IB2,IB3559,IBIDTYP,IBID,IBQFL 248 S (IB3559,IBQFL)=0 249 S IBID="" 250 Q:+$G(IBPROV)=0 "" 251 F IB2=1:1 S IB3559=$O(^IBA(355.9,"B",IBPROV,IB3559)) Q:IB3559=""!IBQFL D 252 . S IBIDTYP=+$P($G(^IBA(355.9,IB3559,0)),"^",6) 253 . S IBIDTYP=$P($G(^IBE(355.97,IBIDTYP,0)),"^",3) 254 . S:IBIDTYP="SY" IBID=$P($G(^IBA(355.9,IB3559,0)),"^",7),IBQFL=1 255 Q $$NOPUNCT^IBCEF(IBID) 256 ; 257 ;IBIDTYP-provider ID type, ptr to #355.97 258 ;IBFULL-full name 259 ;IBEL - Name element : "FAMILY","GIVEN","MIDDLE","SUFFIX" 260 ; 261 PRV1FMT(P) ;FORMAT CODE FOR PRV1 SEGMENT THAT WON'T FIT ON LINE 262 K IBXDATA 263 S:'$D(IBXSAVE("BIL-PROV-SEC")) IBXSAVE("BIL-PROV-SEC")=$$PRV1^IBCEF7(IBXIEN) 264 S IBXDATA=$P($G(IBXSAVE("BIL-PROV-SEC")),"^",P) 265 I $G(IBXDATA)'="" S IBXDATA=$$NOPUNCT^IBCEF(IBXDATA,1) 266 Q 267 ;
Note:
See TracChangeset
for help on using the changeset viewer.
