MAGDIWDX ;WOIFO/PMK - Formatted listing of On Demand Routing request file ; Mar 10, 2022@14:18:40
;;3.0;IMAGING;**110,305**;Mar 19, 2002;Build 3
;; 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. |
;; +---------------------------------------------------------------+
;;
;
; Supported IA #2320 reference ^%ZISH subroutine call
;
; This routine is the same on VistA and the DICOM Gateway
;
REPORT(LOC,A,ODEVNAME,ODEVTYPE) ; display the list of studies in the output file
N ACNUMB,COUNT,D0,DATETIME,DEFAULT,GROUP,I,IGNORESUCCESS,J
N LOCATION,LOCATIONLAST,MSG
N POP,PRIORITY,REQUESTDATETIME,SCP,STATE,STOP,USERAPP,USERAPPLAST,X,Y
F I=2:1:LOC(1) D
. S LOCATION($P(LOC(I),"^",1))=$P(LOC(I),"^",2)
. S LOCATION("N",I-1)=$P(LOC(I),"^",1)
. Q
;
; select the sending location
S DEFAULT=""
I LOC(1)>2 D
. S LOC="" F D Q:LOC'=""
. . W !!,"There are multiple sending locations on file:",!
. . F I=1:1:LOC(1)-1 D
. . . S LOCATION=LOCATION("N",I)
. . . W !,$J(I,5)," -- ",LOCATION(LOCATION)
. . . I LOCATION=LOC("DEFAULT") S DEFAULT=I
. . . Q
. . W !!,"Enter 1-",I," or ""A"" for all: "
. . I DEFAULT'="" W DEFAULT,"// "
. . R X:DTIME E S X="^"
. . I X="" S X=DEFAULT W X
. . I "^"[X S LOC="^"
. . E I X?1N.N,X>=1,X<=I S LOC=LOCATION("N",X) W " -- ",LOCATION(LOC)
. . E I "Aa"[$E(X) S LOC="A" W " -- All"
. . Q
. Q
E S LOC="A" ; just one location
;
; select the Store SCP userapp
S J=0,USERAPP="" F I=1:1:$G(A(1)) D
. S USERAPP=$P(A(I+1),"^",2)
. I '$D(USERAPP(USERAPP)) S J=J+1,USERAPP(USERAPP)=J,USERAPP("N",J)=USERAPP
. Q
S DEFAULT="A"
I J>1 D
. S SCP="" F D Q:SCP'=""
. . W !!,"There are multiple Store SCPs on file:",!
. . F I=1:1:J D
. . . W !,$J(I,5)," -- ",USERAPP("N",I)
. . . Q
. . W !!,"Enter 1-",J," or ""A"" for all: "
. . I DEFAULT'="" W DEFAULT,"// "
. . R X:DTIME E S X="^"
. . I X="" S X=DEFAULT W X
. . I "^"[X S SCP="^"
. . E I X?1N.N,X>=1,X<=J S SCP=USERAPP("N",X) W " -- ",SCP
. . E I "Aa"[$E(X) S SCP="A" W " -- All"
. . Q
. Q
E S SCP="A" ; just one Store SCP
;
S DEFAULT=$S(ODEVTYPE="SCREEN":"Y",1:"N")
S X=$$YESNO("Ignore Successful Transmissions?",DEFAULT,.IGNORESUCCESS)
;
; output the report
;
I ODEVTYPE="FILE" D ; open the file
. I $$VISTA^MAGDSTQ D ; VistA code
. . D OPEN^%ZISH("OUTFILE",ODEVNAME,"W")
. . U IO
. . Q
. E D ; DICOM Gateway code
. . S X=$$OPEN^MAGOSFIL(ODEVNAME,"W")
. . U ODEVNAME
. . Q
. Q
;
S (MSG(1),MSG(3))=""
S $Y=0,STOP=0
S MSG(2)="DICOM Object Export File Status -- "_$$HTE^XLFDT($H)
I ODEVTYPE="SCREEN" Q:$$NEWLINE() Q:$$NEWLINE()
Q:$$HEADING(.MSG)
S LOCATIONLAST=""
F I=1:1:$G(A(1)) S X=A(I+1) D Q:STOP
. N WRITEACNUMB
. S WRITEACNUMB=0
. S LOCATION=$P(X,"^",1),USERAPP=$P(X,"^",2)
. I LOC'="A",LOCATION'=LOC Q
. I SCP'="A",SCP'=USERAPP Q
. S PRIORITY=$P(X,"^",3),D0=$P(X,"^",4),ACNUMB=$P(X,"^",5)
. S REQUESTDATETIME=$P(X,"^",6),GROUP=$P(X,"^",7)
. I LOCATION'=LOCATIONLAST S LOCATIONLAST=LOCATION,USERAPPLAST=""
. I USERAPP'=USERAPPLAST D
. . N MSG
. . S (MSG(1),MSG(3),MSG(5))=""
. . S MSG(2)="Sending Site: "_LOCATION(LOCATION)
. . S MSG(4)="Destination: "_USERAPP
. . Q:$$NEWLINE() Q:$$NEWLINE()
. . Q:$$HEADING(.MSG)
. . S USERAPPLAST=USERAPP
. . Q
. F J=1:1:$L(X,"^")-7 D Q:STOP
. . S Y=$P(X,"^",J+7),STATE=$P(Y,"|",1)
. . I IGNORESUCCESS="YES",STATE="SUCCESS" Q
. . I 'WRITEACNUMB D Q:STOP
. . . S STOP=$$NEWLINE() Q:STOP S STOP=$$NEWLINE() Q:STOP
. . . W ACNUMB S WRITEACNUMB=1
. . . Q
. . S DATETIME=$P(Y,"|",2),COUNT=$P(Y,"|",3)
. . I $X>20 S STOP=$$NEWLINE() Q:STOP
. . W ?20,$J(COUNT,4),?28,STATE,?40,$$HTE^XLFDT(DATETIME,"2M")
. . W ?57,"(",$$FMTE^XLFDT(REQUESTDATETIME,"2M"),")"
. . Q
. Q
;
Q:$$NEWLINE() Q:$$NEWLINE()
W "End of Report" Q:$$NEWLINE()
I ODEVTYPE="FILE" D ; close the file
. I $$VISTA^MAGDSTQ D ; VistA Code
. . D CLOSE^%ZISH("OUTFILE")
. . Q
. E D ; DICOM Gateway code
. . S X=$$CLOSE^MAGOSFIL(ODEVNAME)
. . Q
. U $P
. W !!,"Report successfully written to file """,ODEVNAME,"""",!
. Q
Q
;
HEADING(MSG) ;
N I,STOP
Q:$$NEWLINE() 1 W $TR($J("",80)," ","*")
I $D(MSG)=1 Q:$$NEWLINE() 1 W "*** ",MSG,?76," ***"
E S STOP=0 D Q:STOP 1
. F I=1:1 Q:'$D(MSG(I)) D Q:STOP
. . S STOP=$$NEWLINE() Q:STOP
. . W "*** ",MSG(I),?76," ***"
. . Q
. Q
Q:$$NEWLINE() 1 W $TR($J("",80)," ","*")
Q 0
;
NEWLINE() ; output a <carriage return> <line feed> with scrolling control
N I,STOP,X
S STOP=0
W !
I ODEVTYPE="SCREEN",$Y>=23 D
. W "more..." R X:DTIME F I=1:1:$X W $C(8,32,8)
. S $Y=0 Q:X=""
. S:$TR(X,"quitexnQUITEXN","^^^^^^^^^^^^^^")["^" STOP=1
. Q
Q STOP
;
YESNO(PROMPT,DEFAULT,CHOICE) ; generic YES/NO question driver
N OK,X
S OK=0 F D Q:OK
. W !!,PROMPT," " I $L($G(DEFAULT)) W DEFAULT," // "
. R X:DTIME E S OK=-1 Q
. I X="",$L($G(DEFAULT)) S X=DEFAULT W X
. I X="",'$L($G(DEFAULT)) S X="*" ; fails Y/N tests
. I X["^" S CHOICE="^",OK=-1 Q
. I "Yy"[$E(X) S CHOICE="YES",OK=1 Q
. I "Nn"[$E(X) S CHOICE="NO",OK=1 Q
. W " ??? - Please enter ""Yes"" or ""No""."
. Q
Q OK
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMAGDIWDX 6061 printed Sep 23, 2025@19:36:45 Page 2
MAGDIWDX ;WOIFO/PMK - Formatted listing of On Demand Routing request file ; Mar 10, 2022@14:18:40
+1 ;;3.0;IMAGING;**110,305**;Mar 19, 2002;Build 3
+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 ;
+18 ; Supported IA #2320 reference ^%ZISH subroutine call
+19 ;
+20 ; This routine is the same on VistA and the DICOM Gateway
+21 ;
REPORT(LOC,A,ODEVNAME,ODEVTYPE) ; display the list of studies in the output file
+1 NEW ACNUMB,COUNT,D0,DATETIME,DEFAULT,GROUP,I,IGNORESUCCESS,J
+2 NEW LOCATION,LOCATIONLAST,MSG
+3 NEW POP,PRIORITY,REQUESTDATETIME,SCP,STATE,STOP,USERAPP,USERAPPLAST,X,Y
+4 FOR I=2:1:LOC(1)
Begin DoDot:1
+5 SET LOCATION($PIECE(LOC(I),"^",1))=$PIECE(LOC(I),"^",2)
+6 SET LOCATION("N",I-1)=$PIECE(LOC(I),"^",1)
+7 QUIT
End DoDot:1
+8 ;
+9 ; select the sending location
+10 SET DEFAULT=""
+11 IF LOC(1)>2
Begin DoDot:1
+12 SET LOC=""
FOR
Begin DoDot:2
+13 WRITE !!,"There are multiple sending locations on file:",!
+14 FOR I=1:1:LOC(1)-1
Begin DoDot:3
+15 SET LOCATION=LOCATION("N",I)
+16 WRITE !,$JUSTIFY(I,5)," -- ",LOCATION(LOCATION)
+17 IF LOCATION=LOC("DEFAULT")
SET DEFAULT=I
+18 QUIT
End DoDot:3
+19 WRITE !!,"Enter 1-",I," or ""A"" for all: "
+20 IF DEFAULT'=""
WRITE DEFAULT,"// "
+21 READ X:DTIME
IF '$TEST
SET X="^"
+22 IF X=""
SET X=DEFAULT
WRITE X
+23 IF "^"[X
SET LOC="^"
+24 IF '$TEST
IF X?1N.N
IF X>=1
IF X<=I
SET LOC=LOCATION("N",X)
WRITE " -- ",LOCATION(LOC)
+25 IF '$TEST
IF "Aa"[$EXTRACT(X)
SET LOC="A"
WRITE " -- All"
+26 QUIT
End DoDot:2
if LOC'=""
QUIT
+27 QUIT
End DoDot:1
+28 ; just one location
IF '$TEST
SET LOC="A"
+29 ;
+30 ; select the Store SCP userapp
+31 SET J=0
SET USERAPP=""
FOR I=1:1:$GET(A(1))
Begin DoDot:1
+32 SET USERAPP=$PIECE(A(I+1),"^",2)
+33 IF '$DATA(USERAPP(USERAPP))
SET J=J+1
SET USERAPP(USERAPP)=J
SET USERAPP("N",J)=USERAPP
+34 QUIT
End DoDot:1
+35 SET DEFAULT="A"
+36 IF J>1
Begin DoDot:1
+37 SET SCP=""
FOR
Begin DoDot:2
+38 WRITE !!,"There are multiple Store SCPs on file:",!
+39 FOR I=1:1:J
Begin DoDot:3
+40 WRITE !,$JUSTIFY(I,5)," -- ",USERAPP("N",I)
+41 QUIT
End DoDot:3
+42 WRITE !!,"Enter 1-",J," or ""A"" for all: "
+43 IF DEFAULT'=""
WRITE DEFAULT,"// "
+44 READ X:DTIME
IF '$TEST
SET X="^"
+45 IF X=""
SET X=DEFAULT
WRITE X
+46 IF "^"[X
SET SCP="^"
+47 IF '$TEST
IF X?1N.N
IF X>=1
IF X<=J
SET SCP=USERAPP("N",X)
WRITE " -- ",SCP
+48 IF '$TEST
IF "Aa"[$EXTRACT(X)
SET SCP="A"
WRITE " -- All"
+49 QUIT
End DoDot:2
if SCP'=""
QUIT
+50 QUIT
End DoDot:1
+51 ; just one Store SCP
IF '$TEST
SET SCP="A"
+52 ;
+53 SET DEFAULT=$SELECT(ODEVTYPE="SCREEN":"Y",1:"N")
+54 SET X=$$YESNO("Ignore Successful Transmissions?",DEFAULT,.IGNORESUCCESS)
+55 ;
+56 ; output the report
+57 ;
+58 ; open the file
IF ODEVTYPE="FILE"
Begin DoDot:1
+59 ; VistA code
IF $$VISTA^MAGDSTQ
Begin DoDot:2
+60 DO OPEN^%ZISH("OUTFILE",ODEVNAME,"W")
+61 USE IO
+62 QUIT
End DoDot:2
+63 ; DICOM Gateway code
IF '$TEST
Begin DoDot:2
+64 SET X=$$OPEN^MAGOSFIL(ODEVNAME,"W")
+65 USE ODEVNAME
+66 QUIT
End DoDot:2
+67 QUIT
End DoDot:1
+68 ;
+69 SET (MSG(1),MSG(3))=""
+70 SET $Y=0
SET STOP=0
+71 SET MSG(2)="DICOM Object Export File Status -- "_$$HTE^XLFDT($HOROLOG)
+72 IF ODEVTYPE="SCREEN"
if $$NEWLINE()
QUIT
if $$NEWLINE()
QUIT
+73 if $$HEADING(.MSG)
QUIT
+74 SET LOCATIONLAST=""
+75 FOR I=1:1:$GET(A(1))
SET X=A(I+1)
Begin DoDot:1
+76 NEW WRITEACNUMB
+77 SET WRITEACNUMB=0
+78 SET LOCATION=$PIECE(X,"^",1)
SET USERAPP=$PIECE(X,"^",2)
+79 IF LOC'="A"
IF LOCATION'=LOC
QUIT
+80 IF SCP'="A"
IF SCP'=USERAPP
QUIT
+81 SET PRIORITY=$PIECE(X,"^",3)
SET D0=$PIECE(X,"^",4)
SET ACNUMB=$PIECE(X,"^",5)
+82 SET REQUESTDATETIME=$PIECE(X,"^",6)
SET GROUP=$PIECE(X,"^",7)
+83 IF LOCATION'=LOCATIONLAST
SET LOCATIONLAST=LOCATION
SET USERAPPLAST=""
+84 IF USERAPP'=USERAPPLAST
Begin DoDot:2
+85 NEW MSG
+86 SET (MSG(1),MSG(3),MSG(5))=""
+87 SET MSG(2)="Sending Site: "_LOCATION(LOCATION)
+88 SET MSG(4)="Destination: "_USERAPP
+89 if $$NEWLINE()
QUIT
if $$NEWLINE()
QUIT
+90 if $$HEADING(.MSG)
QUIT
+91 SET USERAPPLAST=USERAPP
+92 QUIT
End DoDot:2
+93 FOR J=1:1:$LENGTH(X,"^")-7
Begin DoDot:2
+94 SET Y=$PIECE(X,"^",J+7)
SET STATE=$PIECE(Y,"|",1)
+95 IF IGNORESUCCESS="YES"
IF STATE="SUCCESS"
QUIT
+96 IF 'WRITEACNUMB
Begin DoDot:3
+97 SET STOP=$$NEWLINE()
if STOP
QUIT
SET STOP=$$NEWLINE()
if STOP
QUIT
+98 WRITE ACNUMB
SET WRITEACNUMB=1
+99 QUIT
End DoDot:3
if STOP
QUIT
+100 SET DATETIME=$PIECE(Y,"|",2)
SET COUNT=$PIECE(Y,"|",3)
+101 IF $X>20
SET STOP=$$NEWLINE()
if STOP
QUIT
+102 WRITE ?20,$JUSTIFY(COUNT,4),?28,STATE,?40,$$HTE^XLFDT(DATETIME,"2M")
+103 WRITE ?57,"(",$$FMTE^XLFDT(REQUESTDATETIME,"2M"),")"
+104 QUIT
End DoDot:2
if STOP
QUIT
+105 QUIT
End DoDot:1
if STOP
QUIT
+106 ;
+107 if $$NEWLINE()
QUIT
if $$NEWLINE()
QUIT
+108 WRITE "End of Report"
if $$NEWLINE()
QUIT
+109 ; close the file
IF ODEVTYPE="FILE"
Begin DoDot:1
+110 ; VistA Code
IF $$VISTA^MAGDSTQ
Begin DoDot:2
+111 DO CLOSE^%ZISH("OUTFILE")
+112 QUIT
End DoDot:2
+113 ; DICOM Gateway code
IF '$TEST
Begin DoDot:2
+114 SET X=$$CLOSE^MAGOSFIL(ODEVNAME)
+115 QUIT
End DoDot:2
+116 USE $PRINCIPAL
+117 WRITE !!,"Report successfully written to file """,ODEVNAME,"""",!
+118 QUIT
End DoDot:1
+119 QUIT
+120 ;
HEADING(MSG) ;
+1 NEW I,STOP
+2 if $$NEWLINE()
QUIT 1
WRITE $TRANSLATE($JUSTIFY("",80)," ","*")
+3 IF $DATA(MSG)=1
if $$NEWLINE()
QUIT 1
WRITE "*** ",MSG,?76," ***"
+4 IF '$TEST
SET STOP=0
Begin DoDot:1
+5 FOR I=1:1
if '$DATA(MSG(I))
QUIT
Begin DoDot:2
+6 SET STOP=$$NEWLINE()
if STOP
QUIT
+7 WRITE "*** ",MSG(I),?76," ***"
+8 QUIT
End DoDot:2
if STOP
QUIT
+9 QUIT
End DoDot:1
if STOP
QUIT 1
+10 if $$NEWLINE()
QUIT 1
WRITE $TRANSLATE($JUSTIFY("",80)," ","*")
+11 QUIT 0
+12 ;
NEWLINE() ; output a <carriage return> <line feed> with scrolling control
+1 NEW I,STOP,X
+2 SET STOP=0
+3 WRITE !
+4 IF ODEVTYPE="SCREEN"
IF $Y>=23
Begin DoDot:1
+5 WRITE "more..."
READ X:DTIME
FOR I=1:1:$X
WRITE $CHAR(8,32,8)
+6 SET $Y=0
if X=""
QUIT
+7 if $TRANSLATE(X,"quitexnQUITEXN","^^^^^^^^^^^^^^")["^"
SET STOP=1
+8 QUIT
End DoDot:1
+9 QUIT STOP
+10 ;
YESNO(PROMPT,DEFAULT,CHOICE) ; generic YES/NO question driver
+1 NEW OK,X
+2 SET OK=0
FOR
Begin DoDot:1
+3 WRITE !!,PROMPT," "
IF $LENGTH($GET(DEFAULT))
WRITE DEFAULT," // "
+4 READ X:DTIME
IF '$TEST
SET OK=-1
QUIT
+5 IF X=""
IF $LENGTH($GET(DEFAULT))
SET X=DEFAULT
WRITE X
+6 ; fails Y/N tests
IF X=""
IF '$LENGTH($GET(DEFAULT))
SET X="*"
+7 IF X["^"
SET CHOICE="^"
SET OK=-1
QUIT
+8 IF "Yy"[$EXTRACT(X)
SET CHOICE="YES"
SET OK=1
QUIT
+9 IF "Nn"[$EXTRACT(X)
SET CHOICE="NO"
SET OK=1
QUIT
+10 WRITE " ??? - Please enter ""Yes"" or ""No""."
+11 QUIT
End DoDot:1
if OK
QUIT
+12 QUIT OK
