Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: IBCRLN

IBCRLN.m

Go to the documentation of this file.
  1. IBCRLN ;ALB/ARH - RATES: DISPLAY PROVIDER DISCOUNT ; 10-OCT-1998
  1. ;;2.0;INTEGRATED BILLING;**106,148**;21-MAR-94
  1. ;;Per VHA Directive 10-93-142, this routine should not be modified.
  1. ;
  1. EN ; -- main entry point for IBCR PROVIDER DISCOUNT
  1. D EN^VALM("IBCR PROVIDER DISCOUNT")
  1. Q
  1. ;
  1. HDR ; -- header code
  1. S VALMHDR(1)="Provider Discounts for "_$P($G(^IBE(363.32,+$G(IBSGFN),0)),U,1)_" Group."
  1. Q
  1. ;
  1. INIT ; -- init variables and list array
  1. K ^TMP("IBCRLN",$J),^TMP("IBCRLNX1",$J)
  1. I '$G(IBSGFN) S IBSGFN=$$GETSG^IBCRU1(2) I IBSGFN'>0 S VALMQUIT="" Q
  1. D BLD
  1. Q
  1. ;
  1. HELP ; -- help code
  1. S X="?" D DISP^XQORM1 W !!
  1. Q
  1. ;
  1. EXIT ; -- exit code
  1. K ^TMP("IBCRLN",$J),^TMP("IBCRLNX1",$J)
  1. D CLEAR^VALM1,CLEAN^VALM10
  1. Q
  1. ;
  1. BLD ; build charge set display array
  1. N IBPDN,IBPDFN,IBPD0,IBPCVA,IBPCFN,IBPC,IBX,IBY,IBZ S VALMCNT=0 K ^TMP($J,"IBCRLN")
  1. ;
  1. D SORT
  1. ;
  1. ; create LM display array
  1. S IBPDN="" F S IBPDN=$O(^TMP($J,"IBCRLN",IBPDN)) Q:IBPDN="" D
  1. . ;
  1. . S IBPDFN=+$G(^TMP($J,"IBCRLN",IBPDN)),IBPD0=$G(^IBE(363.34,+IBPDFN,0)) I $P(IBPD0,U,2)'=+$G(IBSGFN) Q
  1. . ;
  1. . D SET("",IBPDFN) S IBY=" Provider Type: "_$P(IBPD0,U,1)
  1. . D SET(IBY) D CNTRL^VALM10(VALMCNT,1,80,IOINHI,IOINORM) D SET("")
  1. . ;
  1. . S IBY=""
  1. . S IBZ=$P(IBPD0,U,3) I IBZ'="" S IBX=$J(IBZ,3)_"%",IBY=$$SETFLD^VALM1(IBX,IBY,"PCNT")
  1. . ;
  1. . 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=""
  1. . ;
  1. . S IBPCVA="" F S IBPCVA=$O(^TMP($J,"IBCRLN",IBPDN,IBPCVA)) Q:IBPCVA="" D
  1. .. ;
  1. .. S IBPCFN=+$G(^TMP($J,"IBCRLN",IBPDN,IBPCVA)) Q:'IBPCFN
  1. .. S IBPC=$$CODE2TXT^XUA4A72(+IBPCFN)
  1. .. I $P(IBPC,U,1)'="" S IBX=IBPCVA_" "_$P(IBPC,U,1),IBY=$$SETFLD^VALM1(IBX,IBY,"PRVPC") D SET(IBY) S IBY=""
  1. .. I $P(IBPC,U,2)'="" S IBX=" "_$P(IBPC,U,2),IBY=$$SETFLD^VALM1(IBX,IBY,"PRVPC") D SET(IBY) S IBY=""
  1. .. I $P(IBPC,U,3)'="" S IBX=" "_$P(IBPC,U,3),IBY=$$SETFLD^VALM1(IBX,IBY,"PRVPC") D SET(IBY) S IBY=""
  1. . I IBY'="" D SET(IBY) S IBY=""
  1. ;
  1. I VALMCNT=0 D SET(" "),SET("No Provider Discounts for this Group")
  1. ;
  1. K ^TMP($J,"IBCRLN")
  1. Q
  1. ;
  1. ;
  1. SET(X,PDFN) ; set up list manager screen array
  1. S VALMCNT=VALMCNT+1
  1. S ^TMP("IBCRLN",$J,VALMCNT,0)=X
  1. I +$G(PDFN) S ^TMP("IBCRLNX1",$J,+PDFN)=VALMCNT
  1. Q
  1. ;
  1. SORT ; sort the provider discount group by Provider Type then VA Code (IBSGFN expected)
  1. N IBPDFN,IBPD0,IBPDN,IBPCFN,IBPCVA
  1. S IBPDFN=0 F S IBPDFN=$O(^IBE(363.34,IBPDFN)) Q:'IBPDFN D
  1. . S IBPD0=$G(^IBE(363.34,IBPDFN,0)),IBPDN=$P(IBPD0,U,1)_" " I $P(IBPD0,U,2)'=+$G(IBSGFN) Q
  1. . S ^TMP($J,"IBCRLN",IBPDN)=IBPDFN
  1. . S IBPCFN=0 F S IBPCFN=$O(^IBE(363.34,IBPDFN,11,"B",IBPCFN)) Q:'IBPCFN D
  1. .. S IBPCVA=$$IEN2CODE^XUA4A72(IBPCFN)_" "
  1. .. S ^TMP($J,"IBCRLN",IBPDN,IBPCVA)=IBPCFN
  1. Q