IBCNRPM2 ;BHAM ISC/CMW - Match Multiple Group Plans to a Pharmacy Plan ;10-MAR-2004
;;2.0;INTEGRATED BILLING;**251,276,550,617,711,712**;21-MAR-94;Build 14
;;Per VA Directive 6402, this routine should not be modified.
;; ;
EN(IBCNRP,IBCNRI,IBCNRGP) ; -- main entry point for IBCNR PAYERSHEET MATCH (LIST TEMPLATE)
D EN^VALM("IBCNR GROUP PLAN MATCH")
Q
;
HDR ; -- header code
NEW IBCNR0,IBCNRID,IBCNRNM,IBCNR10,IBCNRPBM,IBCNRBIN,IBCNRPCN,IBLEAD
NEW IBCNR3,IBCNRIN,NST,LST,X
; get pharmacy plan data
S IBCNR0=$G(^IBCNR(366.03,+IBCNRP,0))
S IBCNRID=$P(IBCNR0,"^",1) ;id
S IBCNRNM=$P(IBCNR0,"^",2) ;name
S IBCNR10=$G(^IBCNR(366.03,+IBCNRP,10))
S IBCNRPBM=$P(IBCNR10,"^",1) ;pbm
S IBCNRBIN=$P(IBCNR10,"^",2) ;bin
S IBCNRPCN=$P(IBCNR10,"^",3) ;pcn
S IBCNR3=$G(^IBCNR(366.03,+IBCNRP,3,1,0)) ; appl
S NST=$S($P(IBCNR3,"^",2)=0:"Inactive ",1:"Active ")
S LST=$S($P(IBCNR3,"^",3)=0:"Inactive ",1:"Active ")
; get insurance company name
S IBCNRIN=$P($G(^DIC(36,IBCNRI,0)),U)
; row 1
S IBLEAD="FOR PHARMACY PLAN: "
S X=IBCNRNM_" - "_IBCNRID
S VALMHDR(1)=$$SETSTR^VALM1(X,IBLEAD,$L(IBLEAD)+1,80)
; row 2
S IBLEAD="BIN: "_IBCNRBIN
S X=" PCN: "_IBCNRPCN_" STATUS: National "_NST_"/Local "_LST
S VALMHDR(2)=$$SETSTR^VALM1(X,IBLEAD,$L(IBLEAD)+1,80)
; row 3
;S X="STATUS: National "_NST_"/"
;S VALMHDR(3)=$$SETSTR^VALM1("Local "_LST,X,$L(X)+1,80)
; row 4
S X="FOR INSURANCE COMPANY: "
S VALMHDR(4)=$$SETSTR^VALM1(IBCNRIN,X,$L(X)+1,80)
;
Q
;
INIT ; -- init variables and list array
;
I '$D(^TMP("IBCNR",$J,"GP")) D Q
. S VALMCNT=0
. W !,*7,"Warning: No Active Group Plans with Pharmacy Coverage Found."
;
N GPIEN,IBGP0,IBCPOLD,X,IBCPD6,IBCNRPP,IBCOV,IBCRVD,LIM
N IBGNA,IBGNM,IBCNA,IBCNM,IBDAT,MATCH,UNMATCH
K ^TMP("IBCNR",$J,"PM")
S VALMCNT=0,VALMBG=1,(IBCNA,IBCNM,GPIEN)=""
S VALMCNT1=0
S (IBIND,IBMULT,IBW)=1
S MATCH=""
F S MATCH=$O(^TMP("IBCNR",$J,"GP",MATCH)) Q:MATCH="" D
.I MATCH=0 D
.. S VALMCNT=VALMCNT+1
.. S ^TMP("IBCNR",$J,"PM",VALMCNT,0)=" *** "_^TMP("IBCNR",$J,"GP",MATCH)_" UNMATCHED ***"
.. D CNTRL^VALM10(VALMCNT,1,80,IORVON,IORVOFF,0)
.. S ^TMP("IBCNR",$J,"PM","IDX",VALMCNT,1)=""
.. S UNMATCH=^TMP("IBCNR",$J,"GP",MATCH)
.I MATCH=1 D
.. S VALMCNT=VALMCNT+1
.. S ^TMP("IBCNR",$J,"PM",VALMCNT,0)=""
.. S ^TMP("IBCNR",$J,"PM","IDX",VALMCNT,UNMATCH)=""
.. S VALMCNT=VALMCNT+1
.. S ^TMP("IBCNR",$J,"PM",VALMCNT,0)=" *** "_^TMP("IBCNR",$J,"GP",MATCH)_" MATCHED ***"
.. D CNTRL^VALM10(VALMCNT,1,80,IORVON,IORVOFF,0)
.. S ^TMP("IBCNR",$J,"PM","IDX",VALMCNT,UNMATCH)=""
.F S IBCNA=$O(^TMP("IBCNR",$J,"GP",MATCH,IBCNA)) Q:IBCNA="" D
.. F S IBCNM=$O(^TMP("IBCNR",$J,"GP",MATCH,IBCNA,IBCNM)) Q:IBCNM="" D
... ;get pharm plan id
... F S GPIEN=$O(^TMP("IBCNR",$J,"GP",MATCH,IBCNA,IBCNM,GPIEN)) Q:GPIEN="" D
.... S IBDAT=^TMP("IBCNR",$J,"GP",MATCH,IBCNA,IBCNM,GPIEN)
.... ;set up list
.... S VALMCNT=VALMCNT+1
.... S VALMCNT1=VALMCNT1+1
.... S X=$$SETFLD^VALM1(VALMCNT1,"","NUMBER")
.... ;
.... ;group name
.... S X=$$SETFLD^VALM1(IBCNA,X,"GNAME")
.... ;
.... ;group number
.... S X=$$SETFLD^VALM1(IBCNM,X,"GNUM")
.... ;
.... ;group plan type
.... S X=$$SETFLD^VALM1($$EXPAND^IBTRE(355.3,.09,$P(IBDAT,"^",2)),X,"GTYP")
.... ;
.... ;pharmacy plan ID
.... S IBCNRPP=$P($G(IBDAT),U)
.... I IBCNRPP'="" S IBCNRPP=$$GET1^DIQ(366.03,IBCNRPP_",",.01,"E")
.... S X=$$SETFLD^VALM1(IBCNRPP,X,"PHRM")
.... ;
.... ; set up tmp for SEL
.... S ^TMP("IBCNR",$J,"PM",VALMCNT,0)=X
.... S ^TMP("IBCNR",$J,"PM","IDX",VALMCNT,VALMCNT1)=GPIEN
.... S ^TMP("IBCNR",$J,"PM","IDX1",VALMCNT1)=GPIEN
.... ;
.... I IBCNRPP'="" D ; If VA PLAN ID exists
..... I $P(IBDAT,"^",3)'="" D ; If Matched Date exists
...... S X=" Matched by: "_$P(IBDAT,"^",4)_" "_$P(IBDAT,"^",3)
...... S VALMCNT=VALMCNT+1
...... S ^TMP("IBCNR",$J,"PM",VALMCNT,0)=X
...... S ^TMP("IBCNR",$J,"PM","IDX",VALMCNT,VALMCNT1)=GPIEN
...... S ^TMP("IBCNR",$J,"PM","IDX1",VALMCNT1)=GPIEN
.... I IBCNRPP="" D ; If VA PLAN ID does not exist
..... I $P(IBDAT,"^",3)'="" D ; Match Date w/no Plan ID means Deleted
...... S X=" Deleted by: "_$P(IBDAT,"^",4)_" "_$P(IBDAT,"^",3)
...... S VALMCNT=VALMCNT+1
...... S ^TMP("IBCNR",$J,"PM",VALMCNT,0)=X
...... S ^TMP("IBCNR",$J,"PM","IDX",VALMCNT,VALMCNT1)=GPIEN
...... S ^TMP("IBCNR",$J,"PM","IDX1",VALMCNT1)=GPIEN
;
Q
;
HELP ; -- help code
S X="?" D DISP^XQORM1 W !!
Q
;
EXIT ; -- exit code
K ^TMP("IBCNR",$J,"PM"),VALMBCK,VALMY
K IBIND,IBMULT,IBW,IBX
D CLEAN^VALM10,CLEAR^VALM1
Q
;
EXPND ; -- expand code
Q
;
SEL ; Select Plan
;
D S1
;
I 'IBX Q ; no group selected
;
N DA,DIC,DIE,DR,D,IBSEL,IBPLNOLD,IBUSROLD
S IBX=0
F S IBX=$O(VALMY(IBX)) Q:IBX="" D
. ;S IBSEL=+$G(^TMP("IBCNR",$J,"PM","IDX",IBX,IBX))
. S IBSEL=+$G(^TMP("IBCNR",$J,"PM","IDX1",IBX))
. S IBPLNOLD=$$GET1^DIQ(355.3,IBSEL,6.01,"I")
. S IBUSROLD=$$GET1^DIQ(355.3,IBSEL,1.08)
. S DA=IBSEL,DIC="^IBA(355.3,",DIE=DIC,DR="6.01////^S X="_IBCNRP
. ;S DR=DR_";1.07///NOW;1.08////"_DUZ
. I IBPLNOLD'=IBCNRP S DR=DR_";1.07///NOW;1.08////"_DUZ
. I IBPLNOLD=IBCNRP,IBUSROLD="" S DR=DR_";1.07///NOW;1.08////"_DUZ
. D ^DIE
D GIPF^IBCNRPM1
D CLEAN^VALM10
D INIT
;
S IBX=0 F S IBX=$O(VALMY(IBX)) Q:'IBX D
. S ^TMP($J,"IBSEL",+$G(^TMP("IBCNR",$J,"PM","IDX",IBX,IBX)))=""
;
Q
;
DEL ; remove a plan from a group
D S1
;
I 'IBX Q ; no group selected
;
NEW DA,DIC,DIE,DR,IBSEL,IBPLNOLD
S IBX=0
F S IBX=$O(VALMY(IBX)) Q:IBX="" D
. ;S IBSEL=+$G(^TMP("IBCNR",$J,"PM","IDX",IBX,IBX))
. S IBSEL=+$G(^TMP("IBCNR",$J,"PM","IDX1",IBX))
. S IBPLNOLD=$$GET1^DIQ(355.3,IBSEL,6.01,"I")
. S DA=IBSEL,DIC="^IBA(355.3,",DIE=DIC,DR="6.01///@"
. I IBPLNOLD'="" S DR=DR_";1.07///NOW;1.08////"_DUZ
. D ^DIE
D GIPF^IBCNRPM1
D CLEAN^VALM10
D INIT
;
S IBX=0 F S IBX=$O(VALMY(IBX)) Q:'IBX S ^TMP($J,"IBDEL",+$G(^TMP("IBCNR",$J,"PM","IDX",IBX,IBX)))=""
;
Q
;
S1 N DIR,DIRUT,DUOUT,DTOUT,DIROUT,IBOK,IBQUIT,Y,X
D EN^VALM2($G(XQORNOD(0))),FULL^VALM1
S IBX=$O(VALMY(0)),VALMBCK="R"
;
I 'IBX W !!,"No group selected!" D PAUSE^VALM1 Q
I 'IBMULT D G SPQ
. D OK^IBCNSM3
. I IBQUIT S VALMBCK="Q" Q
. I IBOK S IBSEL=+$G(^TMP("IBCNR",$J,"PM","IDX",IBX)),VALMBCK="Q"
;
;S IBSEL=+$G(^TMP("IBCNR",$J,"PM","IDX",IBX))
;Q
;
SPQ ;
S DIR(0)="SB^Y:YES;N:NO",DIR("B")="NO",DIR("A")="OK to Continue? "
D ^DIR K DIR
I $G(Y)="^" S IBX="" Q
I $G(Y(0))="NO" S IBX=""
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCNRPM2 6629 printed Dec 13, 2024@02:16:24 Page 2
IBCNRPM2 ;BHAM ISC/CMW - Match Multiple Group Plans to a Pharmacy Plan ;10-MAR-2004
+1 ;;2.0;INTEGRATED BILLING;**251,276,550,617,711,712**;21-MAR-94;Build 14
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;; ;
EN(IBCNRP,IBCNRI,IBCNRGP) ; -- main entry point for IBCNR PAYERSHEET MATCH (LIST TEMPLATE)
+1 DO EN^VALM("IBCNR GROUP PLAN MATCH")
+2 QUIT
+3 ;
HDR ; -- header code
+1 NEW IBCNR0,IBCNRID,IBCNRNM,IBCNR10,IBCNRPBM,IBCNRBIN,IBCNRPCN,IBLEAD
+2 NEW IBCNR3,IBCNRIN,NST,LST,X
+3 ; get pharmacy plan data
+4 SET IBCNR0=$GET(^IBCNR(366.03,+IBCNRP,0))
+5 ;id
SET IBCNRID=$PIECE(IBCNR0,"^",1)
+6 ;name
SET IBCNRNM=$PIECE(IBCNR0,"^",2)
+7 SET IBCNR10=$GET(^IBCNR(366.03,+IBCNRP,10))
+8 ;pbm
SET IBCNRPBM=$PIECE(IBCNR10,"^",1)
+9 ;bin
SET IBCNRBIN=$PIECE(IBCNR10,"^",2)
+10 ;pcn
SET IBCNRPCN=$PIECE(IBCNR10,"^",3)
+11 ; appl
SET IBCNR3=$GET(^IBCNR(366.03,+IBCNRP,3,1,0))
+12 SET NST=$SELECT($PIECE(IBCNR3,"^",2)=0:"Inactive ",1:"Active ")
+13 SET LST=$SELECT($PIECE(IBCNR3,"^",3)=0:"Inactive ",1:"Active ")
+14 ; get insurance company name
+15 SET IBCNRIN=$PIECE($GET(^DIC(36,IBCNRI,0)),U)
+16 ; row 1
+17 SET IBLEAD="FOR PHARMACY PLAN: "
+18 SET X=IBCNRNM_" - "_IBCNRID
+19 SET VALMHDR(1)=$$SETSTR^VALM1(X,IBLEAD,$LENGTH(IBLEAD)+1,80)
+20 ; row 2
+21 SET IBLEAD="BIN: "_IBCNRBIN
+22 SET X=" PCN: "_IBCNRPCN_" STATUS: National "_NST_"/Local "_LST
+23 SET VALMHDR(2)=$$SETSTR^VALM1(X,IBLEAD,$LENGTH(IBLEAD)+1,80)
+24 ; row 3
+25 ;S X="STATUS: National "_NST_"/"
+26 ;S VALMHDR(3)=$$SETSTR^VALM1("Local "_LST,X,$L(X)+1,80)
+27 ; row 4
+28 SET X="FOR INSURANCE COMPANY: "
+29 SET VALMHDR(4)=$$SETSTR^VALM1(IBCNRIN,X,$LENGTH(X)+1,80)
+30 ;
+31 QUIT
+32 ;
INIT ; -- init variables and list array
+1 ;
+2 IF '$DATA(^TMP("IBCNR",$JOB,"GP"))
Begin DoDot:1
+3 SET VALMCNT=0
+4 WRITE !,*7,"Warning: No Active Group Plans with Pharmacy Coverage Found."
End DoDot:1
QUIT
+5 ;
+6 NEW GPIEN,IBGP0,IBCPOLD,X,IBCPD6,IBCNRPP,IBCOV,IBCRVD,LIM
+7 NEW IBGNA,IBGNM,IBCNA,IBCNM,IBDAT,MATCH,UNMATCH
+8 KILL ^TMP("IBCNR",$JOB,"PM")
+9 SET VALMCNT=0
SET VALMBG=1
SET (IBCNA,IBCNM,GPIEN)=""
+10 SET VALMCNT1=0
+11 SET (IBIND,IBMULT,IBW)=1
+12 SET MATCH=""
+13 FOR
SET MATCH=$ORDER(^TMP("IBCNR",$JOB,"GP",MATCH))
if MATCH=""
QUIT
Begin DoDot:1
+14 IF MATCH=0
Begin DoDot:2
+15 SET VALMCNT=VALMCNT+1
+16 SET ^TMP("IBCNR",$JOB,"PM",VALMCNT,0)=" *** "_^TMP("IBCNR",$JOB,"GP",MATCH)_" UNMATCHED ***"
+17 DO CNTRL^VALM10(VALMCNT,1,80,IORVON,IORVOFF,0)
+18 SET ^TMP("IBCNR",$JOB,"PM","IDX",VALMCNT,1)=""
+19 SET UNMATCH=^TMP("IBCNR",$JOB,"GP",MATCH)
End DoDot:2
+20 IF MATCH=1
Begin DoDot:2
+21 SET VALMCNT=VALMCNT+1
+22 SET ^TMP("IBCNR",$JOB,"PM",VALMCNT,0)=""
+23 SET ^TMP("IBCNR",$JOB,"PM","IDX",VALMCNT,UNMATCH)=""
+24 SET VALMCNT=VALMCNT+1
+25 SET ^TMP("IBCNR",$JOB,"PM",VALMCNT,0)=" *** "_^TMP("IBCNR",$JOB,"GP",MATCH)_" MATCHED ***"
+26 DO CNTRL^VALM10(VALMCNT,1,80,IORVON,IORVOFF,0)
+27 SET ^TMP("IBCNR",$JOB,"PM","IDX",VALMCNT,UNMATCH)=""
End DoDot:2
+28 FOR
SET IBCNA=$ORDER(^TMP("IBCNR",$JOB,"GP",MATCH,IBCNA))
if IBCNA=""
QUIT
Begin DoDot:2
+29 FOR
SET IBCNM=$ORDER(^TMP("IBCNR",$JOB,"GP",MATCH,IBCNA,IBCNM))
if IBCNM=""
QUIT
Begin DoDot:3
+30 ;get pharm plan id
+31 FOR
SET GPIEN=$ORDER(^TMP("IBCNR",$JOB,"GP",MATCH,IBCNA,IBCNM,GPIEN))
if GPIEN=""
QUIT
Begin DoDot:4
+32 SET IBDAT=^TMP("IBCNR",$JOB,"GP",MATCH,IBCNA,IBCNM,GPIEN)
+33 ;set up list
+34 SET VALMCNT=VALMCNT+1
+35 SET VALMCNT1=VALMCNT1+1
+36 SET X=$$SETFLD^VALM1(VALMCNT1,"","NUMBER")
+37 ;
+38 ;group name
+39 SET X=$$SETFLD^VALM1(IBCNA,X,"GNAME")
+40 ;
+41 ;group number
+42 SET X=$$SETFLD^VALM1(IBCNM,X,"GNUM")
+43 ;
+44 ;group plan type
+45 SET X=$$SETFLD^VALM1($$EXPAND^IBTRE(355.3,.09,$PIECE(IBDAT,"^",2)),X,"GTYP")
+46 ;
+47 ;pharmacy plan ID
+48 SET IBCNRPP=$PIECE($GET(IBDAT),U)
+49 IF IBCNRPP'=""
SET IBCNRPP=$$GET1^DIQ(366.03,IBCNRPP_",",.01,"E")
+50 SET X=$$SETFLD^VALM1(IBCNRPP,X,"PHRM")
+51 ;
+52 ; set up tmp for SEL
+53 SET ^TMP("IBCNR",$JOB,"PM",VALMCNT,0)=X
+54 SET ^TMP("IBCNR",$JOB,"PM","IDX",VALMCNT,VALMCNT1)=GPIEN
+55 SET ^TMP("IBCNR",$JOB,"PM","IDX1",VALMCNT1)=GPIEN
+56 ;
+57 ; If VA PLAN ID exists
IF IBCNRPP'=""
Begin DoDot:5
+58 ; If Matched Date exists
IF $PIECE(IBDAT,"^",3)'=""
Begin DoDot:6
+59 SET X=" Matched by: "_$PIECE(IBDAT,"^",4)_" "_$PIECE(IBDAT,"^",3)
+60 SET VALMCNT=VALMCNT+1
+61 SET ^TMP("IBCNR",$JOB,"PM",VALMCNT,0)=X
+62 SET ^TMP("IBCNR",$JOB,"PM","IDX",VALMCNT,VALMCNT1)=GPIEN
+63 SET ^TMP("IBCNR",$JOB,"PM","IDX1",VALMCNT1)=GPIEN
End DoDot:6
End DoDot:5
+64 ; If VA PLAN ID does not exist
IF IBCNRPP=""
Begin DoDot:5
+65 ; Match Date w/no Plan ID means Deleted
IF $PIECE(IBDAT,"^",3)'=""
Begin DoDot:6
+66 SET X=" Deleted by: "_$PIECE(IBDAT,"^",4)_" "_$PIECE(IBDAT,"^",3)
+67 SET VALMCNT=VALMCNT+1
+68 SET ^TMP("IBCNR",$JOB,"PM",VALMCNT,0)=X
+69 SET ^TMP("IBCNR",$JOB,"PM","IDX",VALMCNT,VALMCNT1)=GPIEN
+70 SET ^TMP("IBCNR",$JOB,"PM","IDX1",VALMCNT1)=GPIEN
End DoDot:6
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+71 ;
+72 QUIT
+73 ;
HELP ; -- help code
+1 SET X="?"
DO DISP^XQORM1
WRITE !!
+2 QUIT
+3 ;
EXIT ; -- exit code
+1 KILL ^TMP("IBCNR",$JOB,"PM"),VALMBCK,VALMY
+2 KILL IBIND,IBMULT,IBW,IBX
+3 DO CLEAN^VALM10
DO CLEAR^VALM1
+4 QUIT
+5 ;
EXPND ; -- expand code
+1 QUIT
+2 ;
SEL ; Select Plan
+1 ;
+2 DO S1
+3 ;
+4 ; no group selected
IF 'IBX
QUIT
+5 ;
+6 NEW DA,DIC,DIE,DR,D,IBSEL,IBPLNOLD,IBUSROLD
+7 SET IBX=0
+8 FOR
SET IBX=$ORDER(VALMY(IBX))
if IBX=""
QUIT
Begin DoDot:1
+9 ;S IBSEL=+$G(^TMP("IBCNR",$J,"PM","IDX",IBX,IBX))
+10 SET IBSEL=+$GET(^TMP("IBCNR",$JOB,"PM","IDX1",IBX))
+11 SET IBPLNOLD=$$GET1^DIQ(355.3,IBSEL,6.01,"I")
+12 SET IBUSROLD=$$GET1^DIQ(355.3,IBSEL,1.08)
+13 SET DA=IBSEL
SET DIC="^IBA(355.3,"
SET DIE=DIC
SET DR="6.01////^S X="_IBCNRP
+14 ;S DR=DR_";1.07///NOW;1.08////"_DUZ
+15 IF IBPLNOLD'=IBCNRP
SET DR=DR_";1.07///NOW;1.08////"_DUZ
+16 IF IBPLNOLD=IBCNRP
IF IBUSROLD=""
SET DR=DR_";1.07///NOW;1.08////"_DUZ
+17 DO ^DIE
End DoDot:1
+18 DO GIPF^IBCNRPM1
+19 DO CLEAN^VALM10
+20 DO INIT
+21 ;
+22 SET IBX=0
FOR
SET IBX=$ORDER(VALMY(IBX))
if 'IBX
QUIT
Begin DoDot:1
+23 SET ^TMP($JOB,"IBSEL",+$GET(^TMP("IBCNR",$JOB,"PM","IDX",IBX,IBX)))=""
End DoDot:1
+24 ;
+25 QUIT
+26 ;
DEL ; remove a plan from a group
+1 DO S1
+2 ;
+3 ; no group selected
IF 'IBX
QUIT
+4 ;
+5 NEW DA,DIC,DIE,DR,IBSEL,IBPLNOLD
+6 SET IBX=0
+7 FOR
SET IBX=$ORDER(VALMY(IBX))
if IBX=""
QUIT
Begin DoDot:1
+8 ;S IBSEL=+$G(^TMP("IBCNR",$J,"PM","IDX",IBX,IBX))
+9 SET IBSEL=+$GET(^TMP("IBCNR",$JOB,"PM","IDX1",IBX))
+10 SET IBPLNOLD=$$GET1^DIQ(355.3,IBSEL,6.01,"I")
+11 SET DA=IBSEL
SET DIC="^IBA(355.3,"
SET DIE=DIC
SET DR="6.01///@"
+12 IF IBPLNOLD'=""
SET DR=DR_";1.07///NOW;1.08////"_DUZ
+13 DO ^DIE
End DoDot:1
+14 DO GIPF^IBCNRPM1
+15 DO CLEAN^VALM10
+16 DO INIT
+17 ;
+18 SET IBX=0
FOR
SET IBX=$ORDER(VALMY(IBX))
if 'IBX
QUIT
SET ^TMP($JOB,"IBDEL",+$GET(^TMP("IBCNR",$JOB,"PM","IDX",IBX,IBX)))=""
+19 ;
+20 QUIT
+21 ;
S1 NEW DIR,DIRUT,DUOUT,DTOUT,DIROUT,IBOK,IBQUIT,Y,X
+1 DO EN^VALM2($GET(XQORNOD(0)))
DO FULL^VALM1
+2 SET IBX=$ORDER(VALMY(0))
SET VALMBCK="R"
+3 ;
+4 IF 'IBX
WRITE !!,"No group selected!"
DO PAUSE^VALM1
QUIT
+5 IF 'IBMULT
Begin DoDot:1
+6 DO OK^IBCNSM3
+7 IF IBQUIT
SET VALMBCK="Q"
QUIT
+8 IF IBOK
SET IBSEL=+$GET(^TMP("IBCNR",$JOB,"PM","IDX",IBX))
SET VALMBCK="Q"
End DoDot:1
GOTO SPQ
+9 ;
+10 ;S IBSEL=+$G(^TMP("IBCNR",$J,"PM","IDX",IBX))
+11 ;Q
+12 ;
SPQ ;
+1 SET DIR(0)="SB^Y:YES;N:NO"
SET DIR("B")="NO"
SET DIR("A")="OK to Continue? "
+2 DO ^DIR
KILL DIR
+3 IF $GET(Y)="^"
SET IBX=""
QUIT
+4 IF $GET(Y(0))="NO"
SET IBX=""
+5 QUIT
