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
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,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
Q
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
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,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
Q
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)
Q
;
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)
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBDF9B 4656 printed Oct 16, 2024@18:52:28 Page 2
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 ;
