- 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 Mar 13, 2025@21:56:48 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
