IBCCPT1 ;OAK/ELZ - MCCR OUTPATIENT VISITS LISTING CONT.(2) ;30-JUL-2003
;;2.0;INTEGRATED BILLING;**260,740**;21-MAR-94;Build 9
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
;
NBOEP(IBOEO,IBBCPT,IBDXDAT) ; returnes if a procedure is billable
;
N IBRMARK,IBPCEX,IBARR,IBP,IBDX,IBL,IBT,IBVST800,IBCPT800,IBDX800,DFN,IBDT,IBCPT
S IBRMARK="",IBPCEX=$P(IBOEO,"^",5)
S DFN=$P(IBOEO,"^",2),IBDT=IBOEO/1
;
; look up classification info needed (if any)
D CL^SDCO21(DFN,IBDT,"",.IBARR) ;I '$D(IBARR) G NBOEPQ
;
; look up PCE info
D ENCEVENT^PXKENC(IBPCEX)
I IBPCEX="" S IBRMARK="" G NBOEPQ ;RTW IB*2.0*740
S IBVST800=$G(^TMP("PXKENC",$J,IBPCEX,"VST",IBPCEX,800))
;
; do comparison to find dx to cpt relations
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
. 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
.. S IBDXDAT=$G(IBDXDAT)_+$G(^TMP("PXKENC",$J,IBPCEX,"POV",IBDX,0))_"^"
.. S IBDX800=$G(^TMP("PXKENC",$J,IBPCEX,"POV",IBDX,800))
.. S IBCPT800=$G(^TMP("PXKENC",$J,IBPCEX,"CPT",IBCPT,800))
.. ;
.. ; is classification filled in as true on dx level?
.. 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
.. ;
.. ; if no cl filled in for dx, then check cpt level for true
.. 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
.. ;
.. ; if no cl for dx or cpt, use visit level
.. I $D(^TMP("PXKENC",$J,IBPCEX,"CPT",IBCPT,0)) F IBL=2:1 S IBT=$P($T(CLDATA+IBL^IBTRKR41),";",3) Q:IBT="" D
... 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
;
;
NBOEPQ K ^TMP("PXKENC",$J)
Q IBRMARK
;
ADDDX(IBIFN,IBPROCP,IBDX,IBDR) ; file assoc dx, add to DR string for bill
N DIC,X,Y,DLAYGO,IBP,IBDXDA,DD,DO
F IBP=1:1:4 S X=$P(IBDX,"^",IBP) D:X
. 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
. 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)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCCPT1 2583 printed Apr 09, 2024@21:36:03 Page 2
IBCCPT1 ;OAK/ELZ - MCCR OUTPATIENT VISITS LISTING CONT.(2) ;30-JUL-2003
+1 ;;2.0;INTEGRATED BILLING;**260,740**;21-MAR-94;Build 9
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
+4 ;
NBOEP(IBOEO,IBBCPT,IBDXDAT) ; returnes if a procedure is billable
+1 ;
+2 NEW IBRMARK,IBPCEX,IBARR,IBP,IBDX,IBL,IBT,IBVST800,IBCPT800,IBDX800,DFN,IBDT,IBCPT
+3 SET IBRMARK=""
SET IBPCEX=$PIECE(IBOEO,"^",5)
+4 SET DFN=$PIECE(IBOEO,"^",2)
SET IBDT=IBOEO/1
+5 ;
+6 ; look up classification info needed (if any)
+7 ;I '$D(IBARR) G NBOEPQ
DO CL^SDCO21(DFN,IBDT,"",.IBARR)
+8 ;
+9 ; look up PCE info
+10 DO ENCEVENT^PXKENC(IBPCEX)
+11 ;RTW IB*2.0*740
IF IBPCEX=""
SET IBRMARK=""
GOTO NBOEPQ
+12 SET IBVST800=$GET(^TMP("PXKENC",$JOB,IBPCEX,"VST",IBPCEX,800))
+13 ;
+14 ; do comparison to find dx to cpt relations
+15 SET IBCPT=0
FOR
SET IBCPT=$ORDER(^TMP("PXKENC",$JOB,IBPCEX,"CPT",IBCPT))
if IBCPT<1
QUIT
SET IBDX=0
IF IBBCPT=+^(IBCPT,0)
FOR
SET IBDX=$ORDER(^TMP("PXKENC",$JOB,IBPCEX,"POV",IBDX))
if IBDX<1
QUIT
Begin DoDot:1
+16 FOR IBP=5,9,10,11
if '$DATA(^TMP("PXKENC",$JOB,IBPCEX,"CPT",IBCPT,0))
QUIT
IF $PIECE(^TMP("PXKENC",$JOB,IBPCEX,"CPT",IBCPT,0),"^",IBP)=+$GET(^TMP("PXKENC",$JOB,IBPCEX,"POV",IBDX,0))
Begin DoDot:2
+17 SET IBDXDAT=$GET(IBDXDAT)_+$GET(^TMP("PXKENC",$JOB,IBPCEX,"POV",IBDX,0))_"^"
+18 SET IBDX800=$GET(^TMP("PXKENC",$JOB,IBPCEX,"POV",IBDX,800))
+19 SET IBCPT800=$GET(^TMP("PXKENC",$JOB,IBPCEX,"CPT",IBCPT,800))
+20 ;
+21 ; is classification filled in as true on dx level?
+22 FOR IBL=2:1
SET IBT=$PIECE($TEXT(CLDATA+IBL^IBTRKR41),";",3)
if IBT=""
QUIT
IF $DATA(IBARR(+IBT))
IF $PIECE(IBDX800,"^",$PIECE(IBT,"^",2))
SET IBRMARK=$PIECE(IBT,"^",3)
QUIT
+23 ;
+24 ; if no cl filled in for dx, then check cpt level for true
+25 IF $DATA(^TMP("PXKENC",$JOB,IBPCEX,"CPT",IBCPT,0))
FOR IBL=2:1
SET IBT=$PIECE($TEXT(CLDATA+IBL^IBTRKR41),";",3)
if IBT=""
QUIT
IF $DATA(IBARR(+IBT))
IF $PIECE(IBDX800,"^",$PIECE(IBT,"^",2))=""
IF $PIECE(IBCPT800,"^",$PIECE(IBT,"^",2))
SET IBRMARK=$PIECE(IBT,"^",3)
QUIT
+26 ;
+27 ; if no cl for dx or cpt, use visit level
+28 IF $DATA(^TMP("PXKENC",$JOB,IBPCEX,"CPT",IBCPT,0))
FOR IBL=2:1
SET IBT=$PIECE($TEXT(CLDATA+IBL^IBTRKR41),";",3)
if IBT=""
QUIT
Begin DoDot:3
+29 IF $DATA(IBARR(+IBT))
IF $PIECE(IBDX800,"^",$PIECE(IBT,"^",2))=""
IF $PIECE(IBCPT800,"^",$PIECE(IBT,"^",2))=""
IF $PIECE(IBVST800,"^",$PIECE(IBT,"^",2))
SET IBRMARK=$PIECE(IBT,"^",3)
QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+30 ;
+31 ;
NBOEPQ KILL ^TMP("PXKENC",$JOB)
+1 QUIT IBRMARK
+2 ;
ADDDX(IBIFN,IBPROCP,IBDX,IBDR) ; file assoc dx, add to DR string for bill
+1 NEW DIC,X,Y,DLAYGO,IBP,IBDXDA,DD,DO
+2 FOR IBP=1:1:4
SET X=$PIECE(IBDX,"^",IBP)
if X
Begin DoDot:1
+3 SET IBDXDA=$ORDER(^IBA(362.3,"AIFN"_IBIFN,X,0))
IF IBDXDA
SET IBDR=$GET(IBDR)_$SELECT($LENGTH($GET(IBDR)):";",1:"")_(IBP+9)_"////"_IBDXDA
QUIT
+4 SET DIC("DR")=".02////"_IBIFN
SET DIC="^IBA(362.3,"
SET DIC(0)="L"
SET DLAYGO=362.3
KILL DD,DO
DO FILE^DICN
IF Y>0
SET IBDR=$GET(IBDR)_$SELECT($LENGTH($GET(IBDR)):";",1:"")_(IBP+9)_"////"_(+Y)
End DoDot:1
+5 QUIT
