IBDF9B3 ;ALB/CJM - ENCOUNTER FORM - (edit,delete,add data fields) ;FEB 1,1993
;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997
;
LABELS ;Create, Edit, or Delete LABELS from the form
I Y="I" 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 labels, Shift all of the labels AND data",DIR("?")="fields within a range 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
S VALMBCK="R",VALMBG=IBVALMBG
Q
SHIFT ;expects IBBLK to be defined - shifts all fields within range supplied by user
D SHIFT^IBDF10("D")
D UNCMPBLK^IBDF19(IBBLK),IDXBLOCK^IBDFU4
Q
EDITFLD ;expects IBBLK to be defined
N IBFIELD,NOD
N IBI,IBOLD,IBX,IBY,IBW,IBDELETE ;these are used in the input template
D SELECT
I IBFIELD D
.D RE^VALM4
.S IBOLD=1,(IBX,IBY)=""
.K DR,DIE,DA S DIE=357.5,DA=IBFIELD,DR="[IBDF EDIT LABEL FIELD]",DIE("NO^")="BACKOUTOK" D ^DIE K DIE,DR,DA
.D UNCMPBLK^IBDF19(IBBLK),IDXBLOCK^IBDFU4
Q
SELECT ;
S IBFIELD=0
Q:'$G(IBBLK)
I '$O(^IBE(357.5,"C",IBBLK,0)) W !,"There is no label only 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 label 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.5,IBFIELD,0)),"^"))
.D DLTFLD^IBDFU3(357.5,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,IBW,IBDELETE,IBOLD ;these are used in the input template
S NAME=$$NEWNAME^IBDF9B Q:NAME=-1
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 label!" D PAUSE^IBDFU5
I FIELD D
.S IBDELETE=1
.D RE^VALM4
.K DIE,DA,DR S DIE=357.5,DA=FIELD,DR="[IBDF EDIT LABEL 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
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBDF9B3 2660 printed Dec 13, 2024@02:51:45 Page 2
IBDF9B3 ;ALB/CJM - ENCOUNTER FORM - (edit,delete,add data fields) ;FEB 1,1993
+1 ;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997
+2 ;
LABELS ;Create, Edit, or Delete LABELS from the form
+1 IF Y="I"
DO LABELS^IBDF9B3
QUIT
+2 ;
+3 NEW IBVALMBG,QUIT
+4 SET QUIT=0
+5 SET IBVALMBG=VALMBG
+6 SET VALMBCK="R"
+7 ;
+8 FOR
Begin DoDot:1
+9 DO FULL^VALM1
+10 KILL DIR
SET DIR("?",1)="You can Create, Edit, or Delete labels, Shift all of the labels AND data"
SET DIR("?")="fields within a range up or down."
+11 WRITE !!,DIR("?",1),!,DIR("?"),!
+12 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"
+13 DO ^DIR
KILL DIR
IF $DATA(DIRUT)!(Y<0)
SET QUIT=1
QUIT
+14 IF Y="Q"
SET QUIT=1
QUIT
+15 DO @$SELECT(Y="C":"NEWFLD",Y="E":"EDITFLD",Y="D":"DLTFLD",Y="S":"SHIFT",1:"")
+16 DO RE^VALM4
End DoDot:1
if QUIT
QUIT
+17 SET VALMBCK="R"
SET VALMBG=IBVALMBG
+18 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,NOD
+2 ;these are used in the input template
NEW IBI,IBOLD,IBX,IBY,IBW,IBDELETE
+3 DO SELECT
+4 IF IBFIELD
Begin DoDot:1
+5 DO RE^VALM4
+6 SET IBOLD=1
SET (IBX,IBY)=""
+7 KILL DR,DIE,DA
SET DIE=357.5
SET DA=IBFIELD
SET DR="[IBDF EDIT LABEL FIELD]"
SET DIE("NO^")="BACKOUTOK"
DO ^DIE
KILL DIE,DR,DA
+8 DO UNCMPBLK^IBDF19(IBBLK)
DO IDXBLOCK^IBDFU4
End DoDot:1
+9 QUIT
SELECT ;
+1 SET IBFIELD=0
+2 if '$GET(IBBLK)
QUIT
+3 IF '$ORDER(^IBE(357.5,"C",IBBLK,0))
WRITE !,"There is no label only 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 label 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,IBW,IBDELETE,IBOLD
+3 SET NAME=$$NEWNAME^IBDF9B
if NAME=-1
QUIT
+4 SET IBOLD=0
SET (IBX,IBY)=""
+5 KILL DIC,DIE,DD,DO,DINUM
SET DIC="^IBE(357.5,"
SET DIC(0)="FL"
SET X=NAME
SET DLAYGO=357.5
+6 DO FILE^DICN
KILL DIC,DIE,DA
+7 SET FIELD=$SELECT(+Y<0:"",1:+Y)
+8 IF 'FIELD
Begin DoDot:1
+9 WRITE !,"Unable to create a new label!"
DO PAUSE^IBDFU5
End DoDot:1
+10 IF FIELD
Begin DoDot:1
+11 SET IBDELETE=1
+12 DO RE^VALM4
+13 KILL DIE,DA,DR
SET DIE=357.5
SET DA=FIELD
SET DR="[IBDF EDIT LABEL 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
