MAGSIXGT ;WOIFO/EdM/GEK/SEB - RPC for Document Imaging ; 04/29/2002  16:15
 ;;3.0;IMAGING;**8,48,61**;Feb 07, 2006
 ;; +---------------------------------------------------------------+
 ;; | 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=$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=$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=$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