| [613] | 1 | IBCEU ;ALB/TMP - EDI UTILITIES ;02-OCT-96
|
|---|
| 2 | ;;2.0;INTEGRATED BILLING;**51,137,207,232,349**;21-MAR-94;Build 46
|
|---|
| 3 | ;;Per VHA Directive 2004-038, this routine should not be modified.
|
|---|
| 4 | ; DBIA SUPPORTED REF: GET^XUA4A72 = 1625
|
|---|
| 5 | ; DBIA SUPPORTED REF: $$ESBLOCK^XUSESIG1 = 1557
|
|---|
| 6 | ;
|
|---|
| 7 | TESTPT(DFN) ; Determine if pt is test pt
|
|---|
| 8 | ; Returns 1 if a test pt, 0 if not
|
|---|
| 9 | Q $E($P($G(^DPT(+DFN,0)),U,9),1,5)="00000"
|
|---|
| 10 | ;
|
|---|
| 11 | MAINPRV(IBIFN) ; Returns name^id^ien^type code of 'main' prov on bill IBIFN
|
|---|
| 12 | N IBPRV,IBCOB,IBQ,Z
|
|---|
| 13 | D GETPRV(IBIFN,"3,4",.IBPRV)
|
|---|
| 14 | S IBQ="",IBCOB=$$COBN^IBCEF(IBIFN)
|
|---|
| 15 | F Z=3,4 I $G(IBPRV(Z,1))'="" D Q
|
|---|
| 16 | . S IBQ=IBPRV(Z,1),$P(IBQ,U,4)=Z
|
|---|
| 17 | . I $G(IBPRV(Z,1,IBCOB))'="" S $P(IBQ,U,2)=IBPRV(Z,1,IBCOB)
|
|---|
| 18 | Q IBQ
|
|---|
| 19 | ;
|
|---|
| 20 | PRVOK(VAL,IBIFN) ; Check bill form & prov function agree
|
|---|
| 21 | ; VAL = internal value of prov function
|
|---|
| 22 | ;
|
|---|
| 23 | ; OTHER(9) valid on institutional (UB-04) bills
|
|---|
| 24 | ; REFERRING(1) valid only on professional (1500) claims
|
|---|
| 25 | ; Valid functions by bill types
|
|---|
| 26 | ; OUTPATIENT/UB-04: ATTENDING(4), OPERATING(2)-BILL TYPE 83X
|
|---|
| 27 | ; AND A PRIN. PROC EXISTS
|
|---|
| 28 | ; INPATIENT/UB-04 : ATTENDING(4), OPERATING(2)-BILL TYPE 11X
|
|---|
| 29 | ; AND A PRIN. PROC EXISTS
|
|---|
| 30 | ; OUTPATIENT/CMS-1500 : RENDERING(3), SUPERVISING(5)
|
|---|
| 31 | ; INPATIENT/CMS-1500 : RENDERING(3), SUPERVISING(5)
|
|---|
| 32 | ;
|
|---|
| 33 | N OK,IBUB
|
|---|
| 34 | S VAL=$$UP^XLFSTR(VAL)
|
|---|
| 35 | S OK=$S(VAL'="":1,1:0)
|
|---|
| 36 | G:'OK!'$G(IBIFN) PRVQ
|
|---|
| 37 | ;
|
|---|
| 38 | S IBUB=($$FT^IBCEF(IBIFN)=3) ; 1 if UB-04 ; 0 if CMS-1500
|
|---|
| 39 | ;
|
|---|
| 40 | I VAL=1 S:IBUB OK=0 G PRVQ
|
|---|
| 41 | ;
|
|---|
| 42 | I "249"[VAL,'IBUB S OK=0 G PRVQ
|
|---|
| 43 | I $S(VAL=3:1,1:VAL=5),IBUB S OK=0 G PRVQ
|
|---|
| 44 | ;
|
|---|
| 45 | PRVQ Q OK
|
|---|
| 46 | ;
|
|---|
| 47 | PRVOK1(VAL,IBIFN) ; Check for both attending and rendering on bill
|
|---|
| 48 | N OK
|
|---|
| 49 | S OK=1
|
|---|
| 50 | I $S("34"'[VAL:0,1:$D(^DGCR(399,IBIFN,"PRV","B",$S(VAL=3:4,1:3)))) D EN^DDIOL($S(VAL=3:"ATTENDING",1:"RENDERING")_" ALREADY EXISTS - CAN'T HAVE BOTH ON ONE BILL") S OK=0
|
|---|
| 51 | Q OK
|
|---|
| 52 | ;
|
|---|
| 53 | SPEC(IBPRV,IBDT) ; Returns spec code for vp ien IBPRV from file 355.9
|
|---|
| 54 | ; (for new person entries, as of date in IBDT)
|
|---|
| 55 | ; DBIA 1625
|
|---|
| 56 | N IBSPEC
|
|---|
| 57 | S:'$G(IBDT) IBDT=DT
|
|---|
| 58 | I IBPRV'["IBA(355.93" S IBSPEC=$S(IBPRV:$P($$GET^XUA4A72(+IBPRV,IBDT),U,8),1:"") ; VA
|
|---|
| 59 | I IBPRV["IBA(355.93" S IBSPEC=$P($G(^IBA(355.93,+IBPRV,0)),U,4) ; Non-VA
|
|---|
| 60 | Q IBSPEC
|
|---|
| 61 | ;
|
|---|
| 62 | CRED(IBPRV,IBIFN,IBPIEN,IBTYP) ; Returns prov credentials
|
|---|
| 63 | ; IBPRV = vp of provider for file 200 or 355.93
|
|---|
| 64 | ; IBIFN = bill ien in file 399 (optional)
|
|---|
| 65 | ; IBPIEN = prov ien - file 399.0222 (optional)
|
|---|
| 66 | ; IBTYP = the prov type
|
|---|
| 67 | ;
|
|---|
| 68 | N IBCRED
|
|---|
| 69 | S IBCRED=""
|
|---|
| 70 | I $G(IBIFN),'$D(^DGCR(399,IBIFN,"PRV",0)) G CREDQ
|
|---|
| 71 | I $G(IBIFN),($G(IBPIEN)!$G(IBTYP)) D
|
|---|
| 72 | . I '$G(IBPIEN) S IBPIEN=+$O(^DGCR(399,IBIFN,"PRV","B",IBTYP,0))
|
|---|
| 73 | . S IBCRED=$P($G(^DGCR(399,IBIFN,"PRV",IBPIEN,0)),U,3)
|
|---|
| 74 | I $G(IBPRV),IBCRED="" D
|
|---|
| 75 | . I IBPRV'["IBA(355.93" S IBCRED=$P($$ESBLOCK^XUSESIG1(+IBPRV),U,2)
|
|---|
| 76 | . I IBPRV["IBA(355.93" S IBCRED=$P($G(^IBA(355.93,+IBPRV,0)),U,3)
|
|---|
| 77 | CREDQ Q IBCRED
|
|---|
| 78 | ;
|
|---|
| 79 | GETPRV(IBIFN,IBTYP,IBPRV) ; Returns prov(s) of type(s) IBTYP for
|
|---|
| 80 | ; bill ien IBIFN.
|
|---|
| 81 | ; IBTYP = prov types needed, separated by ',' or ALL
|
|---|
| 82 | ;
|
|---|
| 83 | ; OUTPUT:
|
|---|
| 84 | ; IBPRV array: IBPRV(type)= 1 if prov is from old prov flds
|
|---|
| 85 | ; IBPRV(type,ct)=name^current COB id^vp provider ien^cred
|
|---|
| 86 | ; IBPRV(type,ct,seq)=COB seq specific id
|
|---|
| 87 | ; IBPRV(type)=default nm^def id
|
|---|
| 88 | ; IBPRV(type,"NOTOPT")= defined if a required prov type
|
|---|
| 89 | ;
|
|---|
| 90 | N IB,IBCT,IBD,IBY,IBZ,IBMRAND,IBID,IBWNR,IBPNM,Z ;,IBZFID
|
|---|
| 91 | ;S IBZFID=""
|
|---|
| 92 | D F^IBCEF("N-CURRENT INS POLICY TYPE","IBZ",,IBIFN)
|
|---|
| 93 | ;I IBZ="CI" D F^IBCEF("N-FEDERAL TAX ID","IBZFID",,IBIFN) S IBZFID=$TR(IBZFID,"-")
|
|---|
| 94 | S IBPRV=U_$G(IBZ),IBY=0
|
|---|
| 95 | S IBMRAND=$$MCRONBIL^IBEFUNC(IBIFN)
|
|---|
| 96 | I IBMRAND D
|
|---|
| 97 | . F Z=1:1:3,5,6,7,8,9 S:Z=3&($$FT^IBCEF(IBIFN)=3) Z=4 S IBPRV(Z)=$S(Z=3!(Z=4):"DEPT VETERANS AFFAIRS",1:"")_"^VAD000"
|
|---|
| 98 | . I '$$INPAT^IBCEF(IBIFN,1),$$FT^IBCEF(IBIFN)=3 S IBPRV(4,1)="^SLF000"
|
|---|
| 99 | ;
|
|---|
| 100 | I '$D(^DGCR(399,+IBIFN,"PRV",0)) D G GETQ
|
|---|
| 101 | . N IBALL
|
|---|
| 102 | . S IBALL=(IBTYP="ALL")
|
|---|
| 103 | . I IBTYP[4!IBALL S:$P($G(^DGCR(399,+IBIFN,"U1")),U,13)'="" IBPRV(4,1)=$P(^("U1"),U,13),IBPRV(4)=1 Q:IBTYP=4
|
|---|
| 104 | . I IBTYP[3!IBALL S:$P($G(^DGCR(399,+IBIFN,"UF2")),U)'="" IBPRV(3,1)=$P(^("UF2"),U),IBPRV(3)=1 Q:IBTYP=3
|
|---|
| 105 | . I IBTYP[9!IBALL S:$P($G(^DGCR(399,+IBIFN,"U1")),U,14)'="" IBPRV(9,1)=$P(^("U1"),U,14),IBPRV(9)=1
|
|---|
| 106 | ;
|
|---|
| 107 | S IBID=4+$$COBN^IBCEF(IBIFN),IBWNR=$$WNRBILL^IBEFUNC(IBIFN)
|
|---|
| 108 | F IBZ=1:1:$S(IBTYP="ALL":99,1:$L(IBTYP,",")) S (IBCT,IB)=0,IBY=$S(IBTYP'="ALL":$P(IBTYP,",",IBZ),1:$O(^DGCR(399,+IBIFN,"PRV","B",IBY))) Q:IBY="" F S IB=$O(^DGCR(399,+IBIFN,"PRV","B",IBY,IB)) Q:'IB D
|
|---|
| 109 | . S IBCT=IBCT+1
|
|---|
| 110 | . S IBD=$G(^DGCR(399,+IBIFN,"PRV",IB,0))
|
|---|
| 111 | . Q:'$P(IBD,U,2)
|
|---|
| 112 | . S IBPNM=$$EXPAND^IBTRE(399.0222,.02,$P(IBD,U,2))
|
|---|
| 113 | . I IBWNR Q:'$D(IBPRV(IBY)) S $P(IBD,U,IBID)=$P(IBPRV(IBY),U,2)
|
|---|
| 114 | . S IBPRV(IBY,IBCT)=IBPNM_U_$S($P(IBD,U,IBID)'="":$P(IBD,U,IBID),$P($G(IBPRV(IBY)),U,2)'="":$P(IBPRV(IBY),U,2),1:$P($$DEFID^IBCEF74(IBIFN,IB),U,IBID-4))_U_$P(IBD,U,2)
|
|---|
| 115 | . S $P(IBPRV(IBY,IBCT),U,4)=$$CRED($P(IBPRV(IBY,IBCT),U,3),IBIFN,$S($P(IBD,U,3)'=""!'$P(IBPRV(IBY,IBCT),U,3):IB,1:""))
|
|---|
| 116 | . F Z=1:1:3 D
|
|---|
| 117 | .. ;I IBZFID'="",'$$INPAT^IBCEF(IBIFN,1),$P(IBPRV(IBY,IBCT),U,2)="SLF000" S IBZFID=""
|
|---|
| 118 | .. ;I $S(Z=1:1,1:$D(^DGCR(399,IBIFN,"I"_Z))) S IBPRV(IBY,IBCT,Z)=$S($G(IBZFID)'="":IBZFID,$P(IBD,U,Z+4)'="":$P(IBD,U,Z+4),1:"")
|
|---|
| 119 | .. I $S(Z=1:1,1:$D(^DGCR(399,IBIFN,"I"_Z))) S IBPRV(IBY,IBCT,Z)=$S($P(IBD,U,Z+4)'="":$P(IBD,U,Z+4),1:$P($$DEFID^IBCEF74(IBIFN,IB),U,Z))
|
|---|
| 120 | GETQ D NEEDPRV(IBIFN,IBTYP,.IBPRV)
|
|---|
| 121 | Q
|
|---|
| 122 | ;
|
|---|
| 123 | NEEDPRV(IBIFN,IBTYP,IBPRV) ; Check for needed prov
|
|---|
| 124 | ; If needed, not entered, insert defaults for MCR only
|
|---|
| 125 | N IB0,IBINP,IBFT,IBMRAND,IBTOB
|
|---|
| 126 | S IB0=$G(^DGCR(399,+IBIFN,0))
|
|---|
| 127 | S IBFT=($$FT^IBCEF(IBIFN)=3),IBINP=$$INPAT^IBCEF(IBIFN,1),IBTOB=$$TOB^IBCBB(IB0)
|
|---|
| 128 | ; Only allow defaults for MCR
|
|---|
| 129 | S IBMRAND=$$WNRBILL^IBEFUNC(IBIFN) ;$$MCRONBIL^IBEFUNC(IBIFN)
|
|---|
| 130 | ;
|
|---|
| 131 | I IBTYP="ALL"!((IBTYP_",")["2,") D:IBFT
|
|---|
| 132 | . ; only for bill type inpt - 11X, outpt - 83X
|
|---|
| 133 | . Q:$S(IBINP:$E(IBTOB,1,2)'="11",1:$E(IBTOB,1,2)'="83")
|
|---|
| 134 | . ; UB-04 bill includes HCPCS procs - operating phys required
|
|---|
| 135 | . N Z
|
|---|
| 136 | . S Z=0 F S Z=$O(^DGCR(399,IBIFN,"CP",Z)) Q:'Z I $P($G(^(Z,0)),U)["ICP" D Q
|
|---|
| 137 | .. S IBPRV(2,"NOTOPT")=1
|
|---|
| 138 | .. Q:'IBMRAND
|
|---|
| 139 | .. I '$O(IBPRV(2,0)) S IBPRV(2,"REQ")=1,IBPRV(2,1)=$G(IBPRV(2))
|
|---|
| 140 | ;
|
|---|
| 141 | I IBTYP="ALL"!((IBTYP_",")["3,") D:'IBFT
|
|---|
| 142 | . ; if a CMS-1500 bill, rendering is required
|
|---|
| 143 | . S IBPRV(3,"NOTOPT")=1
|
|---|
| 144 | . Q:'IBMRAND
|
|---|
| 145 | . I '$O(IBPRV(3,0)) S IBPRV(3,1)=$G(IBPRV(3)),IBPRV(3,"REQ")=1
|
|---|
| 146 | ;
|
|---|
| 147 | I IBTYP="ALL"!((IBTYP_",")["4,") D:IBFT
|
|---|
| 148 | . ; if a UB-04, attending required
|
|---|
| 149 | . S IBPRV(4,"NOTOPT")=1
|
|---|
| 150 | . Q:'IBMRAND
|
|---|
| 151 | . I '$O(IBPRV(4,0)) S IBPRV(4,1)=$G(IBPRV(4)),IBPRV(4,"REQ")=1
|
|---|
| 152 | Q
|
|---|
| 153 | ;
|
|---|
| 154 | CKPROV(IBIFN,IBTYP,IBVAL) ; Checks if prov of type IBTYP in 'PRV' node
|
|---|
| 155 | ; of bill IBIFN
|
|---|
| 156 | ; If IBVAL = 1, skips the check for an existing provider, just looks
|
|---|
| 157 | ; for existence of the function itself
|
|---|
| 158 | N OK,IBFT,Z,R
|
|---|
| 159 | S OK=0,IBFT=$$FT^IBCEF(IBIFN)
|
|---|
| 160 | S Z=+$O(^DGCR(399,IBIFN,"PRV","B",+IBTYP,0))
|
|---|
| 161 | I $G(^DGCR(399,IBIFN,"PRV",Z,0))'="" D
|
|---|
| 162 | . ; Only outpt UB-04 can have SLF000 as prov ID with no name
|
|---|
| 163 | . I IBFT=3,'$$INPAT^IBCEF(IBIFN,1),$P(^DGCR(399,IBIFN,"PRV",Z,0),U,2)="",$P(^(0),U,5)="SLF000" S OK=1 Q
|
|---|
| 164 | . I '$G(IBVAL) Q:$P(^DGCR(399,IBIFN,"PRV",Z,0),U,2)=""
|
|---|
| 165 | . S OK=1
|
|---|
| 166 | Q OK
|
|---|
| 167 | ;
|
|---|
| 168 | XFER(IBQ) ; Transfer DILIST
|
|---|
| 169 | ; IBQ = # of entries already found
|
|---|
| 170 | N Z,IBZ
|
|---|
| 171 | S (Z,IBZ)=0
|
|---|
| 172 | F S Z=$O(^TMP("DILIST",$J,1,Z)) Q:'Z S IBZ=IBZ+1,^TMP("IBLIST",$J,1,IBZ+IBQ)=^TMP("DILIST",$J,1,Z),^TMP("IBLIST",$J,2,IBZ+IBQ)=^TMP("DILIST",$J,2,Z) M ^TMP("IBLIST",$J,"ID",IBZ+IBQ)=^TMP("DILIST",$J,"ID",Z)
|
|---|
| 173 | ;
|
|---|
| 174 | I $D(^TMP("DILIST",$J,0)) S ^TMP("IBLIST",$J,0)=^TMP("DILIST",$J,0)
|
|---|
| 175 | S $P(^TMP("IBLIST",$J,0),U)=IBQ+IBZ
|
|---|
| 176 | Q
|
|---|
| 177 | ;
|
|---|
| 178 | DATE(X) ; Convert date X in YYYYMMDD or YYMMDD to FM format
|
|---|
| 179 | ; FP = flag to indicate if past or future dates are expected
|
|---|
| 180 | N %DT,Y
|
|---|
| 181 | I $L(X)=8,$E(X,1,4)<2100,$E(X,5,6)<13,$E(X,7,8)<32 S X=$E(X,1,4)-1700_$E(X,5,8) G DTQ
|
|---|
| 182 | I $L(X)=6,$E(X,3,4)<13,$E(X,5,6)<32 S X=$E(X,3,4)_"/"_$E(X,5,6)_"/"_$E(X,1,2),%DT="N" D ^%DT I Y>0 S X=Y
|
|---|
| 183 | DTQ Q X
|
|---|
| 184 | ;
|
|---|
| 185 | BCLASS(IBIFN) ; Returns actual bill classif. code from ptr fld
|
|---|
| 186 | ; .25 in file 399 for bill ien IBIFN
|
|---|
| 187 | Q $P($G(^DGCR(399.1,+$P($G(^DGCR(399,IBIFN,0)),U,25),0)),U,2)
|
|---|
| 188 | ;
|
|---|
| 189 | ADMHR(IBIFN,IBDTTM) ; Extract admit hr from admit dt/tm
|
|---|
| 190 | ; Default 00 if no time and bill is 11X or 18X
|
|---|
| 191 | N TM
|
|---|
| 192 | S TM=$P(IBDTTM,".",2)
|
|---|
| 193 | I TM="","18"[$$BCLASS(IBIFN),$P($G(^DGCR(399,IBIFN,0)),U,24)=1 S TM="00"
|
|---|
| 194 | I TM'="",TM'="00" S TM=$E(TM_"0000",1,4)
|
|---|
| 195 | Q TM
|
|---|
| 196 | ;
|
|---|
| 197 | OLAB(IBIFN) ; Returns 1 if bill IBIFN is outside lab
|
|---|
| 198 | N IBL,IBLAB
|
|---|
| 199 | S IBL=0
|
|---|
| 200 | S IBLAB=$P($G(^DGCR(399,IBIFN,"U2")),U,11)
|
|---|
| 201 | I IBLAB,"24"[IBLAB S IBL=1
|
|---|
| 202 | Q IBL
|
|---|
| 203 | ;
|
|---|
| 204 | PSRV(IBIFN) ; Returns 1 if bill IBIFN has any purch services
|
|---|
| 205 | N IBZ,IBXDATA,IBXSAVE,Z
|
|---|
| 206 | S IBZ=0
|
|---|
| 207 | D F^IBCEF("N-HCFA 1500 PROCEDURES",,,IBIFN)
|
|---|
| 208 | S Z=0 F S Z=$O(IBXSAVE("BOX24",Z)) Q:'Z I $P(IBXSAVE("BOX24",Z),U,11) S IBZ=1 Q
|
|---|
| 209 | Q IBZ
|
|---|
| 210 | ;
|
|---|
| 211 | SEQBILL(IBIFN) ; Returns the ien's of all bills in COB sequence for bill IBIFN
|
|---|
| 212 | ; Return value is "^" delimited: primary ien^secondary ien^tertiary ien
|
|---|
| 213 | N IBSEQ,Z
|
|---|
| 214 | S IBSEQ=$P($G(^DGCR(399,IBIFN,"M1")),U,5,7)
|
|---|
| 215 | S Z=$$COBN^IBCEF(IBIFN)
|
|---|
| 216 | I $P(IBSEQ,U,Z)="" S $P(IBSEQ,U,Z)=IBIFN
|
|---|
| 217 | Q IBSEQ
|
|---|
| 218 | ;
|
|---|
