IBDFQEA ;ALB/CJM/MAF - ENCOUNTER FORM - BUILD FORM(editing action for group's selections list) ;JUN 16,1995
;;3.0;AUTOMATED INFO COLLECTION SYS;**15,38**;APR 24, 1997
;
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)
K DIK,DA
G EXIT
ADDSLCTN ;allows the user to add a selection to the selection group
N QUIT,SUB
;
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
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) ;edits and adds the selection
.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
FORMAT ;allows the user to format all of the selections in the group in mass
;
D FORMAT^IBDF9A1
G EXIT
;
GRPDEL ; -- Group Delete
D FULL^VALM1
N 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
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
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"
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
IBDFQEA ;ALB/CJM/MAF - ENCOUNTER FORM - BUILD FORM(editing action for group's selections list) ;JUN 16,1995
+1 ;;3.0;AUTOMATED INFO COLLECTION SYS;**15,38**;APR 24, 1997
+2 ;
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)
End DoDot:1
+12 KILL DIK,DA
+13 GOTO EXIT
ADDSLCTN ;allows the user to add a selection to the selection group
+1 NEW QUIT,SUB
+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 KILL @IBRTN("DATA_LOCATION")
+9 SET QUIT=0
FOR
Begin DoDot:1
+10 IF '$$DORTN^IBDFU1B(.IBRTN)
SET QUIT=1
DO NOGOOD^IBDF4
QUIT
+11 IF '$DATA(@IBRTN("DATA_LOCATION"))
SET QUIT=1
QUIT
+12 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
+13 WRITE !!,"A SELECTION GROUP HEADER IS REQUIRED.... The selection will not be added if none is provided....Enter '??' for a list of choices.",!!
+14 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
+15 ;edits and adds the selection
DO ADDREC^IBDF4(.QUIT)
+16 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
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 DO FULL^VALM1
+2 NEW 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 IF '$$RUSURE^IBDFU5($PIECE($GET(^IBE(357.4,GRP,0)),"^"))
QUIT
+6 IF GRP
DO DELSLCTN^IBDF3
KILL DA
SET DIK="^IBE(357.4,"
SET DA=GRP
DO ^DIK
KILL DIK
+7 DO IDXGRP^IBDF3
+8 SET VALMBCK="R"
+9 DO EXIT
QUIT
+10 ;
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"
+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
