IBCRLM ;ALB/ARH - RATES: DISPLAY REVENUE CODE LINKS ; 10-OCT-1998
;;2.0;INTEGRATED BILLING;**106**;21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
EN ; -- main entry point for IBCR REVENUE CODE LINK
D EN^VALM("IBCR REVENUE CODE LINK")
Q
;
HDR ; -- header code
I +$G(IBCPT) S VALMHDR(1)="Revenue Codes linked to "_$P($$CPT^ICPTCOD(+IBCPT),U,2)
I +$G(IBCPT) S VALMSG="* revenue code used on a bill for "_$P($$CPT^ICPTCOD(+IBCPT),U,2)
Q
;
INIT ; -- init variables and list array
K ^TMP("IBCRLM",$J)
I '$G(IBCPT) S IBCPT=$$GETCPT^IBCRU1("",1) I IBCPT'>0 S VALMQUIT="" Q
D BLD
Q
;
HELP ; -- help code
S X="?" D DISP^XQORM1 W !!
Q
;
EXIT ; -- exit code
K ^TMP("IBCRLM",$J) D CLEAR^VALM1,CLEAN^VALM10
Q
;
BLD ; build charge set display array
N IBRLFN,IBCPT1,IBRL0,IBLABEL,IBBRFN,IBCSFN,IBX,IBY,RVCPTARR,BRCSARR S VALMCNT=0
;
D FNDSRT(+$G(IBCPT),.RVCPTARR,.BRCSARR)
;
; create LM display array
S IBCPT1="" F S IBCPT1=$O(RVCPTARR(IBCPT1)) Q:IBCPT1="" D
. S IBRLFN="" F S IBRLFN=$O(RVCPTARR(IBCPT1,IBRLFN)) Q:IBRLFN="" D
.. ;
.. S IBY="",IBRL0=$G(^IBE(363.33,+IBRLFN,0)) Q:IBRL0=""
.. ;
.. I $D(BRCSARR(IBRLFN)) S IBX="*",IBY=$$SETFLD^VALM1(IBX,IBY,"USED")
.. S IBX=$P($$CPT^ICPTCOD(+$P(IBRL0,U,3)),U,2),IBY=$$SETFLD^VALM1(IBX,IBY,"PRC1")
.. I +$P(IBRL0,U,4) S IBX=$P($$CPT^ICPTCOD(+$P(IBRL0,U,4)),U,2),IBY=$$SETFLD^VALM1(IBX,IBY,"PRC2")
.. S IBX=$P($G(^DGCR(399.2,+$P(IBRL0,U,1),0)),U,1),IBY=$$SETFLD^VALM1(IBX,IBY,"RVCD")
.. S IBX=$P($G(^DGCR(399.2,+$P(IBRL0,U,1),0)),U,2),IBY=$$SETFLD^VALM1(IBX,IBY,"RVDS")
.. S IBX=$P($G(^IBE(363.32,+$P(IBRL0,U,2),0)),U,1),IBY=$$SETFLD^VALM1(IBX,IBY,"SGRP")
.. D SET(IBY) S IBY=""
.. ;
.. S IBLABEL="applied to bills for:"
.. S IBBRFN=0 F S IBBRFN=$O(BRCSARR(IBRLFN,IBBRFN)) Q:'IBBRFN D
... S IBCSFN="" F S IBCSFN=$O(BRCSARR(IBRLFN,IBBRFN,IBCSFN)) Q:IBCSFN="" D Q:'IBCSFN
.... S IBX=IBLABEL,IBY=$$SETFLD^VALM1(IBX,IBY,"RVDS"),IBLABEL=""
.... I +IBCSFN S IBX=$P($G(^IBE(363.1,+IBCSFN,0)),U,1),IBY=$$SETFLD^VALM1(IBX,IBY,"SGRP")
.... I 'IBCSFN S IBX=$P($G(^IBE(363.3,+IBBRFN,0)),U,1),IBY=$$SETFLD^VALM1(IBX,IBY,"SGRP")
.... D SET(IBY) S IBY=""
.. ;
.. S IBY="" D SET(IBY) S IBY=""
;
I VALMCNT=0 D SET(" "),SET("No Revenue Code links for this CPT.")
Q
;
SET(X) ; set up list manager screen array
S VALMCNT=VALMCNT+1
S ^TMP("IBCRLM",$J,VALMCNT,0)=X
Q
;
FNDSRT(CPT,CPTARR,BRARR) ; find and sort all revenue code links for a CPT
; array of all links for a CPT: CPTARR(procedure 1, ifn of rev link) = special group
; array of links used on bills: BRARR(ifn of rv link, billing rate, charge set) = special group
N IBSGFN,IBSG0,IBRLFN,IBCPT1,IBSGFN1,IBSG10,IBX,RLARR K CPTARR,BRARR Q:'$G(CPT)
;
S IBSGFN=0 F S IBSGFN=$O(^IBE(363.32,IBSGFN)) Q:'IBSGFN D
. S IBSG0=$G(^IBE(363.32,IBSGFN,0)) I $P(IBSG0,U,2)'=1 Q
. ;
. ; find all revenue code links for the CPT
. K RLARR S RLARR=1,IBX=$$GRVLNK^IBCRU6(CPT,IBSGFN,.RLARR) Q:'IBX
. S IBRLFN=0 F S IBRLFN=$O(RLARR(IBRLFN)) Q:'IBRLFN D
.. S IBCPT1=$P($G(^IBE(363.33,IBRLFN,0)),U,3)
.. S CPTARR(IBCPT1,IBRLFN)=IBSGFN
. ;
. ; find the primary link to be used on a bill for the billing rates and charge sets
. S IBSGFN1=0 F S IBSGFN1=$O(^IBE(363.32,IBSGFN,11,IBSGFN1)) Q:'IBSGFN1 D
.. S IBSG10=$G(^IBE(363.32,IBSGFN,11,IBSGFN1,0))
.. S IBRLFN=$$RVLNK^IBCRU6(CPT,+$P(IBSG10,U,1),+$P(IBSG10,U,2))
.. I +IBRLFN S BRARR(+IBRLFN,+$P(IBSG10,U,1),+$P(IBSG10,U,2))=IBSGFN
;
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCRLM 3538 printed Nov 22, 2024@17:29:49 Page 2
IBCRLM ;ALB/ARH - RATES: DISPLAY REVENUE CODE LINKS ; 10-OCT-1998
+1 ;;2.0;INTEGRATED BILLING;**106**;21-MAR-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
EN ; -- main entry point for IBCR REVENUE CODE LINK
+1 DO EN^VALM("IBCR REVENUE CODE LINK")
+2 QUIT
+3 ;
HDR ; -- header code
+1 IF +$GET(IBCPT)
SET VALMHDR(1)="Revenue Codes linked to "_$PIECE($$CPT^ICPTCOD(+IBCPT),U,2)
+2 IF +$GET(IBCPT)
SET VALMSG="* revenue code used on a bill for "_$PIECE($$CPT^ICPTCOD(+IBCPT),U,2)
+3 QUIT
+4 ;
INIT ; -- init variables and list array
+1 KILL ^TMP("IBCRLM",$JOB)
+2 IF '$GET(IBCPT)
SET IBCPT=$$GETCPT^IBCRU1("",1)
IF IBCPT'>0
SET VALMQUIT=""
QUIT
+3 DO BLD
+4 QUIT
+5 ;
HELP ; -- help code
+1 SET X="?"
DO DISP^XQORM1
WRITE !!
+2 QUIT
+3 ;
EXIT ; -- exit code
+1 KILL ^TMP("IBCRLM",$JOB)
DO CLEAR^VALM1
DO CLEAN^VALM10
+2 QUIT
+3 ;
BLD ; build charge set display array
+1 NEW IBRLFN,IBCPT1,IBRL0,IBLABEL,IBBRFN,IBCSFN,IBX,IBY,RVCPTARR,BRCSARR
SET VALMCNT=0
+2 ;
+3 DO FNDSRT(+$GET(IBCPT),.RVCPTARR,.BRCSARR)
+4 ;
+5 ; create LM display array
+6 SET IBCPT1=""
FOR
SET IBCPT1=$ORDER(RVCPTARR(IBCPT1))
if IBCPT1=""
QUIT
Begin DoDot:1
+7 SET IBRLFN=""
FOR
SET IBRLFN=$ORDER(RVCPTARR(IBCPT1,IBRLFN))
if IBRLFN=""
QUIT
Begin DoDot:2
+8 ;
+9 SET IBY=""
SET IBRL0=$GET(^IBE(363.33,+IBRLFN,0))
if IBRL0=""
QUIT
+10 ;
+11 IF $DATA(BRCSARR(IBRLFN))
SET IBX="*"
SET IBY=$$SETFLD^VALM1(IBX,IBY,"USED")
+12 SET IBX=$PIECE($$CPT^ICPTCOD(+$PIECE(IBRL0,U,3)),U,2)
SET IBY=$$SETFLD^VALM1(IBX,IBY,"PRC1")
+13 IF +$PIECE(IBRL0,U,4)
SET IBX=$PIECE($$CPT^ICPTCOD(+$PIECE(IBRL0,U,4)),U,2)
SET IBY=$$SETFLD^VALM1(IBX,IBY,"PRC2")
+14 SET IBX=$PIECE($GET(^DGCR(399.2,+$PIECE(IBRL0,U,1),0)),U,1)
SET IBY=$$SETFLD^VALM1(IBX,IBY,"RVCD")
+15 SET IBX=$PIECE($GET(^DGCR(399.2,+$PIECE(IBRL0,U,1),0)),U,2)
SET IBY=$$SETFLD^VALM1(IBX,IBY,"RVDS")
+16 SET IBX=$PIECE($GET(^IBE(363.32,+$PIECE(IBRL0,U,2),0)),U,1)
SET IBY=$$SETFLD^VALM1(IBX,IBY,"SGRP")
+17 DO SET(IBY)
SET IBY=""
+18 ;
+19 SET IBLABEL="applied to bills for:"
+20 SET IBBRFN=0
FOR
SET IBBRFN=$ORDER(BRCSARR(IBRLFN,IBBRFN))
if 'IBBRFN
QUIT
Begin DoDot:3
+21 SET IBCSFN=""
FOR
SET IBCSFN=$ORDER(BRCSARR(IBRLFN,IBBRFN,IBCSFN))
if IBCSFN=""
QUIT
Begin DoDot:4
+22 SET IBX=IBLABEL
SET IBY=$$SETFLD^VALM1(IBX,IBY,"RVDS")
SET IBLABEL=""
+23 IF +IBCSFN
SET IBX=$PIECE($GET(^IBE(363.1,+IBCSFN,0)),U,1)
SET IBY=$$SETFLD^VALM1(IBX,IBY,"SGRP")
+24 IF 'IBCSFN
SET IBX=$PIECE($GET(^IBE(363.3,+IBBRFN,0)),U,1)
SET IBY=$$SETFLD^VALM1(IBX,IBY,"SGRP")
+25 DO SET(IBY)
SET IBY=""
End DoDot:4
if 'IBCSFN
QUIT
End DoDot:3
+26 ;
+27 SET IBY=""
DO SET(IBY)
SET IBY=""
End DoDot:2
End DoDot:1
+28 ;
+29 IF VALMCNT=0
DO SET(" ")
DO SET("No Revenue Code links for this CPT.")
+30 QUIT
+31 ;
SET(X) ; set up list manager screen array
+1 SET VALMCNT=VALMCNT+1
+2 SET ^TMP("IBCRLM",$JOB,VALMCNT,0)=X
+3 QUIT
+4 ;
FNDSRT(CPT,CPTARR,BRARR) ; find and sort all revenue code links for a CPT
+1 ; array of all links for a CPT: CPTARR(procedure 1, ifn of rev link) = special group
+2 ; array of links used on bills: BRARR(ifn of rv link, billing rate, charge set) = special group
+3 NEW IBSGFN,IBSG0,IBRLFN,IBCPT1,IBSGFN1,IBSG10,IBX,RLARR
KILL CPTARR,BRARR
if '$GET(CPT)
QUIT
+4 ;
+5 SET IBSGFN=0
FOR
SET IBSGFN=$ORDER(^IBE(363.32,IBSGFN))
if 'IBSGFN
QUIT
Begin DoDot:1
+6 SET IBSG0=$GET(^IBE(363.32,IBSGFN,0))
IF $PIECE(IBSG0,U,2)'=1
QUIT
+7 ;
+8 ; find all revenue code links for the CPT
+9 KILL RLARR
SET RLARR=1
SET IBX=$$GRVLNK^IBCRU6(CPT,IBSGFN,.RLARR)
if 'IBX
QUIT
+10 SET IBRLFN=0
FOR
SET IBRLFN=$ORDER(RLARR(IBRLFN))
if 'IBRLFN
QUIT
Begin DoDot:2
+11 SET IBCPT1=$PIECE($GET(^IBE(363.33,IBRLFN,0)),U,3)
+12 SET CPTARR(IBCPT1,IBRLFN)=IBSGFN
End DoDot:2
+13 ;
+14 ; find the primary link to be used on a bill for the billing rates and charge sets
+15 SET IBSGFN1=0
FOR
SET IBSGFN1=$ORDER(^IBE(363.32,IBSGFN,11,IBSGFN1))
if 'IBSGFN1
QUIT
Begin DoDot:2
+16 SET IBSG10=$GET(^IBE(363.32,IBSGFN,11,IBSGFN1,0))
+17 SET IBRLFN=$$RVLNK^IBCRU6(CPT,+$PIECE(IBSG10,U,1),+$PIECE(IBSG10,U,2))
+18 IF +IBRLFN
SET BRARR(+IBRLFN,+$PIECE(IBSG10,U,1),+$PIECE(IBSG10,U,2))=IBSGFN
End DoDot:2
End DoDot:1
+19 ;
+20 QUIT
