Changeset 623 for WorldVistAEHR/trunk/r/IMAGING-MAG-ZMAG/MAGSIXGT.m
- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
-
WorldVistAEHR/trunk/r/IMAGING-MAG-ZMAG/MAGSIXGT.m (modified) (1 diff)
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/IMAGING-MAG-ZMAG/MAGSIXGT.m
r613 r623 1 MAGSIXGT 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 12 13 14 15 16 17 18 19 20 IGT(OUT,CLS,FLGS) 21 22 23 24 25 26 27 28 29 30 31 S CLS=$G(CLS),FLGS=$P($G(FLGS),"|")32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 IGE(OUT,CLS,SPEC,FLGS) 60 61 62 63 64 65 66 67 68 69 70 71 S CLS=$G(CLS),SPEC=$G(SPEC),FLGS=$P($G(FLGS),"|")72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 IGS(OUT,CLS,EVENT,FLGS) 107 108 109 110 111 112 113 114 115 116 117 118 S CLS=$G(CLS),EVENT=$G(EVENT),FLGS=$P($G(FLGS),"|")119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 PKG 163 164 165 166 ORIGIN 167 168 169 170 171 172 173 174 CLS 175 176 177 178 179 180 181 182 EVENT 183 184 185 186 187 188 189 190 SPEC 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 TYPE 207 208 209 210 211 212 213 214 GETSPECS(LOC,INCL,INST,INSP) 215 216 217 218 219 220 221 222 223 224 225 226 227 D2(N) 228 229 E2I(D) 230 231 232 233 1 MAGSIXGT ;WOIFO/EdM/GEK/SEB - RPC for Document Imaging ; 04/29/2002 16:15 2 ;;3.0;IMAGING;**8,48,61**;Feb 07, 2006 3 ;; +---------------------------------------------------------------+ 4 ;; | Property of the US Government. | 5 ;; | No permission to copy or redistribute this software is given. | 6 ;; | Use of unreleased versions of this software requires the user | 7 ;; | to execute a written test agreement with the VistA Imaging | 8 ;; | Development Office of the Department of Veterans Affairs, | 9 ;; | telephone (301) 734-0100. | 10 ;; | | 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 ; 20 IGT(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=$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 59 IGE(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=$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 ; 106 IGS(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=$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 ; 162 PKG 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 166 ORIGIN 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 174 CLS 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 ; 182 EVENT 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 ; 190 SPEC 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 ; 206 TYPE 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 ; 214 GETSPECS(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 ; 227 D2(N) Q $TR($J(N,2)," ",0) 228 ; 229 E2I(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 TracChangeset
for help on using the changeset viewer.
