- 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 Jan 18, 2025@03:20:55 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