- MAGDCCU1 ;WOIFO/EdM - Failed Images Maintenance ; 01/03/2007 10:54
- ;;3.0;IMAGING;**54**;03-July-2009;;Build 1424
- ;; 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
- ;
- REMOFAIL ; Remove all entries for a specific retired DICOM Gateway
- N ACT,D0,LO,M,N,OLD,P1,P2,P3,UP,X,X0,X1
- S OLD=$$GETGW(1,1) Q:OLD=""
- Q:'$$WARN(OLD)
- S (D0,N)=0 F S D0=$O(^MAGD(2006.575,D0)) Q:'D0 D
- . S X1=$G(^MAGD(2006.575,D0,1)),ACT=$P(X1,"^",4) Q:$TR(ACT,LO,UP)'=OLD
- . S N=N+1
- . S X0=$G(^MAGD(2006.575,D0,0))
- . S P1=$P(X0,"^",1) K:P1'="" ^MAGD(2006.575,"B",P1,D0)
- . S P1=$P(X1,"^",3) K:P1'="" ^MAGD(2006.575,"AD",P1,D0)
- . S P1=$P(X1,"^",5) K:P1'="" ^MAGD(2006.575,"AFX",P1,ACT,D0)
- . S P2=$P($G(^MAGD(2006.575,D0,"ASUID")),"^",1)
- . I P1'="",P2'="" K ^MAGD(2006.575,"F",P1,P2,D0)
- . S P1=$P(X0,"^",3) K:P1'="" ^MAGD(2006.575,"D",P1,D0)
- . K ^MAGD(2006.575,D0)
- . Q
- L +^MAGD(2006.575,0):1E9
- S X=$G(^MAGD(2006.575,0))
- S $P(X,"^",1,2)="DICOM FAILED IMAGES^2006.575"
- S M=$P(X,"^",4)-N S:M<1 M=0
- S $P(X,"^",4)=M
- S ^MAGD(2006.575,0)=X
- L -^MAGD(2006.575,0)
- W !!,N," Entr",$S(N=1:"y",1:"ies")," removed.",!
- Q
- ;
- REMOXMIT ; Remove all entries for a specific retired DICOM Gateway
- N ACT,D0,LO,M,N,OLD,P1,P2,P3,UP,X,X0,X1
- S OLD=$$GETGW(1,2) Q:OLD=""
- Q:'$$WARN(OLD)
- S (D0,N)=0 F S D0=$O(^MAG(2006.587,D0)) Q:'D0 D
- . S X0=$G(^MAG(2006.587,D0,0)),ACT=$P(X0,"^",5) Q:$TR(ACT,LO,UP)'=OLD
- . S N=N+1
- . S P1=$P(X0,"^",1),P2=$P(X0,"^",7)
- . K:P1'="" ^MAG(2006.587,"B",P1,D0)
- . I P1'="",P2'="" K ^MAG(2006.587,"C",P1,P2,ACT,D0)
- . I P2'="" K ^MAG(2006.587,"D",ACT,P2,D0)
- . K ^MAG(2006.587,D0)
- . Q
- L +^MAG(2006.587,0):1E9
- S X=$G(^MAG(2006.587,0))
- S $P(X,"^",1,2)="DICOM TRANSMIT DESTINATION^2006.587"
- S M=$P(X,"^",4)-N S:M<1 M=0
- S $P(X,"^",4)=M
- S ^MAG(2006.587,0)=X
- L -^MAG(2006.587,0)
- W !!,N," Entr",$S(N=1:"y",1:"ies")," removed.",!
- Q
- ;
- RENAFAIL ; Rename all entries for a specific replaced DICOM Gateway
- N ACT,D0,LO,N,NEW,OLD,P1,P2,P3,UP,X,X0,X1
- S OLD=$$GETGW(1,1) Q:OLD=""
- S NEW=$$GETGW(0,1) Q:NEW=""
- I OLD=NEW D Q
- . W !,"Old and new names should be different..."
- . Q
- S (D0,N)=0 F S D0=$O(^MAGD(2006.575,D0)) Q:'D0 D
- . S X1=$G(^MAGD(2006.575,D0,1)),ACT=$P(X1,"^",4) Q:$TR(ACT,LO,UP)'=OLD
- . S N=N+1
- . S P1=$P(X1,"^",5) D:P1'=""
- . . S:$D(^MAGD(2006.575,"AFX",P1,ACT,D0)) ^MAGD(2006.575,"AFX",P1,NEW,D0)=""
- . . K ^MAGD(2006.575,"AFX",P1,ACT,D0)
- . . Q
- . S $P(^MAGD(2006.575,D0,1),"^",4)=NEW
- . Q
- W !!,N," Entr",$S(N=1:"y",1:"ies")," renamed.",!
- Q
- ;
- RENAXMIT ; Rename all entries for a specific replaced DICOM Gateway
- N ACT,D0,LO,N,NEW,OLD,P1,P2,P3,UP,X,X0,X1
- S OLD=$$GETGW(1,2) Q:OLD=""
- S NEW=$$GETGW(0,2) Q:NEW=""
- I OLD=NEW D Q
- . W !,"Old and new names should be different..."
- . Q
- S (D0,N)=0 F S D0=$O(^MAG(2006.587,D0)) Q:'D0 D
- . S X0=$G(^MAG(2006.587,D0,0)),ACT=$P(X0,"^",5) Q:$TR(ACT,LO,UP)'=OLD
- . S N=N+1
- . S P1=$P(X0,"^",1),P2=$P(X0,"^",7)
- . I P1'="",P2'="" K ^MAG(2006.587,"C",P1,P2,ACT,D0)
- . I P2'="" K ^MAG(2006.587,"D",ACT,P2,D0)
- . I P1'="",P2'="" S ^MAG(2006.587,"C",P1,P2,NEW,D0)=""
- . I P2'="" S ^MAG(2006.587,"D",NEW,P2,D0)=""
- . S $P(^MAG(2006.587,D0,0),"^",5)=NEW
- . Q
- W !!,N," Entr",$S(N=1:"y",1:"ies")," renamed.",!
- Q
- ;
- GETGW(EXIST,WHERE) ; Get the name of a DICOM Gateway
- N OK,TBL,TYPE,X
- S UP="ABCDEFGHIJKLMNOPQRSTUVWXYZ"
- S LO="abcdefghijklmnopqrstuvwxyz"
- S WHERE=+$G(WHERE),TBL=$S(WHERE=1:"Host Name",WHERE=2:"System Title",1:"?")
- Q:TBL="?"
- S TYPE=$S($G(EXIST):"current",1:"new")
- S OK=0 F D Q:OK
- . W !,"Enter the ",TYPE," ",TBL," of the DICOM Gateway: "
- . R X:$G(DTIME,300) E S X="^"
- . S X=$TR(X,LO,UP)
- . I X["^" S X="",OK=1
- . I X'["?",X'="" S OK=1 Q
- . W !,"Enter the appropriate name for the DICOM Gateway."
- . W !,"The ""Host Name"" is the name of the computer that is assigned"
- . W !,"by the site's IRM and that follows official naming rules."
- . W !,"The ""System Title"" is the name that is assigned by the staff"
- . W !,"who operates the DICOM Gateway."
- . W !
- . Q
- Q X
- ;
- WARN(NAME) N X
- W !!,"WARNING: this operation will irrevocably remove all entries"
- W !,"for the DICOM Gateway named """,NAME,"""."
- W !!,"Are you certain you wish to remove these entries? No//"
- R X:$G(DTIME,300) E Q 0
- Q "Yy"[$E(X_"N",1)
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMAGDCCU1 5263 printed Feb 18, 2025@23:26:15 Page 2
- MAGDCCU1 ;WOIFO/EdM - Failed Images Maintenance ; 01/03/2007 10:54
- +1 ;;3.0;IMAGING;**54**;03-July-2009;;Build 1424
- +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 ;
- REMOFAIL ; Remove all entries for a specific retired DICOM Gateway
- +1 NEW ACT,D0,LO,M,N,OLD,P1,P2,P3,UP,X,X0,X1
- +2 SET OLD=$$GETGW(1,1)
- if OLD=""
- QUIT
- +3 if '$$WARN(OLD)
- QUIT
- +4 SET (D0,N)=0
- FOR
- SET D0=$ORDER(^MAGD(2006.575,D0))
- if 'D0
- QUIT
- Begin DoDot:1
- +5 SET X1=$GET(^MAGD(2006.575,D0,1))
- SET ACT=$PIECE(X1,"^",4)
- if $TRANSLATE(ACT,LO,UP)'=OLD
- QUIT
- +6 SET N=N+1
- +7 SET X0=$GET(^MAGD(2006.575,D0,0))
- +8 SET P1=$PIECE(X0,"^",1)
- if P1'=""
- KILL ^MAGD(2006.575,"B",P1,D0)
- +9 SET P1=$PIECE(X1,"^",3)
- if P1'=""
- KILL ^MAGD(2006.575,"AD",P1,D0)
- +10 SET P1=$PIECE(X1,"^",5)
- if P1'=""
- KILL ^MAGD(2006.575,"AFX",P1,ACT,D0)
- +11 SET P2=$PIECE($GET(^MAGD(2006.575,D0,"ASUID")),"^",1)
- +12 IF P1'=""
- IF P2'=""
- KILL ^MAGD(2006.575,"F",P1,P2,D0)
- +13 SET P1=$PIECE(X0,"^",3)
- if P1'=""
- KILL ^MAGD(2006.575,"D",P1,D0)
- +14 KILL ^MAGD(2006.575,D0)
- +15 QUIT
- End DoDot:1
- +16 LOCK +^MAGD(2006.575,0):1E9
- +17 SET X=$GET(^MAGD(2006.575,0))
- +18 SET $PIECE(X,"^",1,2)="DICOM FAILED IMAGES^2006.575"
- +19 SET M=$PIECE(X,"^",4)-N
- if M<1
- SET M=0
- +20 SET $PIECE(X,"^",4)=M
- +21 SET ^MAGD(2006.575,0)=X
- +22 LOCK -^MAGD(2006.575,0)
- +23 WRITE !!,N," Entr",$SELECT(N=1:"y",1:"ies")," removed.",!
- +24 QUIT
- +25 ;
- REMOXMIT ; Remove all entries for a specific retired DICOM Gateway
- +1 NEW ACT,D0,LO,M,N,OLD,P1,P2,P3,UP,X,X0,X1
- +2 SET OLD=$$GETGW(1,2)
- if OLD=""
- QUIT
- +3 if '$$WARN(OLD)
- QUIT
- +4 SET (D0,N)=0
- FOR
- SET D0=$ORDER(^MAG(2006.587,D0))
- if 'D0
- QUIT
- Begin DoDot:1
- +5 SET X0=$GET(^MAG(2006.587,D0,0))
- SET ACT=$PIECE(X0,"^",5)
- if $TRANSLATE(ACT,LO,UP)'=OLD
- QUIT
- +6 SET N=N+1
- +7 SET P1=$PIECE(X0,"^",1)
- SET P2=$PIECE(X0,"^",7)
- +8 if P1'=""
- KILL ^MAG(2006.587,"B",P1,D0)
- +9 IF P1'=""
- IF P2'=""
- KILL ^MAG(2006.587,"C",P1,P2,ACT,D0)
- +10 IF P2'=""
- KILL ^MAG(2006.587,"D",ACT,P2,D0)
- +11 KILL ^MAG(2006.587,D0)
- +12 QUIT
- End DoDot:1
- +13 LOCK +^MAG(2006.587,0):1E9
- +14 SET X=$GET(^MAG(2006.587,0))
- +15 SET $PIECE(X,"^",1,2)="DICOM TRANSMIT DESTINATION^2006.587"
- +16 SET M=$PIECE(X,"^",4)-N
- if M<1
- SET M=0
- +17 SET $PIECE(X,"^",4)=M
- +18 SET ^MAG(2006.587,0)=X
- +19 LOCK -^MAG(2006.587,0)
- +20 WRITE !!,N," Entr",$SELECT(N=1:"y",1:"ies")," removed.",!
- +21 QUIT
- +22 ;
- RENAFAIL ; Rename all entries for a specific replaced DICOM Gateway
- +1 NEW ACT,D0,LO,N,NEW,OLD,P1,P2,P3,UP,X,X0,X1
- +2 SET OLD=$$GETGW(1,1)
- if OLD=""
- QUIT
- +3 SET NEW=$$GETGW(0,1)
- if NEW=""
- QUIT
- +4 IF OLD=NEW
- Begin DoDot:1
- +5 WRITE !,"Old and new names should be different..."
- +6 QUIT
- End DoDot:1
- QUIT
- +7 SET (D0,N)=0
- FOR
- SET D0=$ORDER(^MAGD(2006.575,D0))
- if 'D0
- QUIT
- Begin DoDot:1
- +8 SET X1=$GET(^MAGD(2006.575,D0,1))
- SET ACT=$PIECE(X1,"^",4)
- if $TRANSLATE(ACT,LO,UP)'=OLD
- QUIT
- +9 SET N=N+1
- +10 SET P1=$PIECE(X1,"^",5)
- if P1'=""
- Begin DoDot:2
- +11 if $DATA(^MAGD(2006.575,"AFX",P1,ACT,D0))
- SET ^MAGD(2006.575,"AFX",P1,NEW,D0)=""
- +12 KILL ^MAGD(2006.575,"AFX",P1,ACT,D0)
- +13 QUIT
- End DoDot:2
- +14 SET $PIECE(^MAGD(2006.575,D0,1),"^",4)=NEW
- +15 QUIT
- End DoDot:1
- +16 WRITE !!,N," Entr",$SELECT(N=1:"y",1:"ies")," renamed.",!
- +17 QUIT
- +18 ;
- RENAXMIT ; Rename all entries for a specific replaced DICOM Gateway
- +1 NEW ACT,D0,LO,N,NEW,OLD,P1,P2,P3,UP,X,X0,X1
- +2 SET OLD=$$GETGW(1,2)
- if OLD=""
- QUIT
- +3 SET NEW=$$GETGW(0,2)
- if NEW=""
- QUIT
- +4 IF OLD=NEW
- Begin DoDot:1
- +5 WRITE !,"Old and new names should be different..."
- +6 QUIT
- End DoDot:1
- QUIT
- +7 SET (D0,N)=0
- FOR
- SET D0=$ORDER(^MAG(2006.587,D0))
- if 'D0
- QUIT
- Begin DoDot:1
- +8 SET X0=$GET(^MAG(2006.587,D0,0))
- SET ACT=$PIECE(X0,"^",5)
- if $TRANSLATE(ACT,LO,UP)'=OLD
- QUIT
- +9 SET N=N+1
- +10 SET P1=$PIECE(X0,"^",1)
- SET P2=$PIECE(X0,"^",7)
- +11 IF P1'=""
- IF P2'=""
- KILL ^MAG(2006.587,"C",P1,P2,ACT,D0)
- +12 IF P2'=""
- KILL ^MAG(2006.587,"D",ACT,P2,D0)
- +13 IF P1'=""
- IF P2'=""
- SET ^MAG(2006.587,"C",P1,P2,NEW,D0)=""
- +14 IF P2'=""
- SET ^MAG(2006.587,"D",NEW,P2,D0)=""
- +15 SET $PIECE(^MAG(2006.587,D0,0),"^",5)=NEW
- +16 QUIT
- End DoDot:1
- +17 WRITE !!,N," Entr",$SELECT(N=1:"y",1:"ies")," renamed.",!
- +18 QUIT
- +19 ;
- GETGW(EXIST,WHERE) ; Get the name of a DICOM Gateway
- +1 NEW OK,TBL,TYPE,X
- +2 SET UP="ABCDEFGHIJKLMNOPQRSTUVWXYZ"
- +3 SET LO="abcdefghijklmnopqrstuvwxyz"
- +4 SET WHERE=+$GET(WHERE)
- SET TBL=$SELECT(WHERE=1:"Host Name",WHERE=2:"System Title",1:"?")
- +5 if TBL="?"
- QUIT
- +6 SET TYPE=$SELECT($GET(EXIST):"current",1:"new")
- +7 SET OK=0
- FOR
- Begin DoDot:1
- +8 WRITE !,"Enter the ",TYPE," ",TBL," of the DICOM Gateway: "
- +9 READ X:$GET(DTIME,300)
- IF '$TEST
- SET X="^"
- +10 SET X=$TRANSLATE(X,LO,UP)
- +11 IF X["^"
- SET X=""
- SET OK=1
- +12 IF X'["?"
- IF X'=""
- SET OK=1
- QUIT
- +13 WRITE !,"Enter the appropriate name for the DICOM Gateway."
- +14 WRITE !,"The ""Host Name"" is the name of the computer that is assigned"
- +15 WRITE !,"by the site's IRM and that follows official naming rules."
- +16 WRITE !,"The ""System Title"" is the name that is assigned by the staff"
- +17 WRITE !,"who operates the DICOM Gateway."
- +18 WRITE !
- +19 QUIT
- End DoDot:1
- if OK
- QUIT
- +20 QUIT X
- +21 ;
- WARN(NAME) NEW X
- +1 WRITE !!,"WARNING: this operation will irrevocably remove all entries"
- +2 WRITE !,"for the DICOM Gateway named """,NAME,"""."
- +3 WRITE !!,"Are you certain you wish to remove these entries? No//"
- +4 READ X:$GET(DTIME,300)
- IF '$TEST
- QUIT 0
- +5 QUIT "Yy"[$EXTRACT(X_"N",1)
- +6 ;