MAGDSTQ9 ;WOIFO/PMK - Study Tracker - Query/Retrieve user ; Jan 14, 2026@09:59:16
;;3.0;IMAGING;**231,305,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. |
;; +---------------------------------------------------------------+
;;
;
; Supported IA #2056 reference $$GET1^DIQ function call
; Supported IA #10090 to read LOCATION file (#4)
;
;
; Select the DICOM Service Class Provider
;
; Modeled after PICKSCP^MAGDACU on the DICOM Gateway
;
PICKSCP(DEFAULT,SCPTYPE) ; Pick the SCP for the site
N DIVISION,FOUND,HIT,I,LOCATION,MAGIEN,MAGSCPTYPE,N,NEXT,NEXTDATETIME
N USERAPP,TARGET,TIMESTAMP,X
S DIVISION=$$DIVISION^MAGDFCNV ; P333 PMK 01/13/2026
I DIVISION<0 D Q ""
. W !!,"*** ",$P(DIVISION,",",2,999)," ***"
. D CONTINUE^MAGDSTQ
. Q
S DEFAULT=$G(DEFAULT),SCPTYPE=$G(SCPTYPE)
S USERAPP="",(HIT,I)=0
F S USERAPP=$O(^MAG(2006.587,"B",USERAPP)) Q:USERAPP="" D
. S (FOUND,MAGIEN,TIMESTAMP)=""
. F S MAGIEN=$O(^MAG(2006.587,"B",USERAPP,MAGIEN)) Q:MAGIEN="" D
. . S NEXT=^MAG(2006.587,MAGIEN,0)
. . S LOCATION=$P(NEXT,"^",7)
. . I LOCATION'=DIVISION Q ; ignore entries for other locations - P333 PMK 01/13/2026
. . S MAGSCPTYPE=$P(NEXT,"^",9)
. . I SCPTYPE'="",SCPTYPE'=MAGSCPTYPE Q ; skip entries for other types
. . S NEXTDATETIME=$P(NEXT,"^",8)
. . I NEXTDATETIME>TIMESTAMP D ; get latest version
. . . S FOUND=NEXT,TIMESTAMP=NEXTDATETIME
. . . Q
. . Q
. I FOUND'="" D
. . S I=I+1,TARGET(I)=FOUND
. . I USERAPP=DEFAULT S HIT=I
. . Q
. Q
S N=I
I N<1 W !!,"No Service Class Providers defined in SCU_LIST.DIC." Q ""
F D Q:X'=""
. W !,"DICOM ",$S(SCPTYPE'="":SCPTYPE_" ",1:""),"Service Class Providers"
. S X=$X W ! F I=1:1:X W "-"
. F I=1:1:N W !,$J(I,3)," -- ",$P(TARGET(I),"^")
. I N=1 W " (selected)" S X=1 Q
. W !!,"Select the provider application (1-",N,"): "
. W:HIT HIT,"// " R X:DTIME E S X="^"
. I X["^" Q ; a caret will terminate the program
. I X="" S X=HIT W X I X="" S X="^" Q
. I (X<1)!(X>N)!'$D(TARGET(X)) W " ??? -- try again",!! S X="" Q
. Q
I X["^" S X=""
I X S X=$P(TARGET(X),"^",1)
Q X
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMAGDSTQ9 2804 printed Mar 25, 2026@15:26:40 Page 2
MAGDSTQ9 ;WOIFO/PMK - Study Tracker - Query/Retrieve user ; Jan 14, 2026@09:59:16
+1 ;;3.0;IMAGING;**231,305,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 ; Supported IA #2056 reference $$GET1^DIQ function call
+16 ; Supported IA #10090 to read LOCATION file (#4)
+17 ;
+18 ;
+19 ; Select the DICOM Service Class Provider
+20 ;
+21 ; Modeled after PICKSCP^MAGDACU on the DICOM Gateway
+22 ;
PICKSCP(DEFAULT,SCPTYPE) ; Pick the SCP for the site
+1 NEW DIVISION,FOUND,HIT,I,LOCATION,MAGIEN,MAGSCPTYPE,N,NEXT,NEXTDATETIME
+2 NEW USERAPP,TARGET,TIMESTAMP,X
+3 ; P333 PMK 01/13/2026
SET DIVISION=$$DIVISION^MAGDFCNV
+4 IF DIVISION<0
Begin DoDot:1
+5 WRITE !!,"*** ",$PIECE(DIVISION,",",2,999)," ***"
+6 DO CONTINUE^MAGDSTQ
+7 QUIT
End DoDot:1
QUIT ""
+8 SET DEFAULT=$GET(DEFAULT)
SET SCPTYPE=$GET(SCPTYPE)
+9 SET USERAPP=""
SET (HIT,I)=0
+10 FOR
SET USERAPP=$ORDER(^MAG(2006.587,"B",USERAPP))
if USERAPP=""
QUIT
Begin DoDot:1
+11 SET (FOUND,MAGIEN,TIMESTAMP)=""
+12 FOR
SET MAGIEN=$ORDER(^MAG(2006.587,"B",USERAPP,MAGIEN))
if MAGIEN=""
QUIT
Begin DoDot:2
+13 SET NEXT=^MAG(2006.587,MAGIEN,0)
+14 SET LOCATION=$PIECE(NEXT,"^",7)
+15 ; ignore entries for other locations - P333 PMK 01/13/2026
IF LOCATION'=DIVISION
QUIT
+16 SET MAGSCPTYPE=$PIECE(NEXT,"^",9)
+17 ; skip entries for other types
IF SCPTYPE'=""
IF SCPTYPE'=MAGSCPTYPE
QUIT
+18 SET NEXTDATETIME=$PIECE(NEXT,"^",8)
+19 ; get latest version
IF NEXTDATETIME>TIMESTAMP
Begin DoDot:3
+20 SET FOUND=NEXT
SET TIMESTAMP=NEXTDATETIME
+21 QUIT
End DoDot:3
+22 QUIT
End DoDot:2
+23 IF FOUND'=""
Begin DoDot:2
+24 SET I=I+1
SET TARGET(I)=FOUND
+25 IF USERAPP=DEFAULT
SET HIT=I
+26 QUIT
End DoDot:2
+27 QUIT
End DoDot:1
+28 SET N=I
+29 IF N<1
WRITE !!,"No Service Class Providers defined in SCU_LIST.DIC."
QUIT ""
+30 FOR
Begin DoDot:1
+31 WRITE !,"DICOM ",$SELECT(SCPTYPE'="":SCPTYPE_" ",1:""),"Service Class Providers"
+32 SET X=$X
WRITE !
FOR I=1:1:X
WRITE "-"
+33 FOR I=1:1:N
WRITE !,$JUSTIFY(I,3)," -- ",$PIECE(TARGET(I),"^")
+34 IF N=1
WRITE " (selected)"
SET X=1
QUIT
+35 WRITE !!,"Select the provider application (1-",N,"): "
+36 if HIT
WRITE HIT,"// "
READ X:DTIME
IF '$TEST
SET X="^"
+37 ; a caret will terminate the program
IF X["^"
QUIT
+38 IF X=""
SET X=HIT
WRITE X
IF X=""
SET X="^"
QUIT
+39 IF (X<1)!(X>N)!'$DATA(TARGET(X))
WRITE " ??? -- try again",!!
SET X=""
QUIT
+40 QUIT
End DoDot:1
if X'=""
QUIT
+41 IF X["^"
SET X=""
+42 IF X
SET X=$PIECE(TARGET(X),"^",1)
+43 QUIT X
