VistA-WorldVistAEHR/r/IMAGING-MAG-ZMAG/MAGDRPC5.m

273 lines
9.1 KiB
Mathematica

MAGDRPC5 ;WOIFO/EdM - Routing RPCs ; 12/15/2006 13:50
;;3.0;IMAGING;**11,30,51,85**;16-March-2007;;Build 1039
;; 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
;
START(OUT,LOCATION,RULES) ; RPC = MAG DICOM ROUTE EVAL START
N I,LOC,X,ZTDESC,ZTDTH,ZTRTN,ZTSAVE
;
D XTINIT
;
I '$G(LOCATION) S OUT="-1,No Location Specified" Q
I '$O(RULES("")) S OUT="-2,No Routing Rules Specified" Q
;
S LOC=$$GET1^DIQ(4,LOCATION,.01)
L +^MAGDICOM(2006.563,1,"EVAL",LOCATION):0 E D Q
. S OUT="-3,A Rule Evaluator is Already Running for "_LOC
. Q
;
S ^MAGDICOM(2006.563,1,"EVAL")=1
S ZTRTN="EVAL^MAGBRTE4"
S ZTDESC="Evaluate Routing Rules for Origin="_LOC
S ZTDTH=$H
S ZTSAVE("LOCATION")=LOCATION
S I="" F S I=$O(RULES(I)) Q:I="" S:+I=I ZTSAVE("RULES("_I_")")=RULES(I)
D ^%ZTLOAD,HOME^%ZIS
L -^MAGDICOM(2006.563,1,"EVAL",LOCATION)
I '$D(ZTSK) S OUT="-4,TaskMan did not Accept Request" Q
S OUT="0,TaskMan task#="_ZTSK
Q
;
STOP(OUT) ; RPC = MAG DICOM ROUTE EVAL STOP
S ^MAGDICOM(2006.563,1,"EVAL")=0,OUT=1
Q
;
XMIT(OUT,LOCATION,DEST,PRIOR,MECH,DESTS) ; RPC = MAG DICOM ROUTE NEXT FILE
N D0,DIR,DL,IM,M,OK,PLACE,TP,VP,X
;
S PLACE=$$PLACE^MAGDRPC2(LOCATION)
S $P(^MAG(2006.1,PLACE,"LASTROUTE"),"^",1)=DT
;
K OUT S OUT(1)=0,OK=0
S:'$G(MECH) MECH=1 I MECH'=1,MECH'=2 S MECH=1
I '$G(LOCATION) S OUT(1)="-1,No Location Specified" Q
S VP(1)=";MAG(2005.2,"
S VP(2)=";MAG(2006.587,"
S:$G(DEST) DEST=+DEST_VP(MECH)
S M="" F S M=$O(DESTS(M)) Q:M="" D
. S X=DESTS(M) Q:X'["^" Q:$P(X,"^",1)'=MECH Q:'$P(X,"^",2)
. S DL($P(X,"^",2)_VP(MECH))=""
. Q
I $O(DL(""))="" S OUT(1)="-2,No Valid Destinations Specified" Q
S:'$G(DEST) (PRIOR,DEST)=""
I $G(PRIOR) D
. I DEST S X=0 F D Q:X
. . N NXT
. . I $P($G(^MAG(2005.2,+DEST,0)),"^",6) S X=1 Q
. . D NOW^%DTC S %=%*1E6
. . S X=$P($G(^MAG(2005.2,+DEST,3)),"^",6)*1E6
. . I %-X>1500 D ONOFLINE(.X,+DEST,1) Q
. . S X=0,NXT=0
. . F S DEST=$O(^MAGQUEUE(2006.035,"STS",LOCATION,"WAITING",PRIOR,DEST)) Q:DEST="" D Q:NXT
. . . S:$D(DL(DEST)) NXT=1
. . . Q
. . S:'DEST X=1
. . Q
. I 'DEST S (PRIOR,DEST)="" Q
. F D Q:OK
. . S D0=+$G(D0)
. . S D0=$O(^MAGQUEUE(2006.035,"STS",LOCATION,"WAITING",PRIOR,DEST,D0))
. . I 'D0 S OK=1 Q
. . S M=$P($G(^MAGQUEUE(2006.035,D0,0)),"^",4) I M'=1,M'=2 S M=1
. . I M=MECH S OK=1 Q
. . S (PRIOR,DEST)=""
. . Q
. Q
I OK D:$O(^MAGQUEUE(2006.035,"STS",LOCATION,"WAITING",PRIOR))
. ;
. ; Ignore higher priority items for destinations that are not accessible
. ;
. N A,D,P,T,X
. S P=PRIOR F S P=$O(^MAGQUEUE(2006.035,"STS",LOCATION,"WAITING",P)) Q:'P D Q:'PRIOR
. . S D="" F S D=$O(^MAGQUEUE(2006.035,"STS",LOCATION,"WAITING",P,D)) Q:D="" D Q:'PRIOR
. . . ; Interrupt only if we're transmitting there
. . . Q:'$D(DL(D))
. . . ;
. . . D:'$P(^MAG(2005.2,+D,0),"^",6)
. . . . D NOW^%DTC S %=%*1E6
. . . . S X=$P($G(^MAG(2005.2,+D,3)),"^",6)*1E6 Q:%-X<1500
. . . . D ONOFLINE(.X,+D,1)
. . . . Q
. . . S:$P(^MAG(2005.2,+D,0),"^",6) PRIOR=0
. . . Q
. . Q
. Q
I '$G(PRIOR) F D Q:OK Q:'PRIOR
. S PRIOR=" " F S PRIOR=$O(^MAGQUEUE(2006.035,"STS",LOCATION,"WAITING",PRIOR),-1) Q:'PRIOR D Q:OK
. . S DEST="" F S DEST=$O(^MAGQUEUE(2006.035,"STS",LOCATION,"WAITING",PRIOR,DEST)) Q:DEST="" D:$D(DL(DEST)) Q:OK
. . . D:'$P(^MAG(2005.2,+DEST,0),"^",6)
. . . . D NOW^%DTC S %=%*1E6
. . . . S X=$P($G(^MAG(2005.2,+DEST,3)),"^",6)*1E6 Q:%-X<1500
. . . . D ONOFLINE(.X,+DEST,1)
. . . . Q
. . . Q:'$P(^MAG(2005.2,+DEST,0),"^",6)
. . . S D0="" F S D0=$O(^MAGQUEUE(2006.035,"STS",LOCATION,"WAITING",PRIOR,DEST,D0)) Q:D0="" D Q:OK
. . . . S M=$P($G(^MAGQUEUE(2006.035,D0,0)),"^",4) I M'=1,M'=2 S M=1
. . . . I M=MECH S OK=1 Q
. . . . Q
. . . Q
. . Q
. Q
Q:'PRIOR
Q:'OK
I 'D0 S OUT(1)=0 Q ; All files transmitted
;
S X=^MAGQUEUE(2006.035,D0,0),IM=$P(X,"^",1),TP=$P(X,"^",3)
I 'IM D STATUS(X,D0,"SENT",LOCATION) S OUT(1)=2 Q
S OUT(2)=+DEST,OUT(3)=PRIOR,OUT(4)=MECH,OUT(9)=D0
S X=$G(^MAG(2005.2,+DEST,2)),OUT(5)=$P(X,"^",1),OUT(6)=$P(X,"^",2)
D STATUS(X,D0,"SENDING",LOCATION)
S OUT(10)=$P(^MAG(2005.2,+DEST,0),"^",2)
S DIR=$P($G(^MAG(2005.2,+DEST,4)),"^",2)
S OUT(11)=$G(^MAG(2005.2,+DEST,3))
S OUT(12)=IM
S OUT(13)=$P($G(^MAGQUEUE(2006.035,D0,1)),"^",3)
S OUT(14)=$P($G(^MAG(2005.2,+DEST,1)),"^",7) S:OUT(14)="" OUT(14)="NONE"
D XMIT^MAGDRPC6 ; Routine grew over 10,000 characters
I MECH=2 S OUT(2)=OUT(2)_"^"_$P($G(^MAG(2006.587,+DEST,0)),"^",1)
Q
;
PURGE(OUT,LOCATION,DEST,MAX,DONE) ; RPC = MAG DICOM ROUTE GET PURGE
N D0,D1,FILE,FMFILE,I,LIMIT,MORE,NOW,RETAIN,STAMP,STATUS,X
;
D NOW^%DTC S NOW=%
K OUT S OUT(1)=1
S:$D(^MAG(2005.2,DEST,0)) $P(^MAG(2005.2,DEST,3),"^",4)=DT
S X=^MAG(2005.2,DEST,3)
S RETAIN=$P(X,"^",1) S:RETAIN="" RETAIN=32 S:RETAIN<0 RETAIN=0
S LIMIT=$H-RETAIN
;
S X=$G(DONE(1)),MORE="" S:$E(X,1)="^" MORE=$P(X,"^",4,6)
;
S I="" F S I=$O(DONE(I)) Q:I="" D
. N D41,D61
. S X=$G(DONE(I))
. S D0=$P(X,"^",2),D41=$P(X,"^",3)
. S STAMP=$P(X,"^",4)
. Q:'D0 Q:'D41
. ; Just in case the image is being deleted as this purge is taking place
. F FMFILE=2005,2005.1 D
. . K ^MAG(FMFILE,"ROUTE",DEST,STAMP,D0,D41)
. . S D61=$P($G(^MAG(FMFILE,D0,4,D41,0)),"^",7)
. . K ^MAG(FMFILE,D0,4,"LOC",DEST,D41)
. . K ^MAG(FMFILE,D0,4,D41,0)
. . S:D61 $P(^MAG(FMFILE,D0,6,D61,0),"^",5)=NOW
. . Q
. S MORE=""
. Q
;
D
. N %,%H,%I
. S %H=LIMIT D TT^%DTC S LIMIT=X
. Q
;
S MAX=$G(MAX) S:MAX<1 MAX=100
F FMFILE=2005,2005.1 D Q:OUT(1)'<MAX
. S STAMP="" F S STAMP=$O(^MAG(FMFILE,"ROUTE",DEST,STAMP)) Q:STAMP="" Q:STAMP'<LIMIT D Q:OUT(1)'<MAX
. . S D0="" F S D0=$O(^MAG(FMFILE,"ROUTE",DEST,STAMP,D0)) Q:D0="" D Q:OUT(1)'<MAX
. . . S D1="" F S D1=$O(^MAG(FMFILE,"ROUTE",DEST,STAMP,D0,D1)) Q:D1="" D Q:OUT(1)'<MAX
. . . . I MORE'="",FMFILE_"^"_D0_"^"_D1'=MORE Q
. . . . S MORE=""
. . . . S FILE=$P($G(^MAG(FMFILE,D0,4,D1,0)),"^",4),STATUS=0
. . . . S:FILE="" FILE=$P($G(^MAG(2005.1,D0,4,D1,0)),"^",4)
. . . . I FILE="" D Q
. . . . . K ^MAG(FMFILE,"ROUTE",DEST,STAMP,D0,D1)
. . . . . K ^MAG(FMFILE,D0,4,"LOC",DEST,D1)
. . . . . K ^MAG(FMFILE,D0,4,D1,0)
. . . . . Q
. . . . S OUT(1)=OUT(1)+1,OUT(OUT(1))=FMFILE_"^"_D0_"^"_D1_"^"_STAMP_"^"_FILE
. . . . Q
. . . Q
. . Q
. Q
Q
;
STATUS(OUT,D0,STATUS,LOCATION) ; RPC = MAG DICOM ROUTE STATUS
; D0 ------- Internal Entry Number of Send Queue Entry
; STATUS --- New Status
N DEST ;---- Internal Entry Number of destination
N IMAGE ;--- Internal Entry Number of image
N OLD ;----- Old Status Value
N ORIGIN ;-- Origin of image
N PRIOR ;--- Priority
N TYPE ;---- File Type (Big, Text, DICOM, etc)
N X0,X1 ;--- Queue data
;
I '$G(D0) S OUT="-1,Invalid queue identifier: """_$G(D0)_"""." Q
;
S X0=$G(^MAGQUEUE(2006.035,D0,0))
S X1=$G(^MAGQUEUE(2006.035,D0,1))
S OUT=0
;
S DEST=$P(X0,"^",2) Q:DEST=""
S PRIOR=$P(X1,"^",2) Q:PRIOR=""
S ORIGIN=$P(X0,"^",5)
S:'ORIGIN ORIGIN=$G(LOCATION) Q:'ORIGIN
S OLD=$P(X1,"^",1),IMAGE=$P(X0,"^",1),TYPE=$P(X0,"^",3)
;
K:OLD'="" ^MAGQUEUE(2006.035,"DEST",DEST,OLD,IMAGE,TYPE,D0)
K:OLD'="" ^MAGQUEUE(2006.035,"STS",ORIGIN,OLD,PRIOR,DEST,D0)
Q:STATUS=""
S $P(^MAGQUEUE(2006.035,D0,0),"^",5)=ORIGIN
S $P(^MAGQUEUE(2006.035,D0,1),"^",1)=STATUS
S ^MAGQUEUE(2006.035,"DEST",DEST,STATUS,IMAGE,TYPE,D0)=""
S ^MAGQUEUE(2006.035,"STS",ORIGIN,STATUS,PRIOR,DEST,D0)=""
S OUT=1
Q
;
LISTDEST(OUT,LOCATION) ; RPC = MAG DICOM ROUTE LIST DESTI
N D0,F,I,X
; Return list of possible routing destinations
K OUT
S I=1,D0=0 F S D0=$O(^MAG(2005.2,D0)) Q:'D0 D
. S X=$G(^MAG(2005.2,D0,0)) Q:'$P(X,"^",9)
. L +^MAGQUEUE("ROUTE",LOCATION,D0):0 S F='$T
. L:'F -^MAGQUEUE("ROUTE",LOCATION,D0)
. S I=I+1,OUT(I)=D0_"^"_F_"^"_$P(X,"^",1,2)
. Q
S OUT(1)=I-1
Q
;
LOCK(OUT,D0,LOCATION,PLUSMIN) ; RPC = MAG DICOM ROUTE LOCK TRANSMIT
S OUT=0
I $G(PLUSMIN) L +^MAGQUEUE("ROUTE",LOCATION,D0):0 S OUT=$T Q
L -^MAGQUEUE("ROUTE",LOCATION,D0) S OUT=2
Q
;
ONOFLINE(OUT,DEST,STATUS) ; RPC = MAG DICOM NETWORK STATUS
N NET
I '$G(DEST) S OUT="-1,No Network Location Specified" Q
S STATUS=''$G(STATUS)
S NET=$P($G(^MAG(2005.2,DEST,0)),"^",2)
K ^MAG(2005.2,"C",NET,0,DEST)
K ^MAG(2005.2,"C",NET,1,DEST)
S ^MAG(2005.2,"C",NET,STATUS,DEST)=""
S $P(^MAG(2005.2,DEST,0),"^",6)=STATUS
D NOW^%DTC
S $P(^MAG(2005.2,DEST,3),"^",6)=$S(STATUS:"",1:%)
S OUT=1
Q
;
XTINIT ;
D DT^DICRW
S X=$G(^XTMP("MAGEVAL",0))
S $P(X,"^",2)=DT
S $P(X,"^",3)="Routing Rule Evaluator Log - Can be purged at any time"
S ^XTMP("MAGEVAL",0)=X
Q
;