MAGDQR04 ;WOIFO/EdM,MLH,JSL,SAF,DAC - Imaging RPCs for Query/Retrieve ; Aug 28, 2020@07:26:26
;;3.0;IMAGING;**51,54,66,123,118,263,280**;Mar 19, 2002;Build 2
;; 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
;
STUDY(OUT,UID,PRMUID) ; RPC = MAG STUDY UID QUERY
N D1,F1,F2,F3,F4,F5,F6,IMAGE,N,NET,PASS,PAT,PAT0,SERIES,USER,X,IARRAY
N PATIX,PROCIX,PATDTA,PATIDNT,STYIX,SERIX,SOPIX
I $G(UID)="" S OUT(1)="-1,No UID specified." Q
I UID'?1.64(1N,1".") S OUT(1)="-2,Invalid UID format: """_UID_"""." Q
S PRMUID=$G(PRMUID) S:($L(PRMUID)'=1)!(123'[PRMUID) PRMUID=0
S N=1,PAT=""
;
; search old DB
;
S SERIES="" F S SERIES=$O(^MAG(2005,"P",UID,SERIES)) Q:SERIES="" D Q:PAT<0
. S X=$G(^MAG(2005,SERIES,0))
. S PAT0=$P(X,"^",7) D:PAT0 Q:PAT<0
. . I PAT="" S PAT=PAT0 Q
. . Q:PRMUID=1
. . S:PAT'=PAT0 PAT=-1
. . Q
. I $P(X,"^",10) S IARRAY(SERIES)="OLD" Q
. S D1=0 F S D1=$O(^MAG(2005,SERIES,1,D1)) Q:'D1 D
. . S IMAGE=+$G(^MAG(2005,SERIES,1,D1,0)) S:IMAGE IARRAY(IMAGE)="OLD"
. . Q
. Q
I PAT<0 S OUT(1)="-13,Duplicate Study UID" Q
S SERIES="" F S SERIES=$O(^MAG(2005,"SERIESUID",UID,SERIES)) Q:SERIES="" D
. I $P($G(^MAG(2005,SERIES,0)),"^",10) S IARRAY(SERIES)="OLD" Q
. S D1=0 F S D1=$O(^MAG(2005,SERIES,1,D1)) Q:'D1 D
. . S IMAGE=+$G(^MAG(2005,SERIES,1,D1,0)) S:IMAGE IARRAY(IMAGE)="OLD"
. . Q
. Q
;
; search new DB
;
D:$D(^MAGV(2005.62,"B",UID))
. S STYIX="" F S STYIX=$O(^MAGV(2005.62,"B",UID,STYIX)) Q:'STYIX D Q:PAT<0
. . S PROCIX=$P($G(^MAGV(2005.62,STYIX,6)),"^",1) Q:'PROCIX
. . S PATIX=$P($G(^MAGV(2005.61,PROCIX,6)),"^",1) Q:'PATIX
. . S PATDTA=$G(^MAGV(2005.6,PATIX,0)) Q:PATDTA=""
. . S PAT0=$P(PATDTA,"^",1) S:PAT="" PAT=PAT0
. . I ($P(PATDTA,"^",3)'="D")!(PAT'=PAT0) S PAT=-1 Q
. . ; process study for valid pt
. . S SERIX="" F S SERIX=$O(^MAGV(2005.63,"C",STYIX,SERIX)) Q:'SERIX D
. . . S SOPIX="" F S SOPIX=$O(^MAGV(2005.64,"C",SERIX,SOPIX)) Q:'SOPIX D
. . . . N ACTVIMG
. . . . S ACTVIMG=0
. . . . S IMAGE="" F S IMAGE=$O(^MAGV(2005.65,"C",SOPIX,IMAGE)) Q:'IMAGE D Q:ACTVIMG
. . . . . I $P($G(^MAGV(2005.65,IMAGE,1)),"^",5)'="I" S IARRAY(IMAGE)="NEW",ACTVIMG=1
. . . . . Q
. . . . Q
. . . Q
. . Q
. Q
I PAT<0 S OUT(1)="-13,Duplicate Study UID" Q
S OUT(1)=0
S IMAGE="" F N=1:1 S IMAGE=$O(IARRAY(IMAGE)) Q:'IMAGE D VALID(.OUT,IMAGE,IARRAY(IMAGE),PRMUID)
S X=" image" S:N'=2 X=X_"s" S X=X_" found"
S OUT(1)="0,"_(N-1)_X
Q
;
VALID(OUT,IMAGE,DBTYPE,PRMUID) N T,UID,UNIQ
N DATE,Q,F1,F2,F3,T1,T2,T3,X,NET,USER,PASS,RETURN,SOPCLIX
I IMAGE,IMAGE?.N
E S OUT($O(OUT(""),-1)+1)=IMAGE_"^-21,Invalid Image IEN Format" Q
D:DBTYPE="OLD"
. D CHK^MAGGSQI(.X,IMAGE) I +$G(X(0))'=1 D Q
. . S OUT($O(OUT(""),-1)+1)=IMAGE_"^-13,Questionable Integrity"
. . Q
. S UNIQ=0,UID=$P($G(^MAG(2005,IMAGE,"PACS")),"^",1) D:UID'=""
. . S T="" F S T=$O(^MAG(2005,"P",UID,T)) Q:T="" D
. . . S UNIQ=UNIQ+1
. . . S DATE($G(^MAG(2005,T,2))\1_" ",T)=""
. . . Q
. . Q
. S Q=0 I UNIQ>1 D Q:Q
. . Q:PRMUID=1
. . I PRMUID=0 S Q=1,OUT($O(OUT(""),-1)+1)=IMAGE_"^-14,Multiple images with UID="""_UID_"""." Q
. . S DATE=$O(DATE(""),-PRMUID*2+5) S:DATE="" DATE="?"
. . S:'$D(DATE(DATE,IMAGE)) Q=1
. . Q
. S NET=$P($G(^MAG(2005,IMAGE,0)),"^",3) S:NET="" NET=$P($G(^(0)),"^",5)
. S (USER,PASS)=""
. S:NET X=$G(^MAG(2005.2,NET,2)),USER=$P(X,"^",1),PASS=$$DECRYP^ROUTINE($P(X,"^",2))
. S SOPIX=$P($G(^MAG(2005,IMAGE,"SOP")),"^",1)
. D FILEFIND^MAGDFB(IMAGE,"FULL",0,0,.F1,.F2,.F3)
. D FILEFIND^MAGDFB(IMAGE,"BIG",0,0,.T1,.T2,.T3)
. S:T2'<0 F2=T2
. D FILEFIND^MAGDFB(IMAGE,"TEXT",0,0,.F4,.F5,.F6)
. S RETURN=IMAGE_"^DB=OLD|IMGLOC="_F2_"|NWLOCIEN="_NET
. S RETURN=RETURN_"^"_USER_"^"_PASS_"|TXTLOC="_F5
. S:SOPIX RETURN=RETURN_"|SOPCLASS="_$P($G(^MAG(2006.532,SOPIX,0)),"^",1)
. Q
D:DBTYPE="NEW"
. S RETURN=IMAGE_"^DB=NEW|ARTKEY="_$P($G(^MAGV(2005.65,IMAGE,0)),"^",1)
. S SOPIX=$P($G(^MAGV(2005.65,IMAGE,6)),"^",1)
. S:$G(SOPIX) SOPCLIX=$P($G(^MAGV(2005.64,SOPIX,0)),"^",3)
. S:$G(SOPCLIX) RETURN=RETURN_"|SOPCLASS="_$P($G(^MAG(2006.532,SOPCLIX,0)),"^",1)
. Q
S:$D(RETURN) OUT($O(OUT(""),-1)+1)=RETURN
Q
;
INFO(OUT,IMAGE,DBTYPE) ; RPC = MAG IMAGE CURRENT INFO
;
; 0008,0018 SOP Instance UID (Create new one, if needed)
; 0008,0020 Study Date
; 0008,0050 Accession Number
; 0008,0060 Modality
; 0008,0090 Referring Physician's Name
; 0008,1030 Study Description (may be VA procedure name)
; 0008,1050 Performing (attending) Physician
; 0010,0010 Patient Name
; 0010,0020 Patient ID
; 0010,0030 Patient's Birth Date
; 0010,0040 Patient's Sex
; 0010,1000 Other Patient IDs (= ICN, Integration Control Number)
; 0010,1040 Address
; 0010,2160 Ethnic Group
; 0010,2000 Medical Alerts
; 0020,000D Study Instance UID
; 0020,000E Series Instance UID
; 0020,000D Study Instance UID
; 0032,1032 Requesting Physician
; 0032,1033 Requesting Service
; 0032,1060 Requested Procedure Description (CPT name)
; 0032,1064 Requested Procedure Code Sequence
; 0008,0100 > Code Value (CPT code)
; 0008,0102 > Coding Scheme Designator ("C4")
; 0008,0104 > Code Meaning (CPT name)
; 0038,0300 Current Patient Location (ward)
; 0032,1020 Scheduled Study Location
;
N ACN,ATP,CPT,D0,D1,D2,D3,DFN,ERR,I,IT,MO,N,P,PDT,PP,REQP,RFP,RQL,T,TAG,TYPE,UID,V,WRD,X
N TYPE,SOPIX,SERIX,STYIX,PROCIX,PATIX,PATDTA,PROCDTA,ACCARY,ACCIX
K OUT
S DBTYPE=$G(DBTYPE,"OLD")
D Q:$D(OUT) ; validate input parameters
. I "^OLD^NEW^"'[("^"_DBTYPE_"^") S OUT(1)="-3,Database type not specified." Q
. I '$G(IMAGE) S OUT(1)="-1,No Image Specified." Q
. I DBTYPE="OLD",'$D(^MAG(2005,IMAGE)) S OUT(1)="-2,No Such Image ("_IMAGE_")." Q
. ; P263 DAC - Fixed file reference. Changed 2005.64 (SOP) to 2005.65 (Image)
. I DBTYPE="NEW",'$D(^MAGV(2005.65,IMAGE)) S OUT(1)="-2,No Such Image ("_IMAGE_")." Q
. Q
;
S TYPE=$S(DBTYPE="OLD":"R",1:"N")
; P263 DAC - Added IENTYPE or "IMAGE", so that the study lookup knows to start at the Image (#2005.65) file level
S TAG("0008,1030")=$$STYDESC2^MAGUE001(TYPE,IMAGE,.ERR,"IMAGE") ; Study Description
D:DBTYPE="OLD"
. S X=$G(^MAG(2005,IMAGE,0)),P=$P(X,"^",10)
. S DFN=$P(X,"^",7)
. Q
D:DBTYPE="NEW" Q:$D(OUT)
. S P=1
. S SOPIX=$P($G(^MAGV(2005.65,IMAGE,6)),"^",1)
. I 'SOPIX S OUT(1)="-4,SOP instance not found for image IEN "_IMAGE_"." Q
. S SERIX=$P($G(^MAGV(2005.64,SOPIX,6)),"^",1)
. I 'SERIX S OUT(1)="-4,Series not found for image IEN "_IMAGE_"." Q
. S STYIX=$P($G(^MAGV(2005.63,SERIX,6)),"^",1)
. I 'STYIX S OUT(1)="-5,Study not found for image IEN "_IMAGE_"." Q
. S PROCIX=$P($G(^MAGV(2005.62,STYIX,6)),"^",1)
. I 'PROCIX S OUT(1)="-6,Procedure reference not found for image IEN "_IMAGE_"." Q
. ; P263 DAC - Changed STYIX (Study Index) to PROCIX (Procedure Index)
. S PATIX=$P($G(^MAGV(2005.61,PROCIX,6)),"^",1)
. I 'PATIX S OUT(1)="-7,Patient not found for image IEN "_IMAGE_"." Q
. S PATDTA=$G(^MAGV(2005.6,PATIX,0))
. I $P(PATDTA,"^",3)'="D" S OUT(1)="-8,Patient ID is not a VA DFN for image IEN "_IMAGE_"." Q
. S DFN=$P(PATDTA,"^",1)
. I 'DFN S OUT(1)="-9,DFN not found for image IEN "_IMAGE_"." Q
. Q
D:DFN
. N VA,VADM,VAPA,VAERR,DOB,TOB ; return arrays from VADPT
. N I ; scratch loop array
. D DEM^VADPT ; populate standard patient data array VADM() Supported IA (#10061)
. S TAG("0010,0010")=$G(VADM(1)) ; Patient Name
. S TAG("0010,0020")=$S($$ISIHS^MAGSPID():$G(VA("PID")),1:VADM(2)) ; Patient ID (HRN or SSN)
. S DOB=$G(VADM(3))\1+17000000 ; Patient's Birth Date
. ; make sure month and year are DICOM valid
. S TAG("0010,0030")=$S($E(DOB,5,6)="00":"",$E(DOB,7,8)="00":"",1:DOB)
. ; Patient's Birth Time [probably always blank]
. S TAG("0010,0032")=$S(VADM(3)[".":$TR($J("."_$P($G(VADM(3)),".",2)*1E6,6)," ",0),1:"")
. S TAG("0010,2160")=$G(VADM(8)) ; Patient's Race
. S TAG("0010,0040")=$P($G(VADM(5)),"^",1) ; Patient's Sex
. S X=$S($T(GETICN^MPIF001)'="":$$GETICN^MPIF001(DFN),1:"-1^NO MPI") ; Supported IA (#2701)
. S TAG("0010,1000")=$S(X<0:$E(TAG("0010,0010"),1)_$E(TAG("0010,0020"),6,99),1:X) ; Other Patient ID
. D ADD^VADPT ; populate patient address array
. F I=1,2,3,4,6 S $P(TAG("0010,1040"),"^",I)=$G(VAPA(I))
. S $P(TAG("0010,1040"),"^",5)=$P($G(VAPA(5)),"^",2)
. Q
;
; P280 DAC - Fixing index mismatch for NEW data structure
I DBTYPE="OLD" S:P TAG("0008,0018")=$$QRNEWUID^MAGDRPC9(IMAGE,DBTYPE)
I DBTYPE="NEW" S:P TAG("0008,0018")=$$QRNEWUID^MAGDRPC9(SOPIX,DBTYPE)
;
D:DBTYPE="OLD"
. S TAG("0020,000D")=$P($G(^MAG(2005,$S(P:+P,1:IMAGE),"PACS")),"^",1)
. Q ; no series UID on retrieve per WFP 5/6/11
. S X=$P($G(^MAG(2005,IMAGE,"SERIESUID")),"^",1)
. S:X'="" TAG("0020,000E")=X
D:DBTYPE="NEW"
. S TAG("0020,000D")=$P(^MAGV(2005.62,STYIX,0),"^",1)
. Q ; no series UID for study-level query
. S TAG("0020,000E")=$P(^MAGV(2005.62,SERIX,0),"^",1)
. Q
;
; The following references to ^RADPT are allowed according to IA # 1172
S ACN=""
I DBTYPE="OLD" D
. S X=$G(^MAG(2005,IMAGE,2)) D:$P(X,"^",6)=74
. . N P5,P7
. . S P5=$P(X,"^",5),P7=$P(X,"^",7),X=$G(^RARPT(+P7,0))
. . S D0=$P(X,"^",2),D1=9999999.9999=$P(X,"^",3),ACN=$P(X,"^",1)
. . Q
. Q
I DBTYPE="NEW" D
. S PROCDTA=$G(^MAGV(2005.61,PROCIX,0))
. S:$P(PROCDTA,"^",3)="RAD" ACN=$P(PROCDTA,"^",1)
. Q
S IT=0
S:ACN'="" I=$$ACCFIND^RAAPI(ACN,.ACCARY)
S ACCIX="" F S ACCIX=$O(ACCARY(ACCIX)) Q:'ACCIX D
. S D0=$P(ACCARY(ACCIX),"^",1),D1=$P(ACCARY(ACCIX),"^",2),D2=$P(ACCARY(ACCIX),"^",3)
. N M1,VAIN,VAINDT
. ; no study date on retrieve per WFP 5/6/11
. ;S IT=IT+1,TAG("0008,0020",IT)=9999999.9999-D1\1+17000000 ; Study Date
. S VAINDT=9999999.9999-D1 D INP^VADPT ; Supported reference
. S:$G(VAIN(2))'="" RFP(VAIN(2))="" ; Referring Physician's Name
. S:$G(VAIN(4))'="" RFP(VAIN(4))="" ; Current Ward
. S:$G(VAIN(11))'="" ATP(VAIN(11))="" ; Performing (attending) Physician
. S X=$G(^RADPT(D0,"DT",D1,"P",D2,0))
. S P=$P(X,"^",2) D:P
. . S M1=0 F S M1=$O(^RAMIS(71,+P,"MDL",M1)) Q:'M1 D ; IA # 1174
. . . S V=$P($G(^RAMIS(71,+P,"MDL",M1,0)),"^",1) Q:'V ; IA # 1174
. . . S V=$P($G(^RAMIS(73.1,+V,0)),"^",1) S:V'="" MO(V)="" ; IA # 2933
. . . Q
. . S V=$P($G(^RAMIS(71,+P,0)),"^",9) S:V CPT(+V)="" ; IA # 1174
. . Q
. S P=$P(X,"^",14) D:P
. . S V=$P($G(^VA(200,+P,0)),"^",1)
. . S:V'="" REQP(V)=""
. . Q
. S P=$P(X,"^",17) D:P
. . S X=$G(^RARPT(+P,0)) Q:X="" ; IA # 1171
. . S V=$P(X,"^",1) S:V'="" ACN(V)=""
. . Q
. S P=$P(X,"^",22) D:P
. . S X=$G(^SC(+P,0)) Q:X="" ; IA # 10040
. . S V=$P(X,"^",1) S:V'="" RQL(V)=""
. . Q
. S P=0,D3=0 F S D3=$O(^RADPT(D0,"P",D1,"DT",D2,"H",D3)) Q:'D3 D
. . S X=$G(^RADPT(D0,"P",D1,"DT",D2,"H",D3,0)) Q:X=""
. . S P=P+1,TAG("0010,2000 "_$J(P,5))=X
. . Q
. Q
S V="" F S V=$O(ACN(V)) Q:V="" D
. S IT=IT+1,TAG("0008,0050",IT)=V ; Accession Number
. Q
S V="" F S V=$O(WRD(V)) Q:V="" D
. S IT=IT+1,TAG("0038,0300",IT)=$P(V,"^",2) ; Current Patient Location
. Q
S V="" F S V=$O(RFP(V)) Q:V="" D
. S IT=IT+1,TAG("0008,0090",IT)=$P(V,"^",2) ; Referring Physician's Name
. Q
S V="" F S V=$O(ATP(V)) Q:V="" D
. S IT=IT+1,TAG("0008,1050",IT)=$P(V,"^",2) ; Performing (attending) Physician
. Q
S V="" F S V=$O(RQL(V)) Q:V="" D
. S IT=IT+1,TAG("0032,1033",IT)=V ; Requesting Service
. Q
; no modality code on retrieve per WFP 5/6/11
;S V="" F S V=$O(MO(V)) Q:V="" D
;. S IT=IT+1,TAG("0008,0060",IT)=V ; Modality
;. Q
S V="" F S V=$O(REQP(V)) Q:V="" D
. S IT=IT+1,TAG("0032,1032",IT)=V ; Requesting Physician
. Q
S V="" F S V=$O(CPT(V)) Q:V="" D
. S X=$$CPT^ICPTCOD(V) ; IA # 1995, supported reference
. Q:$P(X,"^",2)=""
. S IT=IT+1
. S TAG("0032,1064 0008,0100",IT)=$P(X,"^",2) ; CPT Code
. S TAG("0032,1064 0008,0104",IT)=$P(X,"^",3) ; Code Meaning
. S TAG("0032,1060",IT)=$P(X,"^",3) ; Requested Procedure Description
. S TAG("0032,1064 0008,0102",IT)="C4" ; Coding Scheme Designator
. Q
; Acquisition Site
D:DBTYPE="OLD"
. S V=$P($G(^MAG(2005,IMAGE,100)),"^",3) D:V=""
. . ; Find Acquisition site when not filled in in Image File
. . N D0,LOC,N
. . S (N,D0,LOC)=0 F S D0=$O(^MAG(2006.1,D0)) Q:'D0 D
. . . S N=N+1,LOC=$P($G(^MAG(2006.1,D0,0)),"^",1)
. . . Q
. . Q:N>2 ; Too many to choose from...
. . S:LOC V=LOC
. . Q
. S:V'="" TAG("0032,1020")=V
. Q
D:DBTYPE="NEW"
. S V=$P($G(^MAGV(2005.63,SERIX,2)),"^",4)
. S:V'="" TAG("0032,1020")=V
;
S N=1,T="" F S T=$O(TAG(T)) Q:T="" D
. S V=""
. S:$D(TAG(T))#2 V=TAG(T)
. S I="" F S I=$O(TAG(T,I)) Q:I="" S:V'="" V=V_"\" S V=V_TAG(T,I)
. S:V'="" N=N+1,OUT(N)=T_"^"_V
. Q
;
S OUT(1)=(N-1)_" data fields returned."
Q
;
CLEAN(OUT) ; RPC = MAG DICOM QUERY CLEANUP
N D0,H,N,STAMP
L +^MAGDQR(2006.5732,0):1E6 ; Background task MUST wait
S D0=0 F S D0=$O(^MAGDQR(2006.5732,D0)) Q:'D0 D
. S X=$G(^MAGDQR(2006.5732,D0,0)),STAMP=$P(X,"^",3)
. Q:$$FMDIFF^XLFDT(DT,STAMP,1)<5
. K ^MAGDQR(2006.5732,D0)
. K ^MAGDQR(2006.5732,"B",D0)
. Q
S (D0,N,H)=0 F S D0=$O(^MAGDQR(2006.5732,D0)) Q:'D0 S N=N+1,H=D0
S X="DICOM QUERY RETRIEVE RESULT^2006.5732^"_H_"^"_N
S ^MAGDQR(2006.5732,0)=X
L -^MAGDQR(2006.5732,0)
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMAGDQR04 14264 printed Sep 23, 2025@19:37:03 Page 2
MAGDQR04 ;WOIFO/EdM,MLH,JSL,SAF,DAC - Imaging RPCs for Query/Retrieve ; Aug 28, 2020@07:26:26
+1 ;;3.0;IMAGING;**51,54,66,123,118,263,280**;Mar 19, 2002;Build 2
+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 ;
STUDY(OUT,UID,PRMUID) ; RPC = MAG STUDY UID QUERY
+1 NEW D1,F1,F2,F3,F4,F5,F6,IMAGE,N,NET,PASS,PAT,PAT0,SERIES,USER,X,IARRAY
+2 NEW PATIX,PROCIX,PATDTA,PATIDNT,STYIX,SERIX,SOPIX
+3 IF $GET(UID)=""
SET OUT(1)="-1,No UID specified."
QUIT
+4 IF UID'?1.64(1N,1".")
SET OUT(1)="-2,Invalid UID format: """_UID_"""."
QUIT
+5 SET PRMUID=$GET(PRMUID)
if ($LENGTH(PRMUID)'=1)!(123'[PRMUID)
SET PRMUID=0
+6 SET N=1
SET PAT=""
+7 ;
+8 ; search old DB
+9 ;
+10 SET SERIES=""
FOR
SET SERIES=$ORDER(^MAG(2005,"P",UID,SERIES))
if SERIES=""
QUIT
Begin DoDot:1
+11 SET X=$GET(^MAG(2005,SERIES,0))
+12 SET PAT0=$PIECE(X,"^",7)
if PAT0
Begin DoDot:2
+13 IF PAT=""
SET PAT=PAT0
QUIT
+14 if PRMUID=1
QUIT
+15 if PAT'=PAT0
SET PAT=-1
+16 QUIT
End DoDot:2
if PAT<0
QUIT
+17 IF $PIECE(X,"^",10)
SET IARRAY(SERIES)="OLD"
QUIT
+18 SET D1=0
FOR
SET D1=$ORDER(^MAG(2005,SERIES,1,D1))
if 'D1
QUIT
Begin DoDot:2
+19 SET IMAGE=+$GET(^MAG(2005,SERIES,1,D1,0))
if IMAGE
SET IARRAY(IMAGE)="OLD"
+20 QUIT
End DoDot:2
+21 QUIT
End DoDot:1
if PAT<0
QUIT
+22 IF PAT<0
SET OUT(1)="-13,Duplicate Study UID"
QUIT
+23 SET SERIES=""
FOR
SET SERIES=$ORDER(^MAG(2005,"SERIESUID",UID,SERIES))
if SERIES=""
QUIT
Begin DoDot:1
+24 IF $PIECE($GET(^MAG(2005,SERIES,0)),"^",10)
SET IARRAY(SERIES)="OLD"
QUIT
+25 SET D1=0
FOR
SET D1=$ORDER(^MAG(2005,SERIES,1,D1))
if 'D1
QUIT
Begin DoDot:2
+26 SET IMAGE=+$GET(^MAG(2005,SERIES,1,D1,0))
if IMAGE
SET IARRAY(IMAGE)="OLD"
+27 QUIT
End DoDot:2
+28 QUIT
End DoDot:1
+29 ;
+30 ; search new DB
+31 ;
+32 if $DATA(^MAGV(2005.62,"B",UID))
Begin DoDot:1
+33 SET STYIX=""
FOR
SET STYIX=$ORDER(^MAGV(2005.62,"B",UID,STYIX))
if 'STYIX
QUIT
Begin DoDot:2
+34 SET PROCIX=$PIECE($GET(^MAGV(2005.62,STYIX,6)),"^",1)
if 'PROCIX
QUIT
+35 SET PATIX=$PIECE($GET(^MAGV(2005.61,PROCIX,6)),"^",1)
if 'PATIX
QUIT
+36 SET PATDTA=$GET(^MAGV(2005.6,PATIX,0))
if PATDTA=""
QUIT
+37 SET PAT0=$PIECE(PATDTA,"^",1)
if PAT=""
SET PAT=PAT0
+38 IF ($PIECE(PATDTA,"^",3)'="D")!(PAT'=PAT0)
SET PAT=-1
QUIT
+39 ; process study for valid pt
+40 SET SERIX=""
FOR
SET SERIX=$ORDER(^MAGV(2005.63,"C",STYIX,SERIX))
if 'SERIX
QUIT
Begin DoDot:3
+41 SET SOPIX=""
FOR
SET SOPIX=$ORDER(^MAGV(2005.64,"C",SERIX,SOPIX))
if 'SOPIX
QUIT
Begin DoDot:4
+42 NEW ACTVIMG
+43 SET ACTVIMG=0
+44 SET IMAGE=""
FOR
SET IMAGE=$ORDER(^MAGV(2005.65,"C",SOPIX,IMAGE))
if 'IMAGE
QUIT
Begin DoDot:5
+45 IF $PIECE($GET(^MAGV(2005.65,IMAGE,1)),"^",5)'="I"
SET IARRAY(IMAGE)="NEW"
SET ACTVIMG=1
+46 QUIT
End DoDot:5
if ACTVIMG
QUIT
+47 QUIT
End DoDot:4
+48 QUIT
End DoDot:3
+49 QUIT
End DoDot:2
if PAT<0
QUIT
+50 QUIT
End DoDot:1
+51 IF PAT<0
SET OUT(1)="-13,Duplicate Study UID"
QUIT
+52 SET OUT(1)=0
+53 SET IMAGE=""
FOR N=1:1
SET IMAGE=$ORDER(IARRAY(IMAGE))
if 'IMAGE
QUIT
DO VALID(.OUT,IMAGE,IARRAY(IMAGE),PRMUID)
+54 SET X=" image"
if N'=2
SET X=X_"s"
SET X=X_" found"
+55 SET OUT(1)="0,"_(N-1)_X
+56 QUIT
+57 ;
VALID(OUT,IMAGE,DBTYPE,PRMUID) NEW T,UID,UNIQ
+1 NEW DATE,Q,F1,F2,F3,T1,T2,T3,X,NET,USER,PASS,RETURN,SOPCLIX
+2 IF IMAGE
IF IMAGE?.N
+3 IF '$TEST
SET OUT($ORDER(OUT(""),-1)+1)=IMAGE_"^-21,Invalid Image IEN Format"
QUIT
+4 if DBTYPE="OLD"
Begin DoDot:1
+5 DO CHK^MAGGSQI(.X,IMAGE)
IF +$GET(X(0))'=1
Begin DoDot:2
+6 SET OUT($ORDER(OUT(""),-1)+1)=IMAGE_"^-13,Questionable Integrity"
+7 QUIT
End DoDot:2
QUIT
+8 SET UNIQ=0
SET UID=$PIECE($GET(^MAG(2005,IMAGE,"PACS")),"^",1)
if UID'=""
Begin DoDot:2
+9 SET T=""
FOR
SET T=$ORDER(^MAG(2005,"P",UID,T))
if T=""
QUIT
Begin DoDot:3
+10 SET UNIQ=UNIQ+1
+11 SET DATE($GET(^MAG(2005,T,2))\1_" ",T)=""
+12 QUIT
End DoDot:3
+13 QUIT
End DoDot:2
+14 SET Q=0
IF UNIQ>1
Begin DoDot:2
+15 if PRMUID=1
QUIT
+16 IF PRMUID=0
SET Q=1
SET OUT($ORDER(OUT(""),-1)+1)=IMAGE_"^-14,Multiple images with UID="""_UID_"""."
QUIT
+17 SET DATE=$ORDER(DATE(""),-PRMUID*2+5)
if DATE=""
SET DATE="?"
+18 if '$DATA(DATE(DATE,IMAGE))
SET Q=1
+19 QUIT
End DoDot:2
if Q
QUIT
+20 SET NET=$PIECE($GET(^MAG(2005,IMAGE,0)),"^",3)
if NET=""
SET NET=$PIECE($GET(^(0)),"^",5)
+21 SET (USER,PASS)=""
+22 if NET
SET X=$GET(^MAG(2005.2,NET,2))
SET USER=$PIECE(X,"^",1)
SET PASS=$$DECRYP^ROUTINE($PIECE(X,"^",2))
+23 SET SOPIX=$PIECE($GET(^MAG(2005,IMAGE,"SOP")),"^",1)
+24 DO FILEFIND^MAGDFB(IMAGE,"FULL",0,0,.F1,.F2,.F3)
+25 DO FILEFIND^MAGDFB(IMAGE,"BIG",0,0,.T1,.T2,.T3)
+26 if T2'<0
SET F2=T2
+27 DO FILEFIND^MAGDFB(IMAGE,"TEXT",0,0,.F4,.F5,.F6)
+28 SET RETURN=IMAGE_"^DB=OLD|IMGLOC="_F2_"|NWLOCIEN="_NET
+29 SET RETURN=RETURN_"^"_USER_"^"_PASS_"|TXTLOC="_F5
+30 if SOPIX
SET RETURN=RETURN_"|SOPCLASS="_$PIECE($GET(^MAG(2006.532,SOPIX,0)),"^",1)
+31 QUIT
End DoDot:1
+32 if DBTYPE="NEW"
Begin DoDot:1
+33 SET RETURN=IMAGE_"^DB=NEW|ARTKEY="_$PIECE($GET(^MAGV(2005.65,IMAGE,0)),"^",1)
+34 SET SOPIX=$PIECE($GET(^MAGV(2005.65,IMAGE,6)),"^",1)
+35 if $GET(SOPIX)
SET SOPCLIX=$PIECE($GET(^MAGV(2005.64,SOPIX,0)),"^",3)
+36 if $GET(SOPCLIX)
SET RETURN=RETURN_"|SOPCLASS="_$PIECE($GET(^MAG(2006.532,SOPCLIX,0)),"^",1)
+37 QUIT
End DoDot:1
+38 if $DATA(RETURN)
SET OUT($ORDER(OUT(""),-1)+1)=RETURN
+39 QUIT
+40 ;
INFO(OUT,IMAGE,DBTYPE) ; RPC = MAG IMAGE CURRENT INFO
+1 ;
+2 ; 0008,0018 SOP Instance UID (Create new one, if needed)
+3 ; 0008,0020 Study Date
+4 ; 0008,0050 Accession Number
+5 ; 0008,0060 Modality
+6 ; 0008,0090 Referring Physician's Name
+7 ; 0008,1030 Study Description (may be VA procedure name)
+8 ; 0008,1050 Performing (attending) Physician
+9 ; 0010,0010 Patient Name
+10 ; 0010,0020 Patient ID
+11 ; 0010,0030 Patient's Birth Date
+12 ; 0010,0040 Patient's Sex
+13 ; 0010,1000 Other Patient IDs (= ICN, Integration Control Number)
+14 ; 0010,1040 Address
+15 ; 0010,2160 Ethnic Group
+16 ; 0010,2000 Medical Alerts
+17 ; 0020,000D Study Instance UID
+18 ; 0020,000E Series Instance UID
+19 ; 0020,000D Study Instance UID
+20 ; 0032,1032 Requesting Physician
+21 ; 0032,1033 Requesting Service
+22 ; 0032,1060 Requested Procedure Description (CPT name)
+23 ; 0032,1064 Requested Procedure Code Sequence
+24 ; 0008,0100 > Code Value (CPT code)
+25 ; 0008,0102 > Coding Scheme Designator ("C4")
+26 ; 0008,0104 > Code Meaning (CPT name)
+27 ; 0038,0300 Current Patient Location (ward)
+28 ; 0032,1020 Scheduled Study Location
+29 ;
+30 NEW ACN,ATP,CPT,D0,D1,D2,D3,DFN,ERR,I,IT,MO,N,P,PDT,PP,REQP,RFP,RQL,T,TAG,TYPE,UID,V,WRD,X
+31 NEW TYPE,SOPIX,SERIX,STYIX,PROCIX,PATIX,PATDTA,PROCDTA,ACCARY,ACCIX
+32 KILL OUT
+33 SET DBTYPE=$GET(DBTYPE,"OLD")
+34 ; validate input parameters
Begin DoDot:1
+35 IF "^OLD^NEW^"'[("^"_DBTYPE_"^")
SET OUT(1)="-3,Database type not specified."
QUIT
+36 IF '$GET(IMAGE)
SET OUT(1)="-1,No Image Specified."
QUIT
+37 IF DBTYPE="OLD"
IF '$DATA(^MAG(2005,IMAGE))
SET OUT(1)="-2,No Such Image ("_IMAGE_")."
QUIT
+38 ; P263 DAC - Fixed file reference. Changed 2005.64 (SOP) to 2005.65 (Image)
+39 IF DBTYPE="NEW"
IF '$DATA(^MAGV(2005.65,IMAGE))
SET OUT(1)="-2,No Such Image ("_IMAGE_")."
QUIT
+40 QUIT
End DoDot:1
if $DATA(OUT)
QUIT
+41 ;
+42 SET TYPE=$SELECT(DBTYPE="OLD":"R",1:"N")
+43 ; P263 DAC - Added IENTYPE or "IMAGE", so that the study lookup knows to start at the Image (#2005.65) file level
+44 ; Study Description
SET TAG("0008,1030")=$$STYDESC2^MAGUE001(TYPE,IMAGE,.ERR,"IMAGE")
+45 if DBTYPE="OLD"
Begin DoDot:1
+46 SET X=$GET(^MAG(2005,IMAGE,0))
SET P=$PIECE(X,"^",10)
+47 SET DFN=$PIECE(X,"^",7)
+48 QUIT
End DoDot:1
+49 if DBTYPE="NEW"
Begin DoDot:1
+50 SET P=1
+51 SET SOPIX=$PIECE($GET(^MAGV(2005.65,IMAGE,6)),"^",1)
+52 IF 'SOPIX
SET OUT(1)="-4,SOP instance not found for image IEN "_IMAGE_"."
QUIT
+53 SET SERIX=$PIECE($GET(^MAGV(2005.64,SOPIX,6)),"^",1)
+54 IF 'SERIX
SET OUT(1)="-4,Series not found for image IEN "_IMAGE_"."
QUIT
+55 SET STYIX=$PIECE($GET(^MAGV(2005.63,SERIX,6)),"^",1)
+56 IF 'STYIX
SET OUT(1)="-5,Study not found for image IEN "_IMAGE_"."
QUIT
+57 SET PROCIX=$PIECE($GET(^MAGV(2005.62,STYIX,6)),"^",1)
+58 IF 'PROCIX
SET OUT(1)="-6,Procedure reference not found for image IEN "_IMAGE_"."
QUIT
+59 ; P263 DAC - Changed STYIX (Study Index) to PROCIX (Procedure Index)
+60 SET PATIX=$PIECE($GET(^MAGV(2005.61,PROCIX,6)),"^",1)
+61 IF 'PATIX
SET OUT(1)="-7,Patient not found for image IEN "_IMAGE_"."
QUIT
+62 SET PATDTA=$GET(^MAGV(2005.6,PATIX,0))
+63 IF $PIECE(PATDTA,"^",3)'="D"
SET OUT(1)="-8,Patient ID is not a VA DFN for image IEN "_IMAGE_"."
QUIT
+64 SET DFN=$PIECE(PATDTA,"^",1)
+65 IF 'DFN
SET OUT(1)="-9,DFN not found for image IEN "_IMAGE_"."
QUIT
+66 QUIT
End DoDot:1
if $DATA(OUT)
QUIT
+67 if DFN
Begin DoDot:1
+68 ; return arrays from VADPT
NEW VA,VADM,VAPA,VAERR,DOB,TOB
+69 ; scratch loop array
NEW I
+70 ; populate standard patient data array VADM() Supported IA (#10061)
DO DEM^VADPT
+71 ; Patient Name
SET TAG("0010,0010")=$GET(VADM(1))
+72 ; Patient ID (HRN or SSN)
SET TAG("0010,0020")=$SELECT($$ISIHS^MAGSPID():$GET(VA("PID")),1:VADM(2))
+73 ; Patient's Birth Date
SET DOB=$GET(VADM(3))\1+17000000
+74 ; make sure month and year are DICOM valid
+75 SET TAG("0010,0030")=$SELECT($EXTRACT(DOB,5,6)="00":"",$EXTRACT(DOB,7,8)="00":"",1:DOB)
+76 ; Patient's Birth Time [probably always blank]
+77 SET TAG("0010,0032")=$SELECT(VADM(3)[".":$TRANSLATE($JUSTIFY("."_$PIECE($GET(VADM(3)),".",2)*1E6,6)," ",0),1:"")
+78 ; Patient's Race
SET TAG("0010,2160")=$GET(VADM(8))
+79 ; Patient's Sex
SET TAG("0010,0040")=$PIECE($GET(VADM(5)),"^",1)
+80 ; Supported IA (#2701)
SET X=$SELECT($TEXT(GETICN^MPIF001)'="":$$GETICN^MPIF001(DFN),1:"-1^NO MPI")
+81 ; Other Patient ID
SET TAG("0010,1000")=$SELECT(X<0:$EXTRACT(TAG("0010,0010"),1)_$EXTRACT(TAG("0010,0020"),6,99),1:X)
+82 ; populate patient address array
DO ADD^VADPT
+83 FOR I=1,2,3,4,6
SET $PIECE(TAG("0010,1040"),"^",I)=$GET(VAPA(I))
+84 SET $PIECE(TAG("0010,1040"),"^",5)=$PIECE($GET(VAPA(5)),"^",2)
+85 QUIT
End DoDot:1
+86 ;
+87 ; P280 DAC - Fixing index mismatch for NEW data structure
+88 IF DBTYPE="OLD"
if P
SET TAG("0008,0018")=$$QRNEWUID^MAGDRPC9(IMAGE,DBTYPE)
+89 IF DBTYPE="NEW"
if P
SET TAG("0008,0018")=$$QRNEWUID^MAGDRPC9(SOPIX,DBTYPE)
+90 ;
+91 if DBTYPE="OLD"
Begin DoDot:1
+92 SET TAG("0020,000D")=$PIECE($GET(^MAG(2005,$SELECT(P:+P,1:IMAGE),"PACS")),"^",1)
+93 ; no series UID on retrieve per WFP 5/6/11
QUIT
+94 SET X=$PIECE($GET(^MAG(2005,IMAGE,"SERIESUID")),"^",1)
+95 if X'=""
SET TAG("0020,000E")=X
End DoDot:1
+96 if DBTYPE="NEW"
Begin DoDot:1
+97 SET TAG("0020,000D")=$PIECE(^MAGV(2005.62,STYIX,0),"^",1)
+98 ; no series UID for study-level query
QUIT
+99 SET TAG("0020,000E")=$PIECE(^MAGV(2005.62,SERIX,0),"^",1)
+100 QUIT
End DoDot:1
+101 ;
+102 ; The following references to ^RADPT are allowed according to IA # 1172
+103 SET ACN=""
+104 IF DBTYPE="OLD"
Begin DoDot:1
+105 SET X=$GET(^MAG(2005,IMAGE,2))
if $PIECE(X,"^",6)=74
Begin DoDot:2
+106 NEW P5,P7
+107 SET P5=$PIECE(X,"^",5)
SET P7=$PIECE(X,"^",7)
SET X=$GET(^RARPT(+P7,0))
+108 SET D0=$PIECE(X,"^",2)
SET D1=9999999.9999=$PIECE(X,"^",3)
SET ACN=$PIECE(X,"^",1)
+109 QUIT
End DoDot:2
+110 QUIT
End DoDot:1
+111 IF DBTYPE="NEW"
Begin DoDot:1
+112 SET PROCDTA=$GET(^MAGV(2005.61,PROCIX,0))
+113 if $PIECE(PROCDTA,"^",3)="RAD"
SET ACN=$PIECE(PROCDTA,"^",1)
+114 QUIT
End DoDot:1
+115 SET IT=0
+116 if ACN'=""
SET I=$$ACCFIND^RAAPI(ACN,.ACCARY)
+117 SET ACCIX=""
FOR
SET ACCIX=$ORDER(ACCARY(ACCIX))
if 'ACCIX
QUIT
Begin DoDot:1
+118 SET D0=$PIECE(ACCARY(ACCIX),"^",1)
SET D1=$PIECE(ACCARY(ACCIX),"^",2)
SET D2=$PIECE(ACCARY(ACCIX),"^",3)
+119 NEW M1,VAIN,VAINDT
+120 ; no study date on retrieve per WFP 5/6/11
+121 ;S IT=IT+1,TAG("0008,0020",IT)=9999999.9999-D1\1+17000000 ; Study Date
+122 ; Supported reference
SET VAINDT=9999999.9999-D1
DO INP^VADPT
+123 ; Referring Physician's Name
if $GET(VAIN(2))'=""
SET RFP(VAIN(2))=""
+124 ; Current Ward
if $GET(VAIN(4))'=""
SET RFP(VAIN(4))=""
+125 ; Performing (attending) Physician
if $GET(VAIN(11))'=""
SET ATP(VAIN(11))=""
+126 SET X=$GET(^RADPT(D0,"DT",D1,"P",D2,0))
+127 SET P=$PIECE(X,"^",2)
if P
Begin DoDot:2
+128 ; IA # 1174
SET M1=0
FOR
SET M1=$ORDER(^RAMIS(71,+P,"MDL",M1))
if 'M1
QUIT
Begin DoDot:3
+129 ; IA # 1174
SET V=$PIECE($GET(^RAMIS(71,+P,"MDL",M1,0)),"^",1)
if 'V
QUIT
+130 ; IA # 2933
SET V=$PIECE($GET(^RAMIS(73.1,+V,0)),"^",1)
if V'=""
SET MO(V)=""
+131 QUIT
End DoDot:3
+132 ; IA # 1174
SET V=$PIECE($GET(^RAMIS(71,+P,0)),"^",9)
if V
SET CPT(+V)=""
+133 QUIT
End DoDot:2
+134 SET P=$PIECE(X,"^",14)
if P
Begin DoDot:2
+135 SET V=$PIECE($GET(^VA(200,+P,0)),"^",1)
+136 if V'=""
SET REQP(V)=""
+137 QUIT
End DoDot:2
+138 SET P=$PIECE(X,"^",17)
if P
Begin DoDot:2
+139 ; IA # 1171
SET X=$GET(^RARPT(+P,0))
if X=""
QUIT
+140 SET V=$PIECE(X,"^",1)
if V'=""
SET ACN(V)=""
+141 QUIT
End DoDot:2
+142 SET P=$PIECE(X,"^",22)
if P
Begin DoDot:2
+143 ; IA # 10040
SET X=$GET(^SC(+P,0))
if X=""
QUIT
+144 SET V=$PIECE(X,"^",1)
if V'=""
SET RQL(V)=""
+145 QUIT
End DoDot:2
+146 SET P=0
SET D3=0
FOR
SET D3=$ORDER(^RADPT(D0,"P",D1,"DT",D2,"H",D3))
if 'D3
QUIT
Begin DoDot:2
+147 SET X=$GET(^RADPT(D0,"P",D1,"DT",D2,"H",D3,0))
if X=""
QUIT
+148 SET P=P+1
SET TAG("0010,2000 "_$JUSTIFY(P,5))=X
+149 QUIT
End DoDot:2
+150 QUIT
End DoDot:1
+151 SET V=""
FOR
SET V=$ORDER(ACN(V))
if V=""
QUIT
Begin DoDot:1
+152 ; Accession Number
SET IT=IT+1
SET TAG("0008,0050",IT)=V
+153 QUIT
End DoDot:1
+154 SET V=""
FOR
SET V=$ORDER(WRD(V))
if V=""
QUIT
Begin DoDot:1
+155 ; Current Patient Location
SET IT=IT+1
SET TAG("0038,0300",IT)=$PIECE(V,"^",2)
+156 QUIT
End DoDot:1
+157 SET V=""
FOR
SET V=$ORDER(RFP(V))
if V=""
QUIT
Begin DoDot:1
+158 ; Referring Physician's Name
SET IT=IT+1
SET TAG("0008,0090",IT)=$PIECE(V,"^",2)
+159 QUIT
End DoDot:1
+160 SET V=""
FOR
SET V=$ORDER(ATP(V))
if V=""
QUIT
Begin DoDot:1
+161 ; Performing (attending) Physician
SET IT=IT+1
SET TAG("0008,1050",IT)=$PIECE(V,"^",2)
+162 QUIT
End DoDot:1
+163 SET V=""
FOR
SET V=$ORDER(RQL(V))
if V=""
QUIT
Begin DoDot:1
+164 ; Requesting Service
SET IT=IT+1
SET TAG("0032,1033",IT)=V
+165 QUIT
End DoDot:1
+166 ; no modality code on retrieve per WFP 5/6/11
+167 ;S V="" F S V=$O(MO(V)) Q:V="" D
+168 ;. S IT=IT+1,TAG("0008,0060",IT)=V ; Modality
+169 ;. Q
+170 SET V=""
FOR
SET V=$ORDER(REQP(V))
if V=""
QUIT
Begin DoDot:1
+171 ; Requesting Physician
SET IT=IT+1
SET TAG("0032,1032",IT)=V
+172 QUIT
End DoDot:1
+173 SET V=""
FOR
SET V=$ORDER(CPT(V))
if V=""
QUIT
Begin DoDot:1
+174 ; IA # 1995, supported reference
SET X=$$CPT^ICPTCOD(V)
+175 if $PIECE(X,"^",2)=""
QUIT
+176 SET IT=IT+1
+177 ; CPT Code
SET TAG("0032,1064 0008,0100",IT)=$PIECE(X,"^",2)
+178 ; Code Meaning
SET TAG("0032,1064 0008,0104",IT)=$PIECE(X,"^",3)
+179 ; Requested Procedure Description
SET TAG("0032,1060",IT)=$PIECE(X,"^",3)
+180 ; Coding Scheme Designator
SET TAG("0032,1064 0008,0102",IT)="C4"
+181 QUIT
End DoDot:1
+182 ; Acquisition Site
+183 if DBTYPE="OLD"
Begin DoDot:1
+184 SET V=$PIECE($GET(^MAG(2005,IMAGE,100)),"^",3)
if V=""
Begin DoDot:2
+185 ; Find Acquisition site when not filled in in Image File
+186 NEW D0,LOC,N
+187 SET (N,D0,LOC)=0
FOR
SET D0=$ORDER(^MAG(2006.1,D0))
if 'D0
QUIT
Begin DoDot:3
+188 SET N=N+1
SET LOC=$PIECE($GET(^MAG(2006.1,D0,0)),"^",1)
+189 QUIT
End DoDot:3
+190 ; Too many to choose from...
if N>2
QUIT
+191 if LOC
SET V=LOC
+192 QUIT
End DoDot:2
+193 if V'=""
SET TAG("0032,1020")=V
+194 QUIT
End DoDot:1
+195 if DBTYPE="NEW"
Begin DoDot:1
+196 SET V=$PIECE($GET(^MAGV(2005.63,SERIX,2)),"^",4)
+197 if V'=""
SET TAG("0032,1020")=V
End DoDot:1
+198 ;
+199 SET N=1
SET T=""
FOR
SET T=$ORDER(TAG(T))
if T=""
QUIT
Begin DoDot:1
+200 SET V=""
+201 if $DATA(TAG(T))#2
SET V=TAG(T)
+202 SET I=""
FOR
SET I=$ORDER(TAG(T,I))
if I=""
QUIT
if V'=""
SET V=V_"\"
SET V=V_TAG(T,I)
+203 if V'=""
SET N=N+1
SET OUT(N)=T_"^"_V
+204 QUIT
End DoDot:1
+205 ;
+206 SET OUT(1)=(N-1)_" data fields returned."
+207 QUIT
+208 ;
CLEAN(OUT) ; RPC = MAG DICOM QUERY CLEANUP
+1 NEW D0,H,N,STAMP
+2 ; Background task MUST wait
LOCK +^MAGDQR(2006.5732,0):1E6
+3 SET D0=0
FOR
SET D0=$ORDER(^MAGDQR(2006.5732,D0))
if 'D0
QUIT
Begin DoDot:1
+4 SET X=$GET(^MAGDQR(2006.5732,D0,0))
SET STAMP=$PIECE(X,"^",3)
+5 if $$FMDIFF^XLFDT(DT,STAMP,1)<5
QUIT
+6 KILL ^MAGDQR(2006.5732,D0)
+7 KILL ^MAGDQR(2006.5732,"B",D0)
+8 QUIT
End DoDot:1
+9 SET (D0,N,H)=0
FOR
SET D0=$ORDER(^MAGDQR(2006.5732,D0))
if 'D0
QUIT
SET N=N+1
SET H=D0
+10 SET X="DICOM QUERY RETRIEVE RESULT^2006.5732^"_H_"^"_N
+11 SET ^MAGDQR(2006.5732,0)=X
+12 LOCK -^MAGDQR(2006.5732,0)
+13 QUIT
+14 ;
