source: FOIAVistA/trunk/r/IMAGING-MAG-ZMAG/MAGSIXGT.m@ 731

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

initial load of FOIAVistA 6/30/08 version
File size: 9.1 KB
Line 
1MAGSIXGT ;WOIFO/EdM/GEK/SEB - RPC for Document Imaging ; 04/29/2002 16:15
2 ;;3.0;IMAGING;**8,48,61,59**;Nov 27, 2007;Build 20
3 ;;Per VHA Directive 2004-038, this routine should not be modified.
4 ;; +---------------------------------------------------------------+
5 ;; | Property of the US Government. |
6 ;; | No permission to copy or redistribute this software is given. |
7 ;; | Use of unreleased versions of this software requires the user |
8 ;; | to execute a written test agreement with the VistA Imaging |
9 ;; | Development Office of the Department of Veterans Affairs, |
10 ;; | telephone (301) 734-0100. |
11 ;; | The Food and Drug Administration classifies this software as |
12 ;; | a medical device. As such, it may not be changed in any way. |
13 ;; | Modifications to this software may result in an adulterated |
14 ;; | medical device under 21CFR820, the use of which is considered |
15 ;; | to be a violation of US Federal Statutes. |
16 ;; +---------------------------------------------------------------+
17 ;;
18 Q
19 ;
20IGT(OUT,CLS,FLGS) ;RPC [MAG4 INDEX GET TYPE]
21 ; OUT : the result array
22 ; CLS : a ',' separated list of Classes.
23 ; FLGS : An '^' delimited string
24 ; 1 IGN : Flag to IGNore the Status field
25 ; 2 INCL : Include Class in the Output string
26 ; 3 INST : Include Status in the Output String
27 ;
28 N C,D0,LOC,N,OK,X,NODE,IGN
29 N MAGX
30 K OUT
31 S CLS=$G(CLS),FLGS=$P($G(FLGS),"|")
32 ; Capture app will send CLS as ADMIN,ADMIN/CLIN for admin
33 ; or CLIN,CLIN/ADMIN for clinical
34 ; 61 - We're expanding CLASS returned to include ALL Clin
35 ; or all Admin
36 I CLS="ADMIN,ADMIN/CLIN" S CLS="ADMIN,ADMIN/CLIN,CLIN/ADMIN"
37 I CLS="CLIN,CLIN/ADMIN" S CLS="CLIN,CLIN/ADMIN,ADMIN/CLIN"
38 S IGN=$P(FLGS,"^",1),INCL=$P(FLGS,"^",2),INST=$P(FLGS,"^",3)
39 D CLS Q:$D(OUT(0))
40 ;
41 S N=1
42 S D0=0 F S D0=$O(^MAG(2005.83,D0)) Q:'D0 D
43 . S X=$G(^MAG(2005.83,D0,0)),C=$P(X,"^",2)
44 . ; if Class not null, check it. Null classes will be listed in output.
45 . I CLS'="" Q:C="" Q:'$D(OK(1,C))
46 . I 'IGN Q:$P(X,"^",3)="I" ; This is the Status field inactive Flag;
47 . S NODE=$P(X,"^",1)_"^"_$P($G(^MAG(2005.83,D0,1)),"^",1)
48 . I INCL S NODE=NODE_"^"_$$GET1^DIQ(2005.83,D0,1,"MAGX")
49 . I INST S NODE=NODE_"^"_$$GET1^DIQ(2005.83,D0,2,"MAGX")
50 . S LOC(NODE_"|"_D0)=""
51 . Q
52 S X="" F S X=$O(LOC(X)) Q:X="" S N=N+1,OUT(N)=X
53 I N<2 S OUT(0)="0^-3, No Types Found for """_CLS_"""." Q
54 S OUT(0)="1^OK: "_N
55 S OUT(1)=CLS_" Image Types^Abbr"
56 I INCL S OUT(1)=OUT(1)_"^Class"
57 I INST S OUT(1)=OUT(1)_"^Status"
58 Q
59IGE(OUT,CLS,SPEC,FLGS) ;RPC [MAG4 INDEX GET EVENT]
60 ; Index Get Procedure/Event (optionally based on (Sub)Specialty)
61 ; OUT : the result array
62 ; CLS : a ',' separated list of Classes.
63 ; SPEC : a ',' separated list of Spec/Subspecialties
64 ; FLGS : An '^' delimited string
65 ; - IGN [1|0] : Flag to IGNore the Status field
66 ; - INCL [1|0] : Include Class in the Output string
67 ; - INST [1|0] : Include Status in the Output String
68 ;
69 N C,D0,D1,LOC,N,NO,OK,S,X,NODE
70 K OUT
71 S CLS=$G(CLS),SPEC=$G(SPEC),FLGS=$P($G(FLGS),"|")
72 S IGN=$P(FLGS,"^",1),INCL=$P(FLGS,"^",2),INST=$P(FLGS,"^",3)
73 D CLS Q:$D(OUT(0))
74 D SPEC Q:$D(OUT(0))
75 ;
76 S N=1
77 S D0=0 F S D0=$O(^MAG(2005.85,D0)) Q:'D0 D
78 . S X=$G(^MAG(2005.85,D0,0)),C=$P(X,"^",2)
79 . ; if Class not null, check it. Null classes will be listed in output.
80 . I CLS'="" Q:C="" Q:'$D(OK(1,C))
81 . I 'IGN Q:$P(X,"^",3)="I" ;This is the Status field inactive Flag;
82 . ; if Specialty not null, check it. Null Specialties will be listed in output.
83 . I SPEC'="" D Q:NO
84 . . S NO=0
85 . . ; Next line: put "S:'D1 NO=1" before the quit to block implicit mapping
86 . . S D1=0 F S D1=$O(^MAG(2005.85,D0,1,D1)) Q:'D1 D Q:'NO
87 . . . S NO=1
88 . . . S S=$P($G(^MAG(2005.85,D0,1,D1,0)),"^",1)
89 . . . Q:S=""
90 . . . S:$D(OK(3,S)) NO=0
91 . . . Q
92 . . Q
93 . S NODE=$P(X,"^",1)_"^"_$P($G(^MAG(2005.85,D0,2)),"^",1)
94 . I INCL S NODE=NODE_"^"_$$GET1^DIQ(2005.85,D0,1,"MAGX")
95 . I INST S NODE=NODE_"^"_$$GET1^DIQ(2005.85,D0,4,"MAGX")
96 . S LOC(NODE_"|"_D0)=""
97 . Q
98 S X="" F S X=$O(LOC(X)) Q:X="" S N=N+1,OUT(N)=X
99 I N<2 S OUT(0)="0^No Procedures or Events found for """_CLS_""" and """_SPEC_"""." Q
100 S OUT(0)="1^OK: "_N
101 S OUT(1)="Procedure/Event^Abbr"
102 I INCL S OUT(1)=OUT(1)_"^Class"
103 I INST S OUT(1)=OUT(1)_"^Status"
104 Q
105 ;
106IGS(OUT,CLS,EVENT,FLGS) ;RPC [MAG4 INDEX GET SPECIALTY]
107 ; OUT : the result array
108 ; CLS : a ',' separated list of Classes.
109 ; EVENT : a ',' separated list of Proc/Events
110 ; FLGS : An '^' delimited string
111 ; - IGN [1|0] : Flag to IGNore the Status field
112 ; - INCL [1|0] : Include Class in the Output string
113 ; - INST [1|0] : Include Status in the Output String
114 ; - INSP [1|0] : Include Specialty in the OutPut String
115 ;
116 N C,D0,D1,E,LOC,N,OK,X
117 K OUT
118 S CLS=$G(CLS),EVENT=$G(EVENT),FLGS=$P($G(FLGS),"|")
119 S IGN=$P(FLGS,"^",1),INCL=$P(FLGS,"^",2),INST=$P(FLGS,"^",3),INSP=$P(FLGS,"^",4)
120 I CLS'="" D CLS Q:$D(OUT(0))
121 I EVENT'="" D EVENT Q:$D(OUT(0))
122 ;
123 S N=1
124 I EVENT="" S D0=0 F S D0=$O(^MAG(2005.84,D0)) Q:'D0 D
125 . S X=$G(^MAG(2005.84,D0,0)),C=$P(X,"^",2) ;,E=$P(X,"^",3)
126 . ; if Class not null, check it. Null classes will be listed in output.
127 . I CLS'="" Q:C="" Q:'$D(OK(1,C))
128 . I 'IGN Q:$P(X,"^",4)="I" ; This is the Status field inactive Flag;
129 . ;I EVENT'="" Q:E="" Q:'$D(OK(2,E))
130 . S NODE=$P(X,"^",1)_"^"_$P($G(^MAG(2005.84,D0,2)),"^",1)
131 . I INCL S NODE=NODE_"^"_$$GET1^DIQ(2005.84,D0,1,"MAGX")
132 . I INST S NODE=NODE_"^"_$$GET1^DIQ(2005.84,D0,4,"MAGX")
133 . I INSP S NODE=NODE_"^"_$$GET1^DIQ(2005.84,D0,2,"MAGX")
134 . S LOC(NODE_"|"_D0)=""
135 . Q
136 I EVENT]"" S E="" F S E=$O(OK(2,E)) Q:E="" D
137 . ; if Class isn't null, include image if Class matches;
138 . ; images with Null classes will be listed in output.
139 . I CLS'="" S C=$P($G(^MAG(2005.85,E,0)),"^",2) Q:'$D(OK(1,C))
140 . ; if this procedure has specialty pointers, include it if they matches.
141 . ; images with Proc/Event
142 . I +$P($G(^MAG(2005.85,E,1,0)),U,3)=0 D GETSPECS(.LOC,INCL,INST,INSP)
143 . S D0="0" F S D0=$O(^MAG(2005.85,E,1,D0)) Q:D0="" D
144 . . S D1=$G(^MAG(2005.85,E,1,D0,0)) I D1="" Q
145 . . S X=$G(^MAG(2005.84,D1,0))
146 . . I '(X]"") Q
147 . . S NODE=$P(X,"^",1)_"^"_$P($G(^MAG(2005.84,D1,2)),"^",1)
148 . . I INCL S NODE=NODE_"^"_$$GET1^DIQ(2005.84,D1,1,"MAGX")
149 . . I INST S NODE=NODE_"^"_$$GET1^DIQ(2005.84,D1,4,"MAGX")
150 . . I INSP S NODE=NODE_"^"_$$GET1^DIQ(2005.84,D1,2,"MAGX")
151 . . S LOC(NODE_"|"_D1)=""
152 . Q
153 S X="" F S X=$O(LOC(X)) Q:X="" S N=N+1,OUT(N)=X
154 I N<2 S OUT(0)="0^-5, No (Sub)Specialties found for """_CLS_""" and """_EVENT_"""." Q
155 S OUT(0)="1^OK: "_N
156 S OUT(1)="Specialty/SubSpecialty^Abbr"
157 I INCL S OUT(1)=OUT(1)_"^Class"
158 I INST S OUT(1)=OUT(1)_"^Status"
159 I INSP S OUT(1)=OUT(1)_"^Specialty"
160 Q
161 ;
162PKG N P,I
163 I $G(PKG)="" Q
164 F I=1:1:$L(PKG,",") I $L($P(PKG,",",I)) S OK(5,$P(PKG,",",I))=""
165 Q
166ORIGIN N I
167 N V,MAGR,MAGD,MAGE
168 I $G(ORIGIN)="" Q
169 ; P48T1 Allow Internal or External for Origin (set of codes)
170 F I=1:1:$L(ORIGIN,",") I $L($P(ORIGIN,",",I)) S OK(6,$P(ORIGIN,",",I))="" D
171 . S MAGD=$P(ORIGIN,",",I)
172 . D CHK^DIE(2005,45,"E",MAGD,.MAGR) I MAGR'="^" S OK(6,MAGR)="",OK(6,MAGR(0))=""
173 Q
174CLS N C,CLSX,I
175 I $G(CLS)="" Q
176 F I=1:1:$L(CLS,",") I $L($P(CLS,",",I)) S CLSX=$P(CLS,",",I) D
177 . I CLSX=+CLSX,$D(^MAG(2005.82,CLSX)) S OK(1,CLSX)=""
178 . S C="" F S C=$O(^MAG(2005.82,"B",CLSX,C)) Q:C="" S OK(1,C)=""
179 I $O(OK(1,""))="" S OUT(0)="0^Invalid Class: """_CLS_"""." Q
180 Q
181 ;
182EVENT N E,EVENTX,I
183 I $G(EVENT)="" Q
184 F I=1:1:$L(EVENT,",") I $L($P(EVENT,",",I)) S EVENTX=$P(EVENT,",",I) D
185 . I EVENTX=+EVENTX,$D(^MAG(2005.85,EVENTX)) S OK(2,EVENTX)=""
186 . S E="" F S E=$O(^MAG(2005.85,"B",EVENTX,E)) Q:E="" S OK(2,E)=""
187 I $O(OK(2,""))="" S OUT(0)="0^Invalid Event: """_EVENT_"""." Q
188 Q
189 ;
190SPEC N S,SS,SPECX,I
191 I $G(SPEC)="" Q
192 ; Here we examine each piece of Spec, If piece is a Specialty, include
193 ; its subspecialties.
194 ;
195 F I=1:1:$L(SPEC,",") I $L($P(SPEC,",",I)) S SPECX=$P(SPEC,",",I) D
196 . I SPECX=+SPECX,$D(^MAG(2005.84,SPECX)) S OK(3,SPECX)=""
197 . S S="" F S S=$O(^MAG(2005.84,"B",SPECX,S)) Q:S="" S OK(3,S)=""
198 . Q
199 I $O(OK(3,""))="" S OUT(0)="0^Invalid Specialty: """_SPEC_"""." Q
200 I $D(MAGJOB("CAPTURE")) Q ; 59 for capture we don't want subspecs.
201 S S="" F S S=$O(OK(3,S)) Q:S="" I $D(^MAG(2005.84,"ASPEC",S)) D
202 . S SS="" F S SS=$O(^MAG(2005.84,"ASPEC",S,SS)) Q:SS="" S OK(3,SS)=""
203 . Q
204 Q
205 ;
206TYPE N T,TYPEX,I
207 I $G(TYPE)="" Q
208 F I=1:1:$L(TYPE,",") I $L($P(TYPE,",",I)) S TYPEX=$P(TYPE,",",I) D
209 . I TYPEX=+TYPEX,$D(^MAG(2005.83,TYPEX)) S OK(4,TYPEX)=""
210 . S T="" F S T=$O(^MAG(2005.83,"B",TYPEX,T)) Q:T="" S OK(4,T)=""
211 I $O(OK(4,""))="" S OUT(0)="0^Invalid Type: """_TYPE_"""." Q
212 Q
213 ;
214GETSPECS(LOC,INCL,INST,INSP) N D0,X,NODE
215 S D0=0 F S D0=$O(^MAG(2005.84,D0)) Q:'D0 D
216 . S X=$G(^MAG(2005.84,D0,0))
217 . ;I X]"" S LOC($P(X,"^",1)_"^"_$P($G(^MAG(2005.84,D0,2)),"^",1)_"|"_D0)=""
218 . ;Q
219 . S NODE=$P(X,"^",1)_"^"_$P($G(^MAG(2005.84,D0,2)),"^",1)
220 . I INCL S NODE=NODE_"^"_$$GET1^DIQ(2005.84,D0,1,"MAGX")
221 . I INST S NODE=NODE_"^"_$$GET1^DIQ(2005.84,D0,4,"MAGX")
222 . I INSP S NODE=NODE_"^"_$$GET1^DIQ(2005.84,D0,2,"MAGX")
223 . S LOC(NODE_"|"_D0)=""
224 . Q
225 Q
226 ;
227D2(N) Q $TR($J(N,2)," ",0)
228 ;
229E2I(D) N %DT,X,Y
230 Q:$P(D,".",1)?7N D\1
231 Q:D="" 0
232 S X=D,%DT="TS" D ^%DT Q:Y<0 0
233 Q Y\1
Note: See TracBrowser for help on using the repository browser.