source: WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCCPT1.m@ 767

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

initial load of WorldVistAEHR

File size: 2.4 KB
Line 
1IBCCPT1 ;OAK/ELZ - MCCR OUTPATIENT VISITS LISTING CONT.(2) ;30-JUL-2003
2 ;;2.0;INTEGRATED BILLING;**260**;21-MAR-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5 ;
6NBOEP(IBOEO,IBBCPT,IBDXDAT) ; returnes if a procedure is billable
7 ;
8 N IBRMARK,IBPCEX,IBARR,IBP,IBDX,IBL,IBT,IBVST800,IBCPT800,IBDX800,DFN,IBDT,IBCPT
9 S IBRMARK="",IBPCEX=$P(IBOEO,"^",5)
10 S DFN=$P(IBOEO,"^",2),IBDT=IBOEO/1
11 ;
12 ; look up classification info needed (if any)
13 D CL^SDCO21(DFN,IBDT,"",.IBARR) ;I '$D(IBARR) G NBOEPQ
14 ;
15 ; look up PCE info
16 D ENCEVENT^PXKENC(IBPCEX)
17 S IBVST800=$G(^TMP("PXKENC",$J,IBPCEX,"VST",IBPCEX,800))
18 ;
19 ; do comparison to find dx to cpt relations
20 S IBCPT=0 F S IBCPT=$O(^TMP("PXKENC",$J,IBPCEX,"CPT",IBCPT)) Q:IBCPT<1 S IBDX=0 I IBBCPT=+^(IBCPT,0) F S IBDX=$O(^TMP("PXKENC",$J,IBPCEX,"POV",IBDX)) Q:IBDX<1 D
21 . F IBP=5,9,10,11 Q:'$D(^TMP("PXKENC",$J,IBPCEX,"CPT",IBCPT,0)) I $P(^TMP("PXKENC",$J,IBPCEX,"CPT",IBCPT,0),"^",IBP)=+$G(^TMP("PXKENC",$J,IBPCEX,"POV",IBDX,0)) D
22 .. S IBDXDAT=$G(IBDXDAT)_+$G(^TMP("PXKENC",$J,IBPCEX,"POV",IBDX,0))_"^"
23 .. S IBDX800=$G(^TMP("PXKENC",$J,IBPCEX,"POV",IBDX,800))
24 .. S IBCPT800=$G(^TMP("PXKENC",$J,IBPCEX,"CPT",IBCPT,800))
25 .. ;
26 .. ; is classification filled in as true on dx level?
27 .. F IBL=2:1 S IBT=$P($T(CLDATA+IBL^IBTRKR41),";",3) Q:IBT="" I $D(IBARR(+IBT)),$P(IBDX800,"^",$P(IBT,"^",2)) S IBRMARK=$P(IBT,"^",3) Q
28 .. ;
29 .. ; if no cl filled in for dx, then check cpt level for true
30 .. I $D(^TMP("PXKENC",$J,IBPCEX,"CPT",IBCPT,0)) F IBL=2:1 S IBT=$P($T(CLDATA+IBL^IBTRKR41),";",3) Q:IBT="" I $D(IBARR(+IBT)),$P(IBDX800,"^",$P(IBT,"^",2))="",$P(IBCPT800,"^",$P(IBT,"^",2)) S IBRMARK=$P(IBT,"^",3) Q
31 .. ;
32 .. ; if no cl for dx or cpt, use visit level
33 .. I $D(^TMP("PXKENC",$J,IBPCEX,"CPT",IBCPT,0)) F IBL=2:1 S IBT=$P($T(CLDATA+IBL^IBTRKR41),";",3) Q:IBT="" D
34 ... I $D(IBARR(+IBT)),$P(IBDX800,"^",$P(IBT,"^",2))="",$P(IBCPT800,"^",$P(IBT,"^",2))="",$P(IBVST800,"^",$P(IBT,"^",2)) S IBRMARK=$P(IBT,"^",3) Q
35 ;
36 ;
37NBOEPQ K ^TMP("PXKENC",$J)
38 Q IBRMARK
39 ;
40ADDDX(IBIFN,IBPROCP,IBDX,IBDR) ; file assoc dx, add to DR string for bill
41 N DIC,X,Y,DLAYGO,IBP,IBDXDA,DD,DO
42 F IBP=1:1:4 S X=$P(IBDX,"^",IBP) D:X
43 . S IBDXDA=$O(^IBA(362.3,"AIFN"_IBIFN,X,0)) I IBDXDA S IBDR=$G(IBDR)_$S($L($G(IBDR)):";",1:"")_(IBP+9)_"////"_IBDXDA Q
44 . S DIC("DR")=".02////"_IBIFN,DIC="^IBA(362.3,",DIC(0)="L",DLAYGO=362.3 K DD,DO D FILE^DICN I Y>0 S IBDR=$G(IBDR)_$S($L($G(IBDR)):";",1:"")_(IBP+9)_"////"_(+Y)
45 Q
Note: See TracBrowser for help on using the repository browser.