Routine: IBDF9B2

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

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

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

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

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

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

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

IBDF9B2.m