MAGDQR21.m

MAGDQR21 ;WOIFO/EDM,NST,MLH,JSL,SAF,BT,ZEB - RPCs for Query/Retrieve SetUp ; 07 DEC,2023@1:22 PM

 ;;3.0;IMAGING;**83,104,123,119,221,348**;Mar 19, 2002;Build 6;Apr 19, 2013

 ;; 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

 ;

GET(OUT,DEST,GATEWAY) ; RPC = MAG GET DICOM DEST

 N D0,D1,N,OK,X

 I $G(DEST)="" D  Q

 . S N=1

 . S X="" F  S X=$O(^MAG(2006.587,"B",X)) Q:X=""  S N=N+1,OUT(N)="B^"_X

 . S X="" F  S X=$O(^MAG(2006.587,"D",X)) Q:X=""  S N=N+1,OUT(N)="D^"_X

 . S OUT(1)=N

 . Q

 ;

 S GATEWAY=$G(GATEWAY) S:GATEWAY="--All DICOM Gateways--" GATEWAY=""

 S D0=0,OK=0 F  S D0=$O(^MAG(2006.587,D0)) Q:'D0  D  Q:OK

 . S X=$G(^MAG(2006.587,D0,0))

 . Q:$P(X,"^",1)'=DEST

 . I GATEWAY'="",$P(X,"^",5)'=GATEWAY Q

 . S OK=1,N=6

 . S OUT(2)="2^"_$P(X,"^",2)

 . S OUT(3)="3^"_$P(X,"^",3)

 . S OUT(4)="4^"_$P(X,"^",4)

 . S OUT(5)="5^"_$P(X,"^",6)

 . S OUT(6)="6^"_$P(X,"^",7)

 . S D1=0 F  S D1=$O(^MAG(2006.587,D0,1,D1)) Q:'D1  D

 . . S X=$G(^MAG(2006.587,D0,1,D1,0)) Q:$P(X,"^",1)=""

 . . S N=N+1,OUT(N)=X

 . . Q

 . Q

 S OUT(1)=N

 Q

 ;

SET(OUT,DATA,DEST,GATEWAY) ; RPC = MAG SET DICOM DEST

 N D0,D1,I,N,P,Q,O1,O5,O7,OK,T,X

 I $G(DEST)="" S OUT="-1,No Destination Specified." Q

 ;

 S I="" F  S I=$O(DATA(I)) Q:I=""  D

 . S T=DATA(I) Q:T'["^"

 . I +T=2 S P(2)=$P(T,"^",2) Q

 . I +T=3 S P(3)=$P(T,"^",2) Q

 . I +T=4 S P(4)=$P(T,"^",2) Q

 . I +T=5 S P(6)=$P(T,"^",2) Q

 . I +T=6 S P(7)=$P(T,"^",2) Q

 . S Q($P(T,"^",1))=(+$P(T,"^",2))_"^"_(+$P(T,"^",3))

 . Q

 ;

 S OUT=0

 S GATEWAY=$G(GATEWAY) S:GATEWAY="--All DICOM Gateways--" GATEWAY=""

 S D0=0,OK=0 F  S D0=$O(^MAG(2006.587,D0)) Q:'D0  D  Q:OK

 . S X=$G(^MAG(2006.587,D0,0)),O1=$P(X,"^",1),O5=$P(X,"^",5),O7=$P(X,"^",7)

 . Q:O1'=DEST

 . I GATEWAY'="",O5'=GATEWAY Q

 . S:GATEWAY'="" OK=1 S OUT=OUT+1

 . I O1'="",O5'="",O7'="" K ^MAG(2006.587,"C",O1,O7,O5,D0)

 . I O5'="",O7'="" K ^MAG(2006.587,"D",O5,O7,D0)

 . S I="" F  S I=$O(P(I)) Q:I=""  S:P(I)'="" $P(X,"^",I)=P(I)

 . S:$G(P(7))'="" O7=P(7)

 . S ^MAG(2006.587,D0,0)=X

 . I O1'="",O5'="",O7'="" S ^MAG(2006.587,"C",O1,O7,O5,D0)=""

 . I O5'="",O7'="" S ^MAG(2006.587,"D",O5,O7,D0)=""

 . K ^MAG(2006.587,D0,1)

 . S D1=0,I="" F  S I=$O(Q(I)) Q:I=""  D

 . . S D1=D1+1,^MAG(2006.587,D0,1,D1,0)=I_"^"_Q(I)

 . . S ^MAG(2006.587,D0,1,"B",I,D1)=""

 . . Q

 . S:D1 ^MAG(2006.587,D0,1,0)="^2006.5871SA^"_D1_"^"_D1

 . Q

 Q

 ;

TMPOUT(NAME) ; Return name of the temp

 N X

 S X=$$RTRNFMT^XWBLIB("GLOBAL ARRAY",1)

 S X=$NA(^TMP("MAG",$J,NAME))

 K @X

 Q X

 ;

 ;*zeb *348 add Series Description as optional return

STUDY2(OUT,GROUPS,REQDFN,IMGLESS,FLAGS) ; RPC = MAG DOD GET STUDIES IEN

 ; CR, 5-28-09

 ; IMGLESS is a new flag to speed up queries: if=1 (true), just get study-level 

 ;            data, if null or zero get everything. This new flag is optional.

 ; BT, 01-06-12

 ; FLAGS is ""  - Exclude Deleted records (default)

 ;          "D" - Include Deleted records

 ;          "S" - Include Series Description for DICOM Q/R

 ;       

 ;

 N STUDY,INCDEL,INCSERD

 ;

 S REQDFN=$G(REQDFN)

 S INCDEL=$G(FLAGS)["D"

 ;*zeb *348 add study description as optional return

 S INCSERD=$G(FLAGS)["S"

 S IMGLESS=$G(IMGLESS)

 S OUT=$$TMPOUT^MAGDQR21("STUDY")

 S @OUT@(1)=1

 ;

 I $G(GROUPS) D CNVGRP^MAGDQR21(.GROUPS)

 ;

 D GETSTUDY^MAGDQR21(.GROUPS,.STUDY,INCDEL) ; read IENS in GROUPS and sort into STUDY by UID,IEN

 ;

 D GENOUT^MAGDQR21(.STUDY,REQDFN,IMGLESS,INCDEL,INCSERD) ; generate OUT based on STUDY

 ;

 ;update last counter

 S @OUT@(1)=@OUT@(1)-1

 Q

 ;

CNVGRP(GROUPS) ; Add top level GROUPS value to GROUPS array 

 ; GROUPS=10, GROUPS(1)=11, GROUPS(2)=12 becomes GROUPS(1)=11, GROUPS(2)=12, GROUPS(3)=10

 N LAST

 S LAST=$O(GROUPS(""),-1)+1

 S GROUPS(LAST)=GROUPS

 Q

 ;

GETSTUDY(GROUPS,STUDY,INCDEL) ; Read IENS in GROUPS and sort into STUDY by UID,IEN

 N I,IEN

 S I=""

 F  S I=$O(GROUPS(I)) Q:I=""  D

 . S IEN=$G(GROUPS(I))

 . Q:'IEN

 . I 'INCDEL D SRTUID^MAGDQR21(IEN,.STUDY)

 . I INCDEL D SRTUID2^MAGDQR21(IEN,.STUDY)

 . Q

 Q

 ;

SRTUID(IEN,STUDY) ; Sort group by UID, IEN

 N PARENT,UID

 ;get parent IEN

 S PARENT=$P($G(^MAG(2005,IEN,0)),"^",10)

 S:PARENT IEN=PARENT

 ;IEN now is parent IEN or Individual Image

 S UID=$P($G(^MAG(2005,IEN,"PACS")),"^",1) S:UID="" UID="?" ;no pacs

 S STUDY(UID,IEN)=""

 Q

 ; 

SRTUID2(IEN,STUDY) ; Sort group by UID, IEN (include Deleted Images)

 N PARENT,UID,MAGFIL

 ;get parent IEN

 S PARENT=$P($G(^MAG(2005,IEN,0)),"^",10)

 S:'PARENT PARENT=$P($G(^MAG(2005.1,IEN,0)),"^",10)

 S:PARENT IEN=PARENT

 ;IEN now is parent IEN or Individual Image

 S MAGFIL=$$FILE^MAGGI11(IEN)

 S UID=$S(MAGFIL:$P($G(^MAG(MAGFIL,IEN,"PACS")),"^",1),1:"")

 S:UID="" UID="?" ;no pacs

 S STUDY(UID,IEN)=""

 Q

 ;

 ;*zeb *348 pass on INCSERD to code that would actually include the series description

GENOUT(STUDY,REQDFN,IMGLESS,INCDEL,INCSERD) ; Generate output in ^TMP based on STUDY array

 N UID,IEN

 S INCSERD=$G(INCSERD)

 ;

 S UID=""

 F  S UID=$O(STUDY(UID)) Q:UID=""  D

 . I UID="?" D  Q

 . . S IEN=""

 . . F  S IEN=$O(STUDY(UID,IEN)) Q:IEN=""  D STUDY^MAGDQR21("",IEN,REQDFN,IMGLESS,INCDEL,INCSERD)

 . . Q

 . ;ELSE

 . D STUDY^MAGDQR21(UID,"",REQDFN,IMGLESS,INCDEL,INCSERD)

 . Q

 Q

 ; 

 ;*zeb *348 pass on INCSERD to code that would actually include the series description

STUDY(UID,IEN,REQDFN,IMGLESS,INCDEL,INCSERD) ; Generate output in ^TMP based on parameters

 N STUDY

 N SERIESARRAY ; array of series numbers for this study

 N TOTIMAGES ; total number of images for all series in this study

 N PAT ; array of IENs by patient

 N PATCOUNT ; array of patients, use for validation purposes, should contain only one patient

 N I0 ;IEN where the patient found

 N D0

 N STUMO ;Procedure array

 N TDCMIMG ; total number of DICOM images

 S INCSERD=$G(INCSERD)

 ;

 D WRTOUT^MAGDQR21("NEXT_STUDY|"_UID_"|"_IEN)

 ;

 D:UID'="" GETGPUID^MAGDQR21(UID,.STUDY,INCDEL) ;fill STUDY based on UID

 D:IEN GETGPIEN^MAGDQR21(IEN,.STUDY,INCDEL) ;add IEN into STUDY

 Q:'$O(STUDY(""))

 ; 

 D GETPAT^MAGDQR21(.STUDY,.PAT,.PATCOUNT,.TOTIMAGES,.TDCMIMG,REQDFN,INCDEL) ;get images for patient

 Q:'$$VALPAT^MAGDQR21(UID,.PAT,.PATCOUNT,REQDFN)  ;validate to make sure all images belonged to one patient

 ;

 S I0=$O(PAT(REQDFN,"")) ;include the first Image when writing out the STUDY section

 Q:'$$WRTIEN^MAGDQR21(UID,I0,TOTIMAGES,TDCMIMG,REQDFN)

 ;

 Q:'$$INTEGDFN^MAGDQR21(I0,REQDFN,INCDEL)

 ;

 D WRTOUT^MAGDQR21("STUDY_PAT|"_REQDFN_"|"_$S($T(GETICN^MPIF001)'="":$$GETICN^MPIF001(REQDFN),1:"-1^NO MPI")_"|"_$P($G(^DPT(REQDFN,0)),"^",1))

 ;

 ; CR, 5-28-09

 ; For study-level data stop here without additional checks 

 Q:IMGLESS=1

 ;end of check above

 ;

 S D0=""

 F  S D0=$O(PAT(REQDFN,D0)) Q:D0=""  D WRTIMG^MAGDQR20(.SERIESARRAY,D0,REQDFN,.STUMO,INCDEL,INCSERD)

 D WRTMOD^MAGDQR21(.STUMO) ; list all modalities

 Q

 ;

GETGPUID(UID,STUDY,INCDEL) ; Given UID, populate STUDY array with Image IEN 

 N D0

 S D0=""

 F  S D0=$O(^MAG(2005,"P",UID,D0)) Q:D0=""  D

 . S:'$P($G(^MAG(2005,D0,0)),"^",10) STUDY(D0)=2005 ; add either Group IEN or individual IEN (not child IEN)

 . Q

 ;

 I INCDEL D

 . S D0=""

 . F  S D0=$O(^MAG(2005.1,"P",UID,D0)) Q:D0=""  D

 . . Q:'$$ISDEL^MAGGI11(D0)

 . . S:'$P($G(^MAG(2005.1,D0,0)),"^",10) STUDY(D0)=2005.1 ; add either deleted Group IEN or deleted individual IEN (not child IEN)

 . . Q

 . Q

 Q

 ;

GETGPIEN(IEN,STUDY,INCDEL) ; Add IEN into STUDY (include deleted images)

 S:'$P($G(^MAG(2005,IEN,0)),"^",10) STUDY(IEN)=2005 ; add image IEN

 ;

 I INCDEL,$$ISDEL^MAGGI11(IEN) D

 . S:'$P($G(^MAG(2005.1,IEN,0)),"^",10) STUDY(IEN)=2005.1 ;add deleted image IEN

 . Q

 Q

 ;

GETPAT(STUDY,PAT,PATCOUNT,TOTIMAGES,TDCMIMG,REQDFN,INCDEL) ; Get Total Images count and fill Patient array based on STUDY

 ;Input:

 ;   STUDY     - array of all images

 ;   REQDFN    - patient

 ;   INCDEL    - include Deleted Images

 ;Output:

 ;   PAT       - array of all images for the patient

 ;   PATCOUNT  - array to validate all images should belonged only to one patient

 ;   TOTIMAGES - total images for the patient

 ;   TDCMIMG   - total DICOM images 

 ;

 N D0,MAGFIL,DFN,ISGRP,CNT

 S (TOTIMAGES,TDCMIMG)=0

 S D0=""

 ;

 F  S D0=$O(STUDY(D0)) Q:D0=""  D

 . S MAGFIL=STUDY(D0)

 . S DFN=+$P($G(^MAG(MAGFIL,D0,0)),"^",7)

 . S PATCOUNT(DFN)=""

 . S:REQDFN=DFN PAT(DFN,D0)=""

 . ;

 . ;Add image count to Total Images for the study

 . S ISGRP=$$ISGRP^MAGDQR21(D0,INCDEL)

 . I 'ISGRP,REQDFN=DFN S TOTIMAGES=TOTIMAGES+1 Q

 . I MAGFIL=2005 D

 . . S CNT=$$GETGPIM^MAGDQR21(D0,REQDFN,.PATCOUNT)

 . . S TOTIMAGES=TOTIMAGES+$P(CNT,"^",1) ; count group images

 . . S TDCMIMG=TDCMIMG+$P(CNT,"^",2)

 . . Q

 . I INCDEL D

 . . S CNT=$$GETGPDIM^MAGDQR21(D0,REQDFN,.PATCOUNT)

 . . S TOTIMAGES=TOTIMAGES+$P(CNT,"^",1) ; count deleted group images

 . . S TDCMIMG=TDCMIMG+$P(CNT,"^",2)

 . . Q

 . Q

 Q

 ;

ISGRP(D0,INCDEL) ; return 1 if D0 is a group IEN, 0 otherwise

 N ISGRP

 S ISGRP=1

 I 'INCDEL,'$D(^MAG(2005,D0,1)) S ISGRP=0 ; a single image (e.g., photo ID), not a group

 I INCDEL,'$D(^MAG(2005,D0,1)),'$D(^MAG(2005.1,D0,1)) S ISGRP=0 ; a single deleted image (e.g., photo ID), not a group

 Q ISGRP

 ;

GETGPIM(D0,REQDFN,PATCOUNT) ; return total images in the group and PATCOUNT array for patient validation

 N D1,I0,DFN,IMGCNT,IMGCNTOT,MAGOBJTP

 S (IMGCNT,IMGCNTOT)=0

 S D1=0 ;go through all images. They should belong to one pt

 F  S D1=$O(^MAG(2005,D0,1,D1)) Q:'D1  D

 . S I0=+$G(^MAG(2005,D0,1,D1,0)) Q:'I0

 . S DFN=+$P($G(^MAG(2005,I0,0)),"^",7)

 . S PATCOUNT(DFN)="" ;populate PATCOUNT with DFN for validation (DFN might be different in this case it's a corrupted record)

 . ; increment image count unless single pt was requested and this isn't that pt

 . I REQDFN'=DFN Q

 . S IMGCNT=IMGCNT+1

 . S MAGOBJTP=$P($G(^MAG(2005,I0,0)),"^",6)  ; OBJECT TYPE field (#3)

 . S:(MAGOBJTP=100)!(MAGOBJTP=3) IMGCNTOT=IMGCNTOT+1   ; 100 - DICOM IMAGE; 3 - XRAY

 . Q

 Q IMGCNT_"^"_IMGCNTOT

 ;

GETGPDIM(D0,REQDFN,PATCOUNT) ; return total images in the group and PATCOUNT array for patient validation

 N I0,DFN,IMGCNT,IMGCNTOT,MAGOBJTP

 S (IMGCNT,IMGCNTOT)=0

 S I0="" ;go through all AUDIT images.

 F  S I0=$O(^MAG(2005.1,"AGP",D0,I0)) Q:I0=""  D

 . S DFN=+$P($G(^MAG(2005.1,I0,0)),"^",7)

 . S PATCOUNT(DFN)="" ;populate PATCOUNT with DFN for validation (DFN might be different in this case it's a corrupted record)

 . ; increment image count unless single pt was requested and this isn't that pt

 . I REQDFN'=DFN Q

 . S IMGCNT=IMGCNT+1

 . S MAGOBJTP=$P($G(^MAG(2005.1,I0,0)),"^",6)  ; OBJECT TYPE field (#3)

 . S:(MAGOBJTP=100)!(MAGOBJTP=3) IMGCNTOT=IMGCNTOT+1   ; 100 - DICOM IMAGE; 3 - XRAY

 . Q

 Q IMGCNT_"^"_IMGCNTOT

 ;

VALPAT(UID,PAT,PATCOUNT,REQDFN) ; Validate - should only have one patient

 N CONT,DFN

 ;

 S CONT=1,PATCOUNT=0

 S DFN="" F  S DFN=$O(PATCOUNT(DFN)) Q:DFN=""  S PATCOUNT=PATCOUNT+1

 ;

 I PATCOUNT>1 D

 . ; duplicate study instance UID?

 . D WRTOUT^MAGDQR21("STUDY_ERR|"_UID_"|"_PATCOUNT_" different patients")

 . S CONT=$S('REQDFN:0,'$D(PAT(REQDFN)):0,1:1) ;continue processing with error if patient requested found 

 . Q

 ;

 Q CONT

 ;

WRTIEN(UID,I0,TOTIMAGES,TDCMIMG,REQDFN) ; Output STUDY UID and IEN line

 N OBJGRP

 ; 

 D:UID'="" WRTOUT^MAGDQR21("STUDY_UID|"_UID)

 I 'I0 D WRTOUT^MAGDQR21("STUDY_ERR|"_UID_"|Matching study not found for patient "_REQDFN) Q 0

 S OBJGRP=$$ONEGROUP^MAGDQR21(I0) ; get the first image IEN for group/image I0

 D WRTOUT^MAGDQR21("STUDY_IEN|"_I0_"|"_TOTIMAGES_"|"_OBJGRP_"|"_$$CPTCODE^MAGDQR21(I0)_"|"_$$GETSITE1^MAGDQR21(OBJGRP)_"|"_TDCMIMG)

 Q 1

 ; 

INTEGDFN(I0,REQDFN,INCDEL) ; check integrity of study record

 ;Return 1 if Specified DFN (REQDFN) matches study DFN (VA internal use only!)

 ;       0 otherwise

 N X,CONT,MAGFIL,QINTEG

 ;

 D CHK^MAGGSQI(.X,I0)

 S QINTEG='$G(X(0))

 D:QINTEG APDOUT^MAGDQR21("|"_$P($G(X(0)),"^",2))

 S CONT=1

 ; override QI check only if image DFN = DFN specified in call

 ; (VA internal only!)

 I QINTEG D

 . I 'REQDFN S CONT=0 Q

 . S MAGFIL=$$FILE^MAGGI11(I0)

 . I MAGFIL="" S CONT=0 Q

 . S:$P($G(^MAG(MAGFIL,I0,0)),"^",7)'=REQDFN CONT=0

 . Q

 ;

 Q CONT

 ;

WRTMOD(STUMO) ; Output STUDY_MODALITY line

 N M,X

 S X="",M=""

 F  S M=$O(STUMO(M)) Q:M=""  S X=X_$S(X'="":",",1:"")_M

 D:X'="" WRTOUT^MAGDQR21("STUDY_MODALITY|"_X)

 Q

 ;

ONEGROUP(GROUP) ; Get the first IMAGE_IEN for this group in IMAGE file (#2005)

 ;                or IMAGE AUDIT file (#2005.1)  

 N D1,IMGIEN,MAGNODE

 S MAGNODE=$$NODE^MAGGI11(GROUP)

 I MAGNODE="" Q "0^Error 2 - First Image not available; No Data"

 I '$D(@MAGNODE@(1)) Q GROUP ; a single image (e.g., photo ID), not a group

 S IMGIEN=""

 S D1=$O(@MAGNODE@(1,0))

 I D1>0 S IMGIEN=+$G(@MAGNODE@(1,D1,0))

 I IMGIEN'>0 S IMGIEN=$O(^MAG(2005.1,"AGP",GROUP,""))

 I IMGIEN'>0 S IMGIEN="0^Error 1 - First Image not available"

 Q IMGIEN

 ;

WRTOUT(S) ; Write a new line

 N CNT

 S CNT=^TMP("MAG",$J,"STUDY",1)+1

 S ^TMP("MAG",$J,"STUDY",1)=CNT

 S ^TMP("MAG",$J,"STUDY",CNT)=S

 Q

 ;

APDOUT(S) ; Append to last line

 N CNT

 S CNT=^TMP("MAG",$J,"STUDY",1)

 S ^TMP("MAG",$J,"STUDY",CNT)=$G(^TMP("MAG",$J,"STUDY",CNT))_S

 Q

 ;

CPTCODE(MAGIEN) ; Returns CPT code by IEN (image pointer) in IMAGE file (#2005)

 ;                or IMAGE AUDIT file (#2005.1)  

 ; MAGIEN = IEN in IMAGE file (#2005) or IMAGE AUDIT file (#2005.1)

 N RAIEN,CPTCODE,MAGFILE

 S MAGFILE=$$FILE^MAGGI11(MAGIEN)

 S RAIEN=+$$GET1^DIQ(MAGFILE,MAGIEN,62,"I")  ; Get PACS PROCEDURE field #62

 S CPTCODE=$P($G(^RAMIS(71,RAIEN,0)),"^",9) ; IA # 1174  get CPT Code

 Q:CPTCODE="" ""  ; quit with empty code

 S CPTCODE=$$CPT^ICPTCOD(CPTCODE) ; IA # 1995, supported reference

 Q $P(CPTCODE,"^",2) ; Return the code

 ;

GETSITE1(MAGIEN) ; Returns STATION NUMBER where the image is stored

 ; MAGIEN = IEN in IMAGE file (#2005)

 N MAGNODE,TMP,NLOCIEN,PLC

 N SITEIEN,SITENUM

 I MAGIEN'>0 Q ""

 D:'$D(MAGJOB("NETPLC")) NETPLCS^MAGGTU6 ; Initialize MAGJOB("NETPLC")

 S MAGNODE=$$NODE^MAGGI11(MAGIEN)

 I MAGNODE="" Q ""

 S TMP=$G(@MAGNODE@(0))

 S NLOCIEN=+$S($P(TMP,U,3):$P(TMP,U,3),1:$P(TMP,U,5)) ; Get IEN in NETWORK LOCATION file (#2005.2)

 S PLC=$P($G(MAGJOB("NETPLC",NLOCIEN)),U,1)     ; Imaging Site Parameters IEN

 Q $$GETSNUM^MAGDQR21(PLC)  ; Return STATION NUMBER

 ;

GETSNUM(MAGPLC) ; Returns STATION NUMBER by Image Site Parameters IEN

 ; MAGPLC - IEN in IMAGING SITE PARAMETERS file (#2006.1)

 I MAGPLC'>0 Q ""

 N SITEIEN,SITENUM

 S SITEIEN=$P($G(^MAG(2006.1,MAGPLC,0)),U,1)    ; Get Station IEN in INSTITUTION file (#4)

 Q:SITEIEN="" ""  ; if SITE IEN is not defined return blank

 S SITENUM=$P($$NS^XUAF4(SITEIEN),U,2)      ; IA #2171  Get Station Number

 Q SITENUM

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---MAGDQR21   15720     printed  Mar 13, 2025@21:05:58                                                                                                                                                                                                   Page 2

MAGDQR21  ;WOIFO/EDM,NST,MLH,JSL,SAF,BT,ZEB - RPCs for Query/Retrieve SetUp ; 07 DEC,2023@1:22 PM

 +1       ;;3.0;IMAGING;**83,104,123,119,221,348**;Mar 19, 2002;Build 6;Apr 19, 2013

 +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      ;

GET(OUT,DEST,GATEWAY) ; RPC = MAG GET DICOM DEST

 +1        NEW D0,D1,N,OK,X

 +2        IF $GET(DEST)=""

               Begin DoDot:1

 +3                SET N=1

 +4                SET X=""

                   FOR 

                       SET X=$ORDER(^MAG(2006.587,"B",X))

                       if X=""

                           QUIT 

                       SET N=N+1

                       SET OUT(N)="B^"_X

 +5                SET X=""

                   FOR 

                       SET X=$ORDER(^MAG(2006.587,"D",X))

                       if X=""

                           QUIT 

                       SET N=N+1

                       SET OUT(N)="D^"_X

 +6                SET OUT(1)=N

 +7                QUIT 

               End DoDot:1

               QUIT 

 +8       ;

 +9        SET GATEWAY=$GET(GATEWAY)

           if GATEWAY="--All DICOM Gateways--"

               SET GATEWAY=""

 +10       SET D0=0

           SET OK=0

           FOR 

               SET D0=$ORDER(^MAG(2006.587,D0))

               if 'D0

                   QUIT 

               Begin DoDot:1

 +11               SET X=$GET(^MAG(2006.587,D0,0))

 +12               if $PIECE(X,"^",1)'=DEST

                       QUIT 

 +13               IF GATEWAY'=""

                       IF $PIECE(X,"^",5)'=GATEWAY

                           QUIT 

 +14               SET OK=1

                   SET N=6

 +15               SET OUT(2)="2^"_$PIECE(X,"^",2)

 +16               SET OUT(3)="3^"_$PIECE(X,"^",3)

 +17               SET OUT(4)="4^"_$PIECE(X,"^",4)

 +18               SET OUT(5)="5^"_$PIECE(X,"^",6)

 +19               SET OUT(6)="6^"_$PIECE(X,"^",7)

 +20               SET D1=0

                   FOR 

                       SET D1=$ORDER(^MAG(2006.587,D0,1,D1))

                       if 'D1

                           QUIT 

                       Begin DoDot:2

 +21                       SET X=$GET(^MAG(2006.587,D0,1,D1,0))

                           if $PIECE(X,"^",1)=""

                               QUIT 

 +22                       SET N=N+1

                           SET OUT(N)=X

 +23                       QUIT 

                       End DoDot:2

 +24               QUIT 

               End DoDot:1

               if OK

                   QUIT 

 +25       SET OUT(1)=N

 +26       QUIT 

 +27      ;

SET(OUT,DATA,DEST,GATEWAY) ; RPC = MAG SET DICOM DEST

 +1        NEW D0,D1,I,N,P,Q,O1,O5,O7,OK,T,X

 +2        IF $GET(DEST)=""

               SET OUT="-1,No Destination Specified."

               QUIT 

 +3       ;

 +4        SET I=""

           FOR 

               SET I=$ORDER(DATA(I))

               if I=""

                   QUIT 

               Begin DoDot:1

 +5                SET T=DATA(I)

                   if T'["^"

                       QUIT 

 +6                IF +T=2

                       SET P(2)=$PIECE(T,"^",2)

                       QUIT 

 +7                IF +T=3

                       SET P(3)=$PIECE(T,"^",2)

                       QUIT 

 +8                IF +T=4

                       SET P(4)=$PIECE(T,"^",2)

                       QUIT 

 +9                IF +T=5

                       SET P(6)=$PIECE(T,"^",2)

                       QUIT 

 +10               IF +T=6

                       SET P(7)=$PIECE(T,"^",2)

                       QUIT 

 +11               SET Q($PIECE(T,"^",1))=(+$PIECE(T,"^",2))_"^"_(+$PIECE(T,"^",3))

 +12               QUIT 

               End DoDot:1

 +13      ;

 +14       SET OUT=0

 +15       SET GATEWAY=$GET(GATEWAY)

           if GATEWAY="--All DICOM Gateways--"

               SET GATEWAY=""

 +16       SET D0=0

           SET OK=0

           FOR 

               SET D0=$ORDER(^MAG(2006.587,D0))

               if 'D0

                   QUIT 

               Begin DoDot:1

 +17               SET X=$GET(^MAG(2006.587,D0,0))

                   SET O1=$PIECE(X,"^",1)

                   SET O5=$PIECE(X,"^",5)

                   SET O7=$PIECE(X,"^",7)

 +18               if O1'=DEST

                       QUIT 

 +19               IF GATEWAY'=""

                       IF O5'=GATEWAY

                           QUIT 

 +20               if GATEWAY'=""

                       SET OK=1

                   SET OUT=OUT+1

 +21               IF O1'=""

                       IF O5'=""

                           IF O7'=""

                               KILL ^MAG(2006.587,"C",O1,O7,O5,D0)

 +22               IF O5'=""

                       IF O7'=""

                           KILL ^MAG(2006.587,"D",O5,O7,D0)

 +23               SET I=""

                   FOR 

                       SET I=$ORDER(P(I))

                       if I=""

                           QUIT 

                       if P(I)'=""

                           SET $PIECE(X,"^",I)=P(I)

 +24               if $GET(P(7))'=""

                       SET O7=P(7)

 +25               SET ^MAG(2006.587,D0,0)=X

 +26               IF O1'=""

                       IF O5'=""

                           IF O7'=""

                               SET ^MAG(2006.587,"C",O1,O7,O5,D0)=""

 +27               IF O5'=""

                       IF O7'=""

                           SET ^MAG(2006.587,"D",O5,O7,D0)=""

 +28               KILL ^MAG(2006.587,D0,1)

 +29               SET D1=0

                   SET I=""

                   FOR 

                       SET I=$ORDER(Q(I))

                       if I=""

                           QUIT 

                       Begin DoDot:2

 +30                       SET D1=D1+1

                           SET ^MAG(2006.587,D0,1,D1,0)=I_"^"_Q(I)

 +31                       SET ^MAG(2006.587,D0,1,"B",I,D1)=""

 +32                       QUIT 

                       End DoDot:2

 +33               if D1

                       SET ^MAG(2006.587,D0,1,0)="^2006.5871SA^"_D1_"^"_D1

 +34               QUIT 

               End DoDot:1

               if OK

                   QUIT 

 +35       QUIT 

 +36      ;

TMPOUT(NAME) ; Return name of the temp

 +1        NEW X

 +2        SET X=$$RTRNFMT^XWBLIB("GLOBAL ARRAY",1)

 +3        SET X=$NAME(^TMP("MAG",$JOB,NAME))

 +4        KILL @X

 +5        QUIT X

 +6       ;

 +7       ;*zeb *348 add Series Description as optional return

STUDY2(OUT,GROUPS,REQDFN,IMGLESS,FLAGS) ; RPC = MAG DOD GET STUDIES IEN

 +1       ; CR, 5-28-09

 +2       ; IMGLESS is a new flag to speed up queries: if=1 (true), just get study-level 

 +3       ;            data, if null or zero get everything. This new flag is optional.

 +4       ; BT, 01-06-12

 +5       ; FLAGS is ""  - Exclude Deleted records (default)

 +6       ;          "D" - Include Deleted records

 +7       ;          "S" - Include Series Description for DICOM Q/R

 +8       ;       

 +9       ;

 +10       NEW STUDY,INCDEL,INCSERD

 +11      ;

 +12       SET REQDFN=$GET(REQDFN)

 +13       SET INCDEL=$GET(FLAGS)["D"

 +14      ;*zeb *348 add study description as optional return

 +15       SET INCSERD=$GET(FLAGS)["S"

 +16       SET IMGLESS=$GET(IMGLESS)

 +17       SET OUT=$$TMPOUT^MAGDQR21("STUDY")

 +18       SET @OUT@(1)=1

 +19      ;

 +20       IF $GET(GROUPS)

               DO CNVGRP^MAGDQR21(.GROUPS)

 +21      ;

 +22      ; read IENS in GROUPS and sort into STUDY by UID,IEN

           DO GETSTUDY^MAGDQR21(.GROUPS,.STUDY,INCDEL)

 +23      ;

 +24      ; generate OUT based on STUDY

           DO GENOUT^MAGDQR21(.STUDY,REQDFN,IMGLESS,INCDEL,INCSERD)

 +25      ;

 +26      ;update last counter

 +27       SET @OUT@(1)=@OUT@(1)-1

 +28       QUIT 

 +29      ;

CNVGRP(GROUPS) ; Add top level GROUPS value to GROUPS array 

 +1       ; GROUPS=10, GROUPS(1)=11, GROUPS(2)=12 becomes GROUPS(1)=11, GROUPS(2)=12, GROUPS(3)=10

 +2        NEW LAST

 +3        SET LAST=$ORDER(GROUPS(""),-1)+1

 +4        SET GROUPS(LAST)=GROUPS

 +5        QUIT 

 +6       ;

GETSTUDY(GROUPS,STUDY,INCDEL) ; Read IENS in GROUPS and sort into STUDY by UID,IEN

 +1        NEW I,IEN