MAGDQR01 ;WOIFO/EdM,MLH,DAC - Imaging RPCs for Query/Retrieve ; 15 Feb 2013 10:12 PM
;;3.0;IMAGING;**51,54,66,118**;Mar 19, 2002;Build 4525;May 01, 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
;
FIND(OUT,TAGS,RESULT,OFFSET,MAX,AENAME) ; RPC = MAG CFIND QUERY
N ERROR,I,L,MAGDUZ,N,P,REQ,T,V,X,ZTDESC,ZTDTH,ZTRTN,ZTSAVE,ZTSK
K ^TMP("MAG",$J,"ERR") ; common error array (foreground)
;
S RESULT=$G(RESULT),OFFSET=$G(OFFSET),AENAME=$G(AENAME)
S ERROR=0
;
; The MAGDUZ identifier is now the DUZ of the logged in user
S MAGDUZ=$G(DUZ)
;
I 'RESULT D Q
. ; TAGS(i) = tag | VR | flag | value
. S I="" F S I=$O(TAGS(I)) Q:I="" D
. . S X=TAGS(I),T=$P(X,"|",1) Q:T=""
. . S T=$TR(T,"abcdef","ABCDEF"),$P(TAGS(I),"|",1)=T
. . S V=$P(X,"|",4,$L(X)+2) S:V="*" V=""
. . S:$TR(V,"UNKOW","unkow")="<unknown>" V=""
. . S L=$L(V,"\") S:V="" L=0
. . S REQ(T)=L F P=1:1:L S REQ(T,P)=$P(V,"\",P)
. . Q
. S X=0,T="" F S T=$O(REQ(T)) Q:T="" D Q:X
. . S P="" F S P=$O(REQ(T,P)) Q:P="" S:REQ(T,P)'="" X=1
. . Q
. D:'X ERR("No permission to query whole database.")
. S T="" F S T=$O(REQ(T)) Q:T="" D:REQ(T)<-1 ERR("Missing required tag """_T_""".")
. I ERROR D ERRLOG Q
. ;
. ; Convert DICOM name to VA name
. ;
. S T="0010,0010"
. S P="" F S P=$O(REQ(T,P)) Q:P="" S REQ(T,P)=$$DCM2VA(REQ(T,P))
. ;
. ; Initialize Result Set
. ;
. L +^MAGDQR(2006.5732,0):1E9 ; Background process MUST wait
. S X=$G(^MAGDQR(2006.5732,0))
. S $P(X,"^",1,2)="DICOM QUERY RETRIEVE RESULT^2006.5732"
. S RESULT=$O(^MAGDQR(2006.5732," "),-1)+1
. S $P(X,"^",3)=RESULT
. S $P(X,"^",4)=$P(X,"^",4)+1
. S ^MAGDQR(2006.5732,0)=X
. S ^MAGDQR(2006.5732,RESULT,0)=RESULT_"^IP^"_$$NOW^XLFDT()
. S ^MAGDQR(2006.5732,"B",RESULT,RESULT)=""
. L -^MAGDQR(2006.5732,0)
. ;
. ; Queue up actual query
. ;
. S ZTRTN="QUERY^MAGDQR02"
. S ZTDESC="Perform DICOM Query, result-set="_RESULT
. S ZTDTH=$H
. S ZTSAVE("RESULT")=RESULT
. S ZTSAVE("MAGDUZ")=$G(MAGDUZ)
. S T="" F S T=$O(REQ(T)) Q:T="" D
. . S ZTSAVE("REQ("""_T_""")")=REQ(T)
. . S P="" F S P=$O(REQ(T,P)) Q:P="" S ZTSAVE("REQ("""_T_""","_P_")")=REQ(T,P)
. . Q
. D ^%ZTLOAD,HOME^%ZIS
. D:'$G(ZTSK) ERR("TaskMan did not Accept Request")
. S:$G(ZTSK) $P(^MAGDQR(2006.5732,RESULT,0),"^",4)=ZTSK
. I ERROR D ERRLOG Q
. D LOG^MAGDQRUL("TaskMan","","0,"_RESULT_",Query Started through TaskMan")
. Q
;
I OFFSET<0 D Q ; All done, clean up result-set
. D LOG^MAGDQRUL("CleanUp","","1,Result Set Cleaned Up")
. Q:'$D(^MAGDQR(2006.5732,RESULT))
. L +^MAGDQR(2006.5732,0):1E9 ; Background process MUST wait
. S X=$G(^MAGDQR(2006.5732,0))
. S $P(X,"^",1,2)="DICOM QUERY RETRIEVE RESULT^2006.5732"
. S:$P(X,"^",4)>0 $P(X,"^",4)=$P(X,"^",4)-1
. S ^MAGDQR(2006.5732,0)=X
. K ^MAGDQR(2006.5732,RESULT)
. K ^MAGDQR(2006.5732,"B",RESULT)
. L -^MAGDQR(2006.5732,0)
. Q
;
I 'OFFSET D Q:V'="OK" ; Is the query done?
. S X=$G(^MAGDQR(2006.5732,RESULT,0))
. S V=$P(X,"^",2) Q:V="OK"
. I V="X" D LOG^MAGDQRUL("NoResult","","-2,No result returned") S V="OK" Q
. S ZTSK=$P(X,"^",4) D STAT^%ZTLOAD
. I $G(ZTSK(2))'["Inactive" S OUT(1)="-1,TaskMan still active" Q
. I ZTSK(2)["Finished" S V="OK" Q
. D LOG^MAGDQRUL("TaskManAbort",ZTSK(2),"-13,TaskMan aborted: "_ZTSK(2))
. Q
;
S:'$G(MAX) MAX=100
S I=OFFSET,N=1 F S I=$O(^MAGDQR(2006.5732,RESULT,1,I)) Q:'I D Q:N>MAX
. S OFFSET=I
. S N=N+1,OUT(N)=$G(^MAGDQR(2006.5732,RESULT,1,I,0))
. Q
I N=1 D Q
. S N=0,I=" " F S I=$O(^MAGDQR(2006.5732,RESULT,1,I),-1) Q:'I D Q:'I
. . S X=$G(^MAGDQR(2006.5732,RESULT,1,I,0)) Q:X'["0000,0902^Result #"
. . S N=$P(X," # ",2),I=0
. . Q
. D LOG^MAGDQRUL("Done",N,"0,No more results.")
. Q
I N=2,OFFSET=1 D LOG^MAGDQRUL("Error",$P(OUT(2),"^",2),"")
S OUT(1)=(N-1)_","_OFFSET_",result(s)."
Q
;
DCM2VA(NAME) N I,P
; P66T70: Normalize PN VR from legacy comma to current carat before processing
D:NAME'=""
. S NAME=$TR(NAME,"abcdefghijklmnopqrstuvwxyz,","ABCDEFGHIJKLMNOPQRSTUVWXYZ^")
. ; Ignore prefixes and suffices
. F I=1:1:3 D
. . S P(I)=$P(NAME,"^",I)
. . F Q:$E(P(I),1)'=" " S P(I)=$E(P(I),2,$L(P(I)))
. . F Q:$E(P(I),$L(P(I)))'=" " S P(I)=$E(P(I),1,$L(P(I))-1)
. . Q
. S NAME=P(1)_","_P(2) S:P(3)'="" NAME=NAME_" "_P(3)
. S:$E(NAME,$L(NAME))="," NAME=NAME_"*"
. Q
Q NAME
;
VA2DCM(NAME) N I,P
; P66T70: Prepare name for return to caller with consistent comma delimiter
; Also strip leading, trailing, interior spaces
D:NAME'=""
. S P(1)=$P(NAME,",",1),P(2)=$P(NAME,",",2)
. F I=1,2 D
. . F Q:$E(P(I),1)'=" " S P(I)=$E(P(I),2,$L(P(I)))
. . F Q:$E(P(I),$L(P(I)))'=" " S P(I)=$E(P(I),1,$L(P(I))-1)
. . Q
. S:P(2)[" " P(3)=$P(P(2)," ",2,999),P(2)=$P(P(2)," ",1)
. F I=1:1:3 D:$D(P(I))
. . F Q:$E(P(I),1)'=" " S P(I)=$E(P(I),2,$L(P(I)))
. . F Q:P(I)'[" " S P(I)=$P(P(I)," ",1)_" "_$P(P(I)," ",2,999)
. . Q
. S NAME=P(1)_","_P(2) S:$D(P(3)) NAME=NAME_","_P(3)
. Q
Q NAME
;
ERR(X) S ^TMP("MAG",$J,"ERR",$O(^TMP("MAG",$J,"ERR"," "),-1)+1)=X
Q
;
ERRLOG N I,O,X
S O=1,I=""
F S I=$O(^TMP("MAG",$J,"ERR",I)) Q:I="" S X=$G(^(I)) D
. S O=O+1,OUT(O)=X
. Q
D LOG^MAGDQRUL("Error","",(-O)_",Errors encountered")
Q
;
ERRSAV N I,O,RESGBL,X
Q:'$G(RESULT) S RESGBL=$NA(^MAGDQR(2006.5732,RESULT))
S $P(@RESGBL@(0),"^",2,3)="OK^"_$$NOW^XLFDT()
K @RESGBL@(1)
S O=0,I=""
F S I=$O(^TMP("MAG",$J,"ERR",I)) Q:I="" S X=$G(^(I)) D
. S O=O+1,@RESGBL@(1,O,0)="0000,0902^"_X
. Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMAGDQR01 6508 printed Sep 23, 2025@19:37 Page 2
MAGDQR01 ;WOIFO/EdM,MLH,DAC - Imaging RPCs for Query/Retrieve ; 15 Feb 2013 10:12 PM
+1 ;;3.0;IMAGING;**51,54,66,118**;Mar 19, 2002;Build 4525;May 01, 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 ;
FIND(OUT,TAGS,RESULT,OFFSET,MAX,AENAME) ; RPC = MAG CFIND QUERY
+1 NEW ERROR,I,L,MAGDUZ,N,P,REQ,T,V,X,ZTDESC,ZTDTH,ZTRTN,ZTSAVE,ZTSK
+2 ; common error array (foreground)
KILL ^TMP("MAG",$JOB,"ERR")
+3 ;
+4 SET RESULT=$GET(RESULT)
SET OFFSET=$GET(OFFSET)
SET AENAME=$GET(AENAME)
+5 SET ERROR=0
+6 ;
+7 ; The MAGDUZ identifier is now the DUZ of the logged in user
+8 SET MAGDUZ=$GET(DUZ)
+9 ;
+10 IF 'RESULT
Begin DoDot:1
+11 ; TAGS(i) = tag | VR | flag | value
+12 SET I=""
FOR
SET I=$ORDER(TAGS(I))
if I=""
QUIT
Begin DoDot:2
+13 SET X=TAGS(I)
SET T=$PIECE(X,"|",1)
if T=""
QUIT
+14 SET T=$TRANSLATE(T,"abcdef","ABCDEF")
SET $PIECE(TAGS(I),"|",1)=T
+15 SET V=$PIECE(X,"|",4,$LENGTH(X)+2)
if V="*"
SET V=""
+16 if $TRANSLATE(V,"UNKOW","unkow")="<unknown>"
SET V=""
+17 SET L=$LENGTH(V,"\")
if V=""
SET L=0
+18 SET REQ(T)=L
FOR P=1:1:L
SET REQ(T,P)=$PIECE(V,"\",P)
+19 QUIT
End DoDot:2
+20 SET X=0
SET T=""
FOR
SET T=$ORDER(REQ(T))
if T=""
QUIT
Begin DoDot:2
+21 SET P=""
FOR
SET P=$ORDER(REQ(T,P))
if P=""
QUIT
if REQ(T,P)'=""
SET X=1
+22 QUIT
End DoDot:2
if X
QUIT
+23 if 'X
DO ERR("No permission to query whole database.")
+24 SET T=""
FOR
SET T=$ORDER(REQ(T))
if T=""
QUIT
if REQ(T)<-1
DO ERR("Missing required tag """_T_""".")
+25 IF ERROR
DO ERRLOG
QUIT
+26 ;
+27 ; Convert DICOM name to VA name
+28 ;
+29 SET T="0010,0010"
+30 SET P=""
FOR
SET P=$ORDER(REQ(T,P))
if P=""
QUIT
SET REQ(T,P)=$$DCM2VA(REQ(T,P))
+31 ;
+32 ; Initialize Result Set
+33 ;
+34 ; Background process MUST wait
LOCK +^MAGDQR(2006.5732,0):1E9
+35 SET X=$GET(^MAGDQR(2006.5732,0))
+36 SET $PIECE(X,"^",1,2)="DICOM QUERY RETRIEVE RESULT^2006.5732"
+37 SET RESULT=$ORDER(^MAGDQR(2006.5732," "),-1)+1
+38 SET $PIECE(X,"^",3)=RESULT
+39 SET $PIECE(X,"^",4)=$PIECE(X,"^",4)+1
+40 SET ^MAGDQR(2006.5732,0)=X
+41 SET ^MAGDQR(2006.5732,RESULT,0)=RESULT_"^IP^"_$$NOW^XLFDT()
+42 SET ^MAGDQR(2006.5732,"B",RESULT,RESULT)=""
+43 LOCK -^MAGDQR(2006.5732,0)
+44 ;
+45 ; Queue up actual query
+46 ;
+47 SET ZTRTN="QUERY^MAGDQR02"
+48 SET ZTDESC="Perform DICOM Query, result-set="_RESULT
+49 SET ZTDTH=$HOROLOG
+50 SET ZTSAVE("RESULT")=RESULT
+51 SET ZTSAVE("MAGDUZ")=$GET(MAGDUZ)
+52 SET T=""
FOR
SET T=$ORDER(REQ(T))
if T=""
QUIT
Begin DoDot:2
+53 SET ZTSAVE("REQ("""_T_""")")=REQ(T)
+54 SET P=""
FOR
SET P=$ORDER(REQ(T,P))
if P=""
QUIT
SET ZTSAVE("REQ("""_T_""","_P_")")=REQ(T,P)
+55 QUIT
End DoDot:2
+56 DO ^%ZTLOAD
DO HOME^%ZIS
+57 if '$GET(ZTSK)
DO ERR("TaskMan did not Accept Request")
+58 if $GET(ZTSK)
SET $PIECE(^MAGDQR(2006.5732,RESULT,0),"^",4)=ZTSK
+59 IF ERROR
DO ERRLOG
QUIT
+60 DO LOG^MAGDQRUL("TaskMan","","0,"_RESULT_",Query Started through TaskMan")
+61 QUIT
End DoDot:1
QUIT
+62 ;
+63 ; All done, clean up result-set
IF OFFSET<0
Begin DoDot:1
+64 DO LOG^MAGDQRUL("CleanUp","","1,Result Set Cleaned Up")
+65 if '$DATA(^MAGDQR(2006.5732,RESULT))
QUIT
+66 ; Background process MUST wait
LOCK +^MAGDQR(2006.5732,0):1E9
+67 SET X=$GET(^MAGDQR(2006.5732,0))
+68 SET $PIECE(X,"^",1,2)="DICOM QUERY RETRIEVE RESULT^2006.5732"
+69 if $PIECE(X,"^",4)>0
SET $PIECE(X,"^",4)=$PIECE(X,"^",4)-1
+70 SET ^MAGDQR(2006.5732,0)=X
+71 KILL ^MAGDQR(2006.5732,RESULT)
+72 KILL ^MAGDQR(2006.5732,"B",RESULT)
+73 LOCK -^MAGDQR(2006.5732,0)
+74 QUIT
End DoDot:1
QUIT
+75 ;
+76 ; Is the query done?
IF 'OFFSET
Begin DoDot:1
+77 SET X=$GET(^MAGDQR(2006.5732,RESULT,0))
+78 SET V=$PIECE(X,"^",2)
if V="OK"
QUIT
+79 IF V="X"
DO LOG^MAGDQRUL("NoResult","","-2,No result returned")
SET V="OK"
QUIT
+80 SET ZTSK=$PIECE(X,"^",4)
DO STAT^%ZTLOAD
+81 IF $GET(ZTSK(2))'["Inactive"
SET OUT(1)="-1,TaskMan still active"
QUIT
+82 IF ZTSK(2)["Finished"
SET V="OK"
QUIT
+83 DO LOG^MAGDQRUL("TaskManAbort",ZTSK(2),"-13,TaskMan aborted: "_ZTSK(2))
+84 QUIT
End DoDot:1
if V'="OK"
QUIT
+85 ;
+86 if '$GET(MAX)
SET MAX=100
+87 SET I=OFFSET
SET N=1
FOR
SET I=$ORDER(^MAGDQR(2006.5732,RESULT,1,I))
if 'I
QUIT
Begin DoDot:1
+88 SET OFFSET=I
+89 SET N=N+1
SET OUT(N)=$GET(^MAGDQR(2006.5732,RESULT,1,I,0))
+90 QUIT
End DoDot:1
if N>MAX
QUIT
+91 IF N=1
Begin DoDot:1
+92 SET N=0
SET I=" "
FOR
SET I=$ORDER(^MAGDQR(2006.5732,RESULT,1,I),-1)
if 'I
QUIT
Begin DoDot:2
+93 SET X=$GET(^MAGDQR(2006.5732,RESULT,1,I,0))
if X'["0000,0902^Result #"
QUIT
+94 SET N=$PIECE(X," # ",2)
SET I=0
+95 QUIT
End DoDot:2
if 'I
QUIT
+96 DO LOG^MAGDQRUL("Done",N,"0,No more results.")
+97 QUIT
End DoDot:1
QUIT
+98 IF N=2
IF OFFSET=1
DO LOG^MAGDQRUL("Error",$PIECE(OUT(2),"^",2),"")
+99 SET OUT(1)=(N-1)_","_OFFSET_",result(s)."
+100 QUIT
+101 ;
DCM2VA(NAME) NEW I,P
+1 ; P66T70: Normalize PN VR from legacy comma to current carat before processing
+2 if NAME'=""
Begin DoDot:1
+3 SET NAME=$TRANSLATE(NAME,"abcdefghijklmnopqrstuvwxyz,","ABCDEFGHIJKLMNOPQRSTUVWXYZ^")
+4 ; Ignore prefixes and suffices
+5 FOR I=1:1:3
Begin DoDot:2
+6 SET P(I)=$PIECE(NAME,"^",I)
+7 FOR
if $EXTRACT(P(I),1)'=" "
QUIT
SET P(I)=$EXTRACT(P(I),2,$LENGTH(P(I)))
+8 FOR
if $EXTRACT(P(I),$LENGTH(P(I)))'=" "
QUIT
SET P(I)=$EXTRACT(P(I),1,$LENGTH(P(I))-1)
+9 QUIT
End DoDot:2
+10 SET NAME=P(1)_","_P(2)
if P(3)'=""
SET NAME=NAME_" "_P(3)
+11 if $EXTRACT(NAME,$LENGTH(NAME))=","
SET NAME=NAME_"*"
+12 QUIT
End DoDot:1
+13 QUIT NAME
+14 ;
VA2DCM(NAME) NEW I,P
+1 ; P66T70: Prepare name for return to caller with consistent comma delimiter
+2 ; Also strip leading, trailing, interior spaces
+3 if NAME'=""
Begin DoDot:1
+4 SET P(1)=$PIECE(NAME,",",1)
SET P(2)=$PIECE(NAME,",",2)
+5 FOR I=1,2
Begin DoDot:2
+6 FOR
if $EXTRACT(P(I),1)'=" "
QUIT
SET P(I)=$EXTRACT(P(I),2,$LENGTH(P(I)))
+7 FOR
if $EXTRACT(P(I),$LENGTH(P(I)))'=" "
QUIT
SET P(I)=$EXTRACT(P(I),1,$LENGTH(P(I))-1)
+8 QUIT
End DoDot:2
+9 if P(2)[" "
SET P(3)=$PIECE(P(2)," ",2,999)
SET P(2)=$PIECE(P(2)," ",1)
+10 FOR I=1:1:3
if $DATA(P(I))
Begin DoDot:2
+11 FOR
if $EXTRACT(P(I),1)'=" "
QUIT
SET P(I)=$EXTRACT(P(I),2,$LENGTH(P(I)))
+12 FOR
if P(I)'[" "
QUIT
SET P(I)=$PIECE(P(I)," ",1)_" "_$PIECE(P(I)," ",2,999)
+13 QUIT
End DoDot:2
+14 SET NAME=P(1)_","_P(2)
if $DATA(P(3))
SET NAME=NAME_","_P(3)
+15 QUIT
End DoDot:1
+16 QUIT NAME
+17 ;
ERR(X) SET ^TMP("MAG",$JOB,"ERR",$ORDER(^TMP("MAG",$JOB,"ERR"," "),-1)+1)=X
+1 QUIT
+2 ;
ERRLOG NEW I,O,X
+1 SET O=1
SET I=""
+2 FOR
SET I=$ORDER(^TMP("MAG",$JOB,"ERR",I))
if I=""
QUIT
SET X=$GET(^(I))
Begin DoDot:1
+3 SET O=O+1
SET OUT(O)=X
+4 QUIT
End DoDot:1
+5 DO LOG^MAGDQRUL("Error","",(-O)_",Errors encountered")
+6 QUIT
+7 ;
ERRSAV NEW I,O,RESGBL,X
+1 if '$GET(RESULT)
QUIT
SET RESGBL=$NAME(^MAGDQR(2006.5732,RESULT))
+2 SET $PIECE(@RESGBL@(0),"^",2,3)="OK^"_$$NOW^XLFDT()
+3 KILL @RESGBL@(1)
+4 SET O=0
SET I=""
+5 FOR
SET I=$ORDER(^TMP("MAG",$JOB,"ERR",I))
if I=""
QUIT
SET X=$GET(^(I))
Begin DoDot:1
+6 SET O=O+1
SET @RESGBL@(1,O,0)="0000,0902^"_X
+7 QUIT
End DoDot:1
+8 QUIT
