Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: MAGDCCU1

MAGDCCU1.m

Go to the documentation of this file.
  1. MAGDCCU1 ;WOIFO/EdM - Failed Images Maintenance ; 01/03/2007 10:54
  1. ;;3.0;IMAGING;**54**;03-July-2009;;Build 1424
  1. ;; Per VHA Directive 2004-038, this routine should not be modified.
  1. ;; +---------------------------------------------------------------+
  1. ;; | Property of the US Government. |
  1. ;; | No permission to copy or redistribute this software is given. |
  1. ;; | Use of unreleased versions of this software requires the user |
  1. ;; | to execute a written test agreement with the VistA Imaging |
  1. ;; | Development Office of the Department of Veterans Affairs, |
  1. ;; | telephone (301) 734-0100. |
  1. ;; | The Food and Drug Administration classifies this software as |
  1. ;; | a medical device. As such, it may not be changed in any way. |
  1. ;; | Modifications to this software may result in an adulterated |
  1. ;; | medical device under 21CFR820, the use of which is considered |
  1. ;; | to be a violation of US Federal Statutes. |
  1. ;; +---------------------------------------------------------------+
  1. ;;
  1. Q
  1. ;
  1. REMOFAIL ; Remove all entries for a specific retired DICOM Gateway
  1. N ACT,D0,LO,M,N,OLD,P1,P2,P3,UP,X,X0,X1
  1. S OLD=$$GETGW(1,1) Q:OLD=""
  1. Q:'$$WARN(OLD)
  1. S (D0,N)=0 F S D0=$O(^MAGD(2006.575,D0)) Q:'D0 D
  1. . S X1=$G(^MAGD(2006.575,D0,1)),ACT=$P(X1,"^",4) Q:$TR(ACT,LO,UP)'=OLD
  1. . S N=N+1
  1. . S X0=$G(^MAGD(2006.575,D0,0))
  1. . S P1=$P(X0,"^",1) K:P1'="" ^MAGD(2006.575,"B",P1,D0)
  1. . S P1=$P(X1,"^",3) K:P1'="" ^MAGD(2006.575,"AD",P1,D0)
  1. . S P1=$P(X1,"^",5) K:P1'="" ^MAGD(2006.575,"AFX",P1,ACT,D0)
  1. . S P2=$P($G(^MAGD(2006.575,D0,"ASUID")),"^",1)
  1. . I P1'="",P2'="" K ^MAGD(2006.575,"F",P1,P2,D0)
  1. . S P1=$P(X0,"^",3) K:P1'="" ^MAGD(2006.575,"D",P1,D0)
  1. . K ^MAGD(2006.575,D0)
  1. . Q
  1. L +^MAGD(2006.575,0):1E9
  1. S X=$G(^MAGD(2006.575,0))
  1. S $P(X,"^",1,2)="DICOM FAILED IMAGES^2006.575"
  1. S M=$P(X,"^",4)-N S:M<1 M=0
  1. S $P(X,"^",4)=M
  1. S ^MAGD(2006.575,0)=X
  1. L -^MAGD(2006.575,0)
  1. W !!,N," Entr",$S(N=1:"y",1:"ies")," removed.",!
  1. Q
  1. ;
  1. REMOXMIT ; Remove all entries for a specific retired DICOM Gateway
  1. N ACT,D0,LO,M,N,OLD,P1,P2,P3,UP,X,X0,X1
  1. S OLD=$$GETGW(1,2) Q:OLD=""
  1. Q:'$$WARN(OLD)
  1. S (D0,N)=0 F S D0=$O(^MAG(2006.587,D0)) Q:'D0 D
  1. . S X0=$G(^MAG(2006.587,D0,0)),ACT=$P(X0,"^",5) Q:$TR(ACT,LO,UP)'=OLD
  1. . S N=N+1
  1. . S P1=$P(X0,"^",1),P2=$P(X0,"^",7)
  1. . K:P1'="" ^MAG(2006.587,"B",P1,D0)
  1. . I P1'="",P2'="" K ^MAG(2006.587,"C",P1,P2,ACT,D0)
  1. . I P2'="" K ^MAG(2006.587,"D",ACT,P2,D0)
  1. . K ^MAG(2006.587,D0)
  1. . Q
  1. L +^MAG(2006.587,0):1E9
  1. S X=$G(^MAG(2006.587,0))
  1. S $P(X,"^",1,2)="DICOM TRANSMIT DESTINATION^2006.587"
  1. S M=$P(X,"^",4)-N S:M<1 M=0
  1. S $P(X,"^",4)=M
  1. S ^MAG(2006.587,0)=X
  1. L -^MAG(2006.587,0)
  1. W !!,N," Entr",$S(N=1:"y",1:"ies")," removed.",!
  1. Q
  1. ;
  1. RENAFAIL ; Rename all entries for a specific replaced DICOM Gateway
  1. N ACT,D0,LO,N,NEW,OLD,P1,P2,P3,UP,X,X0,X1
  1. S OLD=$$GETGW(1,1) Q:OLD=""
  1. S NEW=$$GETGW(0,1) Q:NEW=""
  1. I OLD=NEW D Q
  1. . W !,"Old and new names should be different..."
  1. . Q
  1. S (D0,N)=0 F S D0=$O(^MAGD(2006.575,D0)) Q:'D0 D
  1. . S X1=$G(^MAGD(2006.575,D0,1)),ACT=$P(X1,"^",4) Q:$TR(ACT,LO,UP)'=OLD
  1. . S N=N+1
  1. . S P1=$P(X1,"^",5) D:P1'=""
  1. . . S:$D(^MAGD(2006.575,"AFX",P1,ACT,D0)) ^MAGD(2006.575,"AFX",P1,NEW,D0)=""
  1. . . K ^MAGD(2006.575,"AFX",P1,ACT,D0)
  1. . . Q
  1. . S $P(^MAGD(2006.575,D0,1),"^",4)=NEW
  1. . Q
  1. W !!,N," Entr",$S(N=1:"y",1:"ies")," renamed.",!
  1. Q
  1. ;
  1. RENAXMIT ; Rename all entries for a specific replaced DICOM Gateway
  1. N ACT,D0,LO,N,NEW,OLD,P1,P2,P3,UP,X,X0,X1
  1. S OLD=$$GETGW(1,2) Q:OLD=""
  1. S NEW=$$GETGW(0,2) Q:NEW=""
  1. I OLD=NEW D Q
  1. . W !,"Old and new names should be different..."
  1. . Q
  1. S (D0,N)=0 F S D0=$O(^MAG(2006.587,D0)) Q:'D0 D
  1. . S X0=$G(^MAG(2006.587,D0,0)),ACT=$P(X0,"^",5) Q:$TR(ACT,LO,UP)'=OLD
  1. . S N=N+1
  1. . S P1=$P(X0,"^",1),P2=$P(X0,"^",7)
  1. . I P1'="",P2'="" K ^MAG(2006.587,"C",P1,P2,ACT,D0)
  1. . I P2'="" K ^MAG(2006.587,"D",ACT,P2,D0)
  1. . I P1'="",P2'="" S ^MAG(2006.587,"C",P1,P2,NEW,D0)=""
  1. . I P2'="" S ^MAG(2006.587,"D",NEW,P2,D0)=""
  1. . S $P(^MAG(2006.587,D0,0),"^",5)=NEW
  1. . Q
  1. W !!,N," Entr",$S(N=1:"y",1:"ies")," renamed.",!
  1. Q
  1. ;
  1. GETGW(EXIST,WHERE) ; Get the name of a DICOM Gateway
  1. N OK,TBL,TYPE,X
  1. S UP="ABCDEFGHIJKLMNOPQRSTUVWXYZ"
  1. S LO="abcdefghijklmnopqrstuvwxyz"
  1. S WHERE=+$G(WHERE),TBL=$S(WHERE=1:"Host Name",WHERE=2:"System Title",1:"?")
  1. Q:TBL="?"
  1. S TYPE=$S($G(EXIST):"current",1:"new")
  1. S OK=0 F D Q:OK
  1. . W !,"Enter the ",TYPE," ",TBL," of the DICOM Gateway: "
  1. . R X:$G(DTIME,300) E S X="^"
  1. . S X=$TR(X,LO,UP)
  1. . I X["^" S X="",OK=1
  1. . I X'["?",X'="" S OK=1 Q
  1. . W !,"Enter the appropriate name for the DICOM Gateway."
  1. . W !,"The ""Host Name"" is the name of the computer that is assigned"
  1. . W !,"by the site's IRM and that follows official naming rules."
  1. . W !,"The ""System Title"" is the name that is assigned by the staff"
  1. . W !,"who operates the DICOM Gateway."
  1. . W !
  1. . Q
  1. Q X
  1. ;
  1. WARN(NAME) N X
  1. W !!,"WARNING: this operation will irrevocably remove all entries"
  1. W !,"for the DICOM Gateway named """,NAME,"""."
  1. W !!,"Are you certain you wish to remove these entries? No//"
  1. R X:$G(DTIME,300) E Q 0
  1. Q "Yy"[$E(X_"N",1)
  1. ;