IBCRLI ;ALB/ARH - RATES: DISPLAY CHARGE ITEMS ; 16-MAY-1996
;;2.0;INTEGRATED BILLING;**52,106,245**;21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
; if Charge Set/Rates Billable Item is Bedsection then default display is current charge for all items
; all other Charge Sets display all charges for a user selected item
; this is due to unknown number of possible entries, for example a CPT set may have thousands of current charges
;
EN ; -- main entry point for IBCR CHARGE ITEM
D EN^VALM("IBCR CHARGE ITEM")
Q
;
HDR ; -- header code
N IBY,IBX,IBZ,IBI,IBK S IBI=1,(IBX,IBY,IBZ,IBK,VALMHDR(1),VALMHDR(2))=""
;
I +$P(IBCS0,U,5) S IBK="Default Revenue Code: "_$P($G(^DGCR(399.2,+$P(IBCS0,U,5),0)),U,1)
;
S IBZ=IBBRBIN_$S(+IBSRNITM:" ",1:"")_$P(IBSRNITM,U,2)_" items billable to Charge Set "
;
S IBX=$P(IBCS0,U,1) I +$G(IBSRNBDT)!(+$G(IBSRNEDT)) D
. I IBSRNBDT=IBSRNEDT S IBX=$E(IBX,1,28),IBY=" on "_$$DATE(IBSRNBDT) Q
. I 'IBSRNBDT S IBY=" on or before "_$$DATE(IBSRNEDT) Q
. I 'IBSRNEDT S IBY=" on or after "_$$DATE(IBSRNBDT) Q
. I IBSRNBDT'=IBSRNEDT S IBY=" between "_$$DATE(IBSRNBDT)_" and "_$$DATE(IBSRNEDT)
;
S VALMHDR(1)=IBZ_IBX
I ($L(IBZ)+$L(IBX)+$L(IBY))<80 S VALMHDR(1)=VALMHDR(1)_IBY,IBY=""
S VALMHDR(2)=IBK_$J("",(80-($L(IBK)+$L(IBY))))_IBY
Q
;
INIT ; -- init variables and list array IBCSFN required
K ^TMP("IBCRLI",$J)
I '$G(IBCSFN) S IBCSFN=$$GETCS^IBCRU1 I IBCSFN'>0 S VALMQUIT="" Q
I $$GET(IBCSFN)<0 S VALMQUIT="" Q
D BLD
Q
;
HELP ; -- help code
S X="?" D DISP^XQORM1 W !!
Q
;
EXIT ; -- exit code
K ^TMP("IBCRLI",$J),IBCS0,IBBRBI,IBBRBIN,IBSRNITM,IBSRNBDT,IBSRNEDT
D CLEAR^VALM1,CLEAN^VALM10
Q
;
BLD ; build array for display for Charge Item display: charge set required
N IBITEM,IBDT1,IBCIFN,IBLN,IBX,IBY S VALMCNT=0 K ^TMP($J,"IBCRCI")
S IBSRNITM=$G(IBSRNITM),IBSRNBDT=$G(IBSRNBDT),IBSRNEDT=$G(IBSRNEDT)
;
I (IBBRBI=1)!(+IBSRNITM) D SORTCI(IBCSFN,$G(IBSRNITM),$G(IBSRNBDT),$G(IBSRNEDT))
;
; create LM diplay array of charge items
S IBITEM="" F S IBITEM=$O(^TMP($J,"IBCRCI",IBITEM)) Q:IBITEM="" D
. S IBDT1="" F S IBDT1=$O(^TMP($J,"IBCRCI",IBITEM,IBDT1)) Q:IBDT1="" D
.. S IBCIFN=0 F S IBCIFN=$O(^TMP($J,"IBCRCI",IBITEM,IBDT1,IBCIFN)) Q:'IBCIFN D
... ;
... S IBLN=$G(^IBA(363.2,IBCIFN,0)),IBY=""
... S IBX=$$EXPAND^IBCRU1(363.2,.01,$P(IBLN,U,1))
... I +$P(IBLN,U,7) S IBX=IBX_" - "_$$EXPAND^IBCRU1(363.2,.07,+$P(IBLN,U,7))
... S IBY=$$SETFLD^VALM1(IBX,IBY,"ITEM")
... S IBX=$J($P(IBLN,U,5),8,2),IBY=$$SETFLD^VALM1(IBX,IBY,"UCHG")
... S IBX=$J($P(IBLN,U,8),8,2),IBY=$$SETFLD^VALM1(IBX,IBY,"BCHG")
... S IBX=$P($G(^DGCR(399.2,+$P(IBLN,U,6),0)),U,1),IBY=$$SETFLD^VALM1(IBX,IBY,"RVCD")
... S IBX=$$DATE($P(IBLN,U,3)),IBY=$$SETFLD^VALM1(IBX,IBY,"EFFDT")
... S IBX=$P(IBLN,U,4)
... I +IBX S IBY=$$SETFLD^VALM1("-",IBY,"DS"),IBX=$$DATE(IBX),IBY=$$SETFLD^VALM1(IBX,IBY,"INADT")
... D SET(IBY)
;
I VALMCNT=0 D SET(" ") D
. I 'IBBRBI D SET("The Billing Rate of this Set has no Billable Item defined, therefore no"),SET("Charge Items may be defined for it. (The charges may be calculated amounts.)") Q
. I '$D(^IBA(363.2,"AIVDTS"_+$G(IBCSFN))) D SET("No Charge Items defined for this Set.") Q
. I +IBSRNITM,'$D(^IBA(363.2,"AIVDTS"_+$G(IBCSFN),+IBSRNITM)) D SET(IBBRBIN_" "_$P(IBSRNITM,U,2)_" has no charges for this set.") Q
. I 'IBSRNITM,IBBRBI'=1 D SET("No Charge Item chosen for display:"),SET(" - Non-bedsection type Items must be specifically chosen for display."),SET(" - Use the CI action and select an item to display.") Q
. I 'IBSRNITM D SET("This set has no charges in this date range.") Q
. D SET(IBBRBIN_" "_$P(IBSRNITM,U,2)_" has no charges for this set in this date range.")
;
K ^TMP($J,"IBCRCI")
Q
;
DATE(X) ; date in external format
N Y S Y="" I $G(X)?7N.E S Y=$E(X,4,5)_"/"_$E(X,6,7)_"/"_$E(X,2,3)
Q Y
;
SET(X) ; set up list manager screen array
S VALMCNT=VALMCNT+1
S ^TMP("IBCRLI",$J,VALMCNT,0)=X
Q
;
;
SORTCI(IBCSFN,IBITM,IBDT1,IBDT2) ; sort a charge sets items by item name and inverse effective date
; if ITEM is not defined than dates should be, if ITEM or dates not defined then assumes all should be included
; ^TMP("IBCRCI",$J, item name, - effective date, ITEM IFN)=""
;
N IBXRF,IBBITM,IBEITM,IBITEM,IBBDT,IBEDT,IBEFDT,IBCIFN,IBLN,IBITEMN
;
S IBXRF="AIVDTS"_+$G(IBCSFN)
S IBBITM=+$G(IBITM)-.0001,IBEITM=$S(+$G(IBITM):IBITM,1:9999999999)
S IBBDT=$S(+$G(IBDT1):-IBDT1,1:-1000000),IBEDT=$S(+$G(IBDT2):-(IBDT2+.01),1:-9999999) Q:IBBDT<IBEDT
;
S IBITEM=IBBITM F S IBITEM=$O(^IBA(363.2,IBXRF,IBITEM)) Q:'IBITEM!(IBITEM>IBEITM) D
. S IBEFDT=IBEDT F S IBEFDT=$O(^IBA(363.2,IBXRF,IBITEM,IBEFDT)) Q:'IBEFDT D Q:(IBEFDT'<IBBDT)
.. S IBCIFN=0 F S IBCIFN=$O(^IBA(363.2,IBXRF,IBITEM,IBEFDT,IBCIFN)) Q:'IBCIFN D
... S IBLN=$G(^IBA(363.2,IBCIFN,0)),IBITEMN=$$EXPAND^IBCRU1(363.2,.01,$P(IBLN,U,1))_" - "
... I +$P(IBLN,U,7) S IBITEMN=IBITEMN_$$EXPAND^IBCRU1(363.2,.07,+$P(IBLN,U,7))
... I $P(IBLN,U,4),+$P(IBLN,U,4)<-IBBDT Q
... S ^TMP($J,"IBCRCI",IBITEMN,IBEFDT,IBCIFN)=""
Q
;
GET(IBCSFN) ; get item to display on screen for specific charge set, set up general variables required
; (returns 0 if error, -1 if ^) all active bedsections or all entries for a specific CPT or NDC #
;
; returns general data on the Charge set to be diplayed, may ask user for a specific item
; variables defined on exit: IBCS0,IBBRBI,IBBRBIN,IBSRNITM,IBSRNBDT,IBSRNEDT
; if billable item is bedsection returns current date but no item
; if billable item is anything else asks user for specific item but returns no date
;
N IBX S IBX=1,(IBBRBI,IBBRBIN,IBSRNITM,IBSRNBDT,IBSRNEDT)=""
S IBCS0=$G(^IBE(363.1,+$G(IBCSFN),0)) I IBCS0="" S IBX=0 G GETQ
S IBBRBI=$P($G(^IBE(363.3,+$P(IBCS0,U,2),0)),U,4) I 'IBBRBI S IBX=0 G GETQ
S IBBRBIN=$$EXPAND^IBCRU1(363.3,.04,IBBRBI)
I IBBRBI>1 W !!,"Select a billable ",IBBRBIN," to display for Charge Set ",$P(IBCS0,U,1),!
;
I IBBRBI=1 S (IBSRNBDT,IBSRNEDT)=DT ; all currently active charges (bedsection)
I IBBRBI=2 S (IBX,IBSRNITM)=$$GETCPT^IBCRU1("",1) ; all charges for a specific CPT
I IBBRBI=3 S (IBX,IBSRNITM)=$$GETNDC^IBCRU1 ; all charges for a specific NDC #
I IBBRBI=4 S (IBX,IBSRNITM)=$$GETDRG^IBCRU1 ; all charges for a specific DRG
I IBBRBI=9 S (IBX,IBSRNITM)=$$GETMISC^IBCRU1 ; all charges for a specific MISCELLANEOUS item
GETQ Q IBX
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCRLI 6479 printed Oct 16, 2024@18:20:22 Page 2
IBCRLI ;ALB/ARH - RATES: DISPLAY CHARGE ITEMS ; 16-MAY-1996
+1 ;;2.0;INTEGRATED BILLING;**52,106,245**;21-MAR-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
+4 ; if Charge Set/Rates Billable Item is Bedsection then default display is current charge for all items
+5 ; all other Charge Sets display all charges for a user selected item
+6 ; this is due to unknown number of possible entries, for example a CPT set may have thousands of current charges
+7 ;
EN ; -- main entry point for IBCR CHARGE ITEM
+1 DO EN^VALM("IBCR CHARGE ITEM")
+2 QUIT
+3 ;
HDR ; -- header code
+1 NEW IBY,IBX,IBZ,IBI,IBK
SET IBI=1
SET (IBX,IBY,IBZ,IBK,VALMHDR(1),VALMHDR(2))=""
+2 ;
+3 IF +$PIECE(IBCS0,U,5)
SET IBK="Default Revenue Code: "_$PIECE($GET(^DGCR(399.2,+$PIECE(IBCS0,U,5),0)),U,1)
+4 ;
+5 SET IBZ=IBBRBIN_$SELECT(+IBSRNITM:" ",1:"")_$PIECE(IBSRNITM,U,2)_" items billable to Charge Set "
+6 ;
+7 SET IBX=$PIECE(IBCS0,U,1)
IF +$GET(IBSRNBDT)!(+$GET(IBSRNEDT))
Begin DoDot:1
+8 IF IBSRNBDT=IBSRNEDT
SET IBX=$EXTRACT(IBX,1,28)
SET IBY=" on "_$$DATE(IBSRNBDT)
QUIT
+9 IF 'IBSRNBDT
SET IBY=" on or before "_$$DATE(IBSRNEDT)
QUIT
+10 IF 'IBSRNEDT
SET IBY=" on or after "_$$DATE(IBSRNBDT)
QUIT
+11 IF IBSRNBDT'=IBSRNEDT
SET IBY=" between "_$$DATE(IBSRNBDT)_" and "_$$DATE(IBSRNEDT)
End DoDot:1
+12 ;
+13 SET VALMHDR(1)=IBZ_IBX
+14 IF ($LENGTH(IBZ)+$LENGTH(IBX)+$LENGTH(IBY))<80
SET VALMHDR(1)=VALMHDR(1)_IBY
SET IBY=""
+15 SET VALMHDR(2)=IBK_$JUSTIFY("",(80-($LENGTH(IBK)+$LENGTH(IBY))))_IBY
+16 QUIT
+17 ;
INIT ; -- init variables and list array IBCSFN required
+1 KILL ^TMP("IBCRLI",$JOB)
+2 IF '$GET(IBCSFN)
SET IBCSFN=$$GETCS^IBCRU1
IF IBCSFN'>0
SET VALMQUIT=""
QUIT
+3 IF $$GET(IBCSFN)<0
SET VALMQUIT=""
QUIT
+4 DO BLD
+5 QUIT
+6 ;
HELP ; -- help code
+1 SET X="?"
DO DISP^XQORM1
WRITE !!
+2 QUIT
+3 ;
EXIT ; -- exit code
+1 KILL ^TMP("IBCRLI",$JOB),IBCS0,IBBRBI,IBBRBIN,IBSRNITM,IBSRNBDT,IBSRNEDT
+2 DO CLEAR^VALM1
DO CLEAN^VALM10
+3 QUIT
+4 ;
BLD ; build array for display for Charge Item display: charge set required
+1 NEW IBITEM,IBDT1,IBCIFN,IBLN,IBX,IBY
SET VALMCNT=0
KILL ^TMP($JOB,"IBCRCI")
+2 SET IBSRNITM=$GET(IBSRNITM)
SET IBSRNBDT=$GET(IBSRNBDT)
SET IBSRNEDT=$GET(IBSRNEDT)
+3 ;
+4 IF (IBBRBI=1)!(+IBSRNITM)
DO SORTCI(IBCSFN,$GET(IBSRNITM),$GET(IBSRNBDT),$GET(IBSRNEDT))
+5 ;
+6 ; create LM diplay array of charge items
+7 SET IBITEM=""
FOR
SET IBITEM=$ORDER(^TMP($JOB,"IBCRCI",IBITEM))
if IBITEM=""
QUIT
Begin DoDot:1
+8 SET IBDT1=""
FOR
SET IBDT1=$ORDER(^TMP($JOB,"IBCRCI",IBITEM,IBDT1))
if IBDT1=""
QUIT
Begin DoDot:2
+9 SET IBCIFN=0
FOR
SET IBCIFN=$ORDER(^TMP($JOB,"IBCRCI",IBITEM,IBDT1,IBCIFN))
if 'IBCIFN
QUIT
Begin DoDot:3
+10 ;
+11 SET IBLN=$GET(^IBA(363.2,IBCIFN,0))
SET IBY=""
+12 SET IBX=$$EXPAND^IBCRU1(363.2,.01,$PIECE(IBLN,U,1))
+13 IF +$PIECE(IBLN,U,7)
SET IBX=IBX_" - "_$$EXPAND^IBCRU1(363.2,.07,+$PIECE(IBLN,U,7))
+14 SET IBY=$$SETFLD^VALM1(IBX,IBY,"ITEM")
+15 SET IBX=$JUSTIFY($PIECE(IBLN,U,5),8,2)
SET IBY=$$SETFLD^VALM1(IBX,IBY,"UCHG")
+16 SET IBX=$JUSTIFY($PIECE(IBLN,U,8),8,2)
SET IBY=$$SETFLD^VALM1(IBX,IBY,"BCHG")
+17 SET IBX=$PIECE($GET(^DGCR(399.2,+$PIECE(IBLN,U,6),0)),U,1)
SET IBY=$$SETFLD^VALM1(IBX,IBY,"RVCD")
+18 SET IBX=$$DATE($PIECE(IBLN,U,3))
SET IBY=$$SETFLD^VALM1(IBX,IBY,"EFFDT")
+19 SET IBX=$PIECE(IBLN,U,4)
+20 IF +IBX
SET IBY=$$SETFLD^VALM1("-",IBY,"DS")
SET IBX=$$DATE(IBX)
SET IBY=$$SETFLD^VALM1(IBX,IBY,"INADT")
+21 DO SET(IBY)
End DoDot:3
End DoDot:2
End DoDot:1
+22 ;
+23 IF VALMCNT=0
DO SET(" ")
Begin DoDot:1
+24 IF 'IBBRBI
DO SET("The Billing Rate of this Set has no Billable Item defined, therefore no")
DO SET("Charge Items may be defined for it. (The charges may be calculated amounts.)")
QUIT
+25 IF '$DATA(^IBA(363.2,"AIVDTS"_+$GET(IBCSFN)))
DO SET("No Charge Items defined for this Set.")
QUIT
+26 IF +IBSRNITM
IF '$DATA(^IBA(363.2,"AIVDTS"_+$GET(IBCSFN),+IBSRNITM))
DO SET(IBBRBIN_" "_$PIECE(IBSRNITM,U,2)_" has no charges for this set.")
QUIT
+27 IF 'IBSRNITM
IF IBBRBI'=1
DO SET("No Charge Item chosen for display:")
DO SET(" - Non-bedsection type Items must be specifically chosen for display.")
DO SET(" - Use the CI action and select an item to display.")
QUIT
+28 IF 'IBSRNITM
DO SET("This set has no charges in this date range.")
QUIT
+29 DO SET(IBBRBIN_" "_$PIECE(IBSRNITM,U,2)_" has no charges for this set in this date range.")
End DoDot:1
+30 ;
+31 KILL ^TMP($JOB,"IBCRCI")
+32 QUIT
+33 ;
DATE(X) ; date in external format
+1 NEW Y
SET Y=""
IF $GET(X)?7N.E
SET Y=$EXTRACT(X,4,5)_"/"_$EXTRACT(X,6,7)_"/"_$EXTRACT(X,2,3)
+2 QUIT Y
+3 ;
SET(X) ; set up list manager screen array
+1 SET VALMCNT=VALMCNT+1
+2 SET ^TMP("IBCRLI",$JOB,VALMCNT,0)=X
+3 QUIT
+4 ;
+5 ;
SORTCI(IBCSFN,IBITM,IBDT1,IBDT2) ; sort a charge sets items by item name and inverse effective date
+1 ; if ITEM is not defined than dates should be, if ITEM or dates not defined then assumes all should be included
+2 ; ^TMP("IBCRCI",$J, item name, - effective date, ITEM IFN)=""
+3 ;
+4 NEW IBXRF,IBBITM,IBEITM,IBITEM,IBBDT,IBEDT,IBEFDT,IBCIFN,IBLN,IBITEMN
+5 ;
+6 SET IBXRF="AIVDTS"_+$GET(IBCSFN)
+7 SET IBBITM=+$GET(IBITM)-.0001
SET IBEITM=$SELECT(+$GET(IBITM):IBITM,1:9999999999)
+8 SET IBBDT=$SELECT(+$GET(IBDT1):-IBDT1,1:-1000000)
SET IBEDT=$SELECT(+$GET(IBDT2):-(IBDT2+.01),1:-9999999)
if IBBDT<IBEDT
QUIT
+9 ;
+10 SET IBITEM=IBBITM
FOR
SET IBITEM=$ORDER(^IBA(363.2,IBXRF,IBITEM))
if 'IBITEM!(IBITEM>IBEITM)
QUIT
Begin DoDot:1
+11 SET IBEFDT=IBEDT
FOR
SET IBEFDT=$ORDER(^IBA(363.2,IBXRF,IBITEM,IBEFDT))
if 'IBEFDT
QUIT
Begin DoDot:2
+12 SET IBCIFN=0
FOR
SET IBCIFN=$ORDER(^IBA(363.2,IBXRF,IBITEM,IBEFDT,IBCIFN))
if 'IBCIFN
QUIT
Begin DoDot:3
+13 SET IBLN=$GET(^IBA(363.2,IBCIFN,0))
SET IBITEMN=$$EXPAND^IBCRU1(363.2,.01,$PIECE(IBLN,U,1))_" - "
+14 IF +$PIECE(IBLN,U,7)
SET IBITEMN=IBITEMN_$$EXPAND^IBCRU1(363.2,.07,+$PIECE(IBLN,U,7))
+15 IF $PIECE(IBLN,U,4)
IF +$PIECE(IBLN,U,4)<-IBBDT
QUIT
+16 SET ^TMP($JOB,"IBCRCI",IBITEMN,IBEFDT,IBCIFN)=""
End DoDot:3
End DoDot:2
if (IBEFDT'<IBBDT)
QUIT
End DoDot:1
+17 QUIT
+18 ;
GET(IBCSFN) ; get item to display on screen for specific charge set, set up general variables required
+1 ; (returns 0 if error, -1 if ^) all active bedsections or all entries for a specific CPT or NDC #
+2 ;
+3 ; returns general data on the Charge set to be diplayed, may ask user for a specific item
+4 ; variables defined on exit: IBCS0,IBBRBI,IBBRBIN,IBSRNITM,IBSRNBDT,IBSRNEDT
+5 ; if billable item is bedsection returns current date but no item
+6 ; if billable item is anything else asks user for specific item but returns no date
+7 ;
+8 NEW IBX
SET IBX=1
SET (IBBRBI,IBBRBIN,IBSRNITM,IBSRNBDT,IBSRNEDT)=""
+9 SET IBCS0=$GET(^IBE(363.1,+$GET(IBCSFN),0))
IF IBCS0=""
SET IBX=0
GOTO GETQ
+10 SET IBBRBI=$PIECE($GET(^IBE(363.3,+$PIECE(IBCS0,U,2),0)),U,4)
IF 'IBBRBI
SET IBX=0
GOTO GETQ
+11 SET IBBRBIN=$$EXPAND^IBCRU1(363.3,.04,IBBRBI)
+12 IF IBBRBI>1
WRITE !!,"Select a billable ",IBBRBIN," to display for Charge Set ",$PIECE(IBCS0,U,1),!
+13 ;
+14 ; all currently active charges (bedsection)
IF IBBRBI=1
SET (IBSRNBDT,IBSRNEDT)=DT
+15 ; all charges for a specific CPT
IF IBBRBI=2
SET (IBX,IBSRNITM)=$$GETCPT^IBCRU1("",1)
+16 ; all charges for a specific NDC #
IF IBBRBI=3
SET (IBX,IBSRNITM)=$$GETNDC^IBCRU1
+17 ; all charges for a specific DRG
IF IBBRBI=4
SET (IBX,IBSRNITM)=$$GETDRG^IBCRU1
+18 ; all charges for a specific MISCELLANEOUS item
IF IBBRBI=9
SET (IBX,IBSRNITM)=$$GETMISC^IBCRU1
GETQ QUIT IBX
