- 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 Feb 18, 2025@23:46:06 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