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

MAGBRTUT.m

Go to the documentation of this file.
  1. MAGBRTUT ;WOIFO/EdM - Routing Utilities ; 10/30/2008 09:20
  1. ;;3.0;IMAGING;**9,11,30,51,50,85,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. SEND(IMAGE,LOC,PRI,MECH,FROM,ID) ; Enter image into Routing Queue
  1. ; IMAGE ;---- Internal Entry Number in Image FIle
  1. ; LOC ;------ Internal Entry Number in either Network Location file
  1. ; or SCU_List file
  1. ; PRI ;------ Priority
  1. ; MECHanism = 1: Send using MS-DOS-Copy
  1. ; = 2: Send using DICOM_Send
  1. ; FROM ;----- Location from which request originates
  1. ; ID ;------- Transaction ID
  1. N D0 ;------- Internal Entry number
  1. N FLAG ;----- List of file-types to transmit
  1. N I ;-------- Scratch and loop counter
  1. N ORIGIN ;--- Location from which image is being sent (IEN in Institution file)
  1. N QQ ;------- List of queue-entries created
  1. ;
  1. S QQ="",MECH=$G(MECH) S:'MECH MECH=1
  1. I '$D(^MAG(2005,+$G(IMAGE))) Q:$Q QQ Q
  1. I MECH=1,'$D(^MAG(2005.2,+$G(LOC))) Q:$Q QQ Q
  1. I MECH=2,'$D(^MAG(2006.587,+$G(LOC))) Q:$Q QQ Q
  1. I MECH'=1,MECH'=2 Q:$Q QQ Q
  1. S:MECH=1 LOC=(+LOC)_";MAG(2005.2,"
  1. S:MECH=2 LOC=(+LOC)_";MAG(2006.587,"
  1. ;
  1. S ORIGIN=$G(FROM) D:'ORIGIN
  1. . S ORIGIN=$P($G(^MAG(2005,IMAGE,100)),"^",3)
  1. . S:'ORIGIN ORIGIN=$G(DUZ(2))
  1. . S:'ORIGIN ORIGIN=$$KSP^XUPARAM("INST")
  1. . Q
  1. ;
  1. S PRI=$G(PRI,500),ID=$G(ID)
  1. S FLAG=$G(^MAG(2005.2,+LOC,1)) S:MECH=2 FLAG="^^^^5"
  1. ;
  1. I MECH=2 D Q:$Q QQ Q
  1. . ; Stopgap until "native DICOM" storage is supported
  1. . N APPNAM
  1. . S APPNAM=$P($G(^MAG(2006.587,+LOC,0)),"^",1)
  1. . D QUEUE^MAGDRPC3(.QQ,IMAGE,APPNAM,ORIGIN,"","6: Copy to HIPAA Compliant Storage",,PRI)
  1. . Q
  1. ;
  1. F I=1:1:5 D:$P(FLAG,"^",I)
  1. . N D0,T,X
  1. . S T=$P("ABSTRACT FULL BIG TEXT DICOM"," ",I)
  1. . ;
  1. . S D0=$O(^MAGQUEUE(2006.035,"DEST",LOC,"WAITING",IMAGE,T,"")) I D0 D Q
  1. . . N O,P,T,X0,X1
  1. . . S X0=$G(^MAGQUEUE(2006.035,D0,0)),O=$P(X0,"^",5),T=$P(X0,"^",6)
  1. . . S X1=$G(^MAGQUEUE(2006.035,D0,1)),P=$P(X1,"^",2)
  1. . . ; Don't send multiple copies, but do increase priority if needed
  1. . . Q:PRI'>P
  1. . . S $P(X0,"^",5)=ORIGIN,^MAGQUEUE(2006.035,D0,0)=X0
  1. . . I T'=ID,ID'="" D
  1. . . . S $P(X0,"^",6)=ID
  1. . . . S ^MAGQUEUE(2006.035,D0,0)=X0
  1. . . . K:O'="" ^MAGQUEUE(2006.035,"ID",T,D0)
  1. . . . S ^MAGQUEUE(2006.035,"ID",ID,D0)=""
  1. . . . Q
  1. . . S $P(X1,"^",2)=PRI,^MAGQUEUE(2006.035,D0,1)=X1
  1. . . K:O ^MAGQUEUE(2006.035,"STS",O,"WAITING",P,LOC,D0)
  1. . . S ^MAGQUEUE(2006.035,"STS",ORIGIN,"WAITING",PRI,LOC,D0)=""
  1. . . Q
  1. . ;
  1. . L +^MAGQUEUE(2006.035,0):1E9 ; Background job MUST wait
  1. . S D0=$O(^MAGQUEUE(2006.035," "),-1)+1
  1. . S X=$G(^MAGQUEUE(2006.035,0))
  1. . S $P(X,"^",1,2)="SEND QUEUE^2006.035"
  1. . S $P(X,"^",3)=D0
  1. . S $P(X,"^",4)=$P(X,"^",4)+1
  1. . S ^MAGQUEUE(2006.035,0)=X
  1. . S X=IMAGE_"^"_LOC_"^"_T_"^"_MECH_"^"_ORIGIN_"^"_ID
  1. . S:ID'="" ^MAGQUEUE(2006.035,"ID",ID,D0)=""
  1. . S ^MAGQUEUE(2006.035,D0,0)=X
  1. . S ^MAGQUEUE(2006.035,D0,1)="WAITING^"_PRI_"^"_$$NOW^XLFDT()
  1. . S ^MAGQUEUE(2006.035,"STS",ORIGIN,"WAITING",PRI,LOC,D0)=""
  1. . S ^MAGQUEUE(2006.035,"DEST",LOC,"WAITING",IMAGE,T,D0)=""
  1. . L -^MAGQUEUE(2006.035,0)
  1. . S QQ=QQ_D0_"^"
  1. . Q
  1. Q:$Q QQ Q
  1. ;
  1. DCMLIST(OUT,LOCATION) N D0,LO,LST,N,NM,X
  1. S LOCATION=+$G(LOCATION)
  1. S D0=0 F S D0=$O(^MAG(2006.587,D0)) Q:'D0 D
  1. . S X=$G(^MAG(2006.587,D0,0))
  1. . S NM=$P(X,"^",1),LO=$P(X,"^",7) Q:NM=""
  1. . I LOCATION,LO,LO'=LOCATION Q
  1. . S LST(NM,LO)=D0
  1. . Q
  1. S N=1,NM="" F S NM=$O(LST(NM)) Q:NM="" D
  1. . S LO="",X=0 F S LO=$O(LST(NM,LO)) Q:LO="" S X=X+1,D0=LST(NM,LO)
  1. . I X=1 S N=N+1,OUT(N)=NM_"^"_D0 Q
  1. . S LO="" F S LO=$O(LST(NM,LO)) Q:LO="" S N=N+1,OUT(N)=NM_" ("_LO_")^"_LST(NM,LO)
  1. . Q
  1. S OUT(1)=N-1
  1. Q
  1. ;
  1. EVALPU(OUT,UNTIL) ; RPC = MAG DICOM ROUTE EVAL PURGE
  1. N D0,MORE,N,P1,P4,P5,P6,P7,P8,TIME
  1. S TIME=$$STAMP($H)+55,N=0,MORE=0
  1. L +^MAGQUEUE(2006.03,0):1E9 ; Background process must wait
  1. S D0="" F S D0=$O(^MAGQUEUE(2006.03,"B","EVAL",D0)) Q:D0="" D Q:MORE
  1. . S X=$G(^MAGQUEUE(2006.03,D0,0))
  1. . S P4=$P(X,"^",4),P6=$P(X,"^",6)
  1. . S:P6 P4=-1
  1. . Q:P4>UNTIL
  1. . I $$STAMP($H)>TIME S MORE=1 Q
  1. . S N=N+1,P1=$P(X,"^",1),P5=$P(X,"^",5),P7=$P(X,"^",7),P8=$P(X,"^",8)
  1. . I P1'="" K ^MAGQUEUE(2006.03,"B",P1,D0)
  1. . I P5'="" K ^MAGQUEUE(2006.03,"C",P5,D0)
  1. . I P7'="",P8'="" K ^MAGQUEUE(2006.03,"JD",P7,P8,D0)
  1. . I P7'="" K ^MAGQUEUE(2006.03,"JX",P7,D0)
  1. . K ^MAGQUEUE(2006.03,D0)
  1. . Q
  1. S X=$G(^MAGQUEUE(2006.03,0))
  1. S P1=$P(X,"^",4)-N S:P1<1 P1=0 S $P(X,"^",4)=P1
  1. S $P(X,"^",1,2)="IMAGE BACKGROUND QUEUE^2006.03"
  1. S ^MAGQUEUE(2006.03,0)=X
  1. L -^MAGQUEUE(2006.03,0)
  1. S OUT=N_"^"_MORE
  1. Q
  1. ;
  1. STAMP(H) Q H*86400+$P(H,",",2)
  1. ;
  1. RENAME(OUT,OLD,NEW,KEY) ; RPC = MAG DICOM XMIT RENAME GATEWAY
  1. N D0,ID,LOC,SVC,N,X
  1. I $G(OLD)="" S OUT="-1,No previous Gateway name specified" Q
  1. I $G(NEW)="" S OUT="-2,No new Gateway name specified" Q
  1. S:'$G(KEY) KEY=5
  1. I KEY'=5,KEY'=6 S OUT="-3,Invalid key specified ("_KEY_")" Q
  1. ;
  1. S (N,D0)=0 F S D0=$O(^MAG(2006.587,D0)) Q:'D0 D
  1. . S X=$G(^MAG(2006.587,D0,0)),ID=$P(X,"^",KEY) Q:ID'=OLD
  1. . S N=N+1
  1. . S $P(X,"^",KEY)=NEW
  1. . Q:KEY'=5
  1. . S LOC=$P(X,"^",7),SVC=$P(X,"^",1)
  1. . I LOC'="",SVC'="" K ^MAG(2006.587,"C",SVC,OLD,LOC,D0)
  1. . I LOC'="" K ^MAG(2006.587,"D",OLD,LOC,D0)
  1. . I LOC'="",SVC'="" S ^MAG(2006.587,"C",SVC,NEW,LOC,D0)=""
  1. . I LOC'="" S ^MAG(2006.587,"D",NEW,LOC,D0)=""
  1. . Q
  1. S OUT=N_" entr"_$S(N=1:"y",1:"ies")_" renamed"
  1. Q
  1. ;
  1. REMOVE(OUT,OLD,KEY) ; RPC = MAG DICOM XMIT REMOVE GATEWAY
  1. N D0,ID,LOC,SVC,N,T,X
  1. I $G(OLD)="" S OUT="-1,No Gateway name specified" Q
  1. S:'$G(KEY) KEY=5
  1. I KEY'=5,KEY'=6 S OUT="-3,Invalid key specified ("_KEY_")" Q
  1. ;
  1. L +^MAG(2006.587,0):1E9 ; Background process MUST wait
  1. S (N,D0)=0 F S D0=$O(^MAG(2006.587,D0)) Q:'D0 D
  1. . S X=$G(^MAG(2006.587,D0,0)),ID=$P(X,"^",KEY) Q:ID'=OLD
  1. . S N=N+1
  1. . S LOC=$P(X,"^",7),SVC=$P(X,"^",1)
  1. . I LOC'="",SVC'="" K ^MAG(2006.587,"C",SVC,OLD,LOC,D0)
  1. . I LOC'="" K ^MAG(2006.587,"D",OLD,LOC,D0)
  1. . I SVC'="" K ^MAG(2006.587,"B",SVC,D0)
  1. . K ^MAG(2006.587,D0)
  1. . Q
  1. S X=$G(^MAG(2006.587,0))
  1. S $P(X,"^",1,2)="DICOM TRANSMIT DESTINATION^2006.587"
  1. S $P(X,"^",3)=$O(^MAG(2006.587," "),-1)
  1. S T=$P(X,"^",4)-N S:T<1 T="" S $P(X,"^",4)=T
  1. S ^MAG(2006.587,0)=X
  1. L -^MAG(2006.587,0)
  1. S OUT=N_" entr"_$S(N=1:"y",1:"ies")_" removed"
  1. Q
  1. ;