- 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/IBCEF1.m
r613 r623 1 IBCEF1 ;ALB/TMP - FORMATTER SPECIFIC BILL FUNCTIONS - CONT ;30-JAN-96 2 ;;2.0;INTEGRATED BILLING;**52,124,51,137,210,155,349,371**;21-MAR-94;Build 57 3 ;;Per VHA Directive 2004-038, this routine should not be modified. 4 ; 5 OCC(IBIFN,REL,TEXT) ;Sets up an arrays of occurrence codes for various cks 6 ;RETURNS 1^additional data for entry IBXSAVE("OCC",n) if REL or TEXT 7 ; parameters have been met or null if conditions not met 8 ;If no REL or TEXT parameters sent, just extract codes array 9 ; IBIFN = bill ien 10 ; REL = 'OCC RELATED TO' value to check for 11 ; TEXT = text to check for the .01 field of 399.1 entry pointed to 12 ; by the occurrence code 13 N OCC,SORT,ARR,N,DATA,CODE,CT 14 I '$D(IBXSAVE("OCC")),'$D(IBXSAVE("OCCS")) D 15 .N IBI,Z,CT1,CT2,Z0 S (IBI,CT1,CT2)=0 16 .F S IBI=$O(^DGCR(399,IBIFN,"OC",IBI)) Q:'IBI S Z=$G(^(IBI,0)) D 17 ..S Z0=$G(^DGCR(399.1,+Z,0)) 18 ..Q:'$P(Z0,U,10)&'$P(Z0,U,4) ;Not an occurrence code 19 ..I $P(Z0,U,10) S CT2=CT2+1,IBXSAVE("OCCS",CT2)=$S($P(Z0,U,4):$P(Z0,U,2)_U_$P(Z,U,2),1:U)_U_$P(Z,U,4)_U_$P(Z0,U)_U_$P(Z0,U,9)_U_$P(Z,U,3)_U_$P(Z,U,2) 20 ..I '$P(Z0,U,10) S CT1=CT1+1,IBXSAVE("OCC",CT1)=$S($P(Z0,U,4):$P(Z0,U,2)_U_$P(Z,U,2),1:U)_U_U_$P(Z0,U)_U_$P(Z0,U,9)_U_$P(Z,U,3)_U_$P(Z,U,2) 21 I '$D(IBXSAVE("OCC"))&'$D(IBXSAVE("OCCS")) S IBXSAVE("OCC")="" G OCCQ 22 ; 23 ; esg - IB*2*349 - order the occurrence codes 24 ; Build the SORT array sorted by the occ code 25 F ARR="OCC","OCCS" S N=0 F S N=$O(IBXSAVE(ARR,N)) Q:'N S DATA=$G(IBXSAVE(ARR,N)) I $P(DATA,U,1)'="" S CODE=" "_$P(DATA,U,1),SORT(ARR,CODE,N)=DATA 26 ; Loop thru the SORT array and re-build the IBXSAVE array 27 F ARR="OCC","OCCS" K IBXSAVE(ARR) S CODE="",CT=0 F S CODE=$O(SORT(ARR,CODE)) Q:CODE="" S N=0 F S N=$O(SORT(ARR,CODE,N)) Q:'N S CT=CT+1,IBXSAVE(ARR,CT)=SORT(ARR,CODE,N) 28 ; 29 I $G(REL)'=""!($G(TEXT)'="") D OCC1("",.OCC,$G(REL),$G(TEXT)) D:'$D(OCC) OCC1("S",.OCC,$G(REL),$G(TEXT)) 30 OCCQ Q $G(OCC) 31 ; 32 OCC1(ARR,OCC,REL,TEXT) ; Search thru local array for parameters met 33 ; ARR = null to search OCC subscript, "S" to search OCCS subscript 34 N Z 35 S ARR="OCC"_ARR,Z=0 36 F S Z=$O(IBXSAVE(ARR,Z)) Q:'Z D 37 .I $G(REL)'="",$P(IBXSAVE(ARR,Z),U,5)=REL S OCC="1"_$S(REL=2:U_$P(IBXSAVE(ARR,Z),U,6),1:"") Q 38 .I $G(TEXT)'="",$P(IBXSAVE(ARR,Z),U,4)=TEXT S OCC="1^"_$P(IBXSAVE(ARR,Z),U,7) 39 Q 40 ; 41 RX(IBIFN) ; Format billable prescription data for refills for 837 42 N Z,IBXDATA,CT 43 I '$D(IBXSAVE("BOX24")) D B24^IBCEF3(.IBXSAVE,IBIFN,1) 44 S Z="",CT=0 45 F S Z=$O(IBXSAVE("BOX24",Z)) Q:Z="" I $D(IBXSAVE("BOX24",Z,"RX")) S CT=CT+1,IBXDATA(Z)=IBXSAVE("BOX24",Z,"RX") 46 RXQ Q CT 47 ; 48 OTHPAY(IBIFN,SEQ) ; Return the other insurance payment amount for bill 49 ; IBIFN and payer sequence SEQ (1-3) 50 N AMT,IBIFN1 51 S IBIFN1=$P($G(^DGCR(399,IBIFN,"M1")),U,SEQ+4) 52 I IBIFN1 D 53 . I $$MCRWNR^IBEFUNC(+$G(^DGCR(399,IBIFN,"I"_SEQ))) S AMT=$$MCRPAY^IBCEU0(IBIFN) Q 54 . S AMT=+$$TPR^PRCAFN(IBIFN1) Q:AMT ; A/R amount 55 . S AMT=+$P($G(^DGCR(399,IBIFN,"U2")),U,SEQ+3) ; amount on bill 56 Q $G(AMT) 57 ; 58 OUTPT(IBIFN,IBPRINT) ; Moved for space 59 D OUTPT^IBCEF11(IBIFN,$G(IBPRINT)) 60 Q 61 ; 62 OCC92 ;Reformats IBXSAVE("OCC") and IBXSAVE("OCCS") to fit blocks on UB-04 63 ; Set up IBXSAVE(32-36) arrays 64 N IBPG,IB32,IB33,IB34,IB35,IB36,IBFL,Z,Z0,PG 65 S IBPG=0 66 F Z=32:1:36 K IBFL(Z) S IBFL(Z)=0 67 M IB32=IBXSAVE("OCC"),IB36=IBXSAVE("OCCS") 68 S IB32=$O(IB32(""),-1),IB36=$O(IB36(""),-1),PG=1 69 D OCC^IBCF32 70 F Z=32:1:36 S Z0="" F S Z0=$O(IBFL(Z,Z0)) Q:'Z0 S IBXSAVE("OC92",Z,Z0)=$P(IBFL(Z,Z0),U,1,3) 71 Q 72 ; 73 BATCH() ; Moved for space IB*2*349 74 Q $$BATCH^IBCEF11() 75 ; 76 PROC(T,TYPE) ; Find procedure code, strip '.' Function returns result 77 ; T = Procedure internal entry #;file reference 78 ; TYPE = "CPT" for only CPT/HCPCS valid 79 ; "ICD" for only ICD9 valid or null for either 80 N Q,S 81 S Q="",S="^"_$P($P(T,";",2),"(") 82 I $G(TYPE)="" D 83 . I $E(S,2,3)="IC" S Q=$P($$PRCD(T),U) Q 84 . I T["DIC(81.3" S Q=$$MOD^ICPTMOD(+T,"I") S Q=$S(Q>0:$P(Q,U,4),1:"") 85 I $G(TYPE)="CPT",$E(S,2,3)="IC" S Q=$$PRCD(T) Q 86 I $G(TYPE)="ICD",T["ICD0" S Q=$P($$ICD0^IBACSV(+T),U) 87 Q $TR(Q,".") 88 ; 89 FACILITY(IBIFN) ;return the Facility (Institution pointer-#4) for a bill 90 ; the institution of the Bill Division (399,.22) if defined, otherwise the Facility Name (350.9,.02) 91 ; 92 N IB0,IBIN S IBIN=0 93 S IB0=$G(^DGCR(399,+$G(IBIFN),0)) I +$P(IB0,U,22) S IBIN=$$SITE^VASITE(+$P(IB0,U,3),+$P(IB0,U,22)) 94 I IBIN'>0 S IBIN=+$P($G(^IBE(350.9,1,0)),U,2) 95 Q +IBIN 96 ; 97 ISRX(IBIFN) ; Function to determine if bill is a prescription refill bill 98 ; Returns 0 if no Rx on bill or 1 if there is. 99 ; 100 N IBRX 101 I $D(^IBA(362.4,"AIFN"_IBIFN)) S IBRX=1 102 Q +$G(IBRX) 103 ; 104 ISPROS(IBIFN) ; Function to determine if bill is a prosthetics bill 105 ; Returns 0 if no Prosthetics on bill or 1 if there is. 106 ; 107 N IBPROS 108 I $D(^IBA(362.5,"AIFN"_IBIFN)) S IBPROS=1 109 Q +$G(IBPROS) 110 ; 111 FINDINS(IBIFN,IBSEQ) ; Returns the internal entry number of the insurance 112 ; company for bill ien IBIFN for payer sequence IBSEQ (or current if 113 ; IBSEQ is null) 114 Q $P($G(^DGCR(399,IBIFN,"I"_$$COBN^IBCEF(IBIFN,$G(IBSEQ)))),U) 115 ; 116 TOB(IBIFN) ; Returns UB-04 type of bill from data in the output formatter 117 N IBTOB,IBZ1,IBZ2,IBZ3 118 D F^IBCEF("N-UB-04 LOCATION OF CARE","IBZ1",,IBIFN) 119 D F^IBCEF("N-UB-04 BILL CLASSIFICATION","IBZ2",,IBIFN) 120 D F^IBCEF("N-UB-04 TIMEFRAME OF BILL","IBZ3",,IBIFN) 121 S IBTOB=IBZ1_IBZ2_IBZ3 122 Q IBTOB 123 ; 124 PRCD(PRIEN,ALL,EDT) ; Function returns the code that corresponds to the variable 125 ; pointer data in PRIEN (ien;file) 126 ; ALL = if ALL=1, returns the entire $$CPT^ICPTCOD for CPT or 127 ; ^code^name format for ICD result 128 ; or null if lookup fails 129 ; EDT = Effective date to check (not used if +$G(ALL)=0) 130 N CODE,IBX 131 S CODE="" 132 ;Modified for Code Set Versioning 133 I PRIEN["ICPT" S IBX=$$CPT^ICPTCOD(+PRIEN,$G(EDT)) G:IBX'>0 PRCDQ S CODE=$S($G(ALL):IBX,1:$P(IBX,U,2)) 134 I PRIEN["ICD0" S IBX=$$ICD0^IBACSV(+PRIEN,$G(EDT)) G:IBX="" PRCDQ S CODE=$S($G(ALL):U_$P(IBX,U)_U_$P(IBX,U,4),1:$P(IBX,U)) 135 PRCDQ Q CODE 136 ; 137 NFT(FT,IBIFN) ; Returns 1 if bill IBIFN is not of form type FT (internal) 138 ; so the data element should not be required 139 S FT=$S($$FT^IBCEF(IBIFN)=FT:0,1:1) 140 Q FT 141 ; 142 REQ(FT,INP,IBIFN) ; Determine if bill IBIFN is of form type FT and 143 ; Inpatient (I) or Outpatient (O) status INP [or either if (null)] 144 ; 145 ;Returns 1 if both conditions FT and INP match for the bill 146 ; or 0 if either of these conditions are not true 147 ; I $$REQ^IBCEF1(2,"I",1) would mean if bill entry #1 is 148 ; CMS-1500/inpatient the data would be required 149 ; I '$$REQ^IBCEF1(2,"I",1) would mean if bill entry #1 is anything but 150 ; CMS-1500/inpatient, the data would not be 151 ; required 152 N Z 153 S Z=1 154 S:$$NFT(FT,IBIFN) Z=0 ; Not the form type for requirement 155 I Z,$G(INP)'="" D 156 . S Z0=$$INPAT^IBCEF(IBIFN,1),INP=$G(INP) 157 . S Z=$S(Z0:INP="I",1:INP="O") ;Check if I/O matches required state 158 Q Z 159 ; 160 SET1(IBIFN,A,IBZ,IBXDATA,IBXNOREQ) ; Utility to set variables for output 161 ; formatter for professional EDI 162 ; Returns values of A, IBXDATA, IBZ, IBXNOREQ 163 N Z,CT 164 S A="^TMP($J,""IBLCT"")" 165 S (Z,CT)=0 166 F S Z=$O(IBXDATA(Z)) Q:'Z D ; Don't transmit 0-charges 167 . I $P(IBXDATA(Z),U,9),$P(IBXDATA(Z),U,8) S CT=CT+1 M IBZ(CT)=IBXDATA(Z) 168 K IBXDATA 169 S IBXNOREQ='$$REQ(2,"O",IBIFN) 170 Q 171 ; 172 CIADDR(IBXDATA,IBXSAVE,LINE,FORM) ; Format current ins co address line LINE for FORM 173 ; FORM = 1 for CMS-1500, 2 for UB-04 174 ; Called from output formatter - both IBXDATA, IBXSAVE parameters are 175 ; passed by reference 176 ; 177 K IBXDATA 178 I $G(FORM)'=1 D 179 . ; 180 . ; esg - 11/17/06 - IB*2*349 - UB-04 FL-38 contains the payer name 181 . ; and address on 4 lines within this 5 line box. All 5 lines 182 . ; are formatted here into the IBXDATA array. This is the 183 . ; address that shows through the envelope window. 184 . ; 185 . ; esg - 9/13/07 - IB*2*371 - Line 1 of this box contains the print 186 . ; status (i.e. copy, 2nd notice, 3rd notice, MRA needed). 187 . ; 188 . N Z,Z1,LM,Q,ADDR,X,IBPSTAT 189 . S LM=$P($G(^IBE(350.9,1,1)),U,31) ; UB address column parameter 190 . S Z="" 191 . I LM S $P(Z," ",LM)="" ; beginning spaces indent 192 . S ADDR=$G(IBXSAVE("CADR")) ; address data string 193 . ; 194 . D F^IBCEF("N-PRINT BILL SUBMIT STATUS","IBPSTAT",,+$G(IBXIEN)) 195 . S Z1=Z I Z1="" S Z1=" " ; line 1 can't start in column 1 196 . S IBXDATA(1)=Z1_$G(IBPSTAT),Q=1 ; line 1 print status 197 . S Q=Q+1 198 . S IBXDATA(Q)=Z_$G(IBXSAVE("CADR_NAME")) ; line 2 payer name 199 . S X=$P(ADDR,U,1) 200 . I X'="" S Q=Q+1,IBXDATA(Q)=Z_X ; address line 1 201 . S X=$P(ADDR,U,2) 202 . I X'="" S Q=Q+1,IBXDATA(Q)=Z_X D ; address line 2 203 .. S X=$P(ADDR,U,3) 204 .. I X'="" S IBXDATA(Q)=IBXDATA(Q)_" "_X ; address line 3 205 .. Q 206 . S Q=Q+1 ; city,st,zip on last line 207 . S IBXDATA(Q)=Z_$P(ADDR,U,4)_", "_$$STATE^IBCEFG1($P(ADDR,U,5))_" "_$P(ADDR,U,6) 208 . KILL IBXSAVE("CADR_NAME"),IBXSAVE("CADR") ; cleanup 209 . Q 210 ; 211 I $G(FORM)=1 D ; CMS-1500 212 . N CT,X,Z 213 . S:'$D(IBXSAVE("INDENT")) Z="",$P(Z," ",+$P($G(^IBE(350.9,1,1)),U,27)+1)="",IBXSAVE("INDENT")=Z 214 . S CT=0 215 . S X=$P(IBXSAVE("CADR"),U) S:X'="" CT=CT+1,IBXDATA(CT)=IBXSAVE("INDENT")_X 216 . S X=$S($P(IBXSAVE("CADR"),U,2)'="":$P(IBXSAVE("CADR"),U,2),1:"")_$S($P(IBXSAVE("CADR"),U,2)'="":" ",1:"")_$P(IBXSAVE("CADR"),U,3) S:X'="" CT=CT+1,IBXDATA(CT)=IBXSAVE("INDENT")_X 217 . S CT=CT+1,IBXDATA(CT)=IBXSAVE("INDENT")_$P(IBXSAVE("CADR"),U,4)_", "_$$STATE^IBCEFG1($P(IBXSAVE("CADR"),U,5))_" "_$P(IBXSAVE("CADR"),U,6) 218 . Q 219 ; 220 Q 221 ; 1 IBCEF1 ;ALB/TMP - FORMATTER SPECIFIC BILL FUNCTIONS - CONT ;30-JAN-96 2 ;;2.0;INTEGRATED BILLING;**52,124,51,137,210,155,349**;21-MAR-94;Build 46 3 ;;Per VHA Directive 2004-038, this routine should not be modified. 4 ; 5 OCC(IBIFN,REL,TEXT) ;Sets up an arrays of occurrence codes for various cks 6 ;RETURNS 1^additional data for entry IBXSAVE("OCC",n) if REL or TEXT 7 ; parameters have been met or null if conditions not met 8 ;If no REL or TEXT parameters sent, just extract codes array 9 ; IBIFN = bill ien 10 ; REL = 'OCC RELATED TO' value to check for 11 ; TEXT = text to check for the .01 field of 399.1 entry pointed to 12 ; by the occurrence code 13 N OCC,SORT,ARR,N,DATA,CODE,CT 14 I '$D(IBXSAVE("OCC")),'$D(IBXSAVE("OCCS")) D 15 .N IBI,Z,CT1,CT2,Z0 S (IBI,CT1,CT2)=0 16 .F S IBI=$O(^DGCR(399,IBIFN,"OC",IBI)) Q:'IBI S Z=$G(^(IBI,0)) D 17 ..S Z0=$G(^DGCR(399.1,+Z,0)) 18 ..Q:'$P(Z0,U,10)&'$P(Z0,U,4) ;Not an occurrence code 19 ..I $P(Z0,U,10) S CT2=CT2+1,IBXSAVE("OCCS",CT2)=$S($P(Z0,U,4):$P(Z0,U,2)_U_$P(Z,U,2),1:U)_U_$P(Z,U,4)_U_$P(Z0,U)_U_$P(Z0,U,9)_U_$P(Z,U,3)_U_$P(Z,U,2) 20 ..I '$P(Z0,U,10) S CT1=CT1+1,IBXSAVE("OCC",CT1)=$S($P(Z0,U,4):$P(Z0,U,2)_U_$P(Z,U,2),1:U)_U_U_$P(Z0,U)_U_$P(Z0,U,9)_U_$P(Z,U,3)_U_$P(Z,U,2) 21 I '$D(IBXSAVE("OCC"))&'$D(IBXSAVE("OCCS")) S IBXSAVE("OCC")="" G OCCQ 22 ; 23 ; esg - IB*2*349 - order the occurrence codes 24 ; Build the SORT array sorted by the occ code 25 F ARR="OCC","OCCS" S N=0 F S N=$O(IBXSAVE(ARR,N)) Q:'N S DATA=$G(IBXSAVE(ARR,N)) I $P(DATA,U,1)'="" S CODE=" "_$P(DATA,U,1),SORT(ARR,CODE,N)=DATA 26 ; Loop thru the SORT array and re-build the IBXSAVE array 27 F ARR="OCC","OCCS" K IBXSAVE(ARR) S CODE="",CT=0 F S CODE=$O(SORT(ARR,CODE)) Q:CODE="" S N=0 F S N=$O(SORT(ARR,CODE,N)) Q:'N S CT=CT+1,IBXSAVE(ARR,CT)=SORT(ARR,CODE,N) 28 ; 29 I $G(REL)'=""!($G(TEXT)'="") D OCC1("",.OCC,$G(REL),$G(TEXT)) D:'$D(OCC) OCC1("S",.OCC,$G(REL),$G(TEXT)) 30 OCCQ Q $G(OCC) 31 ; 32 OCC1(ARR,OCC,REL,TEXT) ; Search thru local array for parameters met 33 ; ARR = null to search OCC subscript, "S" to search OCCS subscript 34 N Z 35 S ARR="OCC"_ARR,Z=0 36 F S Z=$O(IBXSAVE(ARR,Z)) Q:'Z D 37 .I $G(REL)'="",$P(IBXSAVE(ARR,Z),U,5)=REL S OCC="1"_$S(REL=2:U_$P(IBXSAVE(ARR,Z),U,6),1:"") Q 38 .I $G(TEXT)'="",$P(IBXSAVE(ARR,Z),U,4)=TEXT S OCC="1^"_$P(IBXSAVE(ARR,Z),U,7) 39 Q 40 ; 41 RX(IBIFN) ; Format billable prescription data for refills for 837 42 N Z,IBXDATA,CT 43 I '$D(IBXSAVE("BOX24")) D B24^IBCEF3(.IBXSAVE,IBIFN,1) 44 S Z="",CT=0 45 F S Z=$O(IBXSAVE("BOX24",Z)) Q:Z="" I $D(IBXSAVE("BOX24",Z,"RX")) S CT=CT+1,IBXDATA(Z)=IBXSAVE("BOX24",Z,"RX") 46 RXQ Q CT 47 ; 48 OTHPAY(IBIFN,SEQ) ; Return the other insurance payment amount for bill 49 ; IBIFN and payer sequence SEQ (1-3) 50 N AMT,IBIFN1 51 S IBIFN1=$P($G(^DGCR(399,IBIFN,"M1")),U,SEQ+4) 52 I IBIFN1 D 53 . I $$MCRWNR^IBEFUNC(+$G(^DGCR(399,IBIFN,"I"_SEQ))) S AMT=$$MCRPAY^IBCEU0(IBIFN) Q 54 . S AMT=+$$TPR^PRCAFN(IBIFN1) Q:AMT ; A/R amount 55 . S AMT=+$P($G(^DGCR(399,IBIFN,"U2")),U,SEQ+3) ; amount on bill 56 Q $G(AMT) 57 ; 58 OUTPT(IBIFN,IBPRINT) ; Moved for space 59 D OUTPT^IBCEF11(IBIFN,$G(IBPRINT)) 60 Q 61 ; 62 OCC92 ;Reformats IBXSAVE("OCC") and IBXSAVE("OCCS") to fit blocks on UB-04 63 ; Set up IBXSAVE(32-36) arrays 64 N IBPG,IB32,IB33,IB34,IB35,IB36,IBFL,Z,Z0,PG 65 S IBPG=0 66 F Z=32:1:36 K IBFL(Z) S IBFL(Z)=0 67 M IB32=IBXSAVE("OCC"),IB36=IBXSAVE("OCCS") 68 S IB32=$O(IB32(""),-1),IB36=$O(IB36(""),-1),PG=1 69 D OCC^IBCF32 70 F Z=32:1:36 S Z0="" F S Z0=$O(IBFL(Z,Z0)) Q:'Z0 S IBXSAVE("OC92",Z,Z0)=$P(IBFL(Z,Z0),U,1,3) 71 Q 72 ; 73 BATCH() ; Moved for space IB*2*349 74 Q $$BATCH^IBCEF11() 75 ; 76 PROC(T,TYPE) ; Find procedure code, strip '.' Function returns result 77 ; T = Procedure internal entry #;file reference 78 ; TYPE = "CPT" for only CPT/HCPCS valid 79 ; "ICD" for only ICD9 valid or null for either 80 N Q,S 81 S Q="",S="^"_$P($P(T,";",2),"(") 82 I $G(TYPE)="" D 83 . I $E(S,2,3)="IC" S Q=$P($$PRCD(T),U) Q 84 . I T["DIC(81.3" S Q=$$MOD^ICPTMOD(+T,"I") S Q=$S(Q>0:$P(Q,U,4),1:"") 85 I $G(TYPE)="CPT",$E(S,2,3)="IC" S Q=$$PRCD(T) Q 86 I $G(TYPE)="ICD",T["ICD0" S Q=$P($$ICD0^IBACSV(+T),U) 87 Q $TR(Q,".") 88 ; 89 FACILITY(IBIFN) ;return the Facility (Institution pointer-#4) for a bill 90 ; the institution of the Bill Division (399,.22) if defined, otherwise the Facility Name (350.9,.02) 91 ; 92 N IB0,IBIN S IBIN=0 93 S IB0=$G(^DGCR(399,+$G(IBIFN),0)) I +$P(IB0,U,22) S IBIN=$$SITE^VASITE(+$P(IB0,U,3),+$P(IB0,U,22)) 94 I IBIN'>0 S IBIN=+$P($G(^IBE(350.9,1,0)),U,2) 95 Q +IBIN 96 ; 97 ISRX(IBIFN) ; Function to determine if bill is a prescription refill bill 98 ; Returns 0 if no Rx on bill or 1 if there is. 99 ; 100 N IBRX 101 I $D(^IBA(362.4,"AIFN"_IBIFN)) S IBRX=1 102 Q +$G(IBRX) 103 ; 104 ISPROS(IBIFN) ; Function to determine if bill is a prosthetics bill 105 ; Returns 0 if no Prosthetics on bill or 1 if there is. 106 ; 107 N IBPROS 108 I $D(^IBA(362.5,"AIFN"_IBIFN)) S IBPROS=1 109 Q +$G(IBPROS) 110 ; 111 FINDINS(IBIFN,IBSEQ) ; Returns the internal entry number of the insurance 112 ; company for bill ien IBIFN for payer sequence IBSEQ (or current if 113 ; IBSEQ is null) 114 Q $P($G(^DGCR(399,IBIFN,"I"_$$COBN^IBCEF(IBIFN,$G(IBSEQ)))),U) 115 ; 116 TOB(IBIFN) ; Returns UB-04 type of bill from data in the output formatter 117 N IBTOB,IBZ1,IBZ2,IBZ3 118 D F^IBCEF("N-UB-04 LOCATION OF CARE","IBZ1",,IBIFN) 119 D F^IBCEF("N-UB-04 BILL CLASSIFICATION","IBZ2",,IBIFN) 120 D F^IBCEF("N-UB-04 TIMEFRAME OF BILL","IBZ3",,IBIFN) 121 S IBTOB=IBZ1_IBZ2_IBZ3 122 Q IBTOB 123 ; 124 PRCD(PRIEN,ALL,EDT) ; Function returns the code that corresponds to the variable 125 ; pointer data in PRIEN (ien;file) 126 ; ALL = if ALL=1, returns the entire $$CPT^ICPTCOD for CPT or 127 ; ^code^name format for ICD result 128 ; or null if lookup fails 129 ; EDT = Effective date to check (not used if +$G(ALL)=0) 130 N CODE,IBX 131 S CODE="" 132 ;Modified for Code Set Versioning 133 I PRIEN["ICPT" S IBX=$$CPT^ICPTCOD(+PRIEN,$G(EDT)) G:IBX'>0 PRCDQ S CODE=$S($G(ALL):IBX,1:$P(IBX,U,2)) 134 I PRIEN["ICD0" S IBX=$$ICD0^IBACSV(+PRIEN,$G(EDT)) G:IBX="" PRCDQ S CODE=$S($G(ALL):U_$P(IBX,U)_U_$P(IBX,U,4),1:$P(IBX,U)) 135 PRCDQ Q CODE 136 ; 137 NFT(FT,IBIFN) ; Returns 1 if bill IBIFN is not of form type FT (internal) 138 ; so the data element should not be required 139 S FT=$S($$FT^IBCEF(IBIFN)=FT:0,1:1) 140 Q FT 141 ; 142 REQ(FT,INP,IBIFN) ; Determine if bill IBIFN is of form type FT and 143 ; Inpatient (I) or Outpatient (O) status INP [or either if (null)] 144 ; 145 ;Returns 1 if both conditions FT and INP match for the bill 146 ; or 0 if either of these conditions are not true 147 ; I $$REQ^IBCEF1(2,"I",1) would mean if bill entry #1 is 148 ; CMS-1500/inpatient the data would be required 149 ; I '$$REQ^IBCEF1(2,"I",1) would mean if bill entry #1 is anything but 150 ; CMS-1500/inpatient, the data would not be 151 ; required 152 N Z 153 S Z=1 154 S:$$NFT(FT,IBIFN) Z=0 ; Not the form type for requirement 155 I Z,$G(INP)'="" D 156 . S Z0=$$INPAT^IBCEF(IBIFN,1),INP=$G(INP) 157 . S Z=$S(Z0:INP="I",1:INP="O") ;Check if I/O matches required state 158 Q Z 159 ; 160 SET1(IBIFN,A,IBZ,IBXDATA,IBXNOREQ) ; Utility to set variables for output 161 ; formatter for professional EDI 162 ; Returns values of A, IBXDATA, IBZ, IBXNOREQ 163 N Z,CT 164 S A="^TMP($J,""IBLCT"")" 165 S (Z,CT)=0 166 F S Z=$O(IBXDATA(Z)) Q:'Z D ; Don't transmit 0-charges 167 . I $P(IBXDATA(Z),U,9),$P(IBXDATA(Z),U,8) S CT=CT+1 M IBZ(CT)=IBXDATA(Z) 168 K IBXDATA 169 S IBXNOREQ='$$REQ(2,"O",IBIFN) 170 Q 171 ; 172 CIADDR(IBXDATA,IBXSAVE,LINE,FORM) ; Format current ins co address line LINE for FORM 173 ; FORM = 1 for CMS-1500, 2 for UB-04 174 ; Called from output formatter - both IBXDATA, IBXSAVE parameters are 175 ; passed by reference 176 ; 177 K IBXDATA 178 I $G(FORM)'=1 D 179 . ; 180 . ; esg - 11/17/06 - IB*2*349 - UB-04 FL-38 contains the payer name 181 . ; and address on 4 lines within this 5 line box. All 5 lines 182 . ; are formatted here into the IBXDATA array. This is the 183 . ; address that shows through the envelope window. 184 . ; 185 . N Z,LM,Q,ADDR,X 186 . S LM=$P($G(^IBE(350.9,1,1)),U,31) ; UB address column parameter 187 . S Z="" 188 . I LM S $P(Z," ",LM)="" ; beginning spaces indent 189 . S ADDR=$G(IBXSAVE("CADR")) ; address data string 190 . S IBXDATA(1)="",Q=1 ; line 1 is blank 191 . S Q=Q+1 192 . S IBXDATA(Q)=Z_$G(IBXSAVE("CADR_NAME")) ; line 2 payer name 193 . S X=$P(ADDR,U,1) 194 . I X'="" S Q=Q+1,IBXDATA(Q)=Z_X ; address line 1 195 . S X=$P(ADDR,U,2) 196 . I X'="" S Q=Q+1,IBXDATA(Q)=Z_X D ; address line 2 197 .. S X=$P(ADDR,U,3) 198 .. I X'="" S IBXDATA(Q)=IBXDATA(Q)_" "_X ; address line 3 199 .. Q 200 . S Q=Q+1 ; city,st,zip on last line 201 . S IBXDATA(Q)=Z_$P(ADDR,U,4)_", "_$$STATE^IBCEFG1($P(ADDR,U,5))_" "_$P(ADDR,U,6) 202 . KILL IBXSAVE("CADR_NAME"),IBXSAVE("CADR") ; cleanup 203 . Q 204 ; 205 I $G(FORM)=1 D ; CMS-1500 206 . N CT,X,Z 207 . S:'$D(IBXSAVE("INDENT")) Z="",$P(Z," ",+$P($G(^IBE(350.9,1,1)),U,27)+1)="",IBXSAVE("INDENT")=Z 208 . S CT=0 209 . S X=$P(IBXSAVE("CADR"),U) S:X'="" CT=CT+1,IBXDATA(CT)=IBXSAVE("INDENT")_X 210 . S X=$S($P(IBXSAVE("CADR"),U,2)'="":$P(IBXSAVE("CADR"),U,2),1:"")_$S($P(IBXSAVE("CADR"),U,2)'="":" ",1:"")_$P(IBXSAVE("CADR"),U,3) S:X'="" CT=CT+1,IBXDATA(CT)=IBXSAVE("INDENT")_X 211 . S CT=CT+1,IBXDATA(CT)=IBXSAVE("INDENT")_$P(IBXSAVE("CADR"),U,4)_", "_$$STATE^IBCEFG1($P(IBXSAVE("CADR"),U,5))_" "_$P(IBXSAVE("CADR"),U,6) 212 . Q 213 ; 214 Q 215 ;
Note:
See TracChangeset
for help on using the changeset viewer.
