- IBDFQEA ;ALB/CJM/MAF - ENCOUNTER FORM - BUILD FORM(editing action for group's selections list) ;06/16/95
- ;;3.0;AUTOMATED INFO COLLECTION SYS;**15,38,63**;APR 24, 1997;Build 80
- ;
- ;
- EDIT ;allows editing of an existing selection
- D FULL^VALM1
- N SEL,SUB,SLCTN,SC,NODE,OQTY,NQTY
- D EN^VALM2($G(XQORNOD(0)),"S")
- S SEL="" F S SEL=$O(VALMY(SEL)) Q:'SEL D
- .W !,"Editing Entry #",SEL
- .S SLCTN=$P($G(^TMP("SELIDX",$J,SEL)),"^",3) Q:'SLCTN
- .S NODE=$G(^IBE(357.3,SLCTN,0))
- .S IBGRP=$P(NODE,"^",4),ORD=$P(NODE,"^",5)
- .;re-index the record, to insure it is good
- .K DIK,DA S DIK="^IBE(357.3,",DA=SLCTN D IX^DIK K DIK
- .;edit the order of the selection - also, for placeholders, the text, then quit
- .I $P(NODE,"^",2) S DA=SLCTN,DIE=357.3,DR="[IBDF EDIT PLACE HOLDER]" D ^DIE K DIE,DA,DR Q
- .S DA=SLCTN,DIE=357.3,DR=".05;I '$P($G(^IBE(357.6,$P($G(^IBE(357.2,+IBLIST,0)),""^"",11),16)),""^"",8) S Y=""@99"";S OQTY=$P(^IBE(357.3,DA,0),""^"",9);.09;S NQTY=X;@99;S CONT=1" S CONT=0 D ^DIE K DIE,DA,DR
- .D CODES^IBDF4A W !
- .D ADD^IBDF4C W !
- .;add any missing subcolumns
- .S SC=0 F SC=1:1:8 I $G(IBLIST("SCTYPE",SC))=1 I '$D(^IBE(357.3,SLCTN,1,"B",SC)) D
- ..K DA,DO,DINUM,DIC
- ..N DLAYGO
- ..S DIC="^IBE(357.3,"_SLCTN_",1,",DA(1)=SLCTN,X=SC,DIC(0)="L",DLAYGO=357.3 D FILE^DICN
- .;now allow the user to edit editable subcolumns - CONT=0 means the user up-arrowed out, so stop
- .I CONT S SUB=0 F S SUB=$O(^IBE(357.3,SLCTN,1,SUB)) Q:'SUB D
- ..S SC=+$G(^IBE(357.3,SLCTN,1,SUB,0)) I $G(IBLIST("SCTYPE",SC))=1,$G(IBLIST("SCPIECE",SC)),$G(IBLIST("SCEDITABLE",SC)) D
- ...I $G(^IBE(357.3,SLCTN,1,0))="" S ^IBE(357.3,SLCTN,1,0)="^357.31IA^"
- ...S DIE="^IBE(357.3,"_SLCTN_",1,",DA(1)=SLCTN,DA=SUB,DR=".02;S CONT=1",CONT=0 W !!,"Editing Subcolumn "_SC_": Header="_IBLIST("SCHDR",SC)
- ...S IBVAL=$P($G(^IBE(357.3,SLCTN,1,SUB,0)),"^",2)
- ...I $G(OQTY)'=$G(NQTY) D
- ....S IBVAL=$P(IBVAL," x "_OQTY)_$S(NQTY>1:" x "_NQTY,1:""),DR=".02////^S X=IBVAL;I;"_DR
- ...I $P($G(^IBE(357.3,SLCTN,3,0)),"^",4)>0 D
- ....S IBVAL=$P($G(^IBE(357.3,SLCTN,1,SUB,0)),"^",2)
- ....S:IBVAL'["w/ mod" IBVAL=IBVAL_" w/ mod"
- ....S DR=".02////^S X=IBVAL;I;"_DR
- ...D ^DIE K DIE,DA,DR,IBVAL I 'CONT Q
- .D NARR^IBDF4 W !
- .D TERM^IBDF4 W !
- ;
- EDITEXIT ;
- G EXIT
- DELETE ;allows the user to select selections to delete
- D FULL^VALM1
- N SEL
- D EN^VALM2($G(XQORNOD(0)))
- K DA
- S SEL="" F S SEL=$O(VALMY(SEL)) Q:'SEL D
- .S DIK="^IBE(357.3,",DA=$P($G(^TMP("SELIDX",$J,SEL)),"^",3) Q:'DA
- .S NODE=$G(^IBE(357.3,DA,0))
- .S IBGRP=$P(NODE,"^",4),ORD=$P(NODE,"^",5)
- .Q:'$$RUSURE^IBDFU5("Selection #"_SEL)
- .D ^DIK
- .D KILL^VALM10(SEL)
- .I '$D(^TMP("IBDF ADDSLCTN",$J)) S ^TMP("IBDF DELETE SELECTION OPTION",$J)=1
- K DIK,DA
- G EXIT
- ADDSLCTN ;allows the user to add a selection to the selection group
- N QUIT,SUB,IBDSLCTN,IBGRP
- ;
- D FULL^VALM1
- S IBRTN=IBLIST("RTN")
- I $G(IBLIST("CLRM")) S IBLIST("EDITING CLRM")=1
- D RTNDSCR^IBDFU1B(.IBRTN)
- I IBRTN("ACTION")'=3 D NOGOOD^IBDF4 G ADDEXIT
- S ^TMP("IBDF ADDSLCTN",$J)=0 ;Track if the user added a selection but did not save changes. Needed for form history fields.
- K @IBRTN("DATA_LOCATION")
- S QUIT=0 F D G:QUIT EXIT W !,"Now for another!",!
- .I '$$DORTN^IBDFU1B(.IBRTN) S QUIT=1 D NOGOOD^IBDF4 Q
- .I '$D(@IBRTN("DATA_LOCATION")) S QUIT=1 Q
- .S DIC="^IBE(357.4,",DIC(0)="AEMN",DIC("S")="I $P(^IBE(357.4,+Y,0),""^"",3)=IBLIST" D ^DIC K DIC S:X="^" QUIT=1 Q:QUIT S IBGRP=+Y I Y<0 D Q:QUIT=1
- ..W !!,"A SELECTION GROUP HEADER IS REQUIRED.... The selection will not be added if none is provided....Enter '??' for a list of choices.",!!
- ..S DIC="^IBE(357.4,",DIC(0)="AEMN",DIC("S")="I $P(^IBE(357.4,+Y,0),""^"",3)=IBLIST" D ^DIC K DIC S IBGRP=+Y I Y<0 S QUIT=1 Q
- .D ADDREC^IBDF4(.QUIT,"",.IBDSLCTN) ;edits and adds the selection
- .I QUIT=1 D:$D(IBDSLCTN) KILL3573(IBDSLCTN)
- .K @IBRTN("DATA_LOCATION")
- ADDEXIT ;
- G EXIT
- ADDBLANK ;allows the user to add a dummy selection to the selection group
- ;i.e., a place holder that will not actually print a selection
- ;
- ;
- N IBGRP
- D FULL^VALM1
- K DIC S DIC="^IBE(357.4,",DIC(0)="AEMN",DIC("S")="I $D(^IBE(357.3,""APO"",IBLIST,+Y))" D ^DIC S IBGRP=+Y K DIC
- I ('$D(DIRUT))&(Y>0) D ADD^IBDF4A
- D INIT^IBDFQSL1
- S VALMBCK="R"
- Q
- ;To kill incomplete entries in ^IBE(357.3
- KILL3573(IBDSEL) ;
- N DA,DIK
- S DA=IBDSEL,DIK="^IBE(357.3," D ^DIK K DIK ;D BLKCHNG^IBDF19(IBFORM,IBBLK)
- Q
- FORMAT ;allows the user to format all of the selections in the group in mass
- ;
- D FORMAT^IBDF9A1
- G EXIT
- ;
- GRPDEL ; -- Group Delete
- N GRP,IBDSEL
- D FULL^VALM1
- S IBDSEL=0
- I $O(^IBE(357.3,"C",IBLIST,"")) S IBDSEL=1 ;Group has selections.
- S DIC="^IBE(357.4,",DIC(0)="AEMN",DIC("S")="I $P(^IBE(357.4,+Y,0),""^"",3)=IBLIST" D ^DIC K DIC S IBGRP=+Y I Y<0 G EXIT
- S GRP=+Y
- Q:'$$RUSURE^IBDFU5($P($G(^IBE(357.4,GRP,0)),"^"))
- I GRP D DELSLCTN^IBDF3 K DA S DIK="^IBE(357.4,",DA=GRP D ^DIK K DIK
- D IDXGRP^IBDF3
- I IBDSEL,'$G(^TMP("IBDF ADDSLCTN",$J)) S ^TMP("IBDF DELETE SELECTION OPTION",$J)=1 ;User deleted a group that had selections.
- S VALMBCK="R"
- D EXIT Q
- ;
- GROUPADD ; -- Add a new group to the selection list and to file 357.4.
- D FULL^VALM1
- N NAME,QUIT,GRP
- S QUIT=0
- F D D IDXGRP^IBDF3 G:QUIT EXIT
- .K DIR S DIR(0)="357.4,.01O",DIR("B")="" D ^DIR K DIR I $D(DIRUT) S QUIT=1 Q
- .S NAME=Y
- .K DIC,DD,DO,DINUM S DIC="^IBE(357.4,",X=NAME,DIC(0)=""
- .D FILE^DICN K DIC,DIE,DA
- .I +Y<0 W !,"Unable to create a new record!" D PAUSE^VALM1 S QUIT=1 Q
- .I +Y>0 K DA S DA=+Y,DIE="^IBE(357.4,",DIE("NO^")="Any value",DR=".02;.04;.03////"_IBLIST D ^DIE K DIC,DIE,DR,DA
- .W !,"Now Another!",!
- G EXIT
- ;
- GRPEDIT ;
- D FULL^VALM1
- N DIC,DIE,DA,DR,GRP
- S DIC="^IBE(357.4,",DIC(0)="AEMN",DIC("S")="I $P(^IBE(357.4,+Y,0),""^"",3)=IBLIST" D ^DIC K DIC S IBGRP=+Y I Y<0 G EXIT
- S GRP=+Y
- S (DIC,DIE)="^IBE(357.4,",DA=GRP,DR=".01;.02;.04" D ^DIE
- I '$D(DA) D DELSLCTN^IBDF3
- D IDXGRP^IBDF3
- S VALMBCK="R"
- D EXIT Q
- Q
- ;
- EXIT D INIT^IBDFQSL1 S VALMBCK="R" I $D(^TMP("IBDF ADDSLCTN",$J)) S ^TMP("IBDF ADDSLCTN",$J)=1
- Q
- GRPRESEQ ; -- Resequence numerically or alphabetically a group
- ; within a block.
- D FULL^VALM1
- N DIC,GRP,IBGRP,IBGRUP
- Q:$$LSTDSCR2^IBDFU1(.IBLIST) 1
- GRP1 S DIC="^IBE(357.4,",DIC(0)="AEMN",DIC("S")="I $P(^IBE(357.4,+Y,0),""^"",3)=IBLIST" D ^DIC K DIC S IBGRUP(+Y)=+Y
- I Y<0&($D(IBGRUP)) D SEQUENCE^IBDF4,EXIT Q
- I Y<0&('$D(IBGRUP)) G EXIT
- G GRP1
- GRPRSEQ1 ; -- Resequence all groups chosen
- N IBGROUP,IBFLAG
- S IBGROUP=0,IBFLAG=1
- F S IBGROUP=$O(IBGRP(IBGROUP)) Q:'IBGROUP D SEQUENCE^IBDF4
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBDFQEA 6587 printed Jan 18, 2025@03:54:22 Page 2
- IBDFQEA ;ALB/CJM/MAF - ENCOUNTER FORM - BUILD FORM(editing action for group's selections list) ;06/16/95
- +1 ;;3.0;AUTOMATED INFO COLLECTION SYS;**15,38,63**;APR 24, 1997;Build 80
- +2 ;
- +3 ;
- EDIT ;allows editing of an existing selection
- +1 DO FULL^VALM1
- +2 NEW SEL,SUB,SLCTN,SC,NODE,OQTY,NQTY
- +3 DO EN^VALM2($GET(XQORNOD(0)),"S")
- +4 SET SEL=""
- FOR
- SET SEL=$ORDER(VALMY(SEL))
- if 'SEL
- QUIT
- Begin DoDot:1
- +5 WRITE !,"Editing Entry #",SEL
- +6 SET SLCTN=$PIECE($GET(^TMP("SELIDX",$JOB,SEL)),"^",3)
- if 'SLCTN
- QUIT
- +7 SET NODE=$GET(^IBE(357.3,SLCTN,0))
- +8 SET IBGRP=$PIECE(NODE,"^",4)
- SET ORD=$PIECE(NODE,"^",5)
- +9 ;re-index the record, to insure it is good
- +10 KILL DIK,DA
- SET DIK="^IBE(357.3,"
- SET DA=SLCTN
- DO IX^DIK
- KILL DIK
- +11 ;edit the order of the selection - also, for placeholders, the text, then quit
- +12 IF $PIECE(NODE,"^",2)
- SET DA=SLCTN
- SET DIE=357.3
- SET DR="[IBDF EDIT PLACE HOLDER]"
- DO ^DIE
- KILL DIE,DA,DR
- QUIT
- +13 SET DA=SLCTN
- SET DIE=357.3
- SET DR=".05;I '$P($G(^IBE(357.6,$P($G(^IBE(357.2,+IBLIST,0)),""^"",11),16)),""^"",8) S Y=""@99"";S OQTY=$P(^IBE(357.3,DA,0),""^"",9);.09;S NQTY=X;@99;S CONT=1"
- SET CONT=0
- DO ^DIE
- KILL DIE,DA,DR
- +14 DO CODES^IBDF4A
- WRITE !
- +15 DO ADD^IBDF4C
- WRITE !
- +16 ;add any missing subcolumns
- +17 SET SC=0
- FOR SC=1:1:8
- IF $GET(IBLIST("SCTYPE",SC))=1
- IF '$DATA(^IBE(357.3,SLCTN,1,"B",SC))
- Begin DoDot:2
- +18 KILL DA,DO,DINUM,DIC
- +19 NEW DLAYGO
- +20 SET DIC="^IBE(357.3,"_SLCTN_",1,"
- SET DA(1)=SLCTN
- SET X=SC
- SET DIC(0)="L"
- SET DLAYGO=357.3
- DO FILE^DICN
- End DoDot:2
- +21 ;now allow the user to edit editable subcolumns - CONT=0 means the user up-arrowed out, so stop
- +22 IF CONT
- SET SUB=0
- FOR
- SET SUB=$ORDER(^IBE(357.3,SLCTN,1,SUB))
- if 'SUB
- QUIT
- Begin DoDot:2
- +23 SET SC=+$GET(^IBE(357.3,SLCTN,1,SUB,0))
- IF $GET(IBLIST("SCTYPE",SC))=1
- IF $GET(IBLIST("SCPIECE",SC))
- IF $GET(IBLIST("SCEDITABLE",SC))
- Begin DoDot:3
- +24 IF $GET(^IBE(357.3,SLCTN,1,0))=""
- SET ^IBE(357.3,SLCTN,1,0)="^357.31IA^"
- +25 SET DIE="^IBE(357.3,"_SLCTN_",1,"
- SET DA(1)=SLCTN
- SET DA=SUB
- SET DR=".02;S CONT=1"
- SET CONT=0
- WRITE !!,"Editing Subcolumn "_SC_": Header="_IBLIST("SCHDR",SC)
- +26 SET IBVAL=$PIECE($GET(^IBE(357.3,SLCTN,1,SUB,0)),"^",2)
- +27 IF $GET(OQTY)'=$GET(NQTY)
- Begin DoDot:4
- +28 SET IBVAL=$PIECE(IBVAL," x "_OQTY)_$SELECT(NQTY>1:" x "_NQTY,1:"")
- SET DR=".02////^S X=IBVAL;I;"_DR
- End DoDot:4
- +29 IF $PIECE($GET(^IBE(357.3,SLCTN,3,0)),"^",4)>0
- Begin DoDot:4
- +30 SET IBVAL=$PIECE($GET(^IBE(357.3,SLCTN,1,SUB,0)),"^",2)
- +31 if IBVAL'["w/ mod"
- SET IBVAL=IBVAL_" w/ mod"
- +32 SET DR=".02////^S X=IBVAL;I;"_DR
- End DoDot:4
- +33 DO ^DIE
- KILL DIE,DA,DR,IBVAL
- IF 'CONT
- QUIT
- End DoDot:3
- End DoDot:2
- +34 DO NARR^IBDF4
- WRITE !
- +35 DO TERM^IBDF4
- WRITE !
- End DoDot:1
- +36 ;
- EDITEXIT ;
- +1 GOTO EXIT
- DELETE ;allows the user to select selections to delete
- +1 DO FULL^VALM1
- +2 NEW SEL
- +3 DO EN^VALM2($GET(XQORNOD(0)))
- +4 KILL DA
- +5 SET SEL=""
- FOR
- SET SEL=$ORDER(VALMY(SEL))
- if 'SEL
- QUIT
- Begin DoDot:1
- +6 SET DIK="^IBE(357.3,"
- SET DA=$PIECE($GET(^TMP("SELIDX",$JOB,SEL)),"^",3)
- if 'DA
- QUIT
- +7 SET NODE=$GET(^IBE(357.3,DA,0))
- +8 SET IBGRP=$PIECE(NODE,"^",4)
- SET ORD=$PIECE(NODE,"^",5)
- +9 if '$$RUSURE^IBDFU5("Selection #"_SEL)
- QUIT
- +10 DO ^DIK
- +11 DO KILL^VALM10(SEL)
- +12 IF '$DATA(^TMP("IBDF ADDSLCTN",$JOB))
- SET ^TMP("IBDF DELETE SELECTION OPTION",$JOB)=1
- End DoDot:1
- +13 KILL DIK,DA
- +14 GOTO EXIT
- ADDSLCTN ;allows the user to add a selection to the selection group
- +1 NEW QUIT,SUB,IBDSLCTN,IBGRP
- +2 ;
- +3 DO FULL^VALM1
- +4 SET IBRTN=IBLIST("RTN")
- +5 IF $GET(IBLIST("CLRM"))
- SET IBLIST("EDITING CLRM")=1
- +6 DO RTNDSCR^IBDFU1B(.IBRTN)
- +7 IF IBRTN("ACTION")'=3
- DO NOGOOD^IBDF4
- GOTO ADDEXIT
- +8 ;Track if the user added a selection but did not save changes. Needed for form history fields.
- SET ^TMP("IBDF ADDSLCTN",$JOB)=0
- +9 KILL @IBRTN("DATA_LOCATION")
- +10 SET QUIT=0
- FOR
- Begin DoDot:1
- +11 IF '$$DORTN^IBDFU1B(.IBRTN)
- SET QUIT=1
- DO NOGOOD^IBDF4
- QUIT
- +12 IF '$DATA(@IBRTN("DATA_LOCATION"))
- SET QUIT=1
- QUIT
- +13 SET DIC="^IBE(357.4,"
- SET DIC(0)="AEMN"
- SET DIC("S")="I $P(^IBE(357.4,+Y,0),""^"",3)=IBLIST"
- DO ^DIC
- KILL DIC
- if X="^"
- SET QUIT=1
- if QUIT
- QUIT
- SET IBGRP=+Y
- IF Y<0
- Begin DoDot:2
- +14 WRITE !!,"A SELECTION GROUP HEADER IS REQUIRED.... The selection will not be added if none is provided....Enter '??' for a list of choices.",!!
- +15 SET DIC="^IBE(357.4,"
- SET DIC(0)="AEMN"
- SET DIC("S")="I $P(^IBE(357.4,+Y,0),""^"",3)=IBLIST"
- DO ^DIC
- KILL DIC
- SET IBGRP=+Y
- IF Y<0
- SET QUIT=1
- QUIT
- End DoDot:2
- if QUIT=1
- QUIT
- +16 ;edits and adds the selection
- DO ADDREC^IBDF4(.QUIT,"",.IBDSLCTN)
- +17 IF QUIT=1
- if $DATA(IBDSLCTN)
- DO KILL3573(IBDSLCTN)
- +18 KILL @IBRTN("DATA_LOCATION")
- End DoDot:1
- if QUIT
- GOTO EXIT
- WRITE !,"Now for another!",!
- ADDEXIT ;
- +1 GOTO EXIT
- ADDBLANK ;allows the user to add a dummy selection to the selection group
- +1 ;i.e., a place holder that will not actually print a selection
- +2 ;
- +3 ;
- +4 NEW IBGRP
- +5 DO FULL^VALM1
- +6 KILL DIC
- SET DIC="^IBE(357.4,"
- SET DIC(0)="AEMN"
- SET DIC("S")="I $D(^IBE(357.3,""APO"",IBLIST,+Y))"
- DO ^DIC
- SET IBGRP=+Y
- KILL DIC
- +7 IF ('$DATA(DIRUT))&(Y>0)
- DO ADD^IBDF4A
- +8 DO INIT^IBDFQSL1
- +9 SET VALMBCK="R"
- +10 QUIT
- +11 ;To kill incomplete entries in ^IBE(357.3
- KILL3573(IBDSEL) ;
- +1 NEW DA,DIK
- +2 ;D BLKCHNG^IBDF19(IBFORM,IBBLK)
- SET DA=IBDSEL
- SET DIK="^IBE(357.3,"
- DO ^DIK
- KILL DIK
- +3 QUIT
- FORMAT ;allows the user to format all of the selections in the group in mass
- +1 ;
- +2 DO FORMAT^IBDF9A1
- +3 GOTO EXIT
- +4 ;
- GRPDEL ; -- Group Delete
- +1 NEW GRP,IBDSEL
- +2 DO FULL^VALM1
- +3 SET IBDSEL=0
- +4 ;Group has selections.
- IF $ORDER(^IBE(357.3,"C",IBLIST,""))
- SET IBDSEL=1
- +5 SET DIC="^IBE(357.4,"
- SET DIC(0)="AEMN"
- SET DIC("S")="I $P(^IBE(357.4,+Y,0),""^"",3)=IBLIST"
- DO ^DIC
- KILL DIC
- SET IBGRP=+Y
- IF Y<0
- GOTO EXIT
- +6 SET GRP=+Y
- +7 if '$$RUSURE^IBDFU5($PIECE($GET(^IBE(357.4,GRP,0)),"^"))
- QUIT
- +8 IF GRP
- DO DELSLCTN^IBDF3
- KILL DA
- SET DIK="^IBE(357.4,"
- SET DA=GRP
- DO ^DIK
- KILL DIK
- +9 DO IDXGRP^IBDF3
- +10 ;User deleted a group that had selections.
- IF IBDSEL
- IF '$GET(^TMP("IBDF ADDSLCTN",$JOB))
- SET ^TMP("IBDF DELETE SELECTION OPTION",$JOB)=1
- +11 SET VALMBCK="R"
- +12 DO EXIT
- QUIT
- +13 ;
- GROUPADD ; -- Add a new group to the selection list and to file 357.4.
- +1 DO FULL^VALM1
- +2 NEW NAME,QUIT,GRP
- +3 SET QUIT=0
- +4 FOR
- Begin DoDot:1
- +5 KILL DIR
- SET DIR(0)="357.4,.01O"
- SET DIR("B")=""
- DO ^DIR
- KILL DIR
- IF $DATA(DIRUT)
- SET QUIT=1
- QUIT
- +6 SET NAME=Y
- +7 KILL DIC,DD,DO,DINUM
- SET DIC="^IBE(357.4,"
- SET X=NAME
- SET DIC(0)=""
- +8 DO FILE^DICN
- KILL DIC,DIE,DA
- +9 IF +Y<0
- WRITE !,"Unable to create a new record!"
- DO PAUSE^VALM1
- SET QUIT=1
- QUIT
- +10 IF +Y>0
- KILL DA
- SET DA=+Y
- SET DIE="^IBE(357.4,"
- SET DIE("NO^")="Any value"
- SET DR=".02;.04;.03////"_IBLIST
- DO ^DIE
- KILL DIC,DIE,DR,DA
- +11 WRITE !,"Now Another!",!
- End DoDot:1
- DO IDXGRP^IBDF3
- if QUIT
- GOTO EXIT
- +12 GOTO EXIT
- +13 ;
- GRPEDIT ;
- +1 DO FULL^VALM1
- +2 NEW DIC,DIE,DA,DR,GRP
- +3 SET DIC="^IBE(357.4,"
- SET DIC(0)="AEMN"
- SET DIC("S")="I $P(^IBE(357.4,+Y,0),""^"",3)=IBLIST"
- DO ^DIC
- KILL DIC
- SET IBGRP=+Y
- IF Y<0
- GOTO EXIT
- +4 SET GRP=+Y
- +5 SET (DIC,DIE)="^IBE(357.4,"
- SET DA=GRP
- SET DR=".01;.02;.04"
- DO ^DIE
- +6 IF '$DATA(DA)
- DO DELSLCTN^IBDF3
- +7 DO IDXGRP^IBDF3
- +8 SET VALMBCK="R"
- +9 DO EXIT
- QUIT
- +10 QUIT
- +11 ;
- EXIT DO INIT^IBDFQSL1
- SET VALMBCK="R"
- IF $DATA(^TMP("IBDF ADDSLCTN",$JOB))
- SET ^TMP("IBDF ADDSLCTN",$JOB)=1
- +1 QUIT
- GRPRESEQ ; -- Resequence numerically or alphabetically a group
- +1 ; within a block.
- +2 DO FULL^VALM1
- +3 NEW DIC,GRP,IBGRP,IBGRUP
- +4 if $$LSTDSCR2^IBDFU1(.IBLIST)
- QUIT 1
- GRP1 SET DIC="^IBE(357.4,"
- SET DIC(0)="AEMN"
- SET DIC("S")="I $P(^IBE(357.4,+Y,0),""^"",3)=IBLIST"
- DO ^DIC
- KILL DIC
- SET IBGRUP(+Y)=+Y
- +1 IF Y<0&($DATA(IBGRUP))
- DO SEQUENCE^IBDF4
- DO EXIT
- QUIT
- +2 IF Y<0&('$DATA(IBGRUP))
- GOTO EXIT
- +3 GOTO GRP1
- GRPRSEQ1 ; -- Resequence all groups chosen
- +1 NEW IBGROUP,IBFLAG
- +2 SET IBGROUP=0
- SET IBFLAG=1
- +3 FOR
- SET IBGROUP=$ORDER(IBGRP(IBGROUP))
- if 'IBGROUP
- QUIT
- DO SEQUENCE^IBDF4
- +4 QUIT