IBCRLS ;ALB/ARH - RATES: DISPLAY SCHEDULES ; 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 RATE SCHEDULE
D EN^VALM("IBCR RATE SCHEDULE")
Q
;
HDR ; -- header code
S VALMHDR(1)="Link types of payers and charges"
S VALMSG="~ charges not auto added to bills"
Q
;
INIT ; -- init variables and list array
K ^TMP("IBCRLS",$J),^TMP("IBCRLSX1",$J)
D BLD
Q
;
HELP ; -- help code
S X="?" D DISP^XQORM1 W !!
Q
;
EXIT ; -- exit code
K ^TMP("IBCRLS",$J),^TMP("IBCRLSX1",$J)
D CLEAR^VALM1,CLEAN^VALM10
Q
;
BLD ; build LM array for rate schedule display
N IBRT,IBBT,IBCNT,IBCNT1,IBRTBT,IBRSFN,IBCGS,IBLN,IBLN1,IBX,IBY,IBRS10,X S (VALMCNT,IBCNT)=0 K ^TMP($J,"IBCRRS")
;
D SORTRS
;
; create LM display array
S IBRT="" F S IBRT=$O(^TMP($J,"IBCRRS",IBRT)) Q:IBRT="" D
. S IBBT="" F S IBBT=$O(^TMP($J,"IBCRRS",IBRT,IBBT)) Q:IBBT="" D
.. ;
.. S IBRTBT=$G(^TMP($J,"IBCRRS",IBRT,IBBT))
.. D SET("",IBRTBT) S IBY=" "_IBRT_": "_$$BTYPE(IBBT)
.. D SET(IBY) D CNTRL^VALM10(VALMCNT,1,80,IOINHI,IOINORM)
.. ;
.. S IBRSFN=0 F S IBRSFN=$O(^TMP($J,"IBCRRS",IBRT,IBBT,IBRSFN)) Q:'IBRSFN D
... S IBLN=$G(^IBE(363,IBRSFN,0)) Q:IBLN=""
... S IBCNT=IBCNT+1,IBY=""
... S IBX=$P(IBLN,U,1),IBY=$$SETFLD^VALM1(IBX,IBY,"RSCHD")
... S IBX=$$EMUTL^IBCRU1(+$P(IBLN,U,4),2),IBY=$$SETFLD^VALM1(IBX,IBY,"BSVS")
... S IBX=$$DATE(+$P(IBLN,U,5)),IBY=$$SETFLD^VALM1(IBX,IBY,"EFFDT")
... S IBX=$$DATE(+$P(IBLN,U,6)),IBY=$$SETFLD^VALM1(IBX,IBY,"INADT")
... ;
... S IBRS10=$G(^IBE(363,IBRSFN,10)) I IBRS10'="" D
.... S IBY=$$SETFLD^VALM1(" Y",IBY,"ADJ") S X=100 X IBRS10
.... S IBX="(if base $=100, adjusted $="_$J(X,0,2)_") "_IBRS10,IBY=$$SETFLD^VALM1(IBX,IBY,"ADJMC")
... ;
... S IBCGS=0,IBCNT1=IBCNT F S IBCGS=$O(^IBE(363,IBRSFN,11,IBCGS)) Q:'IBCGS D
.... S IBLN1=$G(^IBE(363,IBRSFN,11,IBCGS,0)) Q:'IBLN1
.... S IBX=$P(IBLN1,U,2) I 'IBX S IBX="~",IBY=$$SETFLD^VALM1(IBX,IBY,"AA")
.... S IBX=$P($G(^IBE(363.1,+IBLN1,0)),U,1),IBY=$$SETFLD^VALM1(IBX,IBY,"CGSET")
.... D SET(IBY) S IBCNT1=0,IBY=""
... I +IBCNT1 D SET(IBY)
;
I VALMCNT=0 D SET(" "),SET("No Rate Schedules defined")
;
K ^TMP($J,"IBCRRS")
Q
;
SET(X,RTBTLN) ; set up list manager screen array (if RTBTLN, the line is the first line of the rate tpe-bill type section)
S VALMCNT=VALMCNT+1
S ^TMP("IBCRLS",$J,VALMCNT,0)=X
I +$G(RTBTLN) S ^TMP("IBCRLSX1",$J,+RTBTLN,+$P(RTBTLN,U,2))=VALMCNT
Q
;
SORTRS ; sort rate schedules by rate type name, bill type
; ^TMP($J,"IBCRRS", rate type, bill type)= rate type ifn ^ bill type
; ^TMP($J,"IBCRRS", rate type, bill type, rate schedule IFN)=""
N IBRSFN,IBLN,IBRT,IBBT
S IBRSFN=0 F S IBRSFN=$O(^IBE(363,IBRSFN)) Q:'IBRSFN D
. S IBLN=$G(^IBE(363,IBRSFN,0)) Q:IBLN=""
. S IBRT=$P($G(^DGCR(399.3,+$P(IBLN,U,2),0)),U,1),IBBT=$P(IBLN,U,3)
. S ^TMP($J,"IBCRRS",IBRT,IBBT)=+$P(IBLN,U,2)_U_+$P(IBLN,U,3)
. S ^TMP($J,"IBCRRS",IBRT,IBBT,IBRSFN)=""
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
;
BTYPE(X) ; return abbreviated form of Bill Type
Q $S($G(X)>2:"Outpatient",$G(X)>0:"Inpatient",1:"")
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCRLS 3291 printed Dec 13, 2024@02:19:48 Page 2
IBCRLS ;ALB/ARH - RATES: DISPLAY SCHEDULES ; 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 RATE SCHEDULE
+1 DO EN^VALM("IBCR RATE SCHEDULE")
+2 QUIT
+3 ;
HDR ; -- header code
+1 SET VALMHDR(1)="Link types of payers and charges"
+2 SET VALMSG="~ charges not auto added to bills"
+3 QUIT
+4 ;
INIT ; -- init variables and list array
+1 KILL ^TMP("IBCRLS",$JOB),^TMP("IBCRLSX1",$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("IBCRLS",$JOB),^TMP("IBCRLSX1",$JOB)
+2 DO CLEAR^VALM1
DO CLEAN^VALM10
+3 QUIT
+4 ;
BLD ; build LM array for rate schedule display
+1 NEW IBRT,IBBT,IBCNT,IBCNT1,IBRTBT,IBRSFN,IBCGS,IBLN,IBLN1,IBX,IBY,IBRS10,X
SET (VALMCNT,IBCNT)=0
KILL ^TMP($JOB,"IBCRRS")
+2 ;
+3 DO SORTRS
+4 ;
+5 ; create LM display array
+6 SET IBRT=""
FOR
SET IBRT=$ORDER(^TMP($JOB,"IBCRRS",IBRT))
if IBRT=""
QUIT
Begin DoDot:1
+7 SET IBBT=""
FOR
SET IBBT=$ORDER(^TMP($JOB,"IBCRRS",IBRT,IBBT))
if IBBT=""
QUIT
Begin DoDot:2
+8 ;
+9 SET IBRTBT=$GET(^TMP($JOB,"IBCRRS",IBRT,IBBT))
+10 DO SET("",IBRTBT)
SET IBY=" "_IBRT_": "_$$BTYPE(IBBT)
+11 DO SET(IBY)
DO CNTRL^VALM10(VALMCNT,1,80,IOINHI,IOINORM)
+12 ;
+13 SET IBRSFN=0
FOR
SET IBRSFN=$ORDER(^TMP($JOB,"IBCRRS",IBRT,IBBT,IBRSFN))
if 'IBRSFN
QUIT
Begin DoDot:3
+14 SET IBLN=$GET(^IBE(363,IBRSFN,0))
if IBLN=""
QUIT
+15 SET IBCNT=IBCNT+1
SET IBY=""
+16 SET IBX=$PIECE(IBLN,U,1)
SET IBY=$$SETFLD^VALM1(IBX,IBY,"RSCHD")
+17 SET IBX=$$EMUTL^IBCRU1(+$PIECE(IBLN,U,4),2)
SET IBY=$$SETFLD^VALM1(IBX,IBY,"BSVS")
+18 SET IBX=$$DATE(+$PIECE(IBLN,U,5))
SET IBY=$$SETFLD^VALM1(IBX,IBY,"EFFDT")
+19 SET IBX=$$DATE(+$PIECE(IBLN,U,6))
SET IBY=$$SETFLD^VALM1(IBX,IBY,"INADT")
+20 ;
+21 SET IBRS10=$GET(^IBE(363,IBRSFN,10))
IF IBRS10'=""
Begin DoDot:4
+22 SET IBY=$$SETFLD^VALM1(" Y",IBY,"ADJ")
SET X=100
XECUTE IBRS10
+23 SET IBX="(if base $=100, adjusted $="_$JUSTIFY(X,0,2)_") "_IBRS10
SET IBY=$$SETFLD^VALM1(IBX,IBY,"ADJMC")
End DoDot:4
+24 ;
+25 SET IBCGS=0
SET IBCNT1=IBCNT
FOR
SET IBCGS=$ORDER(^IBE(363,IBRSFN,11,IBCGS))
if 'IBCGS
QUIT
Begin DoDot:4
+26 SET IBLN1=$GET(^IBE(363,IBRSFN,11,IBCGS,0))
if 'IBLN1
QUIT
+27 SET IBX=$PIECE(IBLN1,U,2)
IF 'IBX
SET IBX="~"
SET IBY=$$SETFLD^VALM1(IBX,IBY,"AA")
+28 SET IBX=$PIECE($GET(^IBE(363.1,+IBLN1,0)),U,1)
SET IBY=$$SETFLD^VALM1(IBX,IBY,"CGSET")
+29 DO SET(IBY)
SET IBCNT1=0
SET IBY=""
End DoDot:4
+30 IF +IBCNT1
DO SET(IBY)
End DoDot:3
End DoDot:2
End DoDot:1
+31 ;
+32 IF VALMCNT=0
DO SET(" ")
DO SET("No Rate Schedules defined")
+33 ;
+34 KILL ^TMP($JOB,"IBCRRS")
+35 QUIT
+36 ;
SET(X,RTBTLN) ; set up list manager screen array (if RTBTLN, the line is the first line of the rate tpe-bill type section)
+1 SET VALMCNT=VALMCNT+1
+2 SET ^TMP("IBCRLS",$JOB,VALMCNT,0)=X
+3 IF +$GET(RTBTLN)
SET ^TMP("IBCRLSX1",$JOB,+RTBTLN,+$PIECE(RTBTLN,U,2))=VALMCNT
+4 QUIT
+5 ;
SORTRS ; sort rate schedules by rate type name, bill type
+1 ; ^TMP($J,"IBCRRS", rate type, bill type)= rate type ifn ^ bill type
+2 ; ^TMP($J,"IBCRRS", rate type, bill type, rate schedule IFN)=""
+3 NEW IBRSFN,IBLN,IBRT,IBBT
+4 SET IBRSFN=0
FOR
SET IBRSFN=$ORDER(^IBE(363,IBRSFN))
if 'IBRSFN
QUIT
Begin DoDot:1
+5 SET IBLN=$GET(^IBE(363,IBRSFN,0))
if IBLN=""
QUIT
+6 SET IBRT=$PIECE($GET(^DGCR(399.3,+$PIECE(IBLN,U,2),0)),U,1)
SET IBBT=$PIECE(IBLN,U,3)
+7 SET ^TMP($JOB,"IBCRRS",IBRT,IBBT)=+$PIECE(IBLN,U,2)_U_+$PIECE(IBLN,U,3)
+8 SET ^TMP($JOB,"IBCRRS",IBRT,IBBT,IBRSFN)=""
End DoDot:1
+9 QUIT
+10 ;
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 ;
BTYPE(X) ; return abbreviated form of Bill Type
+1 QUIT $SELECT($GET(X)>2:"Outpatient",$GET(X)>0:"Inpatient",1:"")
