Routine: IBDF9B

IBDF9B ;ALB/CJM - ENCOUNTER FORM - (edit,delete,add data fields) ;FEB 1,1993

 ;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997

FIELD ;Create, Edit, or Delete a data field from the form

 S VALMBCK="R"

 D FULL^VALM1

 K DIR S DIR("?",1)="A DISPLAY FIELD outputs data from VISTA, MULTIPLE CHOICE FIELDS",DIR("?")="and HAND PRINT FIELDS allow input of data, LABELS are for fixed text fields"

 W !,DIR("?",1),!,DIR("?"),!!

 S DIR("B")="D",DIR(0)="SB^D:Display Field;M:Multiple Choice Field;H:Hand Print;L:Label Only",DIR("A")="Edit fields for: [D]isplay,  [M]ultiple Choice, [H]and Print, [L]abel only"

 D ^DIR K DIR I $D(DIRUT)!(Y<0) Q

 I Y="M" D MFIELD^IBDF9B2 Q

 I Y="H" D HFIELD^IBDF9B4 Q

 I Y="L" D LABELS^IBDF9B3 Q

 N IBVALMBG,QUIT

 S QUIT=0

 S IBVALMBG=VALMBG

 S VALMBCK="R"

 F  D  Q:QUIT

 .D FULL^VALM1

 .K DIR S DIR("?",1)="You can Create, Edit, or Delete a data field, Shift all of the data fields",DIR("?")="within a range up or down, or List their locations ."

 .W !!,DIR("?",1),!,DIR("?"),!

 .S DIR("B")="C",DIR(0)="SB^C:Create;E:Edit;D:Delete;S:Shift;L:List;Q:Quit",DIR("A")="[C]reate,  [D]elete,  [E]dit,   [S]hift,  [L]ocations,  [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",Y="L":"^IBDF9B1",1:"")

 .D RE^VALM4

 S VALMBCK="R",VALMBG=IBVALMBG

SHIFT ;expects IBBLK to be defined - shifts all fields within range supplied by user

 D SHIFT^IBDF10("D")

 D UNCMPBLK^IBDF19(IBBLK),IDXBLOCK^IBDFU4

EDITFLD ;expects IBBLK to be defined

 N IBFIELD,RTN,NODE

 N IBMF,IBWP,IBLIST,IBI,IBOLD,IBX,IBY,IBW,IBP,IBLEN,IBDELETE ;these are used in the input template

 ;IBMF=1 if display interface returns records,IBWP=1 display interface returns a word processing field

 D SELECT

 I IBFIELD D

 .D RE^VALM4

 .S (IBMF,IBLIST,IBWP)=0,IBOLD=1,(IBX,IBY)=""

 .S RTN=$P($G(^IBE(357.5,IBFIELD,0)),"^",3)

 .I RTN D DATATYPE(RTN)

 .K DR,DIE,DA S DIE=357.5,DA=IBFIELD,DR="[IBDF EDIT DATA FIELD]",DIE("NO^")="BACKOUTOK" D ^DIE K DIE,DR,DA

 .D UNCMPBLK^IBDF19(IBBLK),IDXBLOCK^IBDFU4

SELECT ;

 S IBFIELD=0

 Q:'$G(IBBLK)

 I '$O(^IBE(357.5,"C",IBBLK,0)) W !,"There is no data field!" D PAUSE^IBDFU5 Q

AGAIN K DIC S DIC="^IBE(357.5,",DIC(0)="EFQ",DIC("B")="",D="C",X=IBBLK

 S DIC("S")="I $P(^(0),U,2)=IBBLK,+$P(^(0),U,3)>0"

 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 data 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.5,IBFIELD,0)),"^"))

 .D DLTFLD^IBDFU3(357.5,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,IBLIST,IBLEN,IBWP,IBMF,IBW,IBP,IBDELETE,IBOLD ;these are used in the input template

 S NAME=$$NEWNAME Q:NAME=-1

 S IBRTN=$$LOOKUP Q:'IBRTN

 S IBOLD=0,(IBX,IBY)=""

 K DIC,DIE,DD,DO,DINUM S DIC="^IBE(357.5,",DIC(0)="FL",X=NAME,DLAYGO=357.5

 D FILE^DICN K DIC,DIE,DA

 S FIELD=$S(+Y<0:"",1:+Y)

 I 'FIELD D

 .W !,"Unable to create a new data field!" D PAUSE^IBDFU5

 I FIELD D

 .S IBDELETE=1

 .K DIE,DA,DR S DIE=357.5,DA=FIELD,DR="[IBDF EDIT DATA FIELD]",DIE("NO^")="BACKOUTOK" D ^DIE K DIE,DR,DA,DIC

 .I IBDELETE K DA S DIK="^IBE(357.5,",DA=FIELD D ^DIK K DIK,DA Q

 .D UNCMPBLK^IBDF19(IBBLK),IDXBLOCK^IBDFU4

NEWNAME() ;

 K DIR S DIR(0)="357.5,.01A",DIR("A")="New Field Name: ",DIR("B")=""

 D ^DIR K DIR I $D(DIRUT) Q -1

Q Y

DATATYPE(RTN) ;

 ;INPUT - RTN is a ptr to the package interface file

 ;OUTPUT - IBLEN() stores the lengths of the pieces of the record returned by the package interface

 ;IBLIST=1 if list,IBMF=1 if record, IBWP=1 if word processing

 N IBSUB,NODE,DATATYPE

 S (IBMF,IBWP,IBLIST)=0

 Q:'$G(RTN)

 S DATATYPE=$P($G(^IBE(357.6,RTN,0)),"^",7) S:DATATYPE=5 IBWP=1 S:(DATATYPE=2)!(DATATYPE=4) IBMF=1 S:(DATATYPE=3)!(DATATYPE=4) IBLIST=1

 I 'IBWP D

 .N IEN

 .S IEN=0 F  S IEN=$O(^IBE(357.6,RTN,15,"C",IEN)) Q:'IEN  S NODE=$G(^IBE(357.6,RTN,15,IEN,0)) I $P(NODE,"^",3) S IBLEN($P(NODE,"^",3))=+$P(NODE,"^",2)

 .S IBLEN(1)=$P($G(^IBE(357.6,RTN,2)),"^",2)

LOOKUP() ;does a lookup on the package interface file using the E cross-reference, which uses the name with the prefix=namespace removed

 K DIC S DIC("S")="I $P(^(0),U,6)=2,$P(^(0),U,9)=1"

 S DIC="^IBE(357.6,",DIC(0)="MQEA",D="E^D^B",DIC("A")="Select the TYPE OF DATA that should be displayed:" D MIX^DIC1 K DIC,DA,D

 Q $S((Y<0)!$D(DTOUT)!$D(DUOUT):0,1:+Y)

IBDF9B    ;ALB/CJM - ENCOUNTER FORM - (edit,delete,add data fields) ;FEB 1,1993

 +1       ;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997

 +2       ;

FIELD     ;Create, Edit, or Delete a data field from the form

 +1        SET VALMBCK="R"

 +2        DO FULL^VALM1

 +3        KILL DIR

           SET DIR("?",1)="A DISPLAY FIELD outputs data from VISTA, MULTIPLE CHOICE FIELDS"

           SET DIR("?")="and HAND PRINT FIELDS allow input of data, LABELS are for fixed text fields"

 +4        WRITE !,DIR("?",1),!,DIR("?"),!!

 +5        SET DIR("B")="D"

           SET DIR(0)="SB^D:Display Field;M:Multiple Choice Field;H:Hand Print;L:Label Only"

           SET DIR("A")="Edit fields for: [D]isplay,  [M]ultiple Choice, [H]and Print, [L]abel only"

 +6        DO ^DIR

           KILL DIR

           IF $DATA(DIRUT)!(Y<0)

               QUIT

 +7        IF Y="M"

               DO MFIELD^IBDF9B2

               QUIT

 +8        IF Y="H"

               DO HFIELD^IBDF9B4

               QUIT

 +9        IF Y="L"

               DO LABELS^IBDF9B3

               QUIT

 +10      ;

 +11       NEW IBVALMBG,QUIT

 +12       SET QUIT=0

 +13       SET IBVALMBG=VALMBG

 +14       SET VALMBCK="R"

 +15      ;

 +16       FOR

               Begin DoDot:1

 +17               DO FULL^VALM1

 +18               KILL DIR

                   SET DIR("?",1)="You can Create, Edit, or Delete a data field, Shift all of the data fields"

                   SET DIR("?")="within a range up or down, or List their locations ."

 +19               WRITE !!,DIR("?",1),!,DIR("?"),!

 +20               SET DIR("B")="C"

                   SET DIR(0)="SB^C:Create;E:Edit;D:Delete;S:Shift;L:List;Q:Quit"

                   SET DIR("A")="[C]reate,  [D]elete,  [E]dit,   [S]hift,  [L]ocations,  [Q]uit"

 +21               DO ^DIR

                   KILL DIR

                   IF $DATA(DIRUT)!(Y<0)

                       SET QUIT=1

                       QUIT

 +22               IF Y="Q"

                       SET QUIT=1

                       QUIT

 +23               DO @$SELECT(Y="C":"NEWFLD",Y="E":"EDITFLD",Y="D":"DLTFLD",Y="S":"SHIFT",Y="L":"^IBDF9B1",1:"")

 +24               DO RE^VALM4

               End DoDot:1

               IF QUIT

                   QUIT

 +25       SET VALMBCK="R"

           SET VALMBG=IBVALMBG

 +26       QUIT

SHIFT     ;expects IBBLK to be defined - shifts all fields within range supplied by user

 +1        DO SHIFT^IBDF10("D")

 +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 IBMF,IBWP,IBLIST,IBI,IBOLD,IBX,IBY,IBW,IBP,IBLEN,IBDELETE

 +3       ;IBMF=1 if display interface returns records,IBWP=1 display interface returns a word processing field

 +4        DO SELECT

 +5        IF IBFIELD

               Begin DoDot:1

 +6                DO RE^VALM4

 +7                SET (IBMF,IBLIST,IBWP)=0

                   SET IBOLD=1

                   SET (IBX,IBY)=""

 +8                SET RTN=$PIECE($GET(^IBE(357.5,IBFIELD,0)),"^",3)

 +9                IF RTN

                       DO DATATYPE(RTN)

 +10               KILL DR,DIE,DA

                   SET DIE=357.5

                   SET DA=IBFIELD

                   SET DR="[IBDF EDIT DATA FIELD]"

                   SET DIE("NO^")="BACKOUTOK"

                   DO ^DIE

                   KILL DIE,DR,DA

 +11               DO UNCMPBLK^IBDF19(IBBLK)

                   DO IDXBLOCK^IBDFU4

               End DoDot:1

 +12       QUIT

SELECT    ;

 +1        SET IBFIELD=0

 +2        IF '$GET(IBBLK)

               QUIT

 +3        IF '$ORDER(^IBE(357.5,"C",IBBLK,0))

               WRITE !,"There is no data field!"

               DO PAUSE^IBDFU5

               QUIT

AGAIN      KILL DIC

           SET DIC="^IBE(357.5,"

           SET DIC(0)="EFQ"

           SET DIC("B")=""

           SET D="C"

           SET X=IBBLK

 +1        SET DIC("S")="I $P(^(0),U,2)=IBBLK,+$P(^(0),U,3)>0"

 +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 data 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.5,IBFIELD,0)),"^"))

                       QUIT

 +5                DO DLTFLD^IBDFU3(357.5,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,IBLIST,IBLEN,IBWP,IBMF,IBW,IBP,IBDELETE,IBOLD

 +3        SET NAME=$$NEWNAME

           IF NAME=-1

               QUIT

 +4        SET IBRTN=$$LOOKUP

           IF 'IBRTN

               QUIT

 +5        SET IBOLD=0

           SET (IBX,IBY)=""

 +6        KILL DIC,DIE,DD,DO,DINUM

           SET DIC="^IBE(357.5,"

           SET DIC(0)="FL"

           SET X=NAME

           SET DLAYGO=357.5

 +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 data field!"

                   DO PAUSE^IBDFU5

               End DoDot:1

 +11       IF FIELD

               Begin DoDot:1

 +12               SET IBDELETE=1

 +13               KILL DIE,DA,DR

                   SET DIE=357.5

                   SET DA=FIELD

                   SET DR="[IBDF EDIT DATA FIELD]"

                   SET DIE("NO^")="BACKOUTOK"

                   DO ^DIE

                   KILL DIE,DR,DA,DIC

 +14               IF IBDELETE

                       KILL DA

                       SET DIK="^IBE(357.5,"

                       SET DA=FIELD

                       DO ^DIK

                       KILL DIK,DA

                       QUIT

 +15               DO UNCMPBLK^IBDF19(IBBLK)

                   DO IDXBLOCK^IBDFU4

               End DoDot:1

 +16       QUIT

NEWNAME() ;

 +1        KILL DIR

           SET DIR(0)="357.5,.01A"

           SET DIR("A")="New Field Name: "

           SET DIR("B")=""

 +2        DO ^DIR

           KILL DIR

           IF $DATA(DIRUT)

               QUIT -1

 +3        QUIT Y

 +4       ;

DATATYPE(RTN) ;

 +1       ;INPUT - RTN is a ptr to the package interface file

 +2       ;

 +3       ;OUTPUT - IBLEN() stores the lengths of the pieces of the record returned by the package interface

 +4       ;IBLIST=1 if list,IBMF=1 if record, IBWP=1 if word processing

 +5       ;

 +6        NEW IBSUB,NODE,DATATYPE

 +7        SET (IBMF,IBWP,IBLIST)=0

 +8        IF '$GET(RTN)

               QUIT

 +9        SET DATATYPE=$PIECE($GET(^IBE(357.6,RTN,0)),"^",7)

           IF DATATYPE=5

               SET IBWP=1

           IF (DATATYPE=2)!(DATATYPE=4)

               SET IBMF=1

           IF (DATATYPE=3)!(DATATYPE=4)

               SET IBLIST=1

 +10       IF 'IBWP

               Begin DoDot:1

 +11               NEW IEN

 +12               SET IEN=0

FOR

                       SET IEN=$ORDER(^IBE(357.6,RTN,15,"C",IEN))

                       IF 'IEN

                           QUIT

                       SET NODE=$GET(^IBE(357.6,RTN,15,IEN,0))

                       IF $PIECE(NODE,"^",3)

                           SET IBLEN($PIECE(NODE,"^",3))=+$PIECE(NODE,"^",2)

 +13               SET IBLEN(1)=$PIECE($GET(^IBE(357.6,RTN,2)),"^",2)

               End DoDot:1

 +14       QUIT

 +15      ;

LOOKUP()  ;does a lookup on the package interface file using the E cross-reference, which uses the name with the prefix=namespace removed

 +1        KILL DIC

           SET DIC("S")="I $P(^(0),U,6)=2,$P(^(0),U,9)=1"

 +2        SET DIC="^IBE(357.6,"

           SET DIC(0)="MQEA"

           SET D="E^D^B"

           SET DIC("A")="Select the TYPE OF DATA that should be displayed:"

           DO MIX^DIC1

           KILL DIC,DA,D

 +3        QUIT $SELECT((Y<0)!$DATA(DTOUT)!$DATA(DUOUT):0,1:+Y)

 +4       ;

IBDF9B.m