| [623] | 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
|
|---|
