source: FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEU.m@ 1800

Last change on this file since 1800 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version
File size: 8.6 KB
Line 
1IBCEU ;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 ;
7TESTPT(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 ;
11MAINPRV(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 ;
20PRVOK(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 ;
45PRVQ Q OK
46 ;
47PRVOK1(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 ;
53SPEC(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 ;
62CRED(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)
77CREDQ Q IBCRED
78 ;
79GETPRV(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))
120GETQ D NEEDPRV(IBIFN,IBTYP,.IBPRV)
121 Q
122 ;
123NEEDPRV(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 ;
154CKPROV(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 ;
168XFER(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 ;
178DATE(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
183DTQ Q X
184 ;
185BCLASS(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 ;
189ADMHR(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 ;
197OLAB(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 ;
204PSRV(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 ;
211SEQBILL(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 ;
Note: See TracBrowser for help on using the repository browser.