141 lines
6.2 KiB
Mathematica
141 lines
6.2 KiB
Mathematica
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
|