source: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMCLST.m@ 636

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

initial load of FOIAVistA 6/30/08 version
File size: 4.8 KB
Line 
1PXRMCLST ; SLC/PJH - List Reminder Categories ;03/09/2000
2 ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
3 ;
4 ;List all categories (for protocol PXRM SELECTION LIST)
5 ;-------------------
6ALL N BY,DC,DHD,DIC,FLDS,FR,L,LOGIC,NOW,TO,Y
7 S Y=1
8 D SET
9 S DIC="^PXRMD(811.7,"
10 S BY=".01"
11 S FR=""
12 S TO=""
13 S DHD="W ?0 D HED^PXRMCLST"
14 D DISP
15 Q
16 ;
17 ;DISPLAY (Display from FLDS array)
18 ;-------
19DISP S L=0,FLDS="[PXRM REMINDER CATEGORIES]"
20 D EN1^DIP
21 Q
22 ;
23 ;Build list of sub-categories
24 ;----------------------------
25DSP N ARRAY,IC,SEQ,TAB,TXT
26 ;
27 ; D0=IEN OF PARENT D1=NODE NUMBER IN 10 OF CHILD
28 ;
29 S IC=0 D GETLST(D0,D1,0)
30 ;Display list of sub-categories
31 S IC=0
32 F S IC=$O(ARRAY(IC)) Q:IC="" D
33 .S TAB=$P(ARRAY(IC),U),TXT=$P(ARRAY(IC),U,2)
34 .W !,?TAB,TXT
35 Q
36 ;
37 ;Get list of sub-categories
38 ;--------------------------
39GETLST(D0,D1,LEVEL) ;
40 N CHILD,DATA,NAME,PXRMIEN,PXRMCAT,SEQ,SUB,TEMP
41 ;Determine if this subcategory has children
42 S DATA=$G(^PXRMD(811.7,D0,10,D1,0)) Q:DATA=""
43 S PXRMCAT=$P(DATA,U) Q:PXRMCAT=""
44 S NAME=$G(^PXRMD(811.7,PXRMCAT,0)) I NAME="" S NAME=PXRMCAT
45 S IC=IC+1,ARRAY(IC)=LEVEL_U_"Sub-category: "_NAME
46 ;Increment tab
47 S LEVEL=LEVEL+5
48 ;Don't allow > 4 levels
49 I LEVEL>20 S IC=IC+1,ARRAY(IC)=LEVEL_U_"Further levels" Q
50 ;
51 ;Sort Reminders from this category into display sequence
52 S SUB=0 K TEMP
53 F S SUB=$O(^PXRMD(811.7,PXRMCAT,2,SUB)) Q:SUB="" D
54 .S DATA=$G(^PXRMD(811.7,PXRMCAT,2,SUB,0)) Q:DATA=""
55 .S PXRMIEN=$P(DATA,U) Q:PXRMIEN=""
56 .S SEQ=$P(DATA,U,2)
57 .S DATA=$G(^PXD(811.9,PXRMIEN,0)) Q:DATA=""
58 .S NAME=$P(DATA,U) I NAME="" S NAME="Unknown"
59 .S TEMP(SEQ)=NAME
60 ;
61 ;Re-save reminders in output array for display
62 S SEQ=""
63 F S SEQ=$O(TEMP(SEQ)) Q:SEQ="" D
64 .S IC=IC+1
65 .S ARRAY(IC)=LEVEL_U_"Sequence: "_$J(SEQ,2)_" Reminder: "_TEMP(SEQ)
66 ;
67 ;Sort Sub-Categories for this category into display order
68 S SUB=0 K TEMP
69 F S SUB=$O(^PXRMD(811.7,PXRMCAT,10,SUB)) Q:SUB="" D
70 .S DATA=$G(^PXRMD(811.7,PXRMCAT,10,SUB,0)) Q:DATA=""
71 .S SEQ=$P(DATA,U,2),TEMP(SEQ)=SUB
72 ;
73 ;Process sub-sub categories in the same manner
74 S SEQ=""
75 F S SEQ=$O(TEMP(SEQ)) Q:SEQ="" D
76 .S SUB=TEMP(SEQ)
77 .D GETLST(PXRMCAT,SUB,LEVEL)
78 Q
79 ;
80 ;Display Header (see DHD variable)
81 ;--------------
82HED N TEMP,TEXTLEN,TEXTHED,TEXTUND
83 S TEXTHED="REMINDER CATEGORY LIST"
84 S TEXTUND=$TR($J("",IOM)," ","-")
85 S TEMP=NOW_" Page "_DC
86 S TEXTLEN=$L(TEMP)
87 W TEXTHED
88 W ?(IOM-TEXTLEN),TEMP
89 W !,TEXTUND,!!
90 Q
91 ;
92 ;Inquire/Print Option (for protocol PXRM GENERAL INQUIRE/PRINT)
93 ;--------------------
94INQ(Y) N BY,DC,DHD,DIC,FLDS,FR,L,LOGIC,NOW,TO
95 S DIC="^PXRMD(811.7,"
96 S DIC(0)="AEMQ"
97 D SET
98 D DISP
99 Q
100 ;
101 ;Input Transforms for edit option PXRM REMINDER CATEGORY EDIT #811.7
102 ;-------------------------------------------------------------------
103BADITEM(X,DA1) ;Subcategory
104 I X=DA1 Q 1
105 Q '$$PARENTOK(DA1,X)
106 ;
107KILLAC ;This only applies if deleting a sub-category
108 I '$D(^PXRMD(811.7,DA)) Q
109 ;
110 N SUB,MAS
111 S MAS=""
112 ;Get the parent categories for this sub sub-category, quit if none
113 F S MAS=$O(^PXRMD(811.7,"AC",DA,MAS)) Q:MAS="" D
114 .;Get sub category position in the parent, quit if none
115 .S SUB=$O(^PXRMD(811.7,"AC",DA,MAS,"")) Q:SUB=""
116 .;
117 .;Kill the sub category on the parent category
118 .N DIC,DIK,DA S DIK="^PXRMD(811.7,MAS,10,",DA(1)=MAS,DA=SUB D ^DIK
119 .;Cross reference on SUBCATEGORY field kills the AC index entry
120 Q
121 ;
122PARENTOK(PARENT,ITEM) ;Returns true if category is already in tree
123 N IDX,OK
124 S IDX=0,OK=1
125 F S IDX=$O(^PXRMD(811.7,"AC",PARENT,IDX)) Q:'IDX D Q:'OK
126 .I IDX=ITEM S OK=0 Q
127 .S OK=$$PARENTOK(IDX,ITEM)
128 Q OK
129 ;
130 ;Reminders for this category
131 ;---------------------------
132REM N ARRAY,DATA,IC,NAME,PXRMIEN,SEQ,TEMP
133 ;
134 ; D0=IEN OF CATEGORY
135 ;
136 S SUB=0
137 ;Sort Reminders from this category into display sequence
138 F S SUB=$O(^PXRMD(811.7,D0,2,SUB)) Q:SUB="" D
139 .S DATA=$G(^PXRMD(811.7,D0,2,SUB,0)) Q:DATA=""
140 .S PXRMIEN=$P(DATA,U) Q:PXRMIEN=""
141 .S SEQ=$P(DATA,U,2)
142 .S DATA=$G(^PXD(811.9,PXRMIEN,0)) Q:DATA=""
143 .S NAME=$P(DATA,U) I NAME="" S NAME="Unknown"
144 .S TEMP(SEQ_0)=NAME
145 ;
146 I $O(TEMP(""))="" W ! Q
147 ;
148 ;Re-save reminders in output array for display
149 S SEQ="",IC=0
150 F S SEQ=$O(TEMP(SEQ)) Q:SEQ="" D
151 .S IC=IC+1
152 .S ARRAY(IC)="Sequence: "_$J(SEQ/10,2)_" Reminder: "_TEMP(SEQ)
153 ;
154 S IC=0
155 F S IC=$O(ARRAY(IC)) Q:IC="" D
156 .W !,ARRAY(IC)
157 Q
158 ;
159SETAC Q
160 ;
161 ;Verify Reminder/Category display order is unique
162 ;RECORD 2=Reminder 10=Sub-category
163UNIQUE(X,DA1,DA,RECORD) ;
164 N SUB,DATA,SEQ,TEMP
165 S SUB=0
166 F S SUB=$O(^PXRMD(811.7,DA1,RECORD,SUB)) Q:'SUB D
167 .Q:SUB=DA
168 .S SEQ=$P($G(^PXRMD(811.7,DA1,RECORD,SUB,0)),U,2)
169 .I SEQ'="" S TEMP(SEQ)=""
170 I $D(TEMP(X)) W " Sequence number already used " Q 0
171 Q 1
172 ;
173SET ;Setup all the variables
174 ; Set Date for Header
175 S NOW=$$NOW^XLFDT
176 S NOW=$$FMTE^XLFDT(NOW,"1P")
177 ;
178 ;These variables need to be setup every time because DIP kills them.
179 S BY="NUMBER"
180 S (FR,TO)=+$P(Y,U,1)
181 S DHD="W ?0 D HED^PXRMCLST"
182 ;
183 Q
Note: See TracBrowser for help on using the repository browser.