MAGSIXGT ;WOIFO/EdM/GEK/SEB/NST - RPC for Document Imaging ; 04/29/2002 16:15
;;3.0;IMAGING;**8,48,61,59,108**;Mar 19, 2002;Build 1738;May 20, 2010
;; Per VHA Directive 2004-038, this routine should not be modified.
;; +---------------------------------------------------------------+
;; | Property of the US Government. |
;; | No permission to copy or redistribute this software is given. |
;; | Use of unreleased versions of this software requires the user |
;; | to execute a written test agreement with the VistA Imaging |
;; | Development Office of the Department of Veterans Affairs, |
;; | telephone (301) 734-0100. |
;; | The Food and Drug Administration classifies this software as |
;; | a medical device. As such, it may not be changed in any way. |
;; | Modifications to this software may result in an adulterated |
;; | medical device under 21CFR820, the use of which is considered |
;; | to be a violation of US Federal Statutes. |
;; +---------------------------------------------------------------+
;;
Q
;
IGT(OUT,CLS,FLGS) ;RPC [MAG4 INDEX GET TYPE]
; OUT : the result array
; CLS : a ',' separated list of Classes.
; FLGS : An '^' delimited string
; 1 IGN : Flag to IGNore the Status field
; 2 INCL : Include Class in the Output string
; 3 INST : Include Status in the Output String
;
N C,D0,LOC,N,OK,X,NODE,IGN
N MAGX
K OUT
S CLS=$G(CLS),FLGS=$P($G(FLGS),"|")
; Capture app will send CLS as ADMIN,ADMIN/CLIN for admin
; or CLIN,CLIN/ADMIN for clinical
; 61 - We're expanding CLASS returned to include ALL Clin
; or all Admin
I CLS="ADMIN,ADMIN/CLIN" S CLS="ADMIN,ADMIN/CLIN,CLIN/ADMIN"
I CLS="CLIN,CLIN/ADMIN" S CLS="CLIN,CLIN/ADMIN,ADMIN/CLIN"
S IGN=$P(FLGS,"^",1),INCL=$P(FLGS,"^",2),INST=$P(FLGS,"^",3)
D CLS Q:$D(OUT(0))
;
S N=1
S D0=0 F S D0=$O(^MAG(2005.83,D0)) Q:'D0 D
. S X=$G(^MAG(2005.83,D0,0)),C=$P(X,"^",2)
. ; if Class not null, check it. Null classes will be listed in output.
. I CLS'="" Q:C="" Q:'$D(OK(1,C))
. I 'IGN Q:$P(X,"^",3)="I" ; This is the Status field inactive Flag;
. S NODE=$P(X,"^",1)_"^"_$P($G(^MAG(2005.83,D0,1)),"^",1)
. I INCL S NODE=NODE_"^"_$$GET1^DIQ(2005.83,D0,1,"MAGX")
. I INST S NODE=NODE_"^"_$$GET1^DIQ(2005.83,D0,2,"MAGX")
. S LOC(NODE_"|"_D0)=""
. Q
S X="" F S X=$O(LOC(X)) Q:X="" S N=N+1,OUT(N)=X
I N<2 S OUT(0)="0^-3, No Types Found for """_CLS_"""." Q
S OUT(0)="1^OK: "_N
S OUT(1)=CLS_" Image Types^Abbr"
I INCL S OUT(1)=OUT(1)_"^Class"
I INST S OUT(1)=OUT(1)_"^Status"
Q
IGE(OUT,CLS,SPEC,FLGS) ;RPC [MAG4 INDEX GET EVENT]
; Index Get Procedure/Event (optionally based on (Sub)Specialty)
; OUT : the result array
; CLS : a ',' separated list of Classes.
; SPEC : a ',' separated list of Spec/Subspecialties
; FLGS : An '^' delimited string
; - IGN [1|0] : Flag to IGNore the Status field
; - INCL [1|0] : Include Class in the Output string
; - INST [1|0] : Include Status in the Output String
;
N C,D0,D1,LOC,N,NO,OK,S,X,NODE
K OUT
S CLS=$G(CLS),SPEC=$G(SPEC),FLGS=$P($G(FLGS),"|")
S IGN=$P(FLGS,"^",1),INCL=$P(FLGS,"^",2),INST=$P(FLGS,"^",3)
D CLS Q:$D(OUT(0))
D SPEC Q:$D(OUT(0))
;
S N=1
S D0=0 F S D0=$O(^MAG(2005.85,D0)) Q:'D0 D
. S X=$G(^MAG(2005.85,D0,0)),C=$P(X,"^",2)
. ; if Class not null, check it. Null classes will be listed in output.
. I CLS'="" Q:C="" Q:'$D(OK(1,C))
. I 'IGN Q:$P(X,"^",3)="I" ;This is the Status field inactive Flag;
. ; if Specialty not null, check it. Null Specialties will be listed in output.
. I SPEC'="" D Q:NO
. . S NO=0
. . ; Next line: put "S:'D1 NO=1" before the quit to block implicit mapping
. . S D1=0 F S D1=$O(^MAG(2005.85,D0,1,D1)) Q:'D1 D Q:'NO
. . . S NO=1
. . . S S=$P($G(^MAG(2005.85,D0,1,D1,0)),"^",1)
. . . Q:S=""
. . . S:$D(OK(3,S)) NO=0
. . . Q
. . Q
. S NODE=$P(X,"^",1)_"^"_$P($G(^MAG(2005.85,D0,2)),"^",1)
. I INCL S NODE=NODE_"^"_$$GET1^DIQ(2005.85,D0,1,"MAGX")
. I INST S NODE=NODE_"^"_$$GET1^DIQ(2005.85,D0,4,"MAGX")
. S LOC(NODE_"|"_D0)=""
. Q
S X="" F S X=$O(LOC(X)) Q:X="" S N=N+1,OUT(N)=X
I N<2 S OUT(0)="0^No Procedures or Events found for """_CLS_""" and """_SPEC_"""." Q
S OUT(0)="1^OK: "_N
S OUT(1)="Procedure/Event^Abbr"
I INCL S OUT(1)=OUT(1)_"^Class"
I INST S OUT(1)=OUT(1)_"^Status"
Q
;
IGS(OUT,CLS,EVENT,FLGS) ;RPC [MAG4 INDEX GET SPECIALTY]
; OUT : the result array
; CLS : a ',' separated list of Classes.
; EVENT : a ',' separated list of Proc/Events
; FLGS : An '^' delimited string
; - IGN [1|0] : Flag to IGNore the Status field
; - INCL [1|0] : Include Class in the Output string
; - INST [1|0] : Include Status in the Output String
; - INSP [1|0] : Include Specialty in the OutPut String
;
N C,D0,D1,E,LOC,N,OK,X
K OUT
S CLS=$G(CLS),EVENT=$G(EVENT),FLGS=$P($G(FLGS),"|")
S IGN=$P(FLGS,"^",1),INCL=$P(FLGS,"^",2),INST=$P(FLGS,"^",3),INSP=$P(FLGS,"^",4)
I CLS'="" D CLS Q:$D(OUT(0))
I EVENT'="" D EVENT Q:$D(OUT(0))
;
S N=1
I EVENT="" S D0=0 F S D0=$O(^MAG(2005.84,D0)) Q:'D0 D
. S X=$G(^MAG(2005.84,D0,0)),C=$P(X,"^",2) ;,E=$P(X,"^",3)
. ; if Class not null, check it. Null classes will be listed in output.
. I CLS'="" Q:C="" Q:'$D(OK(1,C))
. I 'IGN Q:$P(X,"^",4)="I" ; This is the Status field inactive Flag;
. ;I EVENT'="" Q:E="" Q:'$D(OK(2,E))
. S NODE=$P(X,"^",1)_"^"_$P($G(^MAG(2005.84,D0,2)),"^",1)
. I INCL S NODE=NODE_"^"_$$GET1^DIQ(2005.84,D0,1,"MAGX")
. I INST S NODE=NODE_"^"_$$GET1^DIQ(2005.84,D0,4,"MAGX")
. I INSP S NODE=NODE_"^"_$$GET1^DIQ(2005.84,D0,2,"MAGX")
. S LOC(NODE_"|"_D0)=""
. Q
I EVENT]"" S E="" F S E=$O(OK(2,E)) Q:E="" D
. ; if Class isn't null, include image if Class matches;
. ; images with Null classes will be listed in output.
. I CLS'="" S C=$P($G(^MAG(2005.85,E,0)),"^",2) Q:'$D(OK(1,C))
. ; if this procedure has specialty pointers, include it if they matches.
. ; images with Proc/Event
. I +$P($G(^MAG(2005.85,E,1,0)),U,3)=0 D GETSPECS(.LOC,INCL,INST,INSP)
. S D0="0" F S D0=$O(^MAG(2005.85,E,1,D0)) Q:D0="" D
. . S D1=$G(^MAG(2005.85,E,1,D0,0)) I D1="" Q
. . S X=$G(^MAG(2005.84,D1,0))
. . I '(X]"") Q
. . S NODE=$P(X,"^",1)_"^"_$P($G(^MAG(2005.84,D1,2)),"^",1)
. . I INCL S NODE=NODE_"^"_$$GET1^DIQ(2005.84,D1,1,"MAGX")
. . I INST S NODE=NODE_"^"_$$GET1^DIQ(2005.84,D1,4,"MAGX")
. . I INSP S NODE=NODE_"^"_$$GET1^DIQ(2005.84,D1,2,"MAGX")
. . S LOC(NODE_"|"_D1)=""
. Q
S X="" F S X=$O(LOC(X)) Q:X="" S N=N+1,OUT(N)=X
I N<2 S OUT(0)="0^-5, No (Sub)Specialties found for """_CLS_""" and """_EVENT_"""." Q
S OUT(0)="1^OK: "_N
S OUT(1)="Specialty/SubSpecialty^Abbr"
I INCL S OUT(1)=OUT(1)_"^Class"
I INST S OUT(1)=OUT(1)_"^Status"
I INSP S OUT(1)=OUT(1)_"^Specialty"
Q
;
PKG N P,I
I $G(PKG)="" Q
F I=1:1:$L(PKG,",") I $L($P(PKG,",",I)) S OK(5,$P(PKG,",",I))=""
Q
ORIGIN N I
N V,MAGR,MAGD,MAGE
I $G(ORIGIN)="" Q
; P48T1 Allow Internal or External for Origin (set of codes)
F I=1:1:$L(ORIGIN,",") I $L($P(ORIGIN,",",I)) S OK(6,$P(ORIGIN,",",I))="" D
. S MAGD=$P(ORIGIN,",",I)
. D CHK^DIE(2005,45,"E",MAGD,.MAGR) I MAGR'="^" S OK(6,MAGR)="",OK(6,MAGR(0))=""
Q
CLS N C,CLSX,I
I $G(CLS)="" Q
F I=1:1:$L(CLS,",") I $L($P(CLS,",",I)) S CLSX=$P(CLS,",",I) D
. I CLSX=+CLSX,$D(^MAG(2005.82,CLSX)) S OK(1,CLSX)=""
. S C="" F S C=$O(^MAG(2005.82,"B",CLSX,C)) Q:C="" S OK(1,C)=""
I $O(OK(1,""))="" S OUT(0)="0^Invalid Class: """_CLS_"""." Q
Q
;
EVENT N E,EVENTX,I
I $G(EVENT)="" Q
F I=1:1:$L(EVENT,",") I $L($P(EVENT,",",I)) S EVENTX=$P(EVENT,",",I) D
. I EVENTX=+EVENTX,$D(^MAG(2005.85,EVENTX)) S OK(2,EVENTX)=""
. S E="" F S E=$O(^MAG(2005.85,"B",EVENTX,E)) Q:E="" S OK(2,E)=""
I $O(OK(2,""))="" S OUT(0)="0^Invalid Event: """_EVENT_"""." Q
Q
;
SPEC N S,SS,SPECX,I
I $G(SPEC)="" Q
; Here we examine each piece of Spec, If piece is a Specialty, include
; its subspecialties.
;
F I=1:1:$L(SPEC,",") I $L($P(SPEC,",",I)) S SPECX=$P(SPEC,",",I) D
. I SPECX=+SPECX,$D(^MAG(2005.84,SPECX)) S OK(3,SPECX)=""
. S S="" F S S=$O(^MAG(2005.84,"B",SPECX,S)) Q:S="" S OK(3,S)=""
. Q
I $O(OK(3,""))="" S OUT(0)="0^Invalid Specialty: """_SPEC_"""." Q
I $D(MAGJOB("CAPTURE")) Q ; 59 for capture we don't want subspecs.
S S="" F S S=$O(OK(3,S)) Q:S="" I $D(^MAG(2005.84,"ASPEC",S)) D
. S SS="" F S SS=$O(^MAG(2005.84,"ASPEC",S,SS)) Q:SS="" S OK(3,SS)=""
. Q
Q
;
TYPE N T,TYPEX,I
I $G(TYPE)="" Q
F I=1:1:$L(TYPE,",") I $L($P(TYPE,",",I)) S TYPEX=$P(TYPE,",",I) D
. I TYPEX=+TYPEX,$D(^MAG(2005.83,TYPEX)) S OK(4,TYPEX)=""
. S T="" F S T=$O(^MAG(2005.83,"B",TYPEX,T)) Q:T="" S OK(4,T)=""
I $O(OK(4,""))="" S OUT(0)="0^Invalid Type: """_TYPE_"""." Q
Q
;
GETSPECS(LOC,INCL,INST,INSP) N D0,X,NODE
S D0=0 F S D0=$O(^MAG(2005.84,D0)) Q:'D0 D
. S X=$G(^MAG(2005.84,D0,0))
. ;I X]"" S LOC($P(X,"^",1)_"^"_$P($G(^MAG(2005.84,D0,2)),"^",1)_"|"_D0)=""
. ;Q
. S NODE=$P(X,"^",1)_"^"_$P($G(^MAG(2005.84,D0,2)),"^",1)
. I INCL S NODE=NODE_"^"_$$GET1^DIQ(2005.84,D0,1,"MAGX")
. I INST S NODE=NODE_"^"_$$GET1^DIQ(2005.84,D0,4,"MAGX")
. I INSP S NODE=NODE_"^"_$$GET1^DIQ(2005.84,D0,2,"MAGX")
. S LOC(NODE_"|"_D0)=""
. Q
Q
;
D2(N) Q $TR($J(N,2)," ",0)
;
E2I(D) N %DT,X,Y
Q:$P(D,".",1)?7N D\1
Q:D="" 0
S X=D,%DT="TS" D ^%DT Q:Y<0 0
Q Y\1
;
;##### RPC TO RETURN ORIGIN INDEX
;
; Return Values
; =============
; MAGRY(0) = "1^OK: <Number of records>"
; MAGRY(1) = "Image Origin^Abbr"
; MAGRY(2..n) = ORIGIN INDEX^ORIGIN ABBREVIATION
;
IGO(MAGRY) ;RPC [MAG4 INDEX GET ORIGIN]
N I,J,ORGS,ORG
K MAGRY
; ^DD(2005,45,0)=ORIGIN INDEX^S^V:VA;N:NON-VA;D:DOD;F:FEE;^40;6^Q
D FIELD^DID(2005,45,"","POINTER","ORGS")
I $G(ORGS("POINTER"))="" S MAGRY(0)="0^Problem retrieving origin index" Q
S I=1
F J=1:1 S ORG=$P(ORGS("POINTER"),";",J) Q:ORG="" D
. S I=I+1
. S MAGRY(I)=$P(ORG,":",2)_"^"_$P(ORG,":",1)
. Q
S MAGRY(0)="1^OK: "_I
S MAGRY(1)="Image Origin^Abbr"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMAGSIXGT 10222 printed Sep 23, 2025@19:44:42 Page 2
MAGSIXGT ;WOIFO/EdM/GEK/SEB/NST - RPC for Document Imaging ; 04/29/2002 16:15
+1 ;;3.0;IMAGING;**8,48,61,59,108**;Mar 19, 2002;Build 1738;May 20, 2010
+2 ;; Per VHA Directive 2004-038, this routine should not be modified.
+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 ;; | The Food and Drug Administration classifies this software as |
+11 ;; | a medical device. As such, it may not be changed in any way. |
+12 ;; | Modifications to this software may result in an adulterated |
+13 ;; | medical device under 21CFR820, the use of which is considered |
+14 ;; | to be a violation of US Federal Statutes. |
+15 ;; +---------------------------------------------------------------+
+16 ;;
+17 QUIT
+18 ;
IGT(OUT,CLS,FLGS) ;RPC [MAG4 INDEX GET TYPE]
+1 ; OUT : the result array
+2 ; CLS : a ',' separated list of Classes.
+3 ; FLGS : An '^' delimited string
+4 ; 1 IGN : Flag to IGNore the Status field
+5 ; 2 INCL : Include Class in the Output string
+6 ; 3 INST : Include Status in the Output String
+7 ;
+8 NEW C,D0,LOC,N,OK,X,NODE,IGN
+9 NEW MAGX
+10 KILL OUT
+11 SET CLS=$GET(CLS)
SET FLGS=$PIECE($GET(FLGS),"|")
+12 ; Capture app will send CLS as ADMIN,ADMIN/CLIN for admin
+13 ; or CLIN,CLIN/ADMIN for clinical
+14 ; 61 - We're expanding CLASS returned to include ALL Clin
+15 ; or all Admin
+16 IF CLS="ADMIN,ADMIN/CLIN"
SET CLS="ADMIN,ADMIN/CLIN,CLIN/ADMIN"
+17 IF CLS="CLIN,CLIN/ADMIN"
SET CLS="CLIN,CLIN/ADMIN,ADMIN/CLIN"
+18 SET IGN=$PIECE(FLGS,"^",1)
SET INCL=$PIECE(FLGS,"^",2)
SET INST=$PIECE(FLGS,"^",3)
+19 DO CLS
if $DATA(OUT(0))
QUIT
+20 ;
+21 SET N=1
+22 SET D0=0
FOR
SET D0=$ORDER(^MAG(2005.83,D0))
if 'D0
QUIT
Begin DoDot:1
+23 SET X=$GET(^MAG(2005.83,D0,0))
SET C=$PIECE(X,"^",2)
+24 ; if Class not null, check it. Null classes will be listed in output.
+25 IF CLS'=""
if C=""
QUIT
if '$DATA(OK(1,C))
QUIT
+26 ; This is the Status field inactive Flag;
IF 'IGN
if $PIECE(X,"^",3)="I"
QUIT
+27 SET NODE=$PIECE(X,"^",1)_"^"_$PIECE($GET(^MAG(2005.83,D0,1)),"^",1)
+28 IF INCL
SET NODE=NODE_"^"_$$GET1^DIQ(2005.83,D0,1,"MAGX")
+29 IF INST
SET NODE=NODE_"^"_$$GET1^DIQ(2005.83,D0,2,"MAGX")
+30 SET LOC(NODE_"|"_D0)=""
+31 QUIT
End DoDot:1
+32 SET X=""
FOR
SET X=$ORDER(LOC(X))
if X=""
QUIT
SET N=N+1
SET OUT(N)=X
+33 IF N<2
SET OUT(0)="0^-3, No Types Found for """_CLS_"""."
QUIT
+34 SET OUT(0)="1^OK: "_N
+35 SET OUT(1)=CLS_" Image Types^Abbr"
+36 IF INCL
SET OUT(1)=OUT(1)_"^Class"
+37 IF INST
SET OUT(1)=OUT(1)_"^Status"
+38 QUIT
IGE(OUT,CLS,SPEC,FLGS) ;RPC [MAG4 INDEX GET EVENT]
+1 ; Index Get Procedure/Event (optionally based on (Sub)Specialty)
+2 ; OUT : the result array
+3 ; CLS : a ',' separated list of Classes.
+4 ; SPEC : a ',' separated list of Spec/Subspecialties
+5 ; FLGS : An '^' delimited string
+6 ; - IGN [1|0] : Flag to IGNore the Status field
+7 ; - INCL [1|0] : Include Class in the Output string
+8 ; - INST [1|0] : Include Status in the Output String
+9 ;
+10 NEW C,D0,D1,LOC,N,NO,OK,S,X,NODE
+11 KILL OUT
+12 SET CLS=$GET(CLS)
SET SPEC=$GET(SPEC)
SET FLGS=$PIECE($GET(FLGS),"|")
+13 SET IGN=$PIECE(FLGS,"^",1)
SET INCL=$PIECE(FLGS,"^",2)
SET INST=$PIECE(FLGS,"^",3)
+14 DO CLS
if $DATA(OUT(0))
QUIT
+15 DO SPEC
if $DATA(OUT(0))
QUIT
+16 ;
+17 SET N=1
+18 SET D0=0
FOR
SET D0=$ORDER(^MAG(2005.85,D0))
if 'D0
QUIT
Begin DoDot:1
+19 SET X=$GET(^MAG(2005.85,D0,0))
SET C=$PIECE(X,"^",2)
+20 ; if Class not null, check it. Null classes will be listed in output.
+21 IF CLS'=""
if C=""
QUIT
if '$DATA(OK(1,C))
QUIT
+22 ;This is the Status field inactive Flag;
IF 'IGN
if $PIECE(X,"^",3)="I"
QUIT
+23 ; if Specialty not null, check it. Null Specialties will be listed in output.
+24 IF SPEC'=""
Begin DoDot:2
+25 SET NO=0
+26 ; Next line: put "S:'D1 NO=1" before the quit to block implicit mapping
+27 SET D1=0
FOR
SET D1=$ORDER(^MAG(2005.85,D0,1,D1))
if 'D1
QUIT
Begin DoDot:3
+28 SET NO=1
+29 SET S=$PIECE($GET(^MAG(2005.85,D0,1,D1,0)),"^",1)
+30 if S=""
QUIT
+31 if $DATA(OK(3,S))
SET NO=0
+32 QUIT
End DoDot:3
if 'NO
QUIT
+33 QUIT
End DoDot:2
if NO
QUIT
+34 SET NODE=$PIECE(X,"^",1)_"^"_$PIECE($GET(^MAG(2005.85,D0,2)),"^",1)
+35 IF INCL
SET NODE=NODE_"^"_$$GET1^DIQ(2005.85,D0,1,"MAGX")
+36 IF INST
SET NODE=NODE_"^"_$$GET1^DIQ(2005.85,D0,4,"MAGX")
+37 SET LOC(NODE_"|"_D0)=""
+38 QUIT
End DoDot:1
+39 SET X=""
FOR
SET X=$ORDER(LOC(X))
if X=""
QUIT
SET N=N+1
SET OUT(N)=X
+40 IF N<2
SET OUT(0)="0^No Procedures or Events found for """_CLS_""" and """_SPEC_"""."
QUIT
+41 SET OUT(0)="1^OK: "_N
+42 SET OUT(1)="Procedure/Event^Abbr"
+43 IF INCL
SET OUT(1)=OUT(1)_"^Class"
+44 IF INST
SET OUT(1)=OUT(1)_"^Status"
+45 QUIT
+46 ;
IGS(OUT,CLS,EVENT,FLGS) ;RPC [MAG4 INDEX GET SPECIALTY]
+1 ; OUT : the result array
+2 ; CLS : a ',' separated list of Classes.
+3 ; EVENT : a ',' separated list of Proc/Events
+4 ; FLGS : An '^' delimited string
+5 ; - IGN [1|0] : Flag to IGNore the Status field
+6 ; - INCL [1|0] : Include Class in the Output string
+7 ; - INST [1|0] : Include Status in the Output String
+8 ; - INSP [1|0] : Include Specialty in the OutPut String
+9 ;
+10 NEW C,D0,D1,E,LOC,N,OK,X
+11 KILL OUT
+12 SET CLS=$GET(CLS)
SET EVENT=$GET(EVENT)
SET FLGS=$PIECE($GET(FLGS),"|")
+13 SET IGN=$PIECE(FLGS,"^",1)
SET INCL=$PIECE(FLGS,"^",2)
SET INST=$PIECE(FLGS,"^",3)
SET INSP=$PIECE(FLGS,"^",4)
+14 IF CLS'=""
DO CLS
if $DATA(OUT(0))
QUIT
+15 IF EVENT'=""
DO EVENT
if $DATA(OUT(0))
QUIT
+16 ;
+17 SET N=1
+18 IF EVENT=""
SET D0=0
FOR
SET D0=$ORDER(^MAG(2005.84,D0))
if 'D0
QUIT
Begin DoDot:1
+19 ;,E=$P(X,"^",3)
SET X=$GET(^MAG(2005.84,D0,0))
SET C=$PIECE(X,"^",2)
+20 ; if Class not null, check it. Null classes will be listed in output.
+21 IF CLS'=""
if C=""
QUIT
if '$DATA(OK(1,C))
QUIT
+22 ; This is the Status field inactive Flag;
IF 'IGN
if $PIECE(X,"^",4)="I"
QUIT
+23 ;I EVENT'="" Q:E="" Q:'$D(OK(2,E))
+24 SET NODE=$PIECE(X,"^",1)_"^"_$PIECE($GET(^MAG(2005.84,D0,2)),"^",1)
+25 IF INCL
SET NODE=NODE_"^"_$$GET1^DIQ(2005.84,D0,1,"MAGX")
+26 IF INST
SET NODE=NODE_"^"_$$GET1^DIQ(2005.84,D0,4,"MAGX")
+27 IF INSP
SET NODE=NODE_"^"_$$GET1^DIQ(2005.84,D0,2,"MAGX")
+28 SET LOC(NODE_"|"_D0)=""
+29 QUIT
End DoDot:1
+30 IF EVENT]""
SET E=""
FOR
SET E=$ORDER(OK(2,E))
if E=""
QUIT
Begin DoDot:1
+31 ; if Class isn't null, include image if Class matches;
+32 ; images with Null classes will be listed in output.
+33 IF CLS'=""
SET C=$PIECE($GET(^MAG(2005.85,E,0)),"^",2)
if '$DATA(OK(1,C))
QUIT
+34 ; if this procedure has specialty pointers, include it if they matches.
+35 ; images with Proc/Event
+36 IF +$PIECE($GET(^MAG(2005.85,E,1,0)),U,3)=0
DO GETSPECS(.LOC,INCL,INST,INSP)
+37 SET D0="0"
FOR
SET D0=$ORDER(^MAG(2005.85,E,1,D0))
if D0=""
QUIT
Begin DoDot:2
+38 SET D1=$GET(^MAG(2005.85,E,1,D0,0))
IF D1=""
QUIT
+39 SET X=$GET(^MAG(2005.84,D1,0))
+40 IF '(X]"")
QUIT
+41 SET NODE=$PIECE(X,"^",1)_"^"_$PIECE($GET(^MAG(2005.84,D1,2)),"^",1)
+42 IF INCL
SET NODE=NODE_"^"_$$GET1^DIQ(2005.84,D1,1,"MAGX")
+43 IF INST
SET NODE=NODE_"^"_$$GET1^DIQ(2005.84,D1,4,"MAGX")
+44 IF INSP
SET NODE=NODE_"^"_$$GET1^DIQ(2005.84,D1,2,"MAGX")
+45 SET LOC(NODE_"|"_D1)=""
End DoDot:2
+46 QUIT
End DoDot:1
+47 SET X=""
FOR
SET X=$ORDER(LOC(X))
if X=""
QUIT
SET N=N+1
SET OUT(N)=X
+48 IF N<2
SET OUT(0)="0^-5, No (Sub)Specialties found for """_CLS_""" and """_EVENT_"""."
QUIT
+49 SET OUT(0)="1^OK: "_N
+50 SET OUT(1)="Specialty/SubSpecialty^Abbr"
+51 IF INCL
SET OUT(1)=OUT(1)_"^Class"
+52 IF INST
SET OUT(1)=OUT(1)_"^Status"
+53 IF INSP
SET OUT(1)=OUT(1)_"^Specialty"
+54 QUIT
+55 ;
PKG NEW P,I
+1 IF $GET(PKG)=""
QUIT
+2 FOR I=1:1:$LENGTH(PKG,",")
IF $LENGTH($PIECE(PKG,",",I))
SET OK(5,$PIECE(PKG,",",I))=""
+3 QUIT
ORIGIN NEW I
+1 NEW V,MAGR,MAGD,MAGE
+2 IF $GET(ORIGIN)=""
QUIT
+3 ; P48T1 Allow Internal or External for Origin (set of codes)
+4 FOR I=1:1:$LENGTH(ORIGIN,",")
IF $LENGTH($PIECE(ORIGIN,",",I))
SET OK(6,$PIECE(ORIGIN,",",I))=""
Begin DoDot:1
+5 SET MAGD=$PIECE(ORIGIN,",",I)
+6 DO CHK^DIE(2005,45,"E",MAGD,.MAGR)
IF MAGR'="^"
SET OK(6,MAGR)=""
SET OK(6,MAGR(0))=""
End DoDot:1
+7 QUIT
CLS NEW C,CLSX,I
+1 IF $GET(CLS)=""
QUIT
+2 FOR I=1:1:$LENGTH(CLS,",")
IF $LENGTH($PIECE(CLS,",",I))
SET CLSX=$PIECE(CLS,",",I)
Begin DoDot:1
+3 IF CLSX=+CLSX
IF $DATA(^MAG(2005.82,CLSX))
SET OK(1,CLSX)=""
+4 SET C=""
FOR
SET C=$ORDER(^MAG(2005.82,"B",CLSX,C))
if C=""
QUIT
SET OK(1,C)=""
End DoDot:1
+5 IF $ORDER(OK(1,""))=""
SET OUT(0)="0^Invalid Class: """_CLS_"""."
QUIT
+6 QUIT
+7 ;
EVENT NEW E,EVENTX,I
+1 IF $GET(EVENT)=""
QUIT
+2 FOR I=1:1:$LENGTH(EVENT,",")
IF $LENGTH($PIECE(EVENT,",",I))
SET EVENTX=$PIECE(EVENT,",",I)
Begin DoDot:1
+3 IF EVENTX=+EVENTX
IF $DATA(^MAG(2005.85,EVENTX))
SET OK(2,EVENTX)=""
+4 SET E=""
FOR
SET E=$ORDER(^MAG(2005.85,"B",EVENTX,E))
if E=""
QUIT
SET OK(2,E)=""
End DoDot:1
+5 IF $ORDER(OK(2,""))=""
SET OUT(0)="0^Invalid Event: """_EVENT_"""."
QUIT
+6 QUIT
+7 ;
SPEC NEW S,SS,SPECX,I
+1 IF $GET(SPEC)=""
QUIT
+2 ; Here we examine each piece of Spec, If piece is a Specialty, include
+3 ; its subspecialties.
+4 ;
+5 FOR I=1:1:$LENGTH(SPEC,",")
IF $LENGTH($PIECE(SPEC,",",I))
SET SPECX=$PIECE(SPEC,",",I)
Begin DoDot:1
+6 IF SPECX=+SPECX
IF $DATA(^MAG(2005.84,SPECX))
SET OK(3,SPECX)=""
+7 SET S=""
FOR
SET S=$ORDER(^MAG(2005.84,"B",SPECX,S))
if S=""
QUIT
SET OK(3,S)=""
+8 QUIT
End DoDot:1
+9 IF $ORDER(OK(3,""))=""
SET OUT(0)="0^Invalid Specialty: """_SPEC_"""."
QUIT
+10 ; 59 for capture we don't want subspecs.
IF $DATA(MAGJOB("CAPTURE"))
QUIT
+11 SET S=""
FOR
SET S=$ORDER(OK(3,S))
if S=""
QUIT
IF $DATA(^MAG(2005.84,"ASPEC",S))
Begin DoDot:1
+12 SET SS=""
FOR
SET SS=$ORDER(^MAG(2005.84,"ASPEC",S,SS))
if SS=""
QUIT
SET OK(3,SS)=""
+13 QUIT
End DoDot:1
+14 QUIT
+15 ;
TYPE NEW T,TYPEX,I
+1 IF $GET(TYPE)=""
QUIT
+2 FOR I=1:1:$LENGTH(TYPE,",")
IF $LENGTH($PIECE(TYPE,",",I))
SET TYPEX=$PIECE(TYPE,",",I)
Begin DoDot:1
+3 IF TYPEX=+TYPEX
IF $DATA(^MAG(2005.83,TYPEX))
SET OK(4,TYPEX)=""
+4 SET T=""
FOR
SET T=$ORDER(^MAG(2005.83,"B",TYPEX,T))
if T=""
QUIT
SET OK(4,T)=""
End DoDot:1
+5 IF $ORDER(OK(4,""))=""
SET OUT(0)="0^Invalid Type: """_TYPE_"""."
QUIT
+6 QUIT
+7 ;
GETSPECS(LOC,INCL,INST,INSP) NEW D0,X,NODE
+1 SET D0=0
FOR
SET D0=$ORDER(^MAG(2005.84,D0))
if 'D0
QUIT
Begin DoDot:1
+2 SET X=$GET(^MAG(2005.84,D0,0))
+3 ;I X]"" S LOC($P(X,"^",1)_"^"_$P($G(^MAG(2005.84,D0,2)),"^",1)_"|"_D0)=""
+4 ;Q
+5 SET NODE=$PIECE(X,"^",1)_"^"_$PIECE($GET(^MAG(2005.84,D0,2)),"^",1)
+6 IF INCL
SET NODE=NODE_"^"_$$GET1^DIQ(2005.84,D0,1,"MAGX")
+7 IF INST
SET NODE=NODE_"^"_$$GET1^DIQ(2005.84,D0,4,"MAGX")
+8 IF INSP
SET NODE=NODE_"^"_$$GET1^DIQ(2005.84,D0,2,"MAGX")
+9 SET LOC(NODE_"|"_D0)=""
+10 QUIT
End DoDot:1
+11 QUIT
+12 ;
D2(N) QUIT $TRANSLATE($JUSTIFY(N,2)," ",0)
+1 ;
E2I(D) NEW %DT,X,Y
+1 if $PIECE(D,".",1)?7N
QUIT D\1
+2 if D=""
QUIT 0
+3 SET X=D
SET %DT="TS"
DO ^%DT
if Y<0
QUIT 0
+4 QUIT Y\1
+5 ;
+6 ;##### RPC TO RETURN ORIGIN INDEX
+7 ;
+8 ; Return Values
+9 ; =============
+10 ; MAGRY(0) = "1^OK: <Number of records>"
+11 ; MAGRY(1) = "Image Origin^Abbr"
+12 ; MAGRY(2..n) = ORIGIN INDEX^ORIGIN ABBREVIATION
+13 ;
IGO(MAGRY) ;RPC [MAG4 INDEX GET ORIGIN]
+1 NEW I,J,ORGS,ORG
+2 KILL MAGRY
+3 ; ^DD(2005,45,0)=ORIGIN INDEX^S^V:VA;N:NON-VA;D:DOD;F:FEE;^40;6^Q
+4 DO FIELD^DID(2005,45,"","POINTER","ORGS")
+5 IF $GET(ORGS("POINTER"))=""
SET MAGRY(0)="0^Problem retrieving origin index"
QUIT
+6 SET I=1
+7 FOR J=1:1
SET ORG=$PIECE(ORGS("POINTER"),";",J)
if ORG=""
QUIT
Begin DoDot:1
+8 SET I=I+1
+9 SET MAGRY(I)=$PIECE(ORG,":",2)_"^"_$PIECE(ORG,":",1)
+10 QUIT
End DoDot:1
+11 SET MAGRY(0)="1^OK: "_I
+12 SET MAGRY(1)="Image Origin^Abbr"
+13 QUIT
