MAGDSTQ8 ;WOIFO/PMK - Study Tracker - Patient Level Query/Retrieve Display; Apr 07, 2022@11:34:20
;;3.0;IMAGING;**231,333**;Mar 19, 2002;Build 2
;; Per VA Directive 6402, this routine should not be modified.
;; +---------------------------------------------------------------+
;; | Property of the US Government. |
;; | No permission to copy or redistribute this software is given. |
;; | |
;; | 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. |
;; +---------------------------------------------------------------+
;;
;
; Notice: This routine is on both VistA and the DICOM Gateway
;
; Supported IA #10103 reference $$HTE^XLFDT function call
;
; Display Retrieve Status
;
Q
;
RETRIEVE ;
N A,ACNUMB,BADTAGS,BADUIDS,COMMENT,COMPLETED,DONE,ERRORID,FAILED,I,K,MEANING,NORESULTS
N REDISPLAY,REMAINING,STATUS,STATUSCODE,TIMEOUT,TIMESTAMP,X,WARNING
;
S TIMEOUT=1
;
S ACNUMB=$G(^TMP("MAG",$J,"Q/R QUERY",QRSTACK,"ACCESSION NUMBER"))
I ACNUMB="",^TMP("MAG",$J,"Q/R QUERY",QRSTACK,"RETRIEVE LEVEL")="PATIENT" D
. S ACNUMB=^TMP("MAG",$J,"Q/R QUERY",QRSTACK,"PATIENT ID")
. Q
;
K ^XTMP(MAGXTMP,HOSTNAME,$J,QRSTACK,"Q/R RETRIEVE STATUS",ACNUMB)
;
D DISPLAY(.REDISPLAY)
;
S (DONE,NORESULTS)=0
F D Q:DONE
. I REDISPLAY D DISPLAY(.REDIPLAY)
. F Q:$X=0 W @IOBS," ",@IOBS ; erase the line
. S X=$G(^XTMP(MAGXTMP,HOSTNAME,$J,QRSTACK,"Q/R RETRIEVE STATUS",ACNUMB))
. I X="" D
. . W "No retrieve results yet"
. . S NORESULTS=NORESULTS+1
. . F I=1:1:NORESULTS W "."
. . I NORESULTS>45 S DONE=-1
. . Q
. E D
. . S STATUSCODE=$$PARSE(X)
. . I STATUSCODE="" W STATE Q ; informational message
. . ;
. . S STATUS=$$STATUS(STATUSCODE,.MEANING)
. . I STATUS="Success" D
. . . I COMPLETED=0 W "No DICOM objects were retrieved"
. . . E I COMPLETED=1 W "One DICOM object retrieved from """,QRSCP,""""
. . . E W "A total of ",COMPLETED," DICOM objects retrieved from """,QRSCP,""""
. . . S DONE=1
. . . Q
. . E D
. . . D STATUSTEXT(.A)
. . . F K=1:1:A(0) W:K>1 ! W A(K)
. . . W:K>1 ! ; so that the last line isn't erased
. . . Q
. . Q
. Q:DONE
. W ?68,"More?"
. R " y// ",X:TIMEOUT
. I X="" S X="y" W X
. I "Yy"'[$E(X) S DONE=1
. Q
I DONE<1 W !,"*** Possible problem with DICOM Gateway C-Move Request process ***"
D CONTINUE^MAGDSTQ
Q
;
DISPLAY(REDISPLAY) ; refresh the top of the screen
D DISPLAY^MAGDSTQ
W !!!
S REDISPLAY=0
Q
;
PARSE(X) ; $piece apart the result string and store into variables
S STATE=$P(X,"|",1)
S TIMESTAMP=$P(X,"|",2)
S STATUSCODE=$P(X,"|",3)
I STATUSCODE="" D
. ; nothing more, just an informational message
. Q
E D ; c-move result data
. S REMAINING=+$P(X,"|",4) ; coerce null to 0
. S COMPLETED=+$P(X,"|",5) ; coerce null to 0
. S FAILED=$P(X,"|",6)
. S WARNING=$P(X,"|",7)
. S BADTAGS=$P(X,"|",8)
. S BADUIDS=$P(X,"|",9)
. S ERRORID=$P(X,"|",10)
. S COMMENT=$P(X,"|",11,999) ; may contain "|"
. Q
Q STATUSCODE
;
STATUS(CODE,MEANING) ; return status codes
; from Table C.4-2 C-MOVE Response Status Values PS3.4 2108b
I CODE="FF00" D Q "Pending"
. S MEANING="Sub-operations are continuing"
. Q
I CODE="FF01" D Q "Pending"
. S MEANING="Sub-operations are continuing but one or more Optional Keys were not supported"
. Q
I (CODE="0000")!(CODE=0) D Q "Success"
. S MEANING="Sub-operations Complete - No Failures"
. Q
I CODE="A700" D Q "Failure"
. S MEANING="Refused: Out of Resources"
. Q
I CODE="A701" D Q "Failure"
. S MEANING="Refused: Out of Resources - Unable to calculate number of matches"
. Q
I CODE="A702" D Q "Failure"
. S MEANING="Refused: Out of Resources - Unable to perform sub-operations"
. Q
I CODE="A801" D Q "Failure"
. S MEANING="Refused: Move Destination unknown"
. Q
I CODE="A900" D Q "Failure"
. S MEANING="Error: Data Set does not match SOP Class"
. Q
I CODE?1"C"3E D Q "Failure"
. S MEANING="Failed: Unable to Process"
. Q
I CODE="FE00" D Q "Cancel"
. S MEANING="Sub-operations terminated due to Cancel Indication"
. Q
I CODE="B000" D Q "Warning"
. S MEANING="Sub-operations Complete - One or more Failures"
. Q
S MEANING="Unknown Status Code: """_CODE_""""
Q "???"
;
STATUSTEXT(A) ; formulate status text
K A,X
I STATUS="Pending" D
. I COMPLETED=0 S X="No DICOM object retrieved yet"
. E I COMPLETED=1 S X="One DICOM object retrieved"
. E S X=COMPLETED_" DICOM objects retrieved"
. S X=X_" -- "
. I REMAINING=1 S X=X_"one DICOM object remaining"
. E S X=X_REMAINING_" DICOM objects remaining"
. D TEXT(X)
. Q
E I STATUS="Cancel" D
. D TEXT("Retrieve operation canceled -- "_MEANING)
. S DONE=1
. Q
E I STATUS="Failure" D
. D TEXT("Retrieve operation failed -- "_MEANING)
. S DONE=1
. Q
I FAILED D
. D TEXT("Number of failed operations: "_FAILED)
. S REDISPLAY=1
. Q
I WARNING D
. D TEXT("Number of operations with warnings: "_WARNING)
. S REDISPLAY=1
. Q
I ERRORID'="" D
. D TEXT("Error ID: "_ERRORID)
. S REDISPLAY=1
. Q
I COMMENT'="" D
. D TEXT("Error Comment: "_COMMENT)
. S REDISPLAY=1
. Q
I BADTAGS'="" D
. D TEXT("Offending DICOM Elements: "_BADTAGS)
. S REDISPLAY=1
. Q
I BADUIDS'="" D
. D TEXT("Failed SOP Instance UIDs: "_BADUIDS)
. S REDISPLAY=1
. Q
I STATUS="???" D
. D TEXT(MEANING)
. Q
Q
;
TEXT(TEXT) ; save the text in the "A" array
S A(0)=$G(A(0),0)+1
S A(A(0))=TEXT
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMAGDSTQ8 5888 printed Mar 25, 2026@15:26:39 Page 2
MAGDSTQ8 ;WOIFO/PMK - Study Tracker - Patient Level Query/Retrieve Display; Apr 07, 2022@11:34:20
+1 ;;3.0;IMAGING;**231,333**;Mar 19, 2002;Build 2
+2 ;; Per VA Directive 6402, 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 ;; | |
+7 ;; | The Food and Drug Administration classifies this software as |
+8 ;; | a medical device. As such, it may not be changed in any way. |
+9 ;; | Modifications to this software may result in an adulterated |
+10 ;; | medical device under 21CFR820, the use of which is considered |
+11 ;; | to be a violation of US Federal Statutes. |
+12 ;; +---------------------------------------------------------------+
+13 ;;
+14 ;
+15 ; Notice: This routine is on both VistA and the DICOM Gateway
+16 ;
+17 ; Supported IA #10103 reference $$HTE^XLFDT function call
+18 ;
+19 ; Display Retrieve Status
+20 ;
+21 QUIT
+22 ;
RETRIEVE ;
+1 NEW A,ACNUMB,BADTAGS,BADUIDS,COMMENT,COMPLETED,DONE,ERRORID,FAILED,I,K,MEANING,NORESULTS
+2 NEW REDISPLAY,REMAINING,STATUS,STATUSCODE,TIMEOUT,TIMESTAMP,X,WARNING
+3 ;
+4 SET TIMEOUT=1
+5 ;
+6 SET ACNUMB=$GET(^TMP("MAG",$JOB,"Q/R QUERY",QRSTACK,"ACCESSION NUMBER"))
+7 IF ACNUMB=""
IF ^TMP("MAG",$JOB,"Q/R QUERY",QRSTACK,"RETRIEVE LEVEL")="PATIENT"
Begin DoDot:1
+8 SET ACNUMB=^TMP("MAG",$JOB,"Q/R QUERY",QRSTACK,"PATIENT ID")
+9 QUIT
End DoDot:1
+10 ;
+11 KILL ^XTMP(MAGXTMP,HOSTNAME,$JOB,QRSTACK,"Q/R RETRIEVE STATUS",ACNUMB)
+12 ;
+13 DO DISPLAY(.REDISPLAY)
+14 ;
+15 SET (DONE,NORESULTS)=0
+16 FOR
Begin DoDot:1
+17 IF REDISPLAY
DO DISPLAY(.REDIPLAY)
+18 ; erase the line
FOR
if $X=0
QUIT
WRITE @IOBS," ",@IOBS
+19 SET X=$GET(^XTMP(MAGXTMP,HOSTNAME,$JOB,QRSTACK,"Q/R RETRIEVE STATUS",ACNUMB))
+20 IF X=""
Begin DoDot:2
+21 WRITE "No retrieve results yet"
+22 SET NORESULTS=NORESULTS+1
+23 FOR I=1:1:NORESULTS
WRITE "."
+24 IF NORESULTS>45
SET DONE=-1
+25 QUIT
End DoDot:2
+26 IF '$TEST
Begin DoDot:2
+27 SET STATUSCODE=$$PARSE(X)
+28 ; informational message
IF STATUSCODE=""
WRITE STATE
QUIT
+29 ;
+30 SET STATUS=$$STATUS(STATUSCODE,.MEANING)
+31 IF STATUS="Success"
Begin DoDot:3
+32 IF COMPLETED=0
WRITE "No DICOM objects were retrieved"
+33 IF '$TEST
IF COMPLETED=1
WRITE "One DICOM object retrieved from """,QRSCP,""""
+34 IF '$TEST
WRITE "A total of ",COMPLETED," DICOM objects retrieved from """,QRSCP,""""
+35 SET DONE=1
+36 QUIT
End DoDot:3
+37 IF '$TEST
Begin DoDot:3
+38 DO STATUSTEXT(.A)
+39 FOR K=1:1:A(0)
if K>1
WRITE !
WRITE A(K)
+40 ; so that the last line isn't erased
if K>1
WRITE !
+41 QUIT
End DoDot:3
+42 QUIT
End DoDot:2
+43 if DONE
QUIT
+44 WRITE ?68,"More?"
+45 READ " y// ",X:TIMEOUT
+46 IF X=""
SET X="y"
WRITE X
+47 IF "Yy"'[$EXTRACT(X)
SET DONE=1
+48 QUIT
End DoDot:1
if DONE
QUIT
+49 IF DONE<1
WRITE !,"*** Possible problem with DICOM Gateway C-Move Request process ***"
+50 DO CONTINUE^MAGDSTQ
+51 QUIT
+52 ;
DISPLAY(REDISPLAY) ; refresh the top of the screen
+1 DO DISPLAY^MAGDSTQ
+2 WRITE !!!
+3 SET REDISPLAY=0
+4 QUIT
+5 ;
PARSE(X) ; $piece apart the result string and store into variables
+1 SET STATE=$PIECE(X,"|",1)
+2 SET TIMESTAMP=$PIECE(X,"|",2)
+3 SET STATUSCODE=$PIECE(X,"|",3)
+4 IF STATUSCODE=""
Begin DoDot:1
+5 ; nothing more, just an informational message
+6 QUIT
End DoDot:1
+7 ; c-move result data
IF '$TEST
Begin DoDot:1
+8 ; coerce null to 0
SET REMAINING=+$PIECE(X,"|",4)
+9 ; coerce null to 0
SET COMPLETED=+$PIECE(X,"|",5)
+10 SET FAILED=$PIECE(X,"|",6)
+11 SET WARNING=$PIECE(X,"|",7)
+12 SET BADTAGS=$PIECE(X,"|",8)
+13 SET BADUIDS=$PIECE(X,"|",9)
+14 SET ERRORID=$PIECE(X,"|",10)
+15 ; may contain "|"
SET COMMENT=$PIECE(X,"|",11,999)
+16 QUIT
End DoDot:1
+17 QUIT STATUSCODE
+18 ;
STATUS(CODE,MEANING) ; return status codes
+1 ; from Table C.4-2 C-MOVE Response Status Values PS3.4 2108b
+2 IF CODE="FF00"
Begin DoDot:1
+3 SET MEANING="Sub-operations are continuing"
+4 QUIT
End DoDot:1
QUIT "Pending"
+5 IF CODE="FF01"
Begin DoDot:1
+6 SET MEANING="Sub-operations are continuing but one or more Optional Keys were not supported"
+7 QUIT
End DoDot:1
QUIT "Pending"
+8 IF (CODE="0000")!(CODE=0)
Begin DoDot:1
+9 SET MEANING="Sub-operations Complete - No Failures"
+10 QUIT
End DoDot:1
QUIT "Success"
+11 IF CODE="A700"
Begin DoDot:1
+12 SET MEANING="Refused: Out of Resources"
+13 QUIT
End DoDot:1
QUIT "Failure"
+14 IF CODE="A701"
Begin DoDot:1
+15 SET MEANING="Refused: Out of Resources - Unable to calculate number of matches"
+16 QUIT
End DoDot:1
QUIT "Failure"
+17 IF CODE="A702"
Begin DoDot:1
+18 SET MEANING="Refused: Out of Resources - Unable to perform sub-operations"
+19 QUIT
End DoDot:1
QUIT "Failure"
+20 IF CODE="A801"
Begin DoDot:1
+21 SET MEANING="Refused: Move Destination unknown"
+22 QUIT
End DoDot:1
QUIT "Failure"
+23 IF CODE="A900"
Begin DoDot:1
+24 SET MEANING="Error: Data Set does not match SOP Class"
+25 QUIT
End DoDot:1
QUIT "Failure"
+26 IF CODE?1"C"3E
Begin DoDot:1
+27 SET MEANING="Failed: Unable to Process"
+28 QUIT
End DoDot:1
QUIT "Failure"
+29 IF CODE="FE00"
Begin DoDot:1
+30 SET MEANING="Sub-operations terminated due to Cancel Indication"
+31 QUIT
End DoDot:1
QUIT "Cancel"
+32 IF CODE="B000"
Begin DoDot:1
+33 SET MEANING="Sub-operations Complete - One or more Failures"
+34 QUIT
End DoDot:1
QUIT "Warning"
+35 SET MEANING="Unknown Status Code: """_CODE_""""
+36 QUIT "???"
+37 ;
STATUSTEXT(A) ; formulate status text
+1 KILL A,X
+2 IF STATUS="Pending"
Begin DoDot:1
+3 IF COMPLETED=0
SET X="No DICOM object retrieved yet"
+4 IF '$TEST
IF COMPLETED=1
SET X="One DICOM object retrieved"
+5 IF '$TEST
SET X=COMPLETED_" DICOM objects retrieved"
+6 SET X=X_" -- "
+7 IF REMAINING=1
SET X=X_"one DICOM object remaining"
+8 IF '$TEST
SET X=X_REMAINING_" DICOM objects remaining"
+9 DO TEXT(X)
+10 QUIT
End DoDot:1
+11 IF '$TEST
IF STATUS="Cancel"
Begin DoDot:1
+12 DO TEXT("Retrieve operation canceled -- "_MEANING)
+13 SET DONE=1
+14 QUIT
End DoDot:1
+15 IF '$TEST
IF STATUS="Failure"
Begin DoDot:1
+16 DO TEXT("Retrieve operation failed -- "_MEANING)
+17 SET DONE=1
+18 QUIT
End DoDot:1
+19 IF FAILED
Begin DoDot:1
+20 DO TEXT("Number of failed operations: "_FAILED)
+21 SET REDISPLAY=1
+22 QUIT
End DoDot:1
+23 IF WARNING
Begin DoDot:1
+24 DO TEXT("Number of operations with warnings: "_WARNING)
+25 SET REDISPLAY=1
+26 QUIT
End DoDot:1
+27 IF ERRORID'=""
Begin DoDot:1
+28 DO TEXT("Error ID: "_ERRORID)
+29 SET REDISPLAY=1
+30 QUIT
End DoDot:1
+31 IF COMMENT'=""
Begin DoDot:1
+32 DO TEXT("Error Comment: "_COMMENT)
+33 SET REDISPLAY=1
+34 QUIT
End DoDot:1
+35 IF BADTAGS'=""
Begin DoDot:1
+36 DO TEXT("Offending DICOM Elements: "_BADTAGS)
+37 SET REDISPLAY=1
+38 QUIT
End DoDot:1
+39 IF BADUIDS'=""
Begin DoDot:1
+40 DO TEXT("Failed SOP Instance UIDs: "_BADUIDS)
+41 SET REDISPLAY=1
+42 QUIT
End DoDot:1
+43 IF STATUS="???"
Begin DoDot:1
+44 DO TEXT(MEANING)
+45 QUIT
End DoDot:1
+46 QUIT
+47 ;
TEXT(TEXT) ; save the text in the "A" array
+1 SET A(0)=$GET(A(0),0)+1
+2 SET A(A(0))=TEXT
+3 QUIT
