source: FOIAVistA/trunk/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDF9A.m@ 1635

Last change on this file since 1635 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version
File size: 6.2 KB
Line 
1IBDF9A ;ALB/CJM - ENCOUNTER FORM - (create,edit,delete selection list) ;FEB 1,1993
2 ;;3.0;AUTOMATED INFO COLLECTION SYS;**15**;APR 24, 1997
3 ;
4LIST ;Create, Edit, or Delete a selection list from the form
5 N IBVALMBG
6 S VALMBCK="R",IBVALMBG=VALMBG
7 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:"
8 S DIR("B")="C" I $G(IBBLK) D
9 .S X=$G(^IBE(357.2,+$O(^IBE(357.2,"C",IBBLK,0)),0))
10 .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
11 ;
12 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: "
13 W !!,DIR("?",1),!,DIR("?"),!
14 D ^DIR K DIR I $D(DIRUT)!(Y<0) Q
15 D @$S(Y="C":"EDITLIST^IBDF3",Y="A":"EDITLIST",Y="N":"NEWLIST^IBDF9A1",Y="D":"DLTLIST",Y="P":"COLUMNS",1:"NOSUCH")
16 S VALMBG=IBVALMBG
17 Q
18NOSUCH ;
19 Q
20EDITLIST ;allows editing of the structure of a list
21 ;expects IBBLK to be defined
22 ;IBSC1,IBSC2,IBSWITCH,IBD,IBOLD,IBLEN are used in the input template
23 N IBLIST,IBRTN,IBSC1,IBSC2,IBSWITCH,IBSWT,IBD,IBOLD,IBLEN,IBDELETE,IBSCOLD,IBSCNEW,FROM,TO,IBDYN,IBINPUT,IBSC,IBSCRAY
24 S VALMBCK="R",(IBOLD,IBSWITCH)=1
25 D FULL^VALM1
26 D SELECT
27 I IBLIST D
28 .S (IBSCOLD,IBSCNEW)=""
29 .S IBRTN=$P($G(^IBE(357.2,IBLIST,0)),"^",11)
30 .D LISTTYPE(IBRTN)
31 .D GETSC^IBDF9A3(.IBSCOLD,IBLIST)
32 .D:IBRTN DATASIZE(IBRTN)
33 .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
34 .;
35 .;if the list already had selections the subcolumns may need to be reordered/created/deleted
36 .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
37 ..I $D(IBSCOLD(TO)) D DELSC^IBDF9A3(IBLIST,TO)
38 ..;D SWITCH(IBLIST,FROM,TO)
39 ..I $D(IBSCOLD(FROM)) S IBSCOLD(TO)=IBSCOLD(FROM) K IBSCOLD(FROM)
40 .D SWITCH(IBLIST,.IBSWT)
41 .D GETSC^IBDF9A3(.IBSCNEW,IBLIST)
42 .N SC S SC=0 F S SC=$O(IBSCOLD(SC)) Q:'SC I IBSCOLD(SC)'=$G(IBSCNEW(SC)) D DELSC^IBDF9A3(IBLIST,SC)
43 .S SC=0 F S SC=$O(IBSCNEW(SC)) Q:'SC I IBSCNEW(SC)'=$G(IBSCOLD(SC)) D ADDSC^IBDF9A3(IBLIST,SC)
44 .D BLKCHNG^IBDF19(IBFORM,IBBLK) ;8/20/96 changed from d UNCMPLBLK^IBDF19
45 .D IDXBLOCK^IBDFU4
46 S VALMBCK="R"
47 Q
48COLUMNS ;allows the user to place and size the columns of the list
49 ;expects IBBLK to be defined
50 N IBLIST
51 S VALMBCK="R"
52 D FULL^VALM1
53 D SELECT
54 I IBLIST D
55 .K DIE,DA,DR S DIE=357.2,DA=IBLIST,DR="[IBDF POSITION/SIZE COLUMNS]",DIE("NO^")="BACKOUTOK" D ^DIE K DIE,DR,DA
56 .D UNCMPBLK^IBDF19(IBBLK),IDXBLOCK^IBDFU4
57 S VALMBCK="R"
58 Q
59SELECT ;
60 S IBLIST=""
61 Q:'$G(IBBLK)
62 I '$O(^IBE(357.2,"C",IBBLK,0)) W !,"There is no selection list!" D PAUSE^IBDFU5 Q
63AGAIN K DIC S DIC="^IBE(357.2,",DIC(0)="EQ",D="C",X=IBBLK
64 S DIC("S")="I $P($G(^(0)),U,2)=IBBLK"
65 D IX^DIC K DIC
66 S:+Y>0 IBLIST=+Y
67 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
68 Q
69MSG1 ;called by the input template
70 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.",!
71 Q
72MSG2 ;called by the input template
73 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.",!
74 Q
75MSG3 ;called by the input template
76 W !!,"You can now specify the subcolumns the list should contain.",!,"There can be at most 6 subcolumns, numbered 1-6.",!
77 Q
78 ;
79DATASIZE(RTN) ;IBLEN() stores the lengths of the pieces of the record returned by the package interface
80 N NODE,IEN,PIECE
81 Q:'$G(RTN)
82 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)
83 S IBLEN(0)=4
84 S IBLEN(1)=$P($G(^IBE(357.6,RTN,2)),"^",2)_"^"_$P($G(^IBE(357.6,RTN,2)),"^",16)
85 Q
86 ;
87NEWNAME() ;
88 K DIR S DIR(0)="357.2,.01A",DIR("A")="New Selection List Name: ",DIR("B")=""
89 D ^DIR K DIR I $D(DIRUT) Q -1
90 Q Y
91SWITCH(IBLIST,IBARRY) ;FOR loops thru selection list and changes all subcolumn numbers from old to new (called only once)
92 N SLCTN,SC
93 S SLCTN="" F S SLCTN=$O(^IBE(357.3,"C",IBLIST,SLCTN)) Q:'SLCTN D
94 .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
95 . S (IBSC1,SC)=0 F S SC=$O(IBSC(SC)) Q:'SC S IBSC1=IBSC(SC) D
96 ..;I $P($G(^IBE(357.3,SLCTN,1,SC,0)),"^")=IBSC1 D
97 ..I $D(IBARRY(IBSC1)) S IBSC2=IBARRY(IBSC1) D
98 ...I $G(^IBE(357.3,SLCTN,1,0))="" S ^IBE(357.3,SLCTN,1,0)="^357.31IA^"
99 ...K DIE,DA,DR S DIE="^IBE(357.3,SLCTN,1,",DA(1)=SLCTN,DA=SC,DR=".01////"_IBSC2
100 ...D ^DIE
101 ...;K DIE,DA,DR S DA(1)=SLCTN,DIE="^IBE(357.3,"_DA(1)_",1,",DA=SC,DR=".01////"_IBSC2
102 ..E D
103 ...K ^IBE(357.3,SLCTN,1,"B",IBSC1,SC)
104 ...K DIK,DA S DIK="^IBE(357.3,SLCTN,1,",DA(1)=SLCTN,DA=SC D IX^DIK
105 K DIK,DA,DIE,DR
106 Q
107RTN() ;does a lookup on the package interface file using the E cross-reference, which uses the name with the prefix=namespace removed
108 K DIC S DIC("S")="I $P(^(0),U,6)=3,$P(^(0),U,9)=1"
109 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
110 Q $S((Y<0)!$D(DTOUT)!$D(DUOUT):0,1:+Y)
111DLTLIST ;expects IBBLK to be defined
112 N IBLIST
113 D FULL^VALM1
114 D SELECT
115 I IBLIST D
116 .Q:'$$RUSURE^IBDFU5($P($G(^IBE(357.2,IBLIST,0)),"^"))
117 .D DLTLIST^IBDFU3(357.2,IBBLK,IBLIST)
118 .D UNCMPBLK^IBDF19(IBBLK),IDXBLOCK^IBDFU4
119 Q
120 ;
121LISTTYPE(RTN) ;sets IBDYN=1 if the rtn is dynamic selection,IBINPUT to the input interface
122 N NODE
123 I '$G(RTN) S (IBDYN,IBINPUT,IBCLRM)=0 Q
124 S NODE=$G(^IBE(357.6,RTN,0))
125 S IBDYN=$P(NODE,"^",14)
126 S IBINPUT=$P(NODE,"^",13)
127 S IBCLRM=$P(NODE,"^",20)
128 Q
129 ;
130OTHEROK(PI) ;returns 1 if the selection interface=PI allows 'other', 0 otherwise
131 N NODE
132 Q:'$G(PI) 0
133 ;
134 ;there must be an interface for input
135 Q:'$P((^IBE(357.6,PI,0)),"^",13) 0
136 ;
137 ;the selection interface must allow input of narrative or code
138 S NODE=$G(^IBE(357.6,PI,16))
139 I '$P(NODE,"^",2),'$P(NODE,"^",6) Q 0
140 Q 1
Note: See TracBrowser for help on using the repository browser.