IBCEF1 ;ALB/TMP - FORMATTER SPECIFIC BILL FUNCTIONS - CONT ;30-JAN-96
;;2.0;INTEGRATED BILLING;**52,124,51,137,210,155,349,371,447,547,574,592**;21-MAR-94;Build 58
;;Per VA Directive 6402, this routine should not be modified.
;
OCC(IBIFN,REL,TEXT) ;Sets up an arrays of occurrence codes for various cks
;RETURNS 1^additional data for entry IBXSAVE("OCC",n) if REL or TEXT
; parameters have been met or null if conditions not met
;If no REL or TEXT parameters sent, just extract codes array
; IBIFN = bill ien
; REL = 'OCC RELATED TO' value to check for
; TEXT = text to check for the .01 field of 399.1 entry pointed to
; by the occurrence code
N OCC,SORT,ARR,N,DATA,CODE,CT
I '$D(IBXSAVE("OCC")),'$D(IBXSAVE("OCCS")) D
.N IBI,Z,CT1,CT2,Z0 S (IBI,CT1,CT2)=0
.F S IBI=$O(^DGCR(399,IBIFN,"OC",IBI)) Q:'IBI S Z=$G(^(IBI,0)) D
..S Z0=$G(^DGCR(399.1,+Z,0))
..Q:'$P(Z0,U,10)&'$P(Z0,U,4) ;Not an occurrence code
..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)
..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)
I '$D(IBXSAVE("OCC"))&'$D(IBXSAVE("OCCS")) S IBXSAVE("OCC")="" G OCCQ
;
; esg - IB*2*349 - order the occurrence codes
; Build the SORT array sorted by the occ code
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
; Loop thru the SORT array and re-build the IBXSAVE array
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)
;
I $G(REL)'=""!($G(TEXT)'="") D OCC1("",.OCC,$G(REL),$G(TEXT)) D:'$D(OCC) OCC1("S",.OCC,$G(REL),$G(TEXT))
OCCQ Q $G(OCC)
;
OCC1(ARR,OCC,REL,TEXT) ; Search thru local array for parameters met
; ARR = null to search OCC subscript, "S" to search OCCS subscript
N Z
S ARR="OCC"_ARR,Z=0
F S Z=$O(IBXSAVE(ARR,Z)) Q:'Z D
.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
.I $G(TEXT)'="",$P(IBXSAVE(ARR,Z),U,4)=TEXT S OCC="1^"_$P(IBXSAVE(ARR,Z),U,7)
Q
;
RX(IBIFN) ; Format billable prescription data for refills for 837
N Z,IBXDATA,CT
I '$D(IBXSAVE("BOX24")) D B24^IBCEF3(.IBXSAVE,IBIFN,1)
S Z="",CT=0
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")
RXQ Q CT
;
OTHPAY(IBIFN,SEQ) ; Return the other insurance payment amount for bill
; IBIFN and payer sequence SEQ (1-3)
N AMT,IBIFN1,PRP
S IBIFN1=$P($G(^DGCR(399,IBIFN,"M1")),U,SEQ+4),PRP=0
I IBIFN1 D
. ; IB*2.0*547 if Medicare on bill, make sure you are pulling amt paid from correct sequence
. ; code was leaving out MRA amt on tertiary bills and cloned secondary where MRA claim# does NOT match current claim#
. ;I $$MCRWNR^IBEFUNC(+$G(^DGCR(399,IBIFN,"I"_SEQ))) S AMT=$$MCRPAY^IBCEU0(IBIFN) Q
. I $$MCRWNR^IBEFUNC(+$G(^DGCR(399,IBIFN,"I"_SEQ))) S AMT=$$MCRPAY^IBCEU0(IBIFN1),PRP=1 Q
. S AMT=+$$TPR^PRCAFN(IBIFN1) I AMT S PRP=1 Q ; A/R amount
. ; IB*2.0*547 - moved this line because it was not getting executed if IBIFN1 was not defined, which it won't be for
. ; manually created secondary and tertiary claims. Using new flag PRP to indicate if prior payment already found.
. ; S AMT=+$P($G(^DGCR(399,IBIFN,"U2")),U,SEQ+3) ; amount on bill
S:PRP=0 AMT=+$P($G(^DGCR(399,IBIFN,"U2")),U,SEQ+3) ; amount on bill
Q $G(AMT)
;
OUTPT(IBIFN,IBPRINT) ; Moved for space
D OUTPT^IBCEF11(IBIFN,$G(IBPRINT))
Q
;
OCC92 ;Reformats IBXSAVE("OCC") and IBXSAVE("OCCS") to fit blocks on UB-04
; Set up IBXSAVE(32-36) arrays
N IBPG,IB32,IB33,IB34,IB35,IB36,IBFL,Z,Z0,PG
S IBPG=0
F Z=32:1:36 K IBFL(Z) S IBFL(Z)=0
M IB32=IBXSAVE("OCC"),IB36=IBXSAVE("OCCS")
S IB32=$O(IB32(""),-1),IB36=$O(IB36(""),-1),PG=1
D OCC^IBCF32
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)
Q
;
BATCH() ; Moved for space IB*2*349
Q $$BATCH^IBCEF11()
;
PROC(T,TYPE) ; Find procedure code, strip '.' Function returns result
; T = Procedure internal entry #;file reference
; TYPE = "CPT" for only CPT/HCPCS valid
; "ICD" for only ICD9 valid or null for either
N Q,S
S Q="",S="^"_$P($P(T,";",2),"(")
I $G(TYPE)="" D
. I $E(S,2,3)="IC" S Q=$P($$PRCD(T),U) Q
. I T["DIC(81.3" S Q=$$MOD^ICPTMOD(+T,"I") S Q=$S(Q>0:$P(Q,U,4),1:"")
I $G(TYPE)="CPT",$E(S,2,3)="IC" S Q=$$PRCD(T) Q
I $G(TYPE)="ICD",T["ICD0" S Q=$P($$ICD0^IBACSV(+T),U)
Q $TR(Q,".")
;
FACILITY(IBIFN) ;return the Facility (Institution pointer-#4) for a bill
; the institution of the Bill Division (399,.22) if defined, otherwise the Facility Name (350.9,.02)
;
N IB0,IBIN S IBIN=0
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))
I IBIN'>0 S IBIN=+$P($G(^IBE(350.9,1,0)),U,2)
Q +IBIN
;
ISRX(IBIFN) ; Function to determine if bill is a prescription refill bill
; Returns 0 if no Rx on bill or 1 if there is.
;
N IBRX
I $D(^IBA(362.4,"AIFN"_IBIFN)) S IBRX=1
Q +$G(IBRX)
;
ISPROS(IBIFN) ; Function to determine if bill is a prosthetics bill
; Returns 0 if no Prosthetics on bill or 1 if there is.
;
N IBPROS
I $D(^IBA(362.5,"AIFN"_IBIFN)) S IBPROS=1
Q +$G(IBPROS)
;
FINDINS(IBIFN,IBSEQ) ; Returns the internal entry number of the insurance
; company for bill ien IBIFN for payer sequence IBSEQ (or current if
; IBSEQ is null)
Q $P($G(^DGCR(399,IBIFN,"I"_$$COBN^IBCEF(IBIFN,$G(IBSEQ)))),U)
;
TOB(IBIFN) ; Returns UB-04 type of bill from data in the output formatter
N IBTOB,IBZ1,IBZ2,IBZ3
D F^IBCEF("N-UB-04 LOCATION OF CARE","IBZ1",,IBIFN)
D F^IBCEF("N-UB-04 BILL CLASSIFICATION","IBZ2",,IBIFN)
D F^IBCEF("N-UB-04 TIMEFRAME OF BILL","IBZ3",,IBIFN)
S IBTOB=IBZ1_IBZ2_IBZ3
Q IBTOB
;
PRCD(PRIEN,ALL,EDT) ; Function returns the code that corresponds to the variable
; pointer data in PRIEN (ien;file)
; ALL = if ALL=1, returns the entire $$CPT^ICPTCOD for CPT or
; ^code^name format for ICD result
; or null if lookup fails
; EDT = Effective date to check (not used if +$G(ALL)=0)
N CODE,IBX
S CODE=""
;Modified for Code Set Versioning
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))
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))
PRCDQ Q CODE
;
NFT(FT,IBIFN) ; Returns 1 if bill IBIFN is not of form type FT (internal)
; so the data element should not be required
S FT=$S($$FT^IBCEF(IBIFN)=FT:0,1:1)
Q FT
;
REQ(FT,INP,IBIFN) ; Determine if bill IBIFN is of form type FT and
; Inpatient (I) or Outpatient (O) status INP [or either if (null)]
;
;Returns 1 if both conditions FT and INP match for the bill
; or 0 if either of these conditions are not true
; I $$REQ^IBCEF1(2,"I",1) would mean if bill entry #1 is
; CMS-1500/inpatient the data would be required
; I '$$REQ^IBCEF1(2,"I",1) would mean if bill entry #1 is anything but
; CMS-1500/inpatient, the data would not be
; required
N Z
S Z=1
S:$$NFT(FT,IBIFN) Z=0 ; Not the form type for requirement
I Z,$G(INP)'="" D
. S Z0=$$INPAT^IBCEF(IBIFN,1),INP=$G(INP)
. S Z=$S(Z0:INP="I",1:INP="O") ;Check if I/O matches required state
Q Z
;
SET1(IBIFN,A,IBZ,IBXDATA,IBXNOREQ) ; Utility to set variables for output
; formatter for professional EDI
; Returns values of A, IBXDATA, IBZ, IBXNOREQ
N Z,CT
S A="^TMP($J,""IBLCT"")"
S (Z,CT)=0
F S Z=$O(IBXDATA(Z)) Q:'Z D ; Don't transmit 0-charges
. ;IB*2.0*447/TAZ - Transmit $0 charges.
. ;I $P(IBXDATA(Z),U,9),$P(IBXDATA(Z),U,8) S CT=CT+1 M IBZ(CT)=IBXDATA(Z)
. ;JWS;IB*2.0*592:US131
. I $P(IBXDATA(Z),U,9) S CT=CT+1 M IBZ(CT)=IBXDATA(Z)
. ;IB*2.0*447
K IBXDATA
;JWS;IB*2.0*592:US131
I $$FT^IBCEF(IBXIEN)'=7 S IBXNOREQ='$$REQ(2,"O",IBIFN)
Q
;
CIADDR(IBXDATA,IBXSAVE,LINE,FORM) ; Format current ins co address line LINE for FORM
; FORM = 1 for CMS-1500, 2 for UB-04
; Called from output formatter - both IBXDATA, IBXSAVE parameters are
; passed by reference
;
K IBXDATA
I $G(FORM)'=1 D
. ;
. ; esg - 11/17/06 - IB*2*349 - UB-04 FL-38 contains the payer name
. ; and address on 4 lines within this 5 line box. All 5 lines
. ; are formatted here into the IBXDATA array. This is the
. ; address that shows through the envelope window.
. ;
. ; esg - 9/13/07 - IB*2*371 - Line 1 of this box contains the print
. ; status (i.e. copy, 2nd notice, 3rd notice, MRA needed).
. ;
. N Z,Z1,LM,Q,ADDR,X,IBPSTAT
. S LM=$P($G(^IBE(350.9,1,1)),U,31) ; UB address column parameter
. S Z=""
. I LM S $P(Z," ",LM)="" ; beginning spaces indent
. S ADDR=$G(IBXSAVE("CADR")) ; address data string
. ;
. D F^IBCEF("N-PRINT BILL SUBMIT STATUS","IBPSTAT",,+$G(IBXIEN))
. S Z1=Z I Z1="" S Z1=" " ; line 1 can't start in column 1
. S IBXDATA(1)=Z1_$G(IBPSTAT),Q=1 ; line 1 print status
. S Q=Q+1
. S IBXDATA(Q)=Z_$G(IBXSAVE("CADR_NAME")) ; line 2 payer name
. S X=$P(ADDR,U,1)
. I X'="" S Q=Q+1,IBXDATA(Q)=Z_X ; address line 1
. S X=$P(ADDR,U,2)
. I X'="" S Q=Q+1,IBXDATA(Q)=Z_X D ; address line 2
.. S X=$P(ADDR,U,3)
.. I X'="" S IBXDATA(Q)=IBXDATA(Q)_" "_X ; address line 3
.. Q
. S Q=Q+1 ; city,st,zip on last line
. S IBXDATA(Q)=Z_$P(ADDR,U,4)_", "_$$STATE^IBCEFG1($P(ADDR,U,5))_" "_$P(ADDR,U,6)
. KILL IBXSAVE("CADR_NAME"),IBXSAVE("CADR") ; cleanup
. Q
;
I $G(FORM)=1 D ; CMS-1500
. N CT,X,Z
. S:'$D(IBXSAVE("INDENT")) Z="",$P(Z," ",+$P($G(^IBE(350.9,1,1)),U,27)+1)="",IBXSAVE("INDENT")=Z
. S CT=0
. S X=$P(IBXSAVE("CADR"),U) S:X'="" CT=CT+1,IBXDATA(CT)=IBXSAVE("INDENT")_X
. 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
. 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)
. Q
;
Q
;
HHLTH(IBIFN,OUT) ; determine if claim is hospice/home health and needs episode of care date **574**
; per NUBC, date the episode of care began is needed for all outpatient CMS-1500 Home Health and Hospice claims and
; UB-04: 012x,022x,032x,034x,081x & 082x claims
; this string is zero + the Bill Type field from screens 6&7 of enter/edit Bill: 0_field#.24(LOC OF CARE)_.25(BILL CLASS)_.26(TIMEFRAME)
; required - IBIFN = internal claim#
; optional - OUT = optional flag to pass to INPAT^IBCEF
; returns a 1 if date should be included on bill and a 0 if it should NOT be included on bill
;
N IB0,IBL,IBC,IBT
Q:$G(IBIFN)="" 0
; all inpatient claims include date
I $$INPAT^IBCEF(IBIFN,+$G(OUT))'=0 Q 1
S IB0=$G(^DGCR(399,IBIFN,0)),IBL=$P(IB0,U,24)
; Per Lisa Duncan, all Home health must have date, not just 032x & 034x
Q:IBL=3 1
; not home health or hospice if LOC OF CARE = 7
Q:IBL=7 0
S IBC=$P($G(^DGCR(399.1,+$P(IB0,U,25),0)),U,2)
; not home health or hospice if BILL CLASS is 3 or a number greater than 4
Q:IBC>4 0
Q:IBC=3 0
S IBT=IBL_IBC
; any claim where the location of care_bill classification combo is 12,22,32,34,81 or 82 must have date
Q:"^12^22^32^34^81^82^"[IBT 1
Q 0
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCEF1 11746 printed Dec 13, 2024@02:09:56 Page 2
IBCEF1 ;ALB/TMP - FORMATTER SPECIFIC BILL FUNCTIONS - CONT ;30-JAN-96
+1 ;;2.0;INTEGRATED BILLING;**52,124,51,137,210,155,349,371,447,547,574,592**;21-MAR-94;Build 58
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
OCC(IBIFN,REL,TEXT) ;Sets up an arrays of occurrence codes for various cks
+1 ;RETURNS 1^additional data for entry IBXSAVE("OCC",n) if REL or TEXT
+2 ; parameters have been met or null if conditions not met
+3 ;If no REL or TEXT parameters sent, just extract codes array
+4 ; IBIFN = bill ien
+5 ; REL = 'OCC RELATED TO' value to check for
+6 ; TEXT = text to check for the .01 field of 399.1 entry pointed to
+7 ; by the occurrence code
+8 NEW OCC,SORT,ARR,N,DATA,CODE,CT
+9 IF '$DATA(IBXSAVE("OCC"))
IF '$DATA(IBXSAVE("OCCS"))
Begin DoDot:1
+10 NEW IBI,Z,CT1,CT2,Z0
SET (IBI,CT1,CT2)=0
+11 FOR
SET IBI=$ORDER(^DGCR(399,IBIFN,"OC",IBI))
if 'IBI
QUIT
SET Z=$GET(^(IBI,0))
Begin DoDot:2
+12 SET Z0=$GET(^DGCR(399.1,+Z,0))
+13 ;Not an occurrence code
if '$PIECE(Z0,U,10)&'$PIECE(Z0,U,4)
QUIT
+14 IF $PIECE(Z0,U,10)
SET CT2=CT2+1
SET IBXSAVE("OCCS",CT2)=$SELECT($PIECE(Z0,U,4):$PIECE(Z0,U,2)_U_$PIECE(Z,U,2),1:U)_U_$PIECE(Z,U,4)_U_$PIECE(Z0,U)_U_$PIECE(Z0,U,9)_U_$PIECE(Z,U,3)_U_$PIECE(Z,U,2)
+15 IF '$PIECE(Z0,U,10)
SET CT1=CT1+1
SET IBXSAVE("OCC",CT1)=$SELECT($PIECE(Z0,U,4):$PIECE(Z0,U,2)_U_$PIECE(Z,U,2),1:U)_U_U_$PIECE(Z0,U)_U_$PIECE(Z0,U,9)_U_$PIECE(Z,U,3)_U_$PIECE(Z,U,2)
End DoDot:2
End DoDot:1
+16 IF '$DATA(IBXSAVE("OCC"))&'$DATA(IBXSAVE("OCCS"))
SET IBXSAVE("OCC")=""
GOTO OCCQ
+17 ;
+18 ; esg - IB*2*349 - order the occurrence codes
+19 ; Build the SORT array sorted by the occ code
+20 FOR ARR="OCC","OCCS"
SET N=0
FOR
SET N=$ORDER(IBXSAVE(ARR,N))
if 'N
QUIT
SET DATA=$GET(IBXSAVE(ARR,N))
IF $PIECE(DATA,U,1)'=""
SET CODE=" "_$PIECE(DATA,U,1)
SET SORT(ARR,CODE,N)=DATA
+21 ; Loop thru the SORT array and re-build the IBXSAVE array
+22 FOR ARR="OCC","OCCS"
KILL IBXSAVE(ARR)
SET CODE=""
SET CT=0
FOR
SET CODE=$ORDER(SORT(ARR,CODE))
if CODE=""
QUIT
SET N=0
FOR
SET N=$ORDER(SORT(ARR,CODE,N))
if 'N
QUIT
SET CT=CT+1
SET IBXSAVE(ARR,CT)=SORT(ARR,CODE,N)
+23 ;
+24 IF $GET(REL)'=""!($GET(TEXT)'="")
DO OCC1("",.OCC,$GET(REL),$GET(TEXT))
if '$DATA(OCC)
DO OCC1("S",.OCC,$GET(REL),$GET(TEXT))
OCCQ QUIT $GET(OCC)
+1 ;
OCC1(ARR,OCC,REL,TEXT) ; Search thru local array for parameters met
+1 ; ARR = null to search OCC subscript, "S" to search OCCS subscript
+2 NEW Z
+3 SET ARR="OCC"_ARR
SET Z=0
+4 FOR
SET Z=$ORDER(IBXSAVE(ARR,Z))
if 'Z
QUIT
Begin DoDot:1
+5 IF $GET(REL)'=""
IF $PIECE(IBXSAVE(ARR,Z),U,5)=REL
SET OCC="1"_$SELECT(REL=2:U_$PIECE(IBXSAVE(ARR,Z),U,6),1:"")
QUIT
+6 IF $GET(TEXT)'=""
IF $PIECE(IBXSAVE(ARR,Z),U,4)=TEXT
SET OCC="1^"_$PIECE(IBXSAVE(ARR,Z),U,7)
End DoDot:1
+7 QUIT
+8 ;
RX(IBIFN) ; Format billable prescription data for refills for 837
+1 NEW Z,IBXDATA,CT
+2 IF '$DATA(IBXSAVE("BOX24"))
DO B24^IBCEF3(.IBXSAVE,IBIFN,1)
+3 SET Z=""
SET CT=0
+4 FOR
SET Z=$ORDER(IBXSAVE("BOX24",Z))
if Z=""
QUIT
IF $DATA(IBXSAVE("BOX24",Z,"RX"))
SET CT=CT+1
SET IBXDATA(Z)=IBXSAVE("BOX24",Z,"RX")
RXQ QUIT CT
+1 ;
OTHPAY(IBIFN,SEQ) ; Return the other insurance payment amount for bill
+1 ; IBIFN and payer sequence SEQ (1-3)
+2 NEW AMT,IBIFN1,PRP
+3 SET IBIFN1=$PIECE($GET(^DGCR(399,IBIFN,"M1")),U,SEQ+4)
SET PRP=0
+4 IF IBIFN1
Begin DoDot:1
+5 ; IB*2.0*547 if Medicare on bill, make sure you are pulling amt paid from correct sequence
+6 ; code was leaving out MRA amt on tertiary bills and cloned secondary where MRA claim# does NOT match current claim#
+7 ;I $$MCRWNR^IBEFUNC(+$G(^DGCR(399,IBIFN,"I"_SEQ))) S AMT=$$MCRPAY^IBCEU0(IBIFN) Q
+8 IF $$MCRWNR^IBEFUNC(+$GET(^DGCR(399,IBIFN,"I"_SEQ)))
SET AMT=$$MCRPAY^IBCEU0(IBIFN1)
SET PRP=1
QUIT
+9 ; A/R amount
SET AMT=+$$TPR^PRCAFN(IBIFN1)
IF AMT
SET PRP=1
QUIT
+10 ; IB*2.0*547 - moved this line because it was not getting executed if IBIFN1 was not defined, which it won't be for
+11 ; manually created secondary and tertiary claims. Using new flag PRP to indicate if prior payment already found.
+12 ; S AMT=+$P($G(^DGCR(399,IBIFN,"U2")),U,SEQ+3) ; amount on bill
End DoDot:1
+13 ; amount on bill
if PRP=0
SET AMT=+$PIECE($GET(^DGCR(399,IBIFN,"U2")),U,SEQ+3)
+14 QUIT $GET(AMT)
+15 ;
OUTPT(IBIFN,IBPRINT) ; Moved for space
+1 DO OUTPT^IBCEF11(IBIFN,$GET(IBPRINT))
+2 QUIT
+3 ;
OCC92 ;Reformats IBXSAVE("OCC") and IBXSAVE("OCCS") to fit blocks on UB-04
+1 ; Set up IBXSAVE(32-36) arrays
+2 NEW IBPG,IB32,IB33,IB34,IB35,IB36,IBFL,Z,Z0,PG
+3 SET IBPG=0
+4 FOR Z=32:1:36
KILL IBFL(Z)
SET IBFL(Z)=0
+5 MERGE IB32=IBXSAVE("OCC"),IB36=IBXSAVE("OCCS")
+6 SET IB32=$ORDER(IB32(""),-1)
SET IB36=$ORDER(IB36(""),-1)
SET PG=1
+7 DO OCC^IBCF32
+8 FOR Z=32:1:36
SET Z0=""
FOR
SET Z0=$ORDER(IBFL(Z,Z0))
if 'Z0
QUIT
SET IBXSAVE("OC92",Z,Z0)=$PIECE(IBFL(Z,Z0),U,1,3)
+9 QUIT
+10 ;
BATCH() ; Moved for space IB*2*349
+1 QUIT $$BATCH^IBCEF11()
+2 ;
PROC(T,TYPE) ; Find procedure code, strip '.' Function returns result
+1 ; T = Procedure internal entry #;file reference
+2 ; TYPE = "CPT" for only CPT/HCPCS valid
+3 ; "ICD" for only ICD9 valid or null for either
+4 NEW Q,S
+5 SET Q=""
SET S="^"_$PIECE($PIECE(T,";",2),"(")
+6 IF $GET(TYPE)=""
Begin DoDot:1
+7 IF $EXTRACT(S,2,3)="IC"
SET Q=$PIECE($$PRCD(T),U)
QUIT
+8 IF T["DIC(81.3"
SET Q=$$MOD^ICPTMOD(+T,"I")
SET Q=$SELECT(Q>0:$PIECE(Q,U,4),1:"")
End DoDot:1
+9 IF $GET(TYPE)="CPT"
IF $EXTRACT(S,2,3)="IC"
SET Q=$$PRCD(T)
QUIT
+10 IF $GET(TYPE)="ICD"
IF T["ICD0"
SET Q=$PIECE($$ICD0^IBACSV(+T),U)
+11 QUIT $TRANSLATE(Q,".")
+12 ;
FACILITY(IBIFN) ;return the Facility (Institution pointer-#4) for a bill
+1 ; the institution of the Bill Division (399,.22) if defined, otherwise the Facility Name (350.9,.02)
+2 ;
+3 NEW IB0,IBIN
SET IBIN=0
+4 SET IB0=$GET(^DGCR(399,+$GET(IBIFN),0))
IF +$PIECE(IB0,U,22)
SET IBIN=$$SITE^VASITE(+$PIECE(IB0,U,3),+$PIECE(IB0,U,22))
+5 IF IBIN'>0
SET IBIN=+$PIECE($GET(^IBE(350.9,1,0)),U,2)
+6 QUIT +IBIN
+7 ;
ISRX(IBIFN) ; Function to determine if bill is a prescription refill bill
+1 ; Returns 0 if no Rx on bill or 1 if there is.
+2 ;
+3 NEW IBRX
+4 IF $DATA(^IBA(362.4,"AIFN"_IBIFN))
SET IBRX=1
+5 QUIT +$GET(IBRX)
+6 ;
ISPROS(IBIFN) ; Function to determine if bill is a prosthetics bill
+1 ; Returns 0 if no Prosthetics on bill or 1 if there is.
+2 ;
+3 NEW IBPROS
+4 IF $DATA(^IBA(362.5,"AIFN"_IBIFN))
SET IBPROS=1
+5 QUIT +$GET(IBPROS)
+6 ;
FINDINS(IBIFN,IBSEQ) ; Returns the internal entry number of the insurance
+1 ; company for bill ien IBIFN for payer sequence IBSEQ (or current if
+2 ; IBSEQ is null)
+3 QUIT $PIECE($GET(^DGCR(399,IBIFN,"I"_$$COBN^IBCEF(IBIFN,$GET(IBSEQ)))),U)
+4 ;
TOB(IBIFN) ; Returns UB-04 type of bill from data in the output formatter
+1 NEW IBTOB,IBZ1,IBZ2,IBZ3
+2 DO F^IBCEF("N-UB-04 LOCATION OF CARE","IBZ1",,IBIFN)
+3 DO F^IBCEF("N-UB-04 BILL CLASSIFICATION","IBZ2",,IBIFN)
+4 DO F^IBCEF("N-UB-04 TIMEFRAME OF BILL","IBZ3",,IBIFN)
+5 SET IBTOB=IBZ1_IBZ2_IBZ3
+6 QUIT IBTOB
+7 ;
PRCD(PRIEN,ALL,EDT) ; Function returns the code that corresponds to the variable
+1 ; pointer data in PRIEN (ien;file)
+2 ; ALL = if ALL=1, returns the entire $$CPT^ICPTCOD for CPT or
+3 ; ^code^name format for ICD result
+4 ; or null if lookup fails
+5 ; EDT = Effective date to check (not used if +$G(ALL)=0)
+6 NEW CODE,IBX
+7 SET CODE=""
+8 ;Modified for Code Set Versioning
+9 IF PRIEN["ICPT"
SET IBX=$$CPT^ICPTCOD(+PRIEN,$GET(EDT))
if IBX'>0
GOTO PRCDQ
SET CODE=$SELECT($GET(ALL):IBX,1:$PIECE(IBX,U,2))
+10 IF PRIEN["ICD0"
SET IBX=$$ICD0^IBACSV(+PRIEN,$GET(EDT))
if IBX=""
GOTO PRCDQ
SET CODE=$SELECT($GET(ALL):U_$PIECE(IBX,U)_U_$PIECE(IBX,U,4),1:$PIECE(IBX,U))
PRCDQ QUIT CODE
+1 ;
NFT(FT,IBIFN) ; Returns 1 if bill IBIFN is not of form type FT (internal)
+1 ; so the data element should not be required
+2 SET FT=$SELECT($$FT^IBCEF(IBIFN)=FT:0,1:1)
+3 QUIT FT
+4 ;
REQ(FT,INP,IBIFN) ; Determine if bill IBIFN is of form type FT and
+1 ; Inpatient (I) or Outpatient (O) status INP [or either if (null)]
+2 ;
+3 ;Returns 1 if both conditions FT and INP match for the bill
+4 ; or 0 if either of these conditions are not true
+5 ; I $$REQ^IBCEF1(2,"I",1) would mean if bill entry #1 is
+6 ; CMS-1500/inpatient the data would be required
+7 ; I '$$REQ^IBCEF1(2,"I",1) would mean if bill entry #1 is anything but
+8 ; CMS-1500/inpatient, the data would not be
+9 ; required
+10 NEW Z
+11 SET Z=1
+12 ; Not the form type for requirement
if $$NFT(FT,IBIFN)
SET Z=0
+13 IF Z
IF $GET(INP)'=""
Begin DoDot:1
+14 SET Z0=$$INPAT^IBCEF(IBIFN,1)
SET INP=$GET(INP)
+15 ;Check if I/O matches required state
SET Z=$SELECT(Z0:INP="I",1:INP="O")
End DoDot:1
+16 QUIT Z
+17 ;
SET1(IBIFN,A,IBZ,IBXDATA,IBXNOREQ) ; Utility to set variables for output
+1 ; formatter for professional EDI
+2 ; Returns values of A, IBXDATA, IBZ, IBXNOREQ
+3 NEW Z,CT
+4 SET A="^TMP($J,""IBLCT"")"
+5 SET (Z,CT)=0
+6 ; Don't transmit 0-charges
FOR
SET Z=$ORDER(IBXDATA(Z))
if 'Z
QUIT
Begin DoDot:1
+7 ;IB*2.0*447/TAZ - Transmit $0 charges.
+8 ;I $P(IBXDATA(Z),U,9),$P(IBXDATA(Z),U,8) S CT=CT+1 M IBZ(CT)=IBXDATA(Z)
+9 ;JWS;IB*2.0*592:US131
+10 IF $PIECE(IBXDATA(Z),U,9)
SET CT=CT+1
MERGE IBZ(CT)=IBXDATA(Z)
+11 ;IB*2.0*447
End DoDot:1
+12 KILL IBXDATA
+13 ;JWS;IB*2.0*592:US131
+14 IF $$FT^IBCEF(IBXIEN)'=7
SET IBXNOREQ='$$REQ(2,"O",IBIFN)
+15 QUIT
+16 ;
CIADDR(IBXDATA,IBXSAVE,LINE,FORM) ; Format current ins co address line LINE for FORM
+1 ; FORM = 1 for CMS-1500, 2 for UB-04
+2 ; Called from output formatter - both IBXDATA, IBXSAVE parameters are
+3 ; passed by reference
+4 ;
+5 KILL IBXDATA
+6 IF $GET(FORM)'=1
Begin DoDot:1
+7 ;
+8 ; esg - 11/17/06 - IB*2*349 - UB-04 FL-38 contains the payer name
+9 ; and address on 4 lines within this 5 line box. All 5 lines
+10 ; are formatted here into the IBXDATA array. This is the
+11 ; address that shows through the envelope window.
+12 ;
+13 ; esg - 9/13/07 - IB*2*371 - Line 1 of this box contains the print
+14 ; status (i.e. copy, 2nd notice, 3rd notice, MRA needed).
+15 ;
+16 NEW Z,Z1,LM,Q,ADDR,X,IBPSTAT
+17 ; UB address column parameter
SET LM=$PIECE($GET(^IBE(350.9,1,1)),U,31)
+18 SET Z=""
+19 ; beginning spaces indent
IF LM
SET $PIECE(Z," ",LM)=""
+20 ; address data string
SET ADDR=$GET(IBXSAVE("CADR"))
+21 ;
+22 DO F^IBCEF("N-PRINT BILL SUBMIT STATUS","IBPSTAT",,+$GET(IBXIEN))
+23 ; line 1 can't start in column 1
SET Z1=Z
IF Z1=""
SET Z1=" "
+24 ; line 1 print status
SET IBXDATA(1)=Z1_$GET(IBPSTAT)
SET Q=1
+25 SET Q=Q+1
+26 ; line 2 payer name
SET IBXDATA(Q)=Z_$GET(IBXSAVE("CADR_NAME"))
+27 SET X=$PIECE(ADDR,U,1)
+28 ; address line 1
IF X'=""
SET Q=Q+1
SET IBXDATA(Q)=Z_X
+29 SET X=$PIECE(ADDR,U,2)
+30 ; address line 2
IF X'=""
SET Q=Q+1
SET IBXDATA(Q)=Z_X
Begin DoDot:2
+31 SET X=$PIECE(ADDR,U,3)
+32 ; address line 3
IF X'=""
SET IBXDATA(Q)=IBXDATA(Q)_" "_X
+33 QUIT
End DoDot:2
+34 ; city,st,zip on last line
SET Q=Q+1
+35 SET IBXDATA(Q)=Z_$PIECE(ADDR,U,4)_", "_$$STATE^IBCEFG1($PIECE(ADDR,U,5))_" "_$PIECE(ADDR,U,6)
+36 ; cleanup
KILL IBXSAVE("CADR_NAME"),IBXSAVE("CADR")
+37 QUIT
End DoDot:1
+38 ;
+39 ; CMS-1500
IF $GET(FORM)=1
Begin DoDot:1
+40 NEW CT,X,Z
+41 if '$DATA(IBXSAVE("INDENT"))
SET Z=""
SET $PIECE(Z," ",+$PIECE($GET(^IBE(350.9,1,1)),U,27)+1)=""
SET IBXSAVE("INDENT")=Z
+42 SET CT=0
+43 SET X=$PIECE(IBXSAVE("CADR"),U)
if X'=""
SET CT=CT+1
SET IBXDATA(CT)=IBXSAVE("INDENT")_X
+44 SET X=$SELECT($PIECE(IBXSAVE("CADR"),U,2)'="":$PIECE(IBXSAVE("CADR"),U,2),1:"")_$SELECT($PIECE(IBXSAVE("CADR"),U,2)'="":" ",1:"")_$PIECE(IBXSAVE("CADR"),U,3)
if X'=""
SET CT=CT+1
SET IBXDATA(CT)=IBXSAVE("INDENT")_X
+45 SET CT=CT+1
SET IBXDATA(CT)=IBXSAVE("INDENT")_$PIECE(IBXSAVE("CADR"),U,4)_", "_$$STATE^IBCEFG1($PIECE(IBXSAVE("CADR"),U,5))_" "_$PIECE(IBXSAVE("CADR"),U,6)
+46 QUIT
End DoDot:1
+47 ;
+48 QUIT
+49 ;
HHLTH(IBIFN,OUT) ; determine if claim is hospice/home health and needs episode of care date **574**
+1 ; per NUBC, date the episode of care began is needed for all outpatient CMS-1500 Home Health and Hospice claims and
+2 ; UB-04: 012x,022x,032x,034x,081x & 082x claims
+3 ; this string is zero + the Bill Type field from screens 6&7 of enter/edit Bill: 0_field#.24(LOC OF CARE)_.25(BILL CLASS)_.26(TIMEFRAME)
+4 ; required - IBIFN = internal claim#
+5 ; optional - OUT = optional flag to pass to INPAT^IBCEF
+6 ; returns a 1 if date should be included on bill and a 0 if it should NOT be included on bill
+7 ;
+8 NEW IB0,IBL,IBC,IBT
+9 if $GET(IBIFN)=""
QUIT 0
+10 ; all inpatient claims include date
+11 IF $$INPAT^IBCEF(IBIFN,+$GET(OUT))'=0
QUIT 1
+12 SET IB0=$GET(^DGCR(399,IBIFN,0))
SET IBL=$PIECE(IB0,U,24)
+13 ; Per Lisa Duncan, all Home health must have date, not just 032x & 034x
+14 if IBL=3
QUIT 1
+15 ; not home health or hospice if LOC OF CARE = 7
+16 if IBL=7
QUIT 0
+17 SET IBC=$PIECE($GET(^DGCR(399.1,+$PIECE(IB0,U,25),0)),U,2)
+18 ; not home health or hospice if BILL CLASS is 3 or a number greater than 4
+19 if IBC>4
QUIT 0
+20 if IBC=3
QUIT 0
+21 SET IBT=IBL_IBC
+22 ; any claim where the location of care_bill classification combo is 12,22,32,34,81 or 82 must have date
+23 if "^12^22^32^34^81^82^"[IBT
QUIT 1
+24 QUIT 0
