IBDF9A ;ALB/CJM - ENCOUNTER FORM - (create,edit,delete selection list) ;FEB 1,1993
;;3.0;AUTOMATED INFO COLLECTION SYS;**15**;APR 24, 1997
;
LIST ;Create, Edit, or Delete a selection list from the form
N IBVALMBG
S VALMBCK="R",IBVALMBG=VALMBG
K DIR S DIR("?",1)="You can create a [N]ew list, edit its [A]ppearance, [D]elete it,",DIR("?")="edit its [Co]ntents, [P]osition or size its columns. Choose from:"
S DIR("B")="C" I $G(IBBLK) D
.S X=$G(^IBE(357.2,+$O(^IBE(357.2,"C",IBBLK,0)),0))
.I $P(X,"^",14),'$P(X,"^",19) S DIR("B")="A" ;dynamic list, can't edit contents, default changed to appearance, unless its clinical reminders
;
S DIR(0)="SAB^A:APPEARANCE;C:CONTENTS;D:DELETE;N:NEW;P:POSITION",DIR("A")="[N]ew [A]ppearance [D]elete [C]ontents [P]osition: "
W !!,DIR("?",1),!,DIR("?"),!
D ^DIR K DIR I $D(DIRUT)!(Y<0) Q
D @$S(Y="C":"EDITLIST^IBDF3",Y="A":"EDITLIST",Y="N":"NEWLIST^IBDF9A1",Y="D":"DLTLIST",Y="P":"COLUMNS",1:"NOSUCH")
S VALMBG=IBVALMBG
Q
NOSUCH ;
Q
EDITLIST ;allows editing of the structure of a list
;expects IBBLK to be defined
;IBSC1,IBSC2,IBSWITCH,IBD,IBOLD,IBLEN are used in the input template
N IBLIST,IBRTN,IBSC1,IBSC2,IBSWITCH,IBSWT,IBD,IBOLD,IBLEN,IBDELETE,IBSCOLD,IBSCNEW,FROM,TO,IBDYN,IBINPUT,IBSC,IBSCRAY
S VALMBCK="R",(IBOLD,IBSWITCH)=1
D FULL^VALM1
D SELECT
I IBLIST D
.S (IBSCOLD,IBSCNEW)=""
.S IBRTN=$P($G(^IBE(357.2,IBLIST,0)),"^",11)
.D LISTTYPE(IBRTN)
.D GETSC^IBDF9A3(.IBSCOLD,IBLIST)
.D:IBRTN DATASIZE(IBRTN)
.K DIE,DA,DR S DIE=357.2,DA=IBLIST,DR="[IBDF EDIT SELECTION LIST]",DIE("NO^")="BACKOUTOK" D ^DIE K DIE,DR,DA,%,I
.;
.;if the list already had selections the subcolumns may need to be reordered/created/deleted
.S IBSWITCH="" F S IBSWITCH=$O(IBSWITCH(IBSWITCH)) Q:'IBSWITCH S FROM=$P(IBSWITCH(IBSWITCH),"^"),TO=$P(IBSWITCH(IBSWITCH),"^",2) D S IBSWT(FROM)=TO
..I $D(IBSCOLD(TO)) D DELSC^IBDF9A3(IBLIST,TO)
..;D SWITCH(IBLIST,FROM,TO)
..I $D(IBSCOLD(FROM)) S IBSCOLD(TO)=IBSCOLD(FROM) K IBSCOLD(FROM)
.D SWITCH(IBLIST,.IBSWT)
.D GETSC^IBDF9A3(.IBSCNEW,IBLIST)
.N SC S SC=0 F S SC=$O(IBSCOLD(SC)) Q:'SC I IBSCOLD(SC)'=$G(IBSCNEW(SC)) D DELSC^IBDF9A3(IBLIST,SC)
.S SC=0 F S SC=$O(IBSCNEW(SC)) Q:'SC I IBSCNEW(SC)'=$G(IBSCOLD(SC)) D ADDSC^IBDF9A3(IBLIST,SC)
.D BLKCHNG^IBDF19(IBFORM,IBBLK) ;8/20/96 changed from d UNCMPLBLK^IBDF19
.D IDXBLOCK^IBDFU4
S VALMBCK="R"
Q
COLUMNS ;allows the user to place and size the columns of the list
;expects IBBLK to be defined
N IBLIST
S VALMBCK="R"
D FULL^VALM1
D SELECT
I IBLIST D
.K DIE,DA,DR S DIE=357.2,DA=IBLIST,DR="[IBDF POSITION/SIZE COLUMNS]",DIE("NO^")="BACKOUTOK" D ^DIE K DIE,DR,DA
.D UNCMPBLK^IBDF19(IBBLK),IDXBLOCK^IBDFU4
S VALMBCK="R"
Q
SELECT ;
S IBLIST=""
Q:'$G(IBBLK)
I '$O(^IBE(357.2,"C",IBBLK,0)) W !,"There is no selection list!" D PAUSE^IBDFU5 Q
AGAIN K DIC S DIC="^IBE(357.2,",DIC(0)="EQ",D="C",X=IBBLK
S DIC("S")="I $P($G(^(0)),U,2)=IBBLK"
D IX^DIC K DIC
S:+Y>0 IBLIST=+Y
I 'IBLIST,'$D(DTOUT),'$D(DUOUT) K DIR S DIR(0)="Y",DIR("A")="No selection list selected! Try again",DIR("B")="YES" D ^DIR K DIR I '$D(DIRUT),Y=1 G AGAIN
Q
MSG1 ;called by the input template
W !!,"Entering the number of list columns is optional. By default the list will be",!,"given as many columns as the block has space for.",!
Q
MSG2 ;called by the input template
W !!,"Entering the information on the position of the columns and their",!,"height is optional. Appropriate default values will be used. However,",!,"you may specify your own values for up to 4 coulmns.",!
Q
MSG3 ;called by the input template
W !!,"You can now specify the subcolumns the list should contain.",!,"There can be at most 6 subcolumns, numbered 1-6.",!
Q
;
DATASIZE(RTN) ;IBLEN() stores the lengths of the pieces of the record returned by the package interface
N NODE,IEN,PIECE
Q:'$G(RTN)
S PIECE=0 F S PIECE=$O(^IBE(357.6,RTN,15,"C",PIECE)) Q:'PIECE S IEN=0 F S IEN=$O(^IBE(357.6,RTN,15,"C",PIECE,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)_"^"_$P(NODE,"^",5)
S IBLEN(0)=4
S IBLEN(1)=$P($G(^IBE(357.6,RTN,2)),"^",2)_"^"_$P($G(^IBE(357.6,RTN,2)),"^",16)
Q
;
NEWNAME() ;
K DIR S DIR(0)="357.2,.01A",DIR("A")="New Selection List Name: ",DIR("B")=""
D ^DIR K DIR I $D(DIRUT) Q -1
Q Y
SWITCH(IBLIST,IBARRY) ;FOR loops thru selection list and changes all subcolumn numbers from old to new (called only once)
N SLCTN,SC
S SLCTN="" F S SLCTN=$O(^IBE(357.3,"C",IBLIST,SLCTN)) Q:'SLCTN D
.S (IBSC1,SC)=0 F S IBSC1=$O(^IBE(357.3,SLCTN,1,"B",IBSC1)) Q:'IBSC1 F S SC=$O(^IBE(357.3,SLCTN,1,"B",IBSC1,SC)) Q:'SC S IBSC(SC)=IBSC1
. S (IBSC1,SC)=0 F S SC=$O(IBSC(SC)) Q:'SC S IBSC1=IBSC(SC) D
..;I $P($G(^IBE(357.3,SLCTN,1,SC,0)),"^")=IBSC1 D
..I $D(IBARRY(IBSC1)) S IBSC2=IBARRY(IBSC1) D
...I $G(^IBE(357.3,SLCTN,1,0))="" S ^IBE(357.3,SLCTN,1,0)="^357.31IA^"
...K DIE,DA,DR S DIE="^IBE(357.3,SLCTN,1,",DA(1)=SLCTN,DA=SC,DR=".01////"_IBSC2
...D ^DIE
...;K DIE,DA,DR S DA(1)=SLCTN,DIE="^IBE(357.3,"_DA(1)_",1,",DA=SC,DR=".01////"_IBSC2
..E D
...K ^IBE(357.3,SLCTN,1,"B",IBSC1,SC)
...K DIK,DA S DIK="^IBE(357.3,SLCTN,1,",DA(1)=SLCTN,DA=SC D IX^DIK
K DIK,DA,DIE,DR
Q
RTN() ;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)=3,$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 the list will contain: " D MIX^DIC1 K DIC,DA
Q $S((Y<0)!$D(DTOUT)!$D(DUOUT):0,1:+Y)
DLTLIST ;expects IBBLK to be defined
N IBLIST
D FULL^VALM1
D SELECT
I IBLIST D
.Q:'$$RUSURE^IBDFU5($P($G(^IBE(357.2,IBLIST,0)),"^"))
.D DLTLIST^IBDFU3(357.2,IBBLK,IBLIST)
.D UNCMPBLK^IBDF19(IBBLK),IDXBLOCK^IBDFU4
Q
;
LISTTYPE(RTN) ;sets IBDYN=1 if the rtn is dynamic selection,IBINPUT to the input interface
N NODE
I '$G(RTN) S (IBDYN,IBINPUT,IBCLRM)=0 Q
S NODE=$G(^IBE(357.6,RTN,0))
S IBDYN=$P(NODE,"^",14)
S IBINPUT=$P(NODE,"^",13)
S IBCLRM=$P(NODE,"^",20)
Q
;
OTHEROK(PI) ;returns 1 if the selection interface=PI allows 'other', 0 otherwise
N NODE
Q:'$G(PI) 0
;
;there must be an interface for input
Q:'$P((^IBE(357.6,PI,0)),"^",13) 0
;
;the selection interface must allow input of narrative or code
S NODE=$G(^IBE(357.6,PI,16))
I '$P(NODE,"^",2),'$P(NODE,"^",6) Q 0
Q 1
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBDF9A 6480 printed Jan 18, 2025@03:52:51 Page 2
IBDF9A ;ALB/CJM - ENCOUNTER FORM - (create,edit,delete selection list) ;FEB 1,1993
+1 ;;3.0;AUTOMATED INFO COLLECTION SYS;**15**;APR 24, 1997
+2 ;
LIST ;Create, Edit, or Delete a selection list from the form
+1 NEW IBVALMBG
+2 SET VALMBCK="R"
SET IBVALMBG=VALMBG
+3 KILL DIR
SET DIR("?",1)="You can create a [N]ew list, edit its [A]ppearance, [D]elete it,"
SET DIR("?")="edit its [Co]ntents, [P]osition or size its columns. Choose from:"
+4 SET DIR("B")="C"
IF $GET(IBBLK)
Begin DoDot:1
+5 SET X=$GET(^IBE(357.2,+$ORDER(^IBE(357.2,"C",IBBLK,0)),0))
+6 ;dynamic list, can't edit contents, default changed to appearance, unless its clinical reminders
IF $PIECE(X,"^",14)
IF '$PIECE(X,"^",19)
SET DIR("B")="A"
End DoDot:1
+7 ;
+8 SET DIR(0)="SAB^A:APPEARANCE;C:CONTENTS;D:DELETE;N:NEW;P:POSITION"
SET DIR("A")="[N]ew [A]ppearance [D]elete [C]ontents [P]osition: "
+9 WRITE !!,DIR("?",1),!,DIR("?"),!
+10 DO ^DIR
KILL DIR
IF $DATA(DIRUT)!(Y<0)
QUIT
+11 DO @$SELECT(Y="C":"EDITLIST^IBDF3",Y="A":"EDITLIST",Y="N":"NEWLIST^IBDF9A1",Y="D":"DLTLIST",Y="P":"COLUMNS",1:"NOSUCH")
+12 SET VALMBG=IBVALMBG
+13 QUIT
NOSUCH ;
+1 QUIT
EDITLIST ;allows editing of the structure of a list
+1 ;expects IBBLK to be defined
+2 ;IBSC1,IBSC2,IBSWITCH,IBD,IBOLD,IBLEN are used in the input template
+3 NEW IBLIST,IBRTN,IBSC1,IBSC2,IBSWITCH,IBSWT,IBD,IBOLD,IBLEN,IBDELETE,IBSCOLD,IBSCNEW,FROM,TO,IBDYN,IBINPUT,IBSC,IBSCRAY
+4 SET VALMBCK="R"
SET (IBOLD,IBSWITCH)=1
+5 DO FULL^VALM1
+6 DO SELECT
+7 IF IBLIST
Begin DoDot:1
+8 SET (IBSCOLD,IBSCNEW)=""
+9 SET IBRTN=$PIECE($GET(^IBE(357.2,IBLIST,0)),"^",11)
+10 DO LISTTYPE(IBRTN)
+11 DO GETSC^IBDF9A3(.IBSCOLD,IBLIST)
+12 if IBRTN
DO DATASIZE(IBRTN)
+13 KILL DIE,DA,DR
SET DIE=357.2
SET DA=IBLIST
SET DR="[IBDF EDIT SELECTION LIST]"
SET DIE("NO^")="BACKOUTOK"
DO ^DIE
KILL DIE,DR,DA,%,I
+14 ;
+15 ;if the list already had selections the subcolumns may need to be reordered/created/deleted
+16 SET IBSWITCH=""
FOR
SET IBSWITCH=$ORDER(IBSWITCH(IBSWITCH))
if 'IBSWITCH
QUIT
SET FROM=$PIECE(IBSWITCH(IBSWITCH),"^")
SET TO=$PIECE(IBSWITCH(IBSWITCH),"^",2)
Begin DoDot:2
+17 IF $DATA(IBSCOLD(TO))
DO DELSC^IBDF9A3(IBLIST,TO)
+18 ;D SWITCH(IBLIST,FROM,TO)
+19 IF $DATA(IBSCOLD(FROM))
SET IBSCOLD(TO)=IBSCOLD(FROM)
KILL IBSCOLD(FROM)
End DoDot:2
SET IBSWT(FROM)=TO
+20 DO SWITCH(IBLIST,.IBSWT)
+21 DO GETSC^IBDF9A3(.IBSCNEW,IBLIST)
+22 NEW SC
SET SC=0
FOR
SET SC=$ORDER(IBSCOLD(SC))
if 'SC
QUIT
IF IBSCOLD(SC)'=$GET(IBSCNEW(SC))
DO DELSC^IBDF9A3(IBLIST,SC)
+23 SET SC=0
FOR
SET SC=$ORDER(IBSCNEW(SC))
if 'SC
QUIT
IF IBSCNEW(SC)'=$GET(IBSCOLD(SC))
DO ADDSC^IBDF9A3(IBLIST,SC)
+24 ;8/20/96 changed from d UNCMPLBLK^IBDF19
DO BLKCHNG^IBDF19(IBFORM,IBBLK)
+25 DO IDXBLOCK^IBDFU4
End DoDot:1
+26 SET VALMBCK="R"
+27 QUIT
COLUMNS ;allows the user to place and size the columns of the list
+1 ;expects IBBLK to be defined
+2 NEW IBLIST
+3 SET VALMBCK="R"
+4 DO FULL^VALM1
+5 DO SELECT
+6 IF IBLIST
Begin DoDot:1
+7 KILL DIE,DA,DR
SET DIE=357.2
SET DA=IBLIST
SET DR="[IBDF POSITION/SIZE COLUMNS]"
SET DIE("NO^")="BACKOUTOK"
DO ^DIE
KILL DIE,DR,DA
+8 DO UNCMPBLK^IBDF19(IBBLK)
DO IDXBLOCK^IBDFU4
End DoDot:1
+9 SET VALMBCK="R"
+10 QUIT
SELECT ;
+1 SET IBLIST=""
+2 if '$GET(IBBLK)
QUIT
+3 IF '$ORDER(^IBE(357.2,"C",IBBLK,0))
WRITE !,"There is no selection list!"
DO PAUSE^IBDFU5
QUIT
AGAIN KILL DIC
SET DIC="^IBE(357.2,"
SET DIC(0)="EQ"
SET D="C"
SET X=IBBLK
+1 SET DIC("S")="I $P($G(^(0)),U,2)=IBBLK"
+2 DO IX^DIC
KILL DIC
+3 if +Y>0
SET IBLIST=+Y
+4 IF 'IBLIST
IF '$DATA(DTOUT)
IF '$DATA(DUOUT)
KILL DIR
SET DIR(0)="Y"
SET DIR("A")="No selection list selected! Try again"
SET DIR("B")="YES"
DO ^DIR
KILL DIR
IF '$DATA(DIRUT)
IF Y=1
GOTO AGAIN
+5 QUIT
MSG1 ;called by the input template
+1 WRITE !!,"Entering the number of list columns is optional. By default the list will be",!,"given as many columns as the block has space for.",!
+2 QUIT
MSG2 ;called by the input template
+1 WRITE !!,"Entering the information on the position of the columns and their",!,"height is optional. Appropriate default values will be used. However,",!,"you may specify your own values for up to 4 coulmns.",!
+2 QUIT
MSG3 ;called by the input template
+1 WRITE !!,"You can now specify the subcolumns the list should contain.",!,"There can be at most 6 subcolumns, numbered 1-6.",!
+2 QUIT
+3 ;
DATASIZE(RTN) ;IBLEN() stores the lengths of the pieces of the record returned by the package interface
+1 NEW NODE,IEN,PIECE
+2 if '$GET(RTN)
QUIT
+3 SET PIECE=0
FOR
SET PIECE=$ORDER(^IBE(357.6,RTN,15,"C",PIECE))
if 'PIECE
QUIT
SET IEN=0
FOR
SET IEN=$ORDER(^IBE(357.6,RTN,15,"C",PIECE,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)_"^"_$PIECE(NODE,"^",5)
+4 SET IBLEN(0)=4
+5 SET IBLEN(1)=$PIECE($GET(^IBE(357.6,RTN,2)),"^",2)_"^"_$PIECE($GET(^IBE(357.6,RTN,2)),"^",16)
+6 QUIT
+7 ;
NEWNAME() ;
+1 KILL DIR
SET DIR(0)="357.2,.01A"
SET DIR("A")="New Selection List Name: "
SET DIR("B")=""
+2 DO ^DIR
KILL DIR
IF $DATA(DIRUT)
QUIT -1
+3 QUIT Y
SWITCH(IBLIST,IBARRY) ;FOR loops thru selection list and changes all subcolumn numbers from old to new (called only once)
+1 NEW SLCTN,SC
+2 SET SLCTN=""
FOR
SET SLCTN=$ORDER(^IBE(357.3,"C",IBLIST,SLCTN))
if 'SLCTN
QUIT
Begin DoDot:1
+3 SET (IBSC1,SC)=0
FOR
SET IBSC1=$ORDER(^IBE(357.3,SLCTN,1,"B",IBSC1))
if 'IBSC1
QUIT
FOR
SET SC=$ORDER(^IBE(357.3,SLCTN,1,"B",IBSC1,SC))
if 'SC
QUIT
SET IBSC(SC)=IBSC1
+4 SET (IBSC1,SC)=0
FOR
SET SC=$ORDER(IBSC(SC))
if 'SC
QUIT
SET IBSC1=IBSC(SC)
Begin DoDot:2
+5 ;I $P($G(^IBE(357.3,SLCTN,1,SC,0)),"^")=IBSC1 D
+6 IF $DATA(IBARRY(IBSC1))
SET IBSC2=IBARRY(IBSC1)
Begin DoDot:3
+7 IF $GET(^IBE(357.3,SLCTN,1,0))=""
SET ^IBE(357.3,SLCTN,1,0)="^357.31IA^"
+8 KILL DIE,DA,DR
SET DIE="^IBE(357.3,SLCTN,1,"
SET DA(1)=SLCTN
SET DA=SC
SET DR=".01////"_IBSC2
+9 DO ^DIE
+10 ;K DIE,DA,DR S DA(1)=SLCTN,DIE="^IBE(357.3,"_DA(1)_",1,",DA=SC,DR=".01////"_IBSC2
End DoDot:3
+11 IF '$TEST
Begin DoDot:3
+12 KILL ^IBE(357.3,SLCTN,1,"B",IBSC1,SC)
+13 KILL DIK,DA
SET DIK="^IBE(357.3,SLCTN,1,"
SET DA(1)=SLCTN
SET DA=SC
DO IX^DIK
End DoDot:3
End DoDot:2
End DoDot:1
+14 KILL DIK,DA,DIE,DR
+15 QUIT
RTN() ;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)=3,$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 the list will contain: "
DO MIX^DIC1
KILL DIC,DA
+3 QUIT $SELECT((Y<0)!$DATA(DTOUT)!$DATA(DUOUT):0,1:+Y)
DLTLIST ;expects IBBLK to be defined
+1 NEW IBLIST
+2 DO FULL^VALM1
+3 DO SELECT
+4 IF IBLIST
Begin DoDot:1
+5 if '$$RUSURE^IBDFU5($PIECE($GET(^IBE(357.2,IBLIST,0)),"^"))
QUIT
+6 DO DLTLIST^IBDFU3(357.2,IBBLK,IBLIST)
+7 DO UNCMPBLK^IBDF19(IBBLK)
DO IDXBLOCK^IBDFU4
End DoDot:1
+8 QUIT
+9 ;
LISTTYPE(RTN) ;sets IBDYN=1 if the rtn is dynamic selection,IBINPUT to the input interface
+1 NEW NODE
+2 IF '$GET(RTN)
SET (IBDYN,IBINPUT,IBCLRM)=0
QUIT
+3 SET NODE=$GET(^IBE(357.6,RTN,0))
+4 SET IBDYN=$PIECE(NODE,"^",14)
+5 SET IBINPUT=$PIECE(NODE,"^",13)
+6 SET IBCLRM=$PIECE(NODE,"^",20)
+7 QUIT
+8 ;
OTHEROK(PI) ;returns 1 if the selection interface=PI allows 'other', 0 otherwise
+1 NEW NODE
+2 if '$GET(PI)
QUIT 0
+3 ;
+4 ;there must be an interface for input
+5 if '$PIECE((^IBE(357.6,PI,0)),"^",13)
QUIT 0
+6 ;
+7 ;the selection interface must allow input of narrative or code
+8 SET NODE=$GET(^IBE(357.6,PI,16))
+9 IF '$PIECE(NODE,"^",2)
IF '$PIECE(NODE,"^",6)
QUIT 0
+10 QUIT 1
