IBCRLG ;ALB/ARH - RATES: DISPLAY BILLING REGIONS ; 16-MAY-1996
;;2.0;INTEGRATED BILLING;**52,115,138,245**;21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
EN ; -- main entry point for IBCR BILLING REGION
D EN^VALM("IBCR BILLING REGION")
Q
;
HDR ; -- header code
S VALMHDR(1)="Regions/localities covered by the same charges"
Q
;
INIT ; -- init variables and list array
K ^TMP("IBCRLG",$J)
D BLD
Q
;
HELP ; -- help code
S X="?" D DISP^XQORM1 W !!
Q
;
EXIT ; -- exit code
K ^TMP("IBCRLG",$J)
D CLEAR^VALM1,CLEAN^VALM10
Q
;
BLD ; build LM array for billing region display
N IBRGN,IBRGFN,IBRG0,IBDVN,IBDV0,IBX,IBY,IBIST,IBIS0 S VALMCNT=0
;
; create LM display array
S IBRGN="" F S IBRGN=$O(^IBE(363.31,"B",IBRGN)) Q:IBRGN="" D
. S IBRGFN=0 F S IBRGFN=$O(^IBE(363.31,"B",IBRGN,IBRGFN)) Q:'IBRGFN D
.. S IBRG0=$G(^IBE(363.31,IBRGFN,0)) Q:IBRG0=""
.. D SET("") S IBY=""
.. ;
.. S IBX=$P(IBRG0,U,1),IBY=$$SETFLD^VALM1(IBX,IBY,"REGN")
.. S IBX=$P(IBRG0,U,2)_"-"_$P(IBRG0,U,3),IBY=$$SETFLD^VALM1(IBX,IBY,"ID")
.. ;
.. S IBDVN=0 F S IBDVN=$O(^IBE(363.31,IBRGFN,11,IBDVN)) Q:'IBDVN D
... S IBDV0=$G(^IBE(363.31,IBRGFN,11,IBDVN,0)) Q:IBDV0=""
... ;
... I IBY'="" S IBX=$J("Division:",12),IBY=$$SETFLD^VALM1(IBX,IBY,"TYPE")
... S IBX=$G(^DG(40.8,+IBDV0,0)),IBX=$E(($P(IBX,U,2)_" "),1,6)_$P(IBX,U,1),IBY=$$SETFLD^VALM1(IBX,IBY,"DI")
... ;
... D SET(IBY) S IBY=""
.. ;
.. ; institutions for transfer pricing
.. S IBIST=0 F S IBIST=$O(^IBE(363.31,IBRGFN,21,IBIST)) Q:'IBIST D
... S IBIS0=$G(^IBE(363.31,IBRGFN,21,IBIST,0)) Q:IBIS0=""
... ;
... I IBY'="" S IBX=$J("Institution:",12),IBY=$$SETFLD^VALM1(IBX,IBY,"TYPE")
... S IBX=$P($$NNT^XUAF4(+IBIS0),U,1),IBY=$$SETFLD^VALM1(IBX,IBY,"DI")
... ;
... D SET(IBY) S IBY=""
.. ;
.. I IBY'="" D SET(IBY)
;
I VALMCNT=0 D SET(" "),SET("No Billing Regions defined")
;
Q
;
SET(X) ; set up list manager screen array
S VALMCNT=VALMCNT+1
S ^TMP("IBCRLG",$J,VALMCNT,0)=X
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCRLG 2054 printed Oct 16, 2024@18:20:22 Page 2
IBCRLG ;ALB/ARH - RATES: DISPLAY BILLING REGIONS ; 16-MAY-1996
+1 ;;2.0;INTEGRATED BILLING;**52,115,138,245**;21-MAR-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
EN ; -- main entry point for IBCR BILLING REGION
+1 DO EN^VALM("IBCR BILLING REGION")
+2 QUIT
+3 ;
HDR ; -- header code
+1 SET VALMHDR(1)="Regions/localities covered by the same charges"
+2 QUIT
+3 ;
INIT ; -- init variables and list array
+1 KILL ^TMP("IBCRLG",$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("IBCRLG",$JOB)
+2 DO CLEAR^VALM1
DO CLEAN^VALM10
+3 QUIT
+4 ;
BLD ; build LM array for billing region display
+1 NEW IBRGN,IBRGFN,IBRG0,IBDVN,IBDV0,IBX,IBY,IBIST,IBIS0
SET VALMCNT=0
+2 ;
+3 ; create LM display array
+4 SET IBRGN=""
FOR
SET IBRGN=$ORDER(^IBE(363.31,"B",IBRGN))
if IBRGN=""
QUIT
Begin DoDot:1
+5 SET IBRGFN=0
FOR
SET IBRGFN=$ORDER(^IBE(363.31,"B",IBRGN,IBRGFN))
if 'IBRGFN
QUIT
Begin DoDot:2
+6 SET IBRG0=$GET(^IBE(363.31,IBRGFN,0))
if IBRG0=""
QUIT
+7 DO SET("")
SET IBY=""
+8 ;
+9 SET IBX=$PIECE(IBRG0,U,1)
SET IBY=$$SETFLD^VALM1(IBX,IBY,"REGN")
+10 SET IBX=$PIECE(IBRG0,U,2)_"-"_$PIECE(IBRG0,U,3)
SET IBY=$$SETFLD^VALM1(IBX,IBY,"ID")
+11 ;
+12 SET IBDVN=0
FOR
SET IBDVN=$ORDER(^IBE(363.31,IBRGFN,11,IBDVN))
if 'IBDVN
QUIT
Begin DoDot:3
+13 SET IBDV0=$GET(^IBE(363.31,IBRGFN,11,IBDVN,0))
if IBDV0=""
QUIT
+14 ;
+15 IF IBY'=""
SET IBX=$JUSTIFY("Division:",12)
SET IBY=$$SETFLD^VALM1(IBX,IBY,"TYPE")
+16 SET IBX=$GET(^DG(40.8,+IBDV0,0))
SET IBX=$EXTRACT(($PIECE(IBX,U,2)_" "),1,6)_$PIECE(IBX,U,1)
SET IBY=$$SETFLD^VALM1(IBX,IBY,"DI")
+17 ;
+18 DO SET(IBY)
SET IBY=""
End DoDot:3
+19 ;
+20 ; institutions for transfer pricing
+21 SET IBIST=0
FOR
SET IBIST=$ORDER(^IBE(363.31,IBRGFN,21,IBIST))
if 'IBIST
QUIT
Begin DoDot:3
+22 SET IBIS0=$GET(^IBE(363.31,IBRGFN,21,IBIST,0))
if IBIS0=""
QUIT
+23 ;
+24 IF IBY'=""
SET IBX=$JUSTIFY("Institution:",12)
SET IBY=$$SETFLD^VALM1(IBX,IBY,"TYPE")
+25 SET IBX=$PIECE($$NNT^XUAF4(+IBIS0),U,1)
SET IBY=$$SETFLD^VALM1(IBX,IBY,"DI")
+26 ;
+27 DO SET(IBY)
SET IBY=""
End DoDot:3
+28 ;
+29 IF IBY'=""
DO SET(IBY)
End DoDot:2
End DoDot:1
+30 ;
+31 IF VALMCNT=0
DO SET(" ")
DO SET("No Billing Regions defined")
+32 ;
+33 QUIT
+34 ;
SET(X) ; set up list manager screen array
+1 SET VALMCNT=VALMCNT+1
+2 SET ^TMP("IBCRLG",$JOB,VALMCNT,0)=X
+3 QUIT
