IBCRLR ;ALB/ARH - RATES: DISPLAY BILLING RATES ; 16-MAY-1996
;;Version 2.0 ; INTEGRATED BILLING ;**52**; 21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
EN ; -- main entry point for IBCR BILLING RATE
D EN^VALM("IBCR BILLING RATE")
Q
;
HDR ; -- header code
S VALMHDR(1)=""
Q
;
INIT ; -- init variables and list array
K ^TMP("IBCRLR",$J)
D BLD
Q
;
HELP ; -- help code
S X="?" D DISP^XQORM1 W !!
Q
;
EXIT ; -- exit code
K ^TMP("IBCRLR",$J)
D CLEAR^VALM1,CLEAN^VALM10
Q
;
BLD ; build array for billing rate display
N IBDSTR,IBBRN,IBBRFN,IBLN,IBCNT,IBX,IBY S VALMCNT=0,IBCNT=0 K ^TMP($J,"IBCRBR")
;
D SORTBR
;
; create LM display array
S IBDSTR=0 F S IBDSTR=$O(^TMP($J,"IBCRBR",IBDSTR)) Q:'IBDSTR D
. D SET("")
. S IBBRN="" F S IBBRN=$O(^TMP($J,"IBCRBR",IBDSTR,IBBRN)) Q:IBBRN="" D
.. S IBBRFN=0 F S IBBRFN=$O(^TMP($J,"IBCRBR",IBDSTR,IBBRN,IBBRFN)) Q:'IBBRFN D
... ;
... S IBLN=$G(^IBE(363.3,IBBRFN,0)) Q:IBLN=""
... S IBCNT=IBCNT+1,IBY=""
... S IBX=$P(IBLN,U,1),IBY=$$SETFLD^VALM1(IBX,IBY,"RATE")
... S IBX=$P(IBLN,U,2),IBY=$$SETFLD^VALM1(IBX,IBY,"ABBV")
... S IBX=$$EXPAND^IBCRU1(363.3,.03,$P(IBLN,U,3)),IBY=$$SETFLD^VALM1(IBX,IBY,"DSTR")
... S IBX=$$EXPAND^IBCRU1(363.3,.04,$P(IBLN,U,4)),IBY=$$SETFLD^VALM1(IBX,IBY,"BITM")
... S IBX=$$EXPAND^IBCRU1(363.3,.05,$P(IBLN,U,5)),IBY=$$SETFLD^VALM1(IBX,IBY,"CMTHD")
... D SET(IBY)
;
I VALMCNT=0 D SET(" "),SET("No Billing Rates defined")
;
K ^TMP($J,"IBCRBR")
Q
;
SET(X) ; set up list manager screen array
S VALMCNT=VALMCNT+1
S ^TMP("IBCRLR",$J,VALMCNT,0)=X
Q
;
SORTBR ; sort billing rates by distribution and billing rate name
; ^TMP($J,"IBCRBR", national/local grouping , billing rate name, IBBRFN)=""
N IBBRFN,IBLN,IBDSTR
S IBBRFN=0 F S IBBRFN=$O(^IBE(363.3,IBBRFN)) Q:'IBBRFN D
. S IBLN=$G(^IBE(363.3,IBBRFN,0)) Q:IBLN=""
. S IBDSTR=$P(IBLN,U,3) I IBDSTR=2,IBBRFN<1000 S IBDSTR=1.5
. I 'IBDSTR S IBDSTR=9999
. S ^TMP($J,"IBCRBR",IBDSTR,$P(IBLN,U,1),IBBRFN)=""
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCRLR 2068 printed Oct 16, 2024@18:20:26 Page 2
IBCRLR ;ALB/ARH - RATES: DISPLAY BILLING RATES ; 16-MAY-1996
+1 ;;Version 2.0 ; INTEGRATED BILLING ;**52**; 21-MAR-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
EN ; -- main entry point for IBCR BILLING RATE
+1 DO EN^VALM("IBCR BILLING RATE")
+2 QUIT
+3 ;
HDR ; -- header code
+1 SET VALMHDR(1)=""
+2 QUIT
+3 ;
INIT ; -- init variables and list array
+1 KILL ^TMP("IBCRLR",$JOB)
+2 DO BLD
+3 QUIT
+4 ;
HELP ; -- help code
+1 SET X="?"
DO DISP^XQORM1
WRITE !!
+2 QUIT
+3 ;
EXIT ; -- exit code
+1 KILL ^TMP("IBCRLR",$JOB)
+2 DO CLEAR^VALM1
DO CLEAN^VALM10
+3 QUIT
+4 ;
BLD ; build array for billing rate display
+1 NEW IBDSTR,IBBRN,IBBRFN,IBLN,IBCNT,IBX,IBY
SET VALMCNT=0
SET IBCNT=0
KILL ^TMP($JOB,"IBCRBR")
+2 ;
+3 DO SORTBR
+4 ;
+5 ; create LM display array
+6 SET IBDSTR=0
FOR
SET IBDSTR=$ORDER(^TMP($JOB,"IBCRBR",IBDSTR))
if 'IBDSTR
QUIT
Begin DoDot:1
+7 DO SET("")
+8 SET IBBRN=""
FOR
SET IBBRN=$ORDER(^TMP($JOB,"IBCRBR",IBDSTR,IBBRN))
if IBBRN=""
QUIT
Begin DoDot:2
+9 SET IBBRFN=0
FOR
SET IBBRFN=$ORDER(^TMP($JOB,"IBCRBR",IBDSTR,IBBRN,IBBRFN))
if 'IBBRFN
QUIT
Begin DoDot:3
+10 ;
+11 SET IBLN=$GET(^IBE(363.3,IBBRFN,0))
if IBLN=""
QUIT
+12 SET IBCNT=IBCNT+1
SET IBY=""
+13 SET IBX=$PIECE(IBLN,U,1)
SET IBY=$$SETFLD^VALM1(IBX,IBY,"RATE")
+14 SET IBX=$PIECE(IBLN,U,2)
SET IBY=$$SETFLD^VALM1(IBX,IBY,"ABBV")
+15 SET IBX=$$EXPAND^IBCRU1(363.3,.03,$PIECE(IBLN,U,3))
SET IBY=$$SETFLD^VALM1(IBX,IBY,"DSTR")
+16 SET IBX=$$EXPAND^IBCRU1(363.3,.04,$PIECE(IBLN,U,4))
SET IBY=$$SETFLD^VALM1(IBX,IBY,"BITM")
+17 SET IBX=$$EXPAND^IBCRU1(363.3,.05,$PIECE(IBLN,U,5))
SET IBY=$$SETFLD^VALM1(IBX,IBY,"CMTHD")
+18 DO SET(IBY)
End DoDot:3
End DoDot:2
End DoDot:1
+19 ;
+20 IF VALMCNT=0
DO SET(" ")
DO SET("No Billing Rates defined")
+21 ;
+22 KILL ^TMP($JOB,"IBCRBR")
+23 QUIT
+24 ;
SET(X) ; set up list manager screen array
+1 SET VALMCNT=VALMCNT+1
+2 SET ^TMP("IBCRLR",$JOB,VALMCNT,0)=X
+3 QUIT
+4 ;
SORTBR ; sort billing rates by distribution and billing rate name
+1 ; ^TMP($J,"IBCRBR", national/local grouping , billing rate name, IBBRFN)=""
+2 NEW IBBRFN,IBLN,IBDSTR
+3 SET IBBRFN=0
FOR
SET IBBRFN=$ORDER(^IBE(363.3,IBBRFN))
if 'IBBRFN
QUIT
Begin DoDot:1
+4 SET IBLN=$GET(^IBE(363.3,IBBRFN,0))
if IBLN=""
QUIT
+5 SET IBDSTR=$PIECE(IBLN,U,3)
IF IBDSTR=2
IF IBBRFN<1000
SET IBDSTR=1.5
+6 IF 'IBDSTR
SET IBDSTR=9999
+7 SET ^TMP($JOB,"IBCRBR",IBDSTR,$PIECE(IBLN,U,1),IBBRFN)=""
End DoDot:1
+8 QUIT
