IBDF9B2 ;ALB/CJM - ENCOUNTER FORM - (edit,delete,add multiple choice fields) ;JUL 20,1994
;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997
;
MFIELD ;Create, Edit, or Delete a multiple choice field from the form
;
N IBVALMBG,QUIT
S IBVALMBG=VALMBG
S QUIT=0
S VALMBCK="R"
;
F D Q:QUIT
.D FULL^VALM1
.K DIR S DIR("?",1)="You can Create, Edit, or Delete a multiple choice field, or Shift all of the",DIR("?")="multiple choice fields within a definable range either up or down."
.W !!,DIR("?",1),!,DIR("?"),!
.S DIR("B")="C",DIR(0)="SB^C:Create;E:Edit;D:Delete;S:Shift;Q:Quit",DIR("A")="[C]reate, [D]elete, [E]dit, [S]hift, [Q]uit"
.D ^DIR K DIR I $D(DIRUT)!(Y<0) S QUIT=1 Q
.I Y="Q" S QUIT=1 Q
.D @$S(Y="C":"NEWFLD",Y="E":"EDITFLD",Y="D":"DLTFLD",Y="S":"SHIFT",1:"")
.D RE^VALM4
.D FULL^VALM1
S VALMBCK="R",VALMBG=IBVALMBG
Q
SHIFT ;expects IBBLK to be defined - shifts all input fields within range supplied by user
D SHIFT^IBDF10("M")
D UNCMPBLK^IBDF19(IBBLK),IDXBLOCK^IBDFU4
Q
EDITFLD ;expects IBBLK to be defined
N IBFIELD,RTN,NODE
N IBOLD,IBX,IBY,IBLEN,IBTYPE,IBLABEL,IBQUAL,IBID ;these are used in the input template
D SELECT
I IBFIELD D
.D RE^VALM4
.S (IBX,IBY,IBLEN)=0
.S IBOLD=1,IBTYPE=$P($G(^IBE(357.93,IBFIELD,0)),"^",6)
.K DR,DIE,DA S DIE=357.93,DA=IBFIELD,DR="[IBDF EDIT MULT CHOICE FIELD]",DIE("NO^")="BACKOUTOK" D ^DIE K DIE,DR,DA,DIC
.D UNCMPBLK^IBDF19(IBBLK),IDXBLOCK^IBDFU4
Q
SELECT ;
S IBFIELD=0
Q:'$G(IBBLK)
I '$O(^IBE(357.93,"C",IBBLK,0)) W !,"There is no multiple choice field!" D PAUSE^IBDFU5 Q
AGAIN K DIC S DIC="^IBE(357.93,",DIC(0)="EFQ",DIC("B")="",D="C",X=IBBLK
S DIC("S")="I $P($G(^(0)),U,8)=IBBLK"
D IX^DIC K DIC
S:+Y>0 IBFIELD=+Y
I 'IBFIELD,'$D(DTOUT),'$D(DUOUT) K DIR S DIR(0)="Y",DIR("A")="No multiple choice field selected! Try again",DIR("B")="YES" D ^DIR K DIR I '$D(DIRUT),Y=1 G AGAIN
Q
DLTFLD ;expects IBBLK to be defined
N IBFIELD
D SELECT
I IBFIELD D
.Q:'$$RUSURE^IBDFU5($P($G(^IBE(357.93,IBFIELD,0)),"^"))
.D DLTIFLD^IBDFU3(357.93,IBBLK,IBFIELD)
.D UNCMPBLK^IBDF19(IBBLK),IDXBLOCK^IBDFU4
Q
NEWFLD ;adds a new field, expects IBBLK to be defined
N NAME,FIELD,NODE,IBRTN,DLAYGO
N IBX,IBY,IBLEN,IBOLD,IBTYPE,IBLABEL,IBQUAL,IBID ;these are used in the input template
S NAME=$$NEWNAME^IBDF9B
Q:NAME=-1
S IBOLD=0,(IBX,IBY,IBLEN)=""
K DIC,DIE,DD,DO,DINUM S DIC="^IBE(357.93,",DIC(0)="FL",X=NAME,DLAYGO=357.93
D FILE^DICN K DIC,DIE,DA
S FIELD=$S(+Y<0:"",1:+Y)
I 'FIELD D
.W !,"Unable to create a new input field!" D PAUSE^IBDFU5
I FIELD D
.K DIE,DA,DR S DIE=357.93,DA=FIELD,DR="[IBDF EDIT MULT CHOICE FIELD]",DIE("NO^")="BACKOUTOK" D ^DIE K DIE,DR,DA,DIC
.D UNCMPBLK^IBDF19(IBBLK),IDXBLOCK^IBDFU4
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBDF9B2 2769 printed Nov 22, 2024@18:01:55 Page 2
IBDF9B2 ;ALB/CJM - ENCOUNTER FORM - (edit,delete,add multiple choice fields) ;JUL 20,1994
+1 ;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997
+2 ;
MFIELD ;Create, Edit, or Delete a multiple choice field from the form
+1 ;
+2 NEW IBVALMBG,QUIT
+3 SET IBVALMBG=VALMBG
+4 SET QUIT=0
+5 SET VALMBCK="R"
+6 ;
+7 FOR
Begin DoDot:1
+8 DO FULL^VALM1
+9 KILL DIR
SET DIR("?",1)="You can Create, Edit, or Delete a multiple choice field, or Shift all of the"
SET DIR("?")="multiple choice fields within a definable range either up or down."
+10 WRITE !!,DIR("?",1),!,DIR("?"),!
+11 SET DIR("B")="C"
SET DIR(0)="SB^C:Create;E:Edit;D:Delete;S:Shift;Q:Quit"
SET DIR("A")="[C]reate, [D]elete, [E]dit, [S]hift, [Q]uit"
+12 DO ^DIR
KILL DIR
IF $DATA(DIRUT)!(Y<0)
SET QUIT=1
QUIT
+13 IF Y="Q"
SET QUIT=1
QUIT
+14 DO @$SELECT(Y="C":"NEWFLD",Y="E":"EDITFLD",Y="D":"DLTFLD",Y="S":"SHIFT",1:"")
+15 DO RE^VALM4
+16 DO FULL^VALM1
End DoDot:1
if QUIT
QUIT
+17 SET VALMBCK="R"
SET VALMBG=IBVALMBG
+18 QUIT
SHIFT ;expects IBBLK to be defined - shifts all input fields within range supplied by user
+1 DO SHIFT^IBDF10("M")
+2 DO UNCMPBLK^IBDF19(IBBLK)
DO IDXBLOCK^IBDFU4
+3 QUIT
EDITFLD ;expects IBBLK to be defined
+1 NEW IBFIELD,RTN,NODE
+2 ;these are used in the input template
NEW IBOLD,IBX,IBY,IBLEN,IBTYPE,IBLABEL,IBQUAL,IBID
+3 DO SELECT
+4 IF IBFIELD
Begin DoDot:1
+5 DO RE^VALM4
+6 SET (IBX,IBY,IBLEN)=0
+7 SET IBOLD=1
SET IBTYPE=$PIECE($GET(^IBE(357.93,IBFIELD,0)),"^",6)
+8 KILL DR,DIE,DA
SET DIE=357.93
SET DA=IBFIELD
SET DR="[IBDF EDIT MULT CHOICE FIELD]"
SET DIE("NO^")="BACKOUTOK"
DO ^DIE
KILL DIE,DR,DA,DIC
+9 DO UNCMPBLK^IBDF19(IBBLK)
DO IDXBLOCK^IBDFU4
End DoDot:1
+10 QUIT
SELECT ;
+1 SET IBFIELD=0
+2 if '$GET(IBBLK)
QUIT
+3 IF '$ORDER(^IBE(357.93,"C",IBBLK,0))
WRITE !,"There is no multiple choice field!"
DO PAUSE^IBDFU5
QUIT
AGAIN KILL DIC
SET DIC="^IBE(357.93,"
SET DIC(0)="EFQ"
SET DIC("B")=""
SET D="C"
SET X=IBBLK
+1 SET DIC("S")="I $P($G(^(0)),U,8)=IBBLK"
+2 DO IX^DIC
KILL DIC
+3 if +Y>0
SET IBFIELD=+Y
+4 IF 'IBFIELD
IF '$DATA(DTOUT)
IF '$DATA(DUOUT)
KILL DIR
SET DIR(0)="Y"
SET DIR("A")="No multiple choice field selected! Try again"
SET DIR("B")="YES"
DO ^DIR
KILL DIR
IF '$DATA(DIRUT)
IF Y=1
GOTO AGAIN
+5 QUIT
DLTFLD ;expects IBBLK to be defined
+1 NEW IBFIELD
+2 DO SELECT
+3 IF IBFIELD
Begin DoDot:1
+4 if '$$RUSURE^IBDFU5($PIECE($GET(^IBE(357.93,IBFIELD,0)),"^"))
QUIT
+5 DO DLTIFLD^IBDFU3(357.93,IBBLK,IBFIELD)
+6 DO UNCMPBLK^IBDF19(IBBLK)
DO IDXBLOCK^IBDFU4
End DoDot:1
+7 QUIT
NEWFLD ;adds a new field, expects IBBLK to be defined
+1 NEW NAME,FIELD,NODE,IBRTN,DLAYGO
+2 ;these are used in the input template
NEW IBX,IBY,IBLEN,IBOLD,IBTYPE,IBLABEL,IBQUAL,IBID
+3 SET NAME=$$NEWNAME^IBDF9B
+4 if NAME=-1
QUIT
+5 SET IBOLD=0
SET (IBX,IBY,IBLEN)=""
+6 KILL DIC,DIE,DD,DO,DINUM
SET DIC="^IBE(357.93,"
SET DIC(0)="FL"
SET X=NAME
SET DLAYGO=357.93
+7 DO FILE^DICN
KILL DIC,DIE,DA
+8 SET FIELD=$SELECT(+Y<0:"",1:+Y)
+9 IF 'FIELD
Begin DoDot:1
+10 WRITE !,"Unable to create a new input field!"
DO PAUSE^IBDFU5
End DoDot:1
+11 IF FIELD
Begin DoDot:1
+12 KILL DIE,DA,DR
SET DIE=357.93
SET DA=FIELD
SET DR="[IBDF EDIT MULT CHOICE FIELD]"
SET DIE("NO^")="BACKOUTOK"
DO ^DIE
KILL DIE,DR,DA,DIC
+13 DO UNCMPBLK^IBDF19(IBBLK)
DO IDXBLOCK^IBDFU4
End DoDot:1
+14 QUIT
