IBCRLL ;ALB/ARH - RATES: DISPLAY SPECIAL GROUPS ; 10-OCT-1998
;;2.0;INTEGRATED BILLING;**106**;21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
EN ; -- main entry point for IBCR SPECIAL GROUPS
D EN^VALM("IBCR SPECIAL GROUPS")
Q
;
HDR ; -- header code
S VALMHDR(1)=" "
Q
;
INIT ; -- init variables and list array
K ^TMP("IBCRLL",$J)
D BLD
Q
;
HELP ; -- help code
S X="?" D DISP^XQORM1 W !!
Q
;
EXIT ; -- exit code
K ^TMP("IBCRLL",$J)
D CLEAR^VALM1,CLEAN^VALM10
Q
;
BLD ; build charge set display array
N IBTYNM,IBSGNM,IBSGFN,IBSGFN1,IBSG10,IBX,IBY S VALMCNT=0 K ^TMP($J,"IBCRXL")
;
D SORTSG
;
; create LM display array
S IBTYNM="" F S IBTYNM=$O(^TMP($J,"IBCRXL",IBTYNM)) Q:IBTYNM="" D
. ;
. D SET("") S IBY=" Group Type: "_IBTYNM
. D SET(IBY) D CNTRL^VALM10(VALMCNT,1,80,IOINHI,IOINORM) D SET("")
. ;
. S IBSGNM="" F S IBSGNM=$O(^TMP($J,"IBCRXL",IBTYNM,IBSGNM)) Q:IBSGNM="" D
.. ;
.. S IBY="",IBX=IBSGNM,IBY=$$SETFLD^VALM1(IBX,IBY,"GRP")
.. ;
.. S IBSGFN=$G(^TMP($J,"IBCRXL",IBTYNM,IBSGNM)) Q:'IBSGFN
.. S IBSGFN1=0 F S IBSGFN1=$O(^IBE(363.32,IBSGFN,11,IBSGFN1)) Q:'IBSGFN1 D
... ;
... S IBSG10=$G(^IBE(363.32,IBSGFN,11,IBSGFN1,0)) Q:'IBSG10
... S IBX=$P($G(^IBE(363.3,+IBSG10,0)),U,1),IBY=$$SETFLD^VALM1(IBX,IBY,"BR")
... I +$P(IBSG10,U,2) S IBX=$P($G(^IBE(363.1,+$P(IBSG10,U,2),0)),U,1),IBY=$$SETFLD^VALM1(IBX,IBY,"CS")
... S IBX=$P(IBSG10,U,3),IBY=$$SETFLD^VALM1(IBX,IBY,"ORD")
... D SET(IBY) S IBY=""
.. I IBY'="" D SET(IBY) S IBY=""
;
I VALMCNT=0 D SET(" "),SET("No Special Groups")
;
K ^TMP($J,"IBCRXL")
Q
;
;
SET(X) ; set up list manager screen array
S VALMCNT=VALMCNT+1
S ^TMP("IBCRLL",$J,VALMCNT,0)=X
Q
;
SORTSG ; created array of all Special Link Groups sorted by Type and Name
; ^TMP($J,"IBCRXL", group type name) = group type set value
; ^TMP($J,"IBCRXL", group type name, group name) = group name IFN
N IBSGFN,IBSGNM,IBTYNM,IBLN
S IBSGFN=0 F S IBSGFN=$O(^IBE(363.32,IBSGFN)) Q:'IBSGFN D
. S IBLN=$G(^IBE(363.32,IBSGFN,0))
. S IBSGNM=$P(IBLN,U,1) I IBSGNM="" S IBSGNM=" "
. S IBTYNM=$$EXPAND^IBCRU1(363.32,.02,$P(IBLN,U,2)) I IBTYNM="" S IBTYNM=" "
. S ^TMP($J,"IBCRXL",IBTYNM)=$P(IBLN,U,2)
. S ^TMP($J,"IBCRXL",IBTYNM,IBSGNM)=IBSGFN
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCRLL 2331 printed Apr 09, 2024@21:17:52 Page 2
IBCRLL ;ALB/ARH - RATES: DISPLAY SPECIAL GROUPS ; 10-OCT-1998
+1 ;;2.0;INTEGRATED BILLING;**106**;21-MAR-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
EN ; -- main entry point for IBCR SPECIAL GROUPS
+1 DO EN^VALM("IBCR SPECIAL GROUPS")
+2 QUIT
+3 ;
HDR ; -- header code
+1 SET VALMHDR(1)=" "
+2 QUIT
+3 ;
INIT ; -- init variables and list array
+1 KILL ^TMP("IBCRLL",$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("IBCRLL",$JOB)
+2 DO CLEAR^VALM1
DO CLEAN^VALM10
+3 QUIT
+4 ;
BLD ; build charge set display array
+1 NEW IBTYNM,IBSGNM,IBSGFN,IBSGFN1,IBSG10,IBX,IBY
SET VALMCNT=0
KILL ^TMP($JOB,"IBCRXL")
+2 ;
+3 DO SORTSG
+4 ;
+5 ; create LM display array
+6 SET IBTYNM=""
FOR
SET IBTYNM=$ORDER(^TMP($JOB,"IBCRXL",IBTYNM))
if IBTYNM=""
QUIT
Begin DoDot:1
+7 ;
+8 DO SET("")
SET IBY=" Group Type: "_IBTYNM
+9 DO SET(IBY)
DO CNTRL^VALM10(VALMCNT,1,80,IOINHI,IOINORM)
DO SET("")
+10 ;
+11 SET IBSGNM=""
FOR
SET IBSGNM=$ORDER(^TMP($JOB,"IBCRXL",IBTYNM,IBSGNM))
if IBSGNM=""
QUIT
Begin DoDot:2
+12 ;
+13 SET IBY=""
SET IBX=IBSGNM
SET IBY=$$SETFLD^VALM1(IBX,IBY,"GRP")
+14 ;
+15 SET IBSGFN=$GET(^TMP($JOB,"IBCRXL",IBTYNM,IBSGNM))
if 'IBSGFN
QUIT
+16 SET IBSGFN1=0
FOR
SET IBSGFN1=$ORDER(^IBE(363.32,IBSGFN,11,IBSGFN1))
if 'IBSGFN1
QUIT
Begin DoDot:3
+17 ;
+18 SET IBSG10=$GET(^IBE(363.32,IBSGFN,11,IBSGFN1,0))
if 'IBSG10
QUIT
+19 SET IBX=$PIECE($GET(^IBE(363.3,+IBSG10,0)),U,1)
SET IBY=$$SETFLD^VALM1(IBX,IBY,"BR")
+20 IF +$PIECE(IBSG10,U,2)
SET IBX=$PIECE($GET(^IBE(363.1,+$PIECE(IBSG10,U,2),0)),U,1)
SET IBY=$$SETFLD^VALM1(IBX,IBY,"CS")
+21 SET IBX=$PIECE(IBSG10,U,3)
SET IBY=$$SETFLD^VALM1(IBX,IBY,"ORD")
+22 DO SET(IBY)
SET IBY=""
End DoDot:3
+23 IF IBY'=""
DO SET(IBY)
SET IBY=""
End DoDot:2
End DoDot:1
+24 ;
+25 IF VALMCNT=0
DO SET(" ")
DO SET("No Special Groups")
+26 ;
+27 KILL ^TMP($JOB,"IBCRXL")
+28 QUIT
+29 ;
+30 ;
SET(X) ; set up list manager screen array
+1 SET VALMCNT=VALMCNT+1
+2 SET ^TMP("IBCRLL",$JOB,VALMCNT,0)=X
+3 QUIT
+4 ;
SORTSG ; created array of all Special Link Groups sorted by Type and Name
+1 ; ^TMP($J,"IBCRXL", group type name) = group type set value
+2 ; ^TMP($J,"IBCRXL", group type name, group name) = group name IFN
+3 NEW IBSGFN,IBSGNM,IBTYNM,IBLN
+4 SET IBSGFN=0
FOR
SET IBSGFN=$ORDER(^IBE(363.32,IBSGFN))
if 'IBSGFN
QUIT
Begin DoDot:1
+5 SET IBLN=$GET(^IBE(363.32,IBSGFN,0))
+6 SET IBSGNM=$PIECE(IBLN,U,1)
IF IBSGNM=""
SET IBSGNM=" "
+7 SET IBTYNM=$$EXPAND^IBCRU1(363.32,.02,$PIECE(IBLN,U,2))
IF IBTYNM=""
SET IBTYNM=" "
+8 SET ^TMP($JOB,"IBCRXL",IBTYNM)=$PIECE(IBLN,U,2)
+9 SET ^TMP($JOB,"IBCRXL",IBTYNM,IBSGNM)=IBSGFN
End DoDot:1
+10 QUIT
