IBCRLN ;ALB/ARH - RATES: DISPLAY PROVIDER DISCOUNT ; 10-OCT-1998
;;2.0;INTEGRATED BILLING;**106,148**;21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
EN ; -- main entry point for IBCR PROVIDER DISCOUNT
D EN^VALM("IBCR PROVIDER DISCOUNT")
Q
;
HDR ; -- header code
S VALMHDR(1)="Provider Discounts for "_$P($G(^IBE(363.32,+$G(IBSGFN),0)),U,1)_" Group."
Q
;
INIT ; -- init variables and list array
K ^TMP("IBCRLN",$J),^TMP("IBCRLNX1",$J)
I '$G(IBSGFN) S IBSGFN=$$GETSG^IBCRU1(2) I IBSGFN'>0 S VALMQUIT="" Q
D BLD
Q
;
HELP ; -- help code
S X="?" D DISP^XQORM1 W !!
Q
;
EXIT ; -- exit code
K ^TMP("IBCRLN",$J),^TMP("IBCRLNX1",$J)
D CLEAR^VALM1,CLEAN^VALM10
Q
;
BLD ; build charge set display array
N IBPDN,IBPDFN,IBPD0,IBPCVA,IBPCFN,IBPC,IBX,IBY,IBZ S VALMCNT=0 K ^TMP($J,"IBCRLN")
;
D SORT
;
; create LM display array
S IBPDN="" F S IBPDN=$O(^TMP($J,"IBCRLN",IBPDN)) Q:IBPDN="" D
. ;
. S IBPDFN=+$G(^TMP($J,"IBCRLN",IBPDN)),IBPD0=$G(^IBE(363.34,+IBPDFN,0)) I $P(IBPD0,U,2)'=+$G(IBSGFN) Q
. ;
. D SET("",IBPDFN) S IBY=" Provider Type: "_$P(IBPD0,U,1)
. D SET(IBY) D CNTRL^VALM10(VALMCNT,1,80,IOINHI,IOINORM) D SET("")
. ;
. S IBY=""
. S IBZ=$P(IBPD0,U,3) I IBZ'="" S IBX=$J(IBZ,3)_"%",IBY=$$SETFLD^VALM1(IBX,IBY,"PCNT")
. ;
. I '$O(^IBE(363.34,+IBPDFN,11,0)) S IBX="No Person Class Assigned",IBY=$$SETFLD^VALM1(IBX,IBY,"PRVPC") D SET(IBY) S IBY=""
. ;
. S IBPCVA="" F S IBPCVA=$O(^TMP($J,"IBCRLN",IBPDN,IBPCVA)) Q:IBPCVA="" D
.. ;
.. S IBPCFN=+$G(^TMP($J,"IBCRLN",IBPDN,IBPCVA)) Q:'IBPCFN
.. S IBPC=$$CODE2TXT^XUA4A72(+IBPCFN)
.. I $P(IBPC,U,1)'="" S IBX=IBPCVA_" "_$P(IBPC,U,1),IBY=$$SETFLD^VALM1(IBX,IBY,"PRVPC") D SET(IBY) S IBY=""
.. I $P(IBPC,U,2)'="" S IBX=" "_$P(IBPC,U,2),IBY=$$SETFLD^VALM1(IBX,IBY,"PRVPC") D SET(IBY) S IBY=""
.. I $P(IBPC,U,3)'="" S IBX=" "_$P(IBPC,U,3),IBY=$$SETFLD^VALM1(IBX,IBY,"PRVPC") D SET(IBY) S IBY=""
. I IBY'="" D SET(IBY) S IBY=""
;
I VALMCNT=0 D SET(" "),SET("No Provider Discounts for this Group")
;
K ^TMP($J,"IBCRLN")
Q
;
;
SET(X,PDFN) ; set up list manager screen array
S VALMCNT=VALMCNT+1
S ^TMP("IBCRLN",$J,VALMCNT,0)=X
I +$G(PDFN) S ^TMP("IBCRLNX1",$J,+PDFN)=VALMCNT
Q
;
SORT ; sort the provider discount group by Provider Type then VA Code (IBSGFN expected)
N IBPDFN,IBPD0,IBPDN,IBPCFN,IBPCVA
S IBPDFN=0 F S IBPDFN=$O(^IBE(363.34,IBPDFN)) Q:'IBPDFN D
. S IBPD0=$G(^IBE(363.34,IBPDFN,0)),IBPDN=$P(IBPD0,U,1)_" " I $P(IBPD0,U,2)'=+$G(IBSGFN) Q
. S ^TMP($J,"IBCRLN",IBPDN)=IBPDFN
. S IBPCFN=0 F S IBPCFN=$O(^IBE(363.34,IBPDFN,11,"B",IBPCFN)) Q:'IBPCFN D
.. S IBPCVA=$$IEN2CODE^XUA4A72(IBPCFN)_" "
.. S ^TMP($J,"IBCRLN",IBPDN,IBPCVA)=IBPCFN
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCRLN 2798 printed Nov 22, 2024@17:29:50 Page 2
IBCRLN ;ALB/ARH - RATES: DISPLAY PROVIDER DISCOUNT ; 10-OCT-1998
+1 ;;2.0;INTEGRATED BILLING;**106,148**;21-MAR-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
EN ; -- main entry point for IBCR PROVIDER DISCOUNT
+1 DO EN^VALM("IBCR PROVIDER DISCOUNT")
+2 QUIT
+3 ;
HDR ; -- header code
+1 SET VALMHDR(1)="Provider Discounts for "_$PIECE($GET(^IBE(363.32,+$GET(IBSGFN),0)),U,1)_" Group."
+2 QUIT
+3 ;
INIT ; -- init variables and list array
+1 KILL ^TMP("IBCRLN",$JOB),^TMP("IBCRLNX1",$JOB)
+2 IF '$GET(IBSGFN)
SET IBSGFN=$$GETSG^IBCRU1(2)
IF IBSGFN'>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("IBCRLN",$JOB),^TMP("IBCRLNX1",$JOB)
+2 DO CLEAR^VALM1
DO CLEAN^VALM10
+3 QUIT
+4 ;
BLD ; build charge set display array
+1 NEW IBPDN,IBPDFN,IBPD0,IBPCVA,IBPCFN,IBPC,IBX,IBY,IBZ
SET VALMCNT=0
KILL ^TMP($JOB,"IBCRLN")
+2 ;
+3 DO SORT
+4 ;
+5 ; create LM display array
+6 SET IBPDN=""
FOR
SET IBPDN=$ORDER(^TMP($JOB,"IBCRLN",IBPDN))
if IBPDN=""
QUIT
Begin DoDot:1
+7 ;
+8 SET IBPDFN=+$GET(^TMP($JOB,"IBCRLN",IBPDN))
SET IBPD0=$GET(^IBE(363.34,+IBPDFN,0))
IF $PIECE(IBPD0,U,2)'=+$GET(IBSGFN)
QUIT
+9 ;
+10 DO SET("",IBPDFN)
SET IBY=" Provider Type: "_$PIECE(IBPD0,U,1)
+11 DO SET(IBY)
DO CNTRL^VALM10(VALMCNT,1,80,IOINHI,IOINORM)
DO SET("")
+12 ;
+13 SET IBY=""
+14 SET IBZ=$PIECE(IBPD0,U,3)
IF IBZ'=""
SET IBX=$JUSTIFY(IBZ,3)_"%"
SET IBY=$$SETFLD^VALM1(IBX,IBY,"PCNT")
+15 ;
+16 IF '$ORDER(^IBE(363.34,+IBPDFN,11,0))
SET IBX="No Person Class Assigned"
SET IBY=$$SETFLD^VALM1(IBX,IBY,"PRVPC")
DO SET(IBY)
SET IBY=""
+17 ;
+18 SET IBPCVA=""
FOR
SET IBPCVA=$ORDER(^TMP($JOB,"IBCRLN",IBPDN,IBPCVA))
if IBPCVA=""
QUIT
Begin DoDot:2
+19 ;
+20 SET IBPCFN=+$GET(^TMP($JOB,"IBCRLN",IBPDN,IBPCVA))
if 'IBPCFN
QUIT
+21 SET IBPC=$$CODE2TXT^XUA4A72(+IBPCFN)
+22 IF $PIECE(IBPC,U,1)'=""
SET IBX=IBPCVA_" "_$PIECE(IBPC,U,1)
SET IBY=$$SETFLD^VALM1(IBX,IBY,"PRVPC")
DO SET(IBY)
SET IBY=""
+23 IF $PIECE(IBPC,U,2)'=""
SET IBX=" "_$PIECE(IBPC,U,2)
SET IBY=$$SETFLD^VALM1(IBX,IBY,"PRVPC")
DO SET(IBY)
SET IBY=""
+24 IF $PIECE(IBPC,U,3)'=""
SET IBX=" "_$PIECE(IBPC,U,3)
SET IBY=$$SETFLD^VALM1(IBX,IBY,"PRVPC")
DO SET(IBY)
SET IBY=""
End DoDot:2
+25 IF IBY'=""
DO SET(IBY)
SET IBY=""
End DoDot:1
+26 ;
+27 IF VALMCNT=0
DO SET(" ")
DO SET("No Provider Discounts for this Group")
+28 ;
+29 KILL ^TMP($JOB,"IBCRLN")
+30 QUIT
+31 ;
+32 ;
SET(X,PDFN) ; set up list manager screen array
+1 SET VALMCNT=VALMCNT+1
+2 SET ^TMP("IBCRLN",$JOB,VALMCNT,0)=X
+3 IF +$GET(PDFN)
SET ^TMP("IBCRLNX1",$JOB,+PDFN)=VALMCNT
+4 QUIT
+5 ;
SORT ; sort the provider discount group by Provider Type then VA Code (IBSGFN expected)
+1 NEW IBPDFN,IBPD0,IBPDN,IBPCFN,IBPCVA
+2 SET IBPDFN=0
FOR
SET IBPDFN=$ORDER(^IBE(363.34,IBPDFN))
if 'IBPDFN
QUIT
Begin DoDot:1
+3 SET IBPD0=$GET(^IBE(363.34,IBPDFN,0))
SET IBPDN=$PIECE(IBPD0,U,1)_" "
IF $PIECE(IBPD0,U,2)'=+$GET(IBSGFN)
QUIT
+4 SET ^TMP($JOB,"IBCRLN",IBPDN)=IBPDFN
+5 SET IBPCFN=0
FOR
SET IBPCFN=$ORDER(^IBE(363.34,IBPDFN,11,"B",IBPCFN))
if 'IBPCFN
QUIT
Begin DoDot:2
+6 SET IBPCVA=$$IEN2CODE^XUA4A72(IBPCFN)_" "
+7 SET ^TMP($JOB,"IBCRLN",IBPDN,IBPCVA)=IBPCFN
End DoDot:2
End DoDot:1
+8 QUIT
