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,812**;21-MAR-94;Build 11
;;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 DEL,GPIEN,IBGP0,IBCPOLD,X,IBCPD6,IBCNRPP,IBCOV,IBCRVD,LIM
N IBGNA,IBGNM,IBCNA,IBCNM,IBDAT,MATCH
K ^TMP("IBCNR",$J,"PM")
S VALMCNT=0,VALMBG=1,(IBCNA,IBCNM,GPIEN)=""
S VALMCNT1=0,LAST=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)=""
.I MATCH=.5 D
.. S VALMCNT=VALMCNT+1
.. ;I VALMCNT1=0 S VALMCNT1=1
.. S ^TMP("IBCNR",$J,"PM",VALMCNT,0)=""
.. I VALMCNT1=0 S ^TMP("IBCNR",$J,"PM","IDX",VALMCNT,1)=""
.. E S ^TMP("IBCNR",$J,"PM","IDX",VALMCNT,VALMCNT1)=""
.. S VALMCNT=VALMCNT+1
.. S ^TMP("IBCNR",$J,"PM",VALMCNT,0)=" *** "_^TMP("IBCNR",$J,"GP",MATCH)_" DELETED ***"
.. D CNTRL^VALM10(VALMCNT,1,80,IORVON,IORVOFF,0)
.. I VALMCNT1=0 S ^TMP("IBCNR",$J,"PM","IDX",VALMCNT,1)=""
.. E S ^TMP("IBCNR",$J,"PM","IDX",VALMCNT,VALMCNT1)=""
.I MATCH=1 D
.. S VALMCNT=VALMCNT+1
.. ;I VALMCNT1=0 S VALMCNT1=1
.. S ^TMP("IBCNR",$J,"PM",VALMCNT,0)=""
.. I VALMCNT1=0 S ^TMP("IBCNR",$J,"PM","IDX",VALMCNT,1)=""
.. E S ^TMP("IBCNR",$J,"PM","IDX",VALMCNT,VALMCNT1)=""
.. 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)
.. I VALMCNT1=0 S ^TMP("IBCNR",$J,"PM","IDX",VALMCNT,1)=""
.. E S ^TMP("IBCNR",$J,"PM","IDX",VALMCNT,VALMCNT1)=""
.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
.... S LAST=VALMCNT
.... ;
.... 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
...... ;
...... S DELCOM=$$GET1^DIQ(355.3,GPIEN_",",3.01)
...... S X=" Comment: "_DELCOM
...... 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
;
;S VALMBG=1
;S VALMLST=LAST
S DEL=0
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","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
. 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
. S DR=DR_";3.01///@"
. 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
;
S DEL=1
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","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_";3.01///"_DELCOM
. 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,IBI,IBOK,IBQUIT,VALMBG1,Y,X
S VALMBG1=VALMBG,VALMBGO=VALMBG
I VALMBG>0 F IBI=VALMBG:1:VALMLST I $P(^TMP("IBCNR",$J,"PM",IBI,0)," ")?1N.N S VALMBG1=IBI Q
I (VALMBG1>VALMBG),(VALMBG1<(VALMLST+1)) S VALMBG=VALMBG1
D EN^VALM2($G(XQORNOD(0))),FULL^VALM1
S IBX=$O(VALMY(0)),VALMBCK="R"
;
I 'IBX W !!,"No group selected!" D PAUSE^VALM1 S VALMBG=VALMBGO 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"
;
I $G(DEL) D I 'IBX Q
. S DELCOM=$$DELCOM^IBCNRP()
. I DELCOM="^" D Q
. . W !!,"A delete reason comment is required."
. . W !,"No action taken."
. . S VALMBG=VALMBGO
. . S IBX=""
. . D PAUSE^VALM1
;
SPQ ;
S DIR(0)="SB^Y:YES;N:NO",DIR("B")="NO",DIR("A")="OK to Continue? "
D ^DIR K DIR
S VALMBG=VALMBGO
I $G(DEL) S VALMBG=VALMBG
I $G(Y)="^" S IBX="" Q
I $G(Y(0))="NO" S IBX=""
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCNRPM2 7997 printed Jan 29, 2026@15:15:19 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,812**;21-MAR-94;Build 11
+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 DEL,GPIEN,IBGP0,IBCPOLD,X,IBCPD6,IBCNRPP,IBCOV,IBCRVD,LIM
+7 NEW IBGNA,IBGNM,IBCNA,IBCNM,IBDAT,MATCH
+8 KILL ^TMP("IBCNR",$JOB,"PM")
+9 SET VALMCNT=0
SET VALMBG=1
SET (IBCNA,IBCNM,GPIEN)=""
+10 SET VALMCNT1=0
SET LAST=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)=""
End DoDot:2
+19 IF MATCH=.5
Begin DoDot:2
+20 SET VALMCNT=VALMCNT+1
+21 ;I VALMCNT1=0 S VALMCNT1=1
+22 SET ^TMP("IBCNR",$JOB,"PM",VALMCNT,0)=""
+23 IF VALMCNT1=0
SET ^TMP("IBCNR",$JOB,"PM","IDX",VALMCNT,1)=""
+24 IF '$TEST
SET ^TMP("IBCNR",$JOB,"PM","IDX",VALMCNT,VALMCNT1)=""
+25 SET VALMCNT=VALMCNT+1
+26 SET ^TMP("IBCNR",$JOB,"PM",VALMCNT,0)=" *** "_^TMP("IBCNR",$JOB,"GP",MATCH)_" DELETED ***"
+27 DO CNTRL^VALM10(VALMCNT,1,80,IORVON,IORVOFF,0)
+28 IF VALMCNT1=0
SET ^TMP("IBCNR",$JOB,"PM","IDX",VALMCNT,1)=""
+29 IF '$TEST
SET ^TMP("IBCNR",$JOB,"PM","IDX",VALMCNT,VALMCNT1)=""
End DoDot:2
+30 IF MATCH=1
Begin DoDot:2
+31 SET VALMCNT=VALMCNT+1
+32 ;I VALMCNT1=0 S VALMCNT1=1
+33 SET ^TMP("IBCNR",$JOB,"PM",VALMCNT,0)=""
+34 IF VALMCNT1=0
SET ^TMP("IBCNR",$JOB,"PM","IDX",VALMCNT,1)=""
+35 IF '$TEST
SET ^TMP("IBCNR",$JOB,"PM","IDX",VALMCNT,VALMCNT1)=""
+36 SET VALMCNT=VALMCNT+1
+37 SET ^TMP("IBCNR",$JOB,"PM",VALMCNT,0)=" *** "_^TMP("IBCNR",$JOB,"GP",MATCH)_" MATCHED ***"
+38 DO CNTRL^VALM10(VALMCNT,1,80,IORVON,IORVOFF,0)
+39 IF VALMCNT1=0
SET ^TMP("IBCNR",$JOB,"PM","IDX",VALMCNT,1)=""
+40 IF '$TEST
SET ^TMP("IBCNR",$JOB,"PM","IDX",VALMCNT,VALMCNT1)=""
End DoDot:2
+41 FOR
SET IBCNA=$ORDER(^TMP("IBCNR",$JOB,"GP",MATCH,IBCNA))
if IBCNA=""
QUIT
Begin DoDot:2
+42 FOR
SET IBCNM=$ORDER(^TMP("IBCNR",$JOB,"GP",MATCH,IBCNA,IBCNM))
if IBCNM=""
QUIT
Begin DoDot:3
+43 ;get pharm plan id
+44 FOR
SET GPIEN=$ORDER(^TMP("IBCNR",$JOB,"GP",MATCH,IBCNA,IBCNM,GPIEN))
if GPIEN=""
QUIT
Begin DoDot:4
+45 SET IBDAT=^TMP("IBCNR",$JOB,"GP",MATCH,IBCNA,IBCNM,GPIEN)
+46 ;set up list
+47 SET VALMCNT=VALMCNT+1
+48 SET VALMCNT1=VALMCNT1+1
+49 SET X=$$SETFLD^VALM1(VALMCNT1,"","NUMBER")
+50 ;
+51 ;group name
+52 SET X=$$SETFLD^VALM1(IBCNA,X,"GNAME")
+53 ;
+54 ;group number
+55 SET X=$$SETFLD^VALM1(IBCNM,X,"GNUM")
+56 ;
+57 ;group plan type
+58 SET X=$$SETFLD^VALM1($$EXPAND^IBTRE(355.3,.09,$PIECE(IBDAT,"^",2)),X,"GTYP")
+59 ;
+60 ;pharmacy plan ID
+61 SET IBCNRPP=$PIECE($GET(IBDAT),U)
+62 IF IBCNRPP'=""
SET IBCNRPP=$$GET1^DIQ(366.03,IBCNRPP_",",.01,"E")
+63 SET X=$$SETFLD^VALM1(IBCNRPP,X,"PHRM")
+64 ;
+65 ; set up tmp for SEL
+66 SET ^TMP("IBCNR",$JOB,"PM",VALMCNT,0)=X
+67 SET ^TMP("IBCNR",$JOB,"PM","IDX",VALMCNT,VALMCNT1)=GPIEN
+68 SET ^TMP("IBCNR",$JOB,"PM","IDX1",VALMCNT1)=GPIEN
+69 SET LAST=VALMCNT
+70 ;
+71 ; If VA PLAN ID exists
IF IBCNRPP'=""
Begin DoDot:5
+72 ; If Matched Date exists
IF $PIECE(IBDAT,"^",3)'=""
Begin DoDot:6
+73 SET X=" Matched by: "_$PIECE(IBDAT,"^",4)_" "_$PIECE(IBDAT,"^",3)
+74 SET VALMCNT=VALMCNT+1
+75 SET ^TMP("IBCNR",$JOB,"PM",VALMCNT,0)=X
+76 SET ^TMP("IBCNR",$JOB,"PM","IDX",VALMCNT,VALMCNT1)=GPIEN
+77 SET ^TMP("IBCNR",$JOB,"PM","IDX1",VALMCNT1)=GPIEN
End DoDot:6
End DoDot:5
+78 ; If VA PLAN ID does not exist
IF IBCNRPP=""
Begin DoDot:5
+79 ; Match Date w/no Plan ID means Deleted
IF $PIECE(IBDAT,"^",3)'=""
Begin DoDot:6
+80 SET X=" Deleted by: "_$PIECE(IBDAT,"^",4)_" "_$PIECE(IBDAT,"^",3)
+81 SET VALMCNT=VALMCNT+1
+82 SET ^TMP("IBCNR",$JOB,"PM",VALMCNT,0)=X
+83 SET ^TMP("IBCNR",$JOB,"PM","IDX",VALMCNT,VALMCNT1)=GPIEN
+84 SET ^TMP("IBCNR",$JOB,"PM","IDX1",VALMCNT1)=GPIEN
+85 ;
+86 SET DELCOM=$$GET1^DIQ(355.3,GPIEN_",",3.01)
+87 SET X=" Comment: "_DELCOM
+88 SET VALMCNT=VALMCNT+1
+89 SET ^TMP("IBCNR",$JOB,"PM",VALMCNT,0)=X
+90 SET ^TMP("IBCNR",$JOB,"PM","IDX",VALMCNT,VALMCNT1)=GPIEN
+91 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
+92 ;
+93 QUIT
+94 ;
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 ;S VALMBG=1
+3 ;S VALMLST=LAST
+4 SET DEL=0
+5 DO S1
+6 ;
+7 ; no group selected
IF 'IBX
QUIT
+8 ;
+9 NEW DA,DIC,DIE,DR,D,IBSEL,IBPLNOLD,IBUSROLD
+10 SET IBX=0
+11 FOR
SET IBX=$ORDER(VALMY(IBX))
if IBX=""
QUIT
Begin DoDot:1
+12 SET IBSEL=+$GET(^TMP("IBCNR",$JOB,"PM","IDX1",IBX))
+13 SET IBPLNOLD=$$GET1^DIQ(355.3,IBSEL,6.01,"I")
+14 SET IBUSROLD=$$GET1^DIQ(355.3,IBSEL,1.08)
+15 SET DA=IBSEL
SET DIC="^IBA(355.3,"
SET DIE=DIC
SET DR="6.01////^S X="_IBCNRP
+16 IF IBPLNOLD'=IBCNRP
SET DR=DR_";1.07///NOW;1.08////"_DUZ
+17 IF IBPLNOLD=IBCNRP
IF IBUSROLD=""
SET DR=DR_";1.07///NOW;1.08////"_DUZ
+18 SET DR=DR_";3.01///@"
+19 DO ^DIE
End DoDot:1
+20 DO GIPF^IBCNRPM1
+21 DO CLEAN^VALM10
+22 DO INIT
+23 ;
+24 SET IBX=0
FOR
SET IBX=$ORDER(VALMY(IBX))
if 'IBX
QUIT
Begin DoDot:1
+25 SET ^TMP($JOB,"IBSEL",+$GET(^TMP("IBCNR",$JOB,"PM","IDX",IBX,IBX)))=""
End DoDot:1
+26 ;
+27 QUIT
+28 ;
DEL ; remove a plan from a group
+1 ;
+2 SET DEL=1
+3 DO S1
+4 ;
+5 ; no group selected
IF 'IBX
QUIT
+6 ;
+7 NEW DA,DIC,DIE,DR,IBSEL,IBPLNOLD
+8 SET IBX=0
+9 FOR
SET IBX=$ORDER(VALMY(IBX))
if IBX=""
QUIT
Begin DoDot:1
+10 SET IBSEL=+$GET(^TMP("IBCNR",$JOB,"PM","IDX1",IBX))
+11 SET IBPLNOLD=$$GET1^DIQ(355.3,IBSEL,6.01,"I")
+12 SET DA=IBSEL
SET DIC="^IBA(355.3,"
SET DIE=DIC
SET DR="6.01///@"
+13 IF IBPLNOLD'=""
SET DR=DR_";1.07///NOW;1.08////"_DUZ_";3.01///"_DELCOM
+14 DO ^DIE
End DoDot:1
+15 DO GIPF^IBCNRPM1
+16 DO CLEAN^VALM10
+17 DO INIT
+18 ;
+19 SET IBX=0
FOR
SET IBX=$ORDER(VALMY(IBX))
if 'IBX
QUIT
SET ^TMP($JOB,"IBDEL",+$GET(^TMP("IBCNR",$JOB,"PM","IDX",IBX,IBX)))=""
+20 ;
+21 QUIT
+22 ;
S1 NEW DIR,DIRUT,DUOUT,DTOUT,DIROUT,IBI,IBOK,IBQUIT,VALMBG1,Y,X
+1 SET VALMBG1=VALMBG
SET VALMBGO=VALMBG
+2 IF VALMBG>0
FOR IBI=VALMBG:1:VALMLST
IF $PIECE(^TMP("IBCNR",$JOB,"PM",IBI,0)," ")?1N.N
SET VALMBG1=IBI
QUIT
+3 IF (VALMBG1>VALMBG)
IF (VALMBG1<(VALMLST+1))
SET VALMBG=VALMBG1
+4 DO EN^VALM2($GET(XQORNOD(0)))
DO FULL^VALM1
+5 SET IBX=$ORDER(VALMY(0))
SET VALMBCK="R"
+6 ;
+7 IF 'IBX
WRITE !!,"No group selected!"
DO PAUSE^VALM1
SET VALMBG=VALMBGO
QUIT
+8 IF 'IBMULT
Begin DoDot:1
+9 DO OK^IBCNSM3
+10 IF IBQUIT
SET VALMBCK="Q"
QUIT
+11 IF IBOK
SET IBSEL=+$GET(^TMP("IBCNR",$JOB,"PM","IDX",IBX))
SET VALMBCK="Q"
End DoDot:1
GOTO SPQ
+12 ;
+13 IF $GET(DEL)
Begin DoDot:1
+14 SET DELCOM=$$DELCOM^IBCNRP()
+15 IF DELCOM="^"
Begin DoDot:2
+16 WRITE !!,"A delete reason comment is required."
+17 WRITE !,"No action taken."
+18 SET VALMBG=VALMBGO
+19 SET IBX=""
+20 DO PAUSE^VALM1
End DoDot:2
QUIT
End DoDot:1
IF 'IBX
QUIT
+21 ;
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 SET VALMBG=VALMBGO
+4 IF $GET(DEL)
SET VALMBG=VALMBG
+5 IF $GET(Y)="^"
SET IBX=""
QUIT
+6 IF $GET(Y(0))="NO"
SET IBX=""
+7 QUIT
