- 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 Mar 13, 2025@21:24:44 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
