MAGDIWDX ;WOIFO/PMK - Formatted listing of On Demand Routing request file ; 06 Mar 2013 8:05 AM
;;3.0;IMAGING;**138**;Mar 19, 2002;Build 5380;Sep 03, 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. |
;; +---------------------------------------------------------------+
;;
;
; This routine is the same on VistA and the DICOM Gateway
;
REPORT(LOC,A,ODEVNAME,ODEVTYPE) ; display the list of studing in the output file
N ACCNUMB,COUNT,D0,DATETIME,DEFAULT,GROUP,I,IGNORESUCCESS,J
N LOCATION,LOCATIONLAST,MSG
N POP,PRIORITY,REQUESTDATETIME,SCP,STATUS,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" O ODEVNAME:"NW" U ODEVNAME
;
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 WRITEACCNUMB
. S WRITEACCNUMB=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),ACCNUMB=$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),STATUS=$P(Y,"|",1)
. . I IGNORESUCCESS="YES",STATUS="SUCCESS" Q
. . I 'WRITEACCNUMB D Q:STOP
. . . S STOP=$$NEWLINE() Q:STOP S STOP=$$NEWLINE() Q:STOP
. . . W ACCNUMB S WRITEACCNUMB=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,STATUS,?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'="SCREEN" D
. I ODEVTYPE="FILE" C ODEVNAME
. U $P
. W !!,"Report successfully writen 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 5692 printed Feb 10, 2021@20:44:19 Page 2
MAGDIWDX ;WOIFO/PMK - Formatted listing of On Demand Routing request file ; 06 Mar 2013 8:05 AM
+1 ;;3.0;IMAGING;**138**;Mar 19, 2002;Build 5380;Sep 03, 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 ;
+18 ; This routine is the same on VistA and the DICOM Gateway
+19 ;
REPORT(LOC,A,ODEVNAME,ODEVTYPE) ; display the list of studing in the output file
+1 NEW ACCNUMB,COUNT,D0,DATETIME,DEFAULT,GROUP,I,IGNORESUCCESS,J
+2 NEW LOCATION,LOCATIONLAST,MSG
+3 NEW POP,PRIORITY,REQUESTDATETIME,SCP,STATUS,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 IF ODEVTYPE="FILE"
OPEN ODEVNAME:"NW"
USE ODEVNAME
+59 ;
+60 SET (MSG(1),MSG(3))=""
+61 SET $Y=0
SET STOP=0
+62 SET MSG(2)="DICOM Object Export File Status -- "_$$HTE^XLFDT($HOROLOG)
+63 IF ODEVTYPE="SCREEN"
if $$NEWLINE()
QUIT
if $$NEWLINE()
QUIT
+64 if $$HEADING(.MSG)
QUIT
+65 SET LOCATIONLAST=""
+66 FOR I=1:1:$GET(A(1))
SET X=A(I+1)
Begin DoDot:1
+67 NEW WRITEACCNUMB
+68 SET WRITEACCNUMB=0
+69 SET LOCATION=$PIECE(X,"^",1)
SET USERAPP=$PIECE(X,"^",2)
+70 IF LOC'="A"
IF LOCATION'=LOC
QUIT
+71 IF SCP'="A"
IF SCP'=USERAPP
QUIT
+72 SET PRIORITY=$PIECE(X,"^",3)
SET D0=$PIECE(X,"^",4)
SET ACCNUMB=$PIECE(X,"^",5)
+73 SET REQUESTDATETIME=$PIECE(X,"^",6)
SET GROUP=$PIECE(X,"^",7)
+74 IF LOCATION'=LOCATIONLAST
SET LOCATIONLAST=LOCATION
SET USERAPPLAST=""
+75 IF USERAPP'=USERAPPLAST
Begin DoDot:2
+76 NEW MSG
+77 SET (MSG(1),MSG(3),MSG(5))=""
+78 SET MSG(2)="Sending Site: "_LOCATION(LOCATION)
+79 SET MSG(4)="Destination: "_USERAPP
+80 if $$NEWLINE()
QUIT
if $$NEWLINE()
QUIT
+81 if $$HEADING(.MSG)
QUIT
+82 SET USERAPPLAST=USERAPP
+83 QUIT
End DoDot:2
+84 FOR J=1:1:$LENGTH(X,"^")-7
Begin DoDot:2
+85 SET Y=$PIECE(X,"^",J+7)
SET STATUS=$PIECE(Y,"|",1)
+86 IF IGNORESUCCESS="YES"
IF STATUS="SUCCESS"
QUIT
+87 IF 'WRITEACCNUMB
Begin DoDot:3
+88 SET STOP=$$NEWLINE()
if STOP
QUIT
SET STOP=$$NEWLINE()
if STOP
QUIT
+89 WRITE ACCNUMB
SET WRITEACCNUMB=1
+90 QUIT
End DoDot:3
if STOP
QUIT
+91 SET DATETIME=$PIECE(Y,"|",2)
SET COUNT=$PIECE(Y,"|",3)
+92 IF $X>20
SET STOP=$$NEWLINE()
if STOP
QUIT
+93 WRITE ?20,$JUSTIFY(COUNT,4),?28,STATUS,?40,$$HTE^XLFDT(DATETIME,"2M")
+94 WRITE ?57,"(",$$FMTE^XLFDT(REQUESTDATETIME,"2M"),")"
+95 QUIT
End DoDot:2
if STOP
QUIT
+96 QUIT
End DoDot:1
if STOP
QUIT
+97 ;
+98 if $$NEWLINE()
QUIT
if $$NEWLINE()
QUIT
+99 WRITE "End of Report"
if $$NEWLINE()
QUIT
+100 IF ODEVTYPE'="SCREEN"
Begin DoDot:1
+101 IF ODEVTYPE="FILE"
CLOSE ODEVNAME
+102 USE $PRINCIPAL
+103 WRITE !!,"Report successfully writen to file """,ODEVNAME,"""",!
+104 QUIT
End DoDot:1
+105 QUIT
+106 ;
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
