- IBCNRP ;DAOU/ALA - Plan Match ListMan ;13-NOV-2003
- ;;2.0;INTEGRATED BILLING;**251,516,550,617**;21-MAR-94;Build 43
- ;;Per VA Directive 6402, this routine should not be modified.
- ;; ;
- EN ; -- main entry point for IBCNR PLAN MATCH
- D EN^VALM("IBCNR PLAN MATCH")
- Q
- ;
- HDR ; -- header code
- NEW IBCNS0,IBCNS11,IBCNS13,IBLEAD,X,X1,X2
- S IBCNS0=$G(^DIC(36,+IBCNSP,0))
- S IBCNS11=$G(^DIC(36,+IBCNSP,.11))
- S IBCNS13=$G(^DIC(36,+IBCNSP,.13))
- S X2=$S(IBW:"",1:"Active ")
- S IBLEAD=$S(IBIND:"All "_X2,1:X2_"Group ")_"Plans for: "
- S X="Phone: "_$S($P(IBCNS13,"^")]"":$P(IBCNS13,"^"),1:"<not filed>")
- S VALMHDR(1)=$$SETSTR^VALM1(X,IBLEAD_$P(IBCNS0,"^"),81-$L(X),40)
- S X1="Precerts: "_$S($P(IBCNS13,"^",3)]"":$P(IBCNS13,"^",3),1:"<not filed>")
- S X=$TR($J("",$L(IBLEAD)),""," ")_$S($P(IBCNS11,"^")]"":$P(IBCNS11,"^"),1:"<no street address>")
- S VALMHDR(2)=$$SETSTR^VALM1(X1,X,81-$L(X1),40)
- S X=$S($P(IBCNS11,"^",4)]"":$P(IBCNS11,"^",4),1:"<no city>")_", "
- S X=X_$S($P(IBCNS11,"^",5):$P($G(^DIC(5,$P(IBCNS11,"^",5),0)),"^",2),1:"<no state>")_" "_$E($P(IBCNS11,"^",6),1,5)_$S($E($P(IBCNS11,"^",6),6,9)]"":"-"_$E($P(IBCNS11,"^",6),6,9),1:"")
- S VALMHDR(3)=$$SETSTR^VALM1(X,"",$L(IBLEAD)+1,80)
- S X="#" I $G(IBIND) S X="# + => Indiv. Plan"
- I $G(IBW) S X=$E(X_$J("",23),1,23)_"* => Inactive Plan"
- S VALMHDR(4)=$$SETSTR^VALM1(" ",X,64,17)
- Q
- ;
- INIT ; -- init variables and list array
- NEW IBCNRPP,IBCOV,IBCPD6,IBCPOLD,IBCRVD,IBMDTE,IBMUSR,LIM,X
- K ^TMP("IBCNR",$J)
- S VALMCNT=0,VALMBG=1
- S VALMCNT1=0
- ; MRD;IB*2.0*516 - Rather than pull the zero node here, use $$GET1^DIQ
- ; to pull specific pieces down below.
- ;S IBGP0=^IBA(355.3,+IBCNGP,0)
- ;I $G(IBGP0) D
- I $G(^IBA(355.3,+IBCNGP,0)) D
- . ;S IBCPD6=$G(IBGP0,U,6)) ;chk pre-cert
- . ;I 'IBIND,'$P(IBGP0,"^",2) Q ; exclude individual plans
- . ;I 'IBW,$P(IBGP0,"^",11) Q ; plan is inactive
- . ;
- . S VALMCNT=VALMCNT+1
- . S VALMCNT1=VALMCNT1+1
- . S X=$$SETFLD^VALM1(VALMCNT1,"","NUMBER")
- . ;
- . ;I '$P(IBGP0,"^",2) S $E(X,4)="+"
- . ;S X=$$SETFLD^VALM1($P(IBGP0,"^",3),X,"GNAME")
- . I '$$GET1^DIQ(355.3,+IBCNGP_",",.02,"I") S $E(X,4)="+"
- . S X=$$SETFLD^VALM1($$GET1^DIQ(355.3,+IBCNGP_",",2.01),X,"GNAME")
- . ;
- . ;I $P(IBGP0,"^",11) S $E(X,24)="*"
- . ;S X=$$SETFLD^VALM1($P(IBGP0,"^",4),X,"GNUM")
- . I $$GET1^DIQ(355.3,+IBCNGP_",",.11,"I") S $E(X,24)="*"
- . S X=$$SETFLD^VALM1($$GET1^DIQ(355.3,+IBCNGP_",",2.02),X,"GNUM")
- . ;
- . ;S X=$$SETFLD^VALM1($$EXPAND^IBTRE(355.3,.09,$P(IBGP0,"^",9)),X,"TYPE")
- . S X=$$SETFLD^VALM1($$GET1^DIQ(355.3,+IBCNGP_",",.09,"E"),X,"TYPE")
- . ;
- . S IBCNRPP=$$GET1^DIQ(355.3,IBCNGP_",",6.01,"I")
- . I IBCNRPP'="" S IBCNRPP=$$GET1^DIQ(366.03,IBCNRPP_",",.01,"E")
- . S X=$$SETFLD^VALM1(IBCNRPP,X,"PHARM")
- . ;
- . S IBCOV=$O(^IBE(355.31,"B","PHARMACY",""))
- . S LIM="",IBCVRD=0
- . F S LIM=$O(^IBA(355.32,"B",IBCNGP,LIM)) Q:LIM="" D
- .. I $P(^IBA(355.32,LIM,0),U,2)=IBCOV S IBCVRD=$P(^IBA(355.32,LIM,0),U,4)
- . S X=$$SETFLD^VALM1($S(IBCVRD=0:"NO",1:"YES"),X,"COV")
- . ;
- . S ^TMP("IBCNR",$J,VALMCNT,0)=X
- . S ^TMP("IBCNR",$J,"IDX",VALMCNT,VALMCNT1)=IBCNGP
- . S ^TMP("IBCNR",$J,"IDX1",VALMCNT1)=IBCNGP
- . ;
- . I IBCNRPP'="" D ; If VA PLAN ID exists
- . . S IBMDTE=$$GET1^DIQ(355.3,IBCNGP_",",1.07,"E")
- . . S IBMUSR=$$GET1^DIQ(355.3,IBCNGP_",",1.08,"E")
- . . I IBMDTE'="" D ; If DATE LAST MATCHED exists
- . . . S X=" Matched by: "_IBMUSR_" "_IBMDTE
- . . . S VALMCNT=VALMCNT+1
- . . . S ^TMP("IBCNR",$J,VALMCNT,0)=X
- . . . S ^TMP("IBCNR",$J,"IDX",VALMCNT,VALMCNT1)=IBCNGP
- . . . S ^TMP("IBCNR",$J,"IDX1",VALMCNT1)=IBCNGP
- . I IBCNRPP="" D ; If VA PLAN ID does not exist
- . . S IBMDTE=$$GET1^DIQ(355.3,IBCNGP_",",1.07,"E")
- . . S IBMUSR=$$GET1^DIQ(355.3,IBCNGP_",",1.08,"E")
- . . I IBMDTE'="" D ; Match Date w/no Plan ID means Deleted
- . . . S X=" Deleted by: "_IBMUSR_" "_IBMDTE
- . . . S VALMCNT=VALMCNT+1
- . . . S ^TMP("IBCNR",$J,VALMCNT,0)=X
- . . . S ^TMP("IBCNR",$J,"IDX",VALMCNT,VALMCNT1)=IBCNGP
- . . . S ^TMP("IBCNR",$J,"IDX1",VALMCNT1)=IBCNGP
- . ;
- . I '$D(^TMP("IBCNR",$J)) S VALMCNT=2,^TMP("IBCNR",$J,1,0)=" ",^TMP("IBCNR",$J,2,0)=" No plans were identified for this company."
- Q
- ;
- HELP ; -- help code
- S X="?" D DISP^XQORM1 W !!
- Q
- ;
- EXIT ; -- exit code
- K ^TMP("IBCNR",$J),VALMBCK,VALMY
- D CLEAN^VALM10,CLEAR^VALM1
- Q
- ;
- EXPND ; -- expand code
- Q
- ;
- SEL ; -- select plan
- D S1
- I 'IBX Q ; no group selected
- ;
- NEW DA,DIC,DIE,DR,D,IBPLN,IBPLNOLD,IBUSROLD
- S DIC="^IBCNR(366.03,",DIC(0)="AEMNZ" D ^DIC
- I +Y<1 S D="F" D IX^DIC
- I +Y<1 G SPQ
- S IBPLN=+Y K Y,X
- D PLCK ; check plan status
- S IBPLNOLD=$$GET1^DIQ(355.3,IBCNGP,6.01,"I")
- S IBUSROLD=$$GET1^DIQ(355.3,IBCNGP,1.08)
- S DA=IBSEL,DIC="^IBA(355.3,",DIE=DIC,DR="6.01////^S X="_IBPLN
- I IBPLNOLD'=IBPLN S DR=DR_";1.07///NOW;1.08////"_DUZ
- I IBPLNOLD=IBPLN,IBUSROLD="" S DR=DR_";1.07///NOW;1.08////"_DUZ
- D ^DIE
- D INIT
- ;
- S IBX=0 F S IBX=$O(VALMY(IBX)) Q:'IBX S ^TMP($J,"IBSEL",+$G(^TMP("IBCNR",$J,"IDX",IBX,IBX)))=""
- ;
- D SPQ
- Q
- ;
- PLCK ; -- check plan status
- NEW ARRAY
- D STCHK^IBCNRU1(IBPLN,.ARRAY)
- I $G(ARRAY(1))'="A" D
- . W !!,"WARNING....PLAN NOT ACTIVE!"
- ;
- Q
- ;
- DEL ; -- remove a plan from a group
- D S1
- ;
- NEW DA,DIC,DIE,DR,IBPLNOLD
- S IBPLNOLD=$$GET1^DIQ(355.3,IBCNGP,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 INIT
- ;
- S IBX=0 F S IBX=$O(VALMY(IBX)) Q:'IBX S ^TMP($J,"IBSEL",+$G(^TMP("IBCNR",$J,"IDX",IBX,IBX)))=""
- ;
- D SPQ
- Q
- ;
- S1 ;
- NEW DIR,DIRUT,DUOUT,DTOUT,DIROUT,IBOK,IBQUIT,Y
- D EN^VALM2($G(XQORNOD(0)),"S"),FULL^VALM1
- S IBX=$O(VALMY(0)),VALMBCK="R"
- ;
- I 'IBX W !!,"No group selected!" G SPQ
- I 'IBMULT D G SPQ
- . I $O(VALMY(IBX)) W !!,*7,"You may only select a single plan!" Q
- . I $G(IBALR),+$G(^TMP("IBCNR",$J,"IDX",IBX,IBX))=IBALR W !!,*7,"This plan is not allowed for selection!" Q
- . D OK^IBCNSM3
- . I IBQUIT S VALMBCK="Q" Q
- . ;I IBOK S IBSEL=+$G(^TMP("IBCNR",$J,"IDX",IBX,IBX)),VALMBCK="Q"
- . I IBOK S IBSEL=+$G(^TMP("IBCNR",$J,"IDX1",IBX)),VALMBCK="Q"
- ;
- ;S IBSEL=+$G(^TMP("IBCNR",$J,"IDX",IBX,IBX))
- S IBSEL=+$G(^TMP("IBCNR",$J,"IDX1",IBX))
- Q
- ;
- SPQ ;
- I '$O(IBSEL(0)),VALMBCK="R" D PAUSE^VALM1
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCNRP 6278 printed Feb 18, 2025@23:42:44 Page 2
- IBCNRP ;DAOU/ALA - Plan Match ListMan ;13-NOV-2003
- +1 ;;2.0;INTEGRATED BILLING;**251,516,550,617**;21-MAR-94;Build 43
- +2 ;;Per VA Directive 6402, this routine should not be modified.
- +3 ;; ;
- EN ; -- main entry point for IBCNR PLAN MATCH
- +1 DO EN^VALM("IBCNR PLAN MATCH")
- +2 QUIT
- +3 ;
- HDR ; -- header code
- +1 NEW IBCNS0,IBCNS11,IBCNS13,IBLEAD,X,X1,X2
- +2 SET IBCNS0=$GET(^DIC(36,+IBCNSP,0))
- +3 SET IBCNS11=$GET(^DIC(36,+IBCNSP,.11))
- +4 SET IBCNS13=$GET(^DIC(36,+IBCNSP,.13))
- +5 SET X2=$SELECT(IBW:"",1:"Active ")
- +6 SET IBLEAD=$SELECT(IBIND:"All "_X2,1:X2_"Group ")_"Plans for: "
- +7 SET X="Phone: "_$SELECT($PIECE(IBCNS13,"^")]"":$PIECE(IBCNS13,"^"),1:"<not filed>")
- +8 SET VALMHDR(1)=$$SETSTR^VALM1(X,IBLEAD_$PIECE(IBCNS0,"^"),81-$LENGTH(X),40)
- +9 SET X1="Precerts: "_$SELECT($PIECE(IBCNS13,"^",3)]"":$PIECE(IBCNS13,"^",3),1:"<not filed>")
- +10 SET X=$TRANSLATE($JUSTIFY("",$LENGTH(IBLEAD)),""," ")_$SELECT($PIECE(IBCNS11,"^")]"":$PIECE(IBCNS11,"^"),1:"<no street address>")
- +11 SET VALMHDR(2)=$$SETSTR^VALM1(X1,X,81-$LENGTH(X1),40)
- +12 SET X=$SELECT($PIECE(IBCNS11,"^",4)]"":$PIECE(IBCNS11,"^",4),1:"<no city>")_", "
- +13 SET X=X_$SELECT($PIECE(IBCNS11,"^",5):$PIECE($GET(^DIC(5,$PIECE(IBCNS11,"^",5),0)),"^",2),1:"<no state>")_" "_$EXTRACT($PIECE(IBCNS11,"^",6),1,5)_$SELECT($EXTRACT($PIECE(IBCNS11,"^",6),6,9)]"":"-"_$EXTRACT($PIECE(IBCNS11,"^",6),6,9),1:"")
- +14 SET VALMHDR(3)=$$SETSTR^VALM1(X,"",$LENGTH(IBLEAD)+1,80)
- +15 SET X="#"
- IF $GET(IBIND)
- SET X="# + => Indiv. Plan"
- +16 IF $GET(IBW)
- SET X=$EXTRACT(X_$JUSTIFY("",23),1,23)_"* => Inactive Plan"
- +17 SET VALMHDR(4)=$$SETSTR^VALM1(" ",X,64,17)
- +18 QUIT
- +19 ;
- INIT ; -- init variables and list array
- +1 NEW IBCNRPP,IBCOV,IBCPD6,IBCPOLD,IBCRVD,IBMDTE,IBMUSR,LIM,X
- +2 KILL ^TMP("IBCNR",$JOB)
- +3 SET VALMCNT=0
- SET VALMBG=1
- +4 SET VALMCNT1=0
- +5 ; MRD;IB*2.0*516 - Rather than pull the zero node here, use $$GET1^DIQ
- +6 ; to pull specific pieces down below.
- +7 ;S IBGP0=^IBA(355.3,+IBCNGP,0)
- +8 ;I $G(IBGP0) D
- +9 IF $GET(^IBA(355.3,+IBCNGP,0))
- Begin DoDot:1
- +10 ;S IBCPD6=$G(IBGP0,U,6)) ;chk pre-cert
- +11 ;I 'IBIND,'$P(IBGP0,"^",2) Q ; exclude individual plans
- +12 ;I 'IBW,$P(IBGP0,"^",11) Q ; plan is inactive
- +13 ;
- +14 SET VALMCNT=VALMCNT+1
- +15 SET VALMCNT1=VALMCNT1+1
- +16 SET X=$$SETFLD^VALM1(VALMCNT1,"","NUMBER")
- +17 ;
- +18 ;I '$P(IBGP0,"^",2) S $E(X,4)="+"
- +19 ;S X=$$SETFLD^VALM1($P(IBGP0,"^",3),X,"GNAME")
- +20 IF '$$GET1^DIQ(355.3,+IBCNGP_",",.02,"I")
- SET $EXTRACT(X,4)="+"
- +21 SET X=$$SETFLD^VALM1($$GET1^DIQ(355.3,+IBCNGP_",",2.01),X,"GNAME")
- +22 ;
- +23 ;I $P(IBGP0,"^",11) S $E(X,24)="*"
- +24 ;S X=$$SETFLD^VALM1($P(IBGP0,"^",4),X,"GNUM")
- +25 IF $$GET1^DIQ(355.3,+IBCNGP_",",.11,"I")
- SET $EXTRACT(X,24)="*"
- +26 SET X=$$SETFLD^VALM1($$GET1^DIQ(355.3,+IBCNGP_",",2.02),X,"GNUM")
- +27 ;
- +28 ;S X=$$SETFLD^VALM1($$EXPAND^IBTRE(355.3,.09,$P(IBGP0,"^",9)),X,"TYPE")
- +29 SET X=$$SETFLD^VALM1($$GET1^DIQ(355.3,+IBCNGP_",",.09,"E"),X,"TYPE")
- +30 ;
- +31 SET IBCNRPP=$$GET1^DIQ(355.3,IBCNGP_",",6.01,"I")
- +32 IF IBCNRPP'=""
- SET IBCNRPP=$$GET1^DIQ(366.03,IBCNRPP_",",.01,"E")
- +33 SET X=$$SETFLD^VALM1(IBCNRPP,X,"PHARM")
- +34 ;
- +35 SET IBCOV=$ORDER(^IBE(355.31,"B","PHARMACY",""))
- +36 SET LIM=""
- SET IBCVRD=0
- +37 FOR
- SET LIM=$ORDER(^IBA(355.32,"B",IBCNGP,LIM))
- if LIM=""
- QUIT
- Begin DoDot:2
- +38 IF $PIECE(^IBA(355.32,LIM,0),U,2)=IBCOV
- SET IBCVRD=$PIECE(^IBA(355.32,LIM,0),U,4)
- End DoDot:2
- +39 SET X=$$SETFLD^VALM1($SELECT(IBCVRD=0:"NO",1:"YES"),X,"COV")
- +40 ;
- +41 SET ^TMP("IBCNR",$JOB,VALMCNT,0)=X
- +42 SET ^TMP("IBCNR",$JOB,"IDX",VALMCNT,VALMCNT1)=IBCNGP
- +43 SET ^TMP("IBCNR",$JOB,"IDX1",VALMCNT1)=IBCNGP
- +44 ;
- +45 ; If VA PLAN ID exists
- IF IBCNRPP'=""
- Begin DoDot:2
- +46 SET IBMDTE=$$GET1^DIQ(355.3,IBCNGP_",",1.07,"E")
- +47 SET IBMUSR=$$GET1^DIQ(355.3,IBCNGP_",",1.08,"E")
- +48 ; If DATE LAST MATCHED exists
- IF IBMDTE'=""
- Begin DoDot:3
- +49 SET X=" Matched by: "_IBMUSR_" "_IBMDTE
- +50 SET VALMCNT=VALMCNT+1
- +51 SET ^TMP("IBCNR",$JOB,VALMCNT,0)=X
- +52 SET ^TMP("IBCNR",$JOB,"IDX",VALMCNT,VALMCNT1)=IBCNGP
- +53 SET ^TMP("IBCNR",$JOB,"IDX1",VALMCNT1)=IBCNGP
- End DoDot:3
- End DoDot:2
- +54 ; If VA PLAN ID does not exist
- IF IBCNRPP=""
- Begin DoDot:2
- +55 SET IBMDTE=$$GET1^DIQ(355.3,IBCNGP_",",1.07,"E")
- +56 SET IBMUSR=$$GET1^DIQ(355.3,IBCNGP_",",1.08,"E")
- +57 ; Match Date w/no Plan ID means Deleted
- IF IBMDTE'=""
- Begin DoDot:3
- +58 SET X=" Deleted by: "_IBMUSR_" "_IBMDTE
- +59 SET VALMCNT=VALMCNT+1
- +60 SET ^TMP("IBCNR",$JOB,VALMCNT,0)=X
- +61 SET ^TMP("IBCNR",$JOB,"IDX",VALMCNT,VALMCNT1)=IBCNGP
- +62 SET ^TMP("IBCNR",$JOB,"IDX1",VALMCNT1)=IBCNGP
- End DoDot:3
- End DoDot:2
- +63 ;
- +64 IF '$DATA(^TMP("IBCNR",$JOB))
- SET VALMCNT=2
- SET ^TMP("IBCNR",$JOB,1,0)=" "
- SET ^TMP("IBCNR",$JOB,2,0)=" No plans were identified for this company."
- End DoDot:1
- +65 QUIT
- +66 ;
- HELP ; -- help code
- +1 SET X="?"
- DO DISP^XQORM1
- WRITE !!
- +2 QUIT
- +3 ;
- EXIT ; -- exit code
- +1 KILL ^TMP("IBCNR",$JOB),VALMBCK,VALMY
- +2 DO CLEAN^VALM10
- DO CLEAR^VALM1
- +3 QUIT
- +4 ;
- EXPND ; -- expand code
- +1 QUIT
- +2 ;
- SEL ; -- select plan
- +1 DO S1
- +2 ; no group selected
- IF 'IBX
- QUIT
- +3 ;
- +4 NEW DA,DIC,DIE,DR,D,IBPLN,IBPLNOLD,IBUSROLD
- +5 SET DIC="^IBCNR(366.03,"
- SET DIC(0)="AEMNZ"
- DO ^DIC
- +6 IF +Y<1
- SET D="F"
- DO IX^DIC
- +7 IF +Y<1
- GOTO SPQ
- +8 SET IBPLN=+Y
- KILL Y,X
- +9 ; check plan status
- DO PLCK
- +10 SET IBPLNOLD=$$GET1^DIQ(355.3,IBCNGP,6.01,"I")
- +11 SET IBUSROLD=$$GET1^DIQ(355.3,IBCNGP,1.08)
- +12 SET DA=IBSEL
- SET DIC="^IBA(355.3,"
- SET DIE=DIC
- SET DR="6.01////^S X="_IBPLN
- +13 IF IBPLNOLD'=IBPLN
- SET DR=DR_";1.07///NOW;1.08////"_DUZ
- +14 IF IBPLNOLD=IBPLN
- IF IBUSROLD=""
- SET DR=DR_";1.07///NOW;1.08////"_DUZ
- +15 DO ^DIE
- +16 DO INIT
- +17 ;
- +18 SET IBX=0
- FOR
- SET IBX=$ORDER(VALMY(IBX))
- if 'IBX
- QUIT
- SET ^TMP($JOB,"IBSEL",+$GET(^TMP("IBCNR",$JOB,"IDX",IBX,IBX)))=""
- +19 ;
- +20 DO SPQ
- +21 QUIT
- +22 ;
- PLCK ; -- check plan status
- +1 NEW ARRAY
- +2 DO STCHK^IBCNRU1(IBPLN,.ARRAY)
- +3 IF $GET(ARRAY(1))'="A"
- Begin DoDot:1
- +4 WRITE !!,"WARNING....PLAN NOT ACTIVE!"
- End DoDot:1
- +5 ;
- +6 QUIT
- +7 ;
- DEL ; -- remove a plan from a group
- +1 DO S1
- +2 ;
- +3 NEW DA,DIC,DIE,DR,IBPLNOLD
- +4 SET IBPLNOLD=$$GET1^DIQ(355.3,IBCNGP,6.01,"I")
- +5 SET DA=IBSEL
- SET DIC="^IBA(355.3,"
- SET DIE=DIC
- SET DR="6.01///@"
- +6 IF IBPLNOLD'=""
- SET DR=DR_";1.07///NOW;1.08////"_DUZ
- +7 DO ^DIE
- +8 DO INIT
- +9 ;
- +10 SET IBX=0
- FOR
- SET IBX=$ORDER(VALMY(IBX))
- if 'IBX
- QUIT
- SET ^TMP($JOB,"IBSEL",+$GET(^TMP("IBCNR",$JOB,"IDX",IBX,IBX)))=""
- +11 ;
- +12 DO SPQ
- +13 QUIT
- +14 ;
- S1 ;
- +1 NEW DIR,DIRUT,DUOUT,DTOUT,DIROUT,IBOK,IBQUIT,Y
- +2 DO EN^VALM2($GET(XQORNOD(0)),"S")
- DO FULL^VALM1
- +3 SET IBX=$ORDER(VALMY(0))
- SET VALMBCK="R"
- +4 ;
- +5 IF 'IBX
- WRITE !!,"No group selected!"
- GOTO SPQ
- +6 IF 'IBMULT
- Begin DoDot:1
- +7 IF $ORDER(VALMY(IBX))
- WRITE !!,*7,"You may only select a single plan!"
- QUIT
- +8 IF $GET(IBALR)
- IF +$GET(^TMP("IBCNR",$JOB,"IDX",IBX,IBX))=IBALR
- WRITE !!,*7,"This plan is not allowed for selection!"
- QUIT
- +9 DO OK^IBCNSM3
- +10 IF IBQUIT
- SET VALMBCK="Q"
- QUIT
- +11 ;I IBOK S IBSEL=+$G(^TMP("IBCNR",$J,"IDX",IBX,IBX)),VALMBCK="Q"
- +12 IF IBOK
- SET IBSEL=+$GET(^TMP("IBCNR",$JOB,"IDX1",IBX))
- SET VALMBCK="Q"
- End DoDot:1
- GOTO SPQ
- +13 ;
- +14 ;S IBSEL=+$G(^TMP("IBCNR",$J,"IDX",IBX,IBX))
- +15 SET IBSEL=+$GET(^TMP("IBCNR",$JOB,"IDX1",IBX))
- +16 QUIT
- +17 ;
- SPQ ;
- +1 IF '$ORDER(IBSEL(0))
- IF VALMBCK="R"
- DO PAUSE^VALM1
- +2 QUIT