MAGDRPC2 ;WOIFO/EDM/PMK - Imaging RPCs ; Feb 15, 2022@10:47:46
;;3.0;IMAGING;**11,30,51,50,54,305**;Mar 19, 2002;Build 3
;; 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
;
SERVICE(OUT) ; RPC = MAG DICOM GET SERVICE INFO
N D0,X
S D0=$O(^MAG(2006.1,0)),OUT="-1,No Imaging Site Parameters defined" Q:'D0
S X=$G(^MAG(2006.1,D0,"GW"))
S OUT=$$ENCRYP^ROUTINE($$DECRYP($P(X,"^",1))_";"_$$DECRYP($P(X,"^",2)))
Q
;
SAME(SET,D0,NODE,PIECE,X) ; Called from FileMan ^DD
N L0
S L0=0 F S L0=$O(^MAG(2006.1,L0)) Q:'L0 D:L0'=D0
. S $P(^MAG(2006.1,L0,NODE),"^",PIECE)=$S(SET:X,1:"")
. Q
Q
;
IMAGE(OUT,D0) ; RPC = MAG DICOM GET BASIC IMAGE
N I,MSG,TARGET,V,VE,VI,X
K OUT S I=1
I '$G(D0) S OUT(1)="-1,Invalid IEN ("_$G(D0)_")" Q
I $D(^MAG(2005.1,D0,0)) S OUT(1)="-3,Image #"_D0_" has been deleted." Q
I '$D(^MAG(2005,D0,0)) S OUT(1)="-2,No data for """_D0_"""." Q
;
D GETS^DIQ(2005,D0_",","*","REIN","TARGET","MSG")
S X="" F S X=$O(TARGET(2005,D0_",",X)) Q:X="" D
. S VI=$G(TARGET(2005,D0_",",X,"I"))
. S VE=$G(TARGET(2005,D0_",",X,"E"))
. S I=I+1,OUT(I)=X_"^"_VI S:VI'=VE OUT(I)=OUT(I)_"^"_VE
. Q
;
D FILEFIND^MAGDFB(D0,"FULL",0,0,.X,.V)
S:X'<0 I=I+1,OUT(I)="Full FileName^"_X
S:V'<0 I=I+1,OUT(I)="Full Path+FileName^"_V
;
D FILEFIND^MAGDFB(D0,"BIG",0,0,.X,.V)
S:X'<0 I=I+1,OUT(I)="Big FileName^"_X
S:V'<0 I=I+1,OUT(I)="Big Path+FileName^"_V
;
D FILEFIND^MAGDFB(D0,"ABSTRACT",0,0,.X,.V)
S:X'<0 I=I+1,OUT(I)="Abstract FileName^"_X
S:V'<0 I=I+1,OUT(I)="Abstract Path+FileName^"_V
;
S (V,X)=0 F S X=$O(^MAG(2005,D0,1,X)) Q:'X S V=V+1
S:V I=I+1,OUT(I)="# Images^"_V
;
S OUT(1)=I-1
Q
;
GRPIMG(OUT,D0) ; RPC = MAG DICOM GET IMAGE GROUP
N I,D1,X
D CHK^MAGGSQI(.OUT,D0) I +$G(OUT(0))'=1 Q ; patient safety
K OUT S I=1
S D1=0 F S D1=$O(^MAG(2005,D0,1,D1)) Q:'D1 D
. S X=$P($G(^MAG(2005,D0,1,D1,0)),"^",1) Q:'X
. S I=I+1,OUT(I)=X
. Q
S OUT(1)=I-1
Q
;
IMAGNEW(OUT,ARTIFACTIX) ; RPC = MAG DICOM GET NEW SOP DB IMAGE - P305 PMK 12/02/2021
N ARTIFACTINSTIX,DISKVOLUME,FILEREF,FILEPATH,I,PHYSICALREF
I '$G(ARTIFACTIX) S OUT="-1,Invalid IEN ("_$G(ARTIFACTIX)_")" Q
S ARTIFACTINSTIX=$O(^MAGV(2006.918,"B",ARTIFACTIX,"")) ; get first Artifact Instance pointer
I ARTIFACTINSTIX="" S OUT="-2,No data for """_ARTIFACTIX_"""." Q
S FILEREF=$$UP^MAGDFCNV($$GET1^DIQ(2006.918,ARTIFACTINSTIX,6)) ; FILEREF (filename)
S DISKVOLUME=$$GET1^DIQ(2006.918,ARTIFACTINSTIX,7,"I") ; DISK VOLUME
S PHYSICALREF=$$GET1^DIQ(2005.2,DISKVOLUME,1) ; PHYSICAL REFERENCE
S FILEPATH=$$GET1^DIQ(2006.918,ARTIFACTINSTIX,8) ; FILEPATH
S OUT=PHYSICALREF_FILEPATH_FILEREF
Q
;
DECRYP(X) Q $S(X="":"",1:$$DECRYP^ROUTINE(X))
;
IMGVER(OUT) ; RPC = MAG DICOM GET VERSION
N D0,DATINS,FME,FML,I,L,N,P,PATCH,X
D FIND^DIC(9.7,"",".01;2I;51I","QU","MAG*3.0","*","B","","","FML","FME")
S I="" F S I=$O(FML("DILIST","ID",I)) Q:I="" D
. S N=$G(FML("DILIST","ID",I,.01)) Q:$P(N,"*",2)'="3.0"
. S PATCH=$P(N,"*",3) Q:'PATCH
. S PATCH(PATCH)=1
. S DATINS=$G(FML("DILIST","ID",I,2)) Q:DATINS=""
. S P=$G(FML("DILIST","ID",I,51)) Q:P=""
. S L(DATINS,PATCH_"-"_P)=""
. Q
;
S (DATINS,L,OUT)="" F S DATINS=$O(L(DATINS),-1) Q:DATINS="" D
. S PATCH="" F S PATCH=$O(L(DATINS,PATCH)) Q:PATCH="" D
. . S:OUT="" OUT=PATCH
. . S:$G(PATCH(+PATCH)) PATCH(+PATCH)=0,L=(+PATCH)_","_L
. . Q
. Q
S OUT=L_OUT
Q
;
PLACE(LOCATION) N D0,FST,LST
S FST=+$O(^MAG(2006.1,0)),LST=+$O(^MAG(2006.1," "),-1) Q:LST=FST FST
S D0=$O(^MAG(2006.1,"B",+$G(LOCATION),"")) Q:D0 D0
Q FST
;
ROUTEDAY ; Scan for Routing Activity
N BUCKET ;- Daily tallies
N D0 ;----- Image pointer for child of current parent
N D1 ;----- Pointer to multiple in image file
N D4 ;----- Loop counter
N DAY ;---- Current FileMan date
N DAYTIM ;- Current FileMan timestamp
N DEST ;--- Destination
N FIRST ;-- First date for scan
N FSTX ;--- First transmission for current study
N IMAGE ;-- Image Pointer for current image
N LAST ;--- Last date for scan
N LSTQ ;--- Timestamp for last queue entry in current study
N P3 ;----- Highest IEN in statistics file
N P4 ;----- Number of entries in statistics file
N PARENT ;- Image Pointer for parent of current image
N R ;------ Retention Period
N X ;------ Scratch
N XMIT ;--- Total duration of transmissions for current study
;
K ^TMP("MAG",$J,"RTD1")
K ^TMP("MAG",$J,"RTD2")
K ^TMP("MAG",$J,"RTD3")
S FIRST=$$HTFM^XLFDT($H-4)
S LAST=$$HTFM^XLFDT($H+2)
;
S DEST="" F S DEST=$O(^MAG(2005,"ROUTE",DEST)) Q:DEST="" D
. S NAME(DEST)=$P($G(^MAG(2005.2,DEST,0)," ? "_DEST),"^",1)
. S DAYTIM=FIRST F D S DAYTIM=$O(^MAG(2005,"ROUTE",DEST,DAYTIM)) Q:DAYTIM="" Q:DAYTIM'<LAST
. . S DAY=DAYTIM\1
. . S IMAGE="" F S IMAGE=$O(^MAG(2005,"ROUTE",DEST,DAYTIM,IMAGE)) Q:IMAGE="" D
. . . S PARENT=$P($G(^MAG(2005,IMAGE,0)),"^",10)
. . . I PARENT,$G(^TMP("MAG",$J,"RTD3",PARENT)) S PARENT=0
. . . S:PARENT ^TMP("MAG",$J,"RTD3",PARENT)=1
. . . S (XMIT,LSTQ)=0,FSTX=1E9
. . . S D0=IMAGE,D1=0 D I PARENT F S D1=$O(^MAG(2005,PARENT,1,D1)) Q:'D1 S D0=+$P($G(^MAG(2005,PARENT,1,D1,0)),"^",1) D
. . . . Q:'D0
. . . . Q:$D(^TMP("MAG",$J,"RTD1",D0,D1))
. . . . S ^TMP("MAG",$J,"RTD1",D0,D1)=""
. . . . S D4=0 F S D4=$O(^MAG(2005,D0,4,D4)) Q:'D4 D
. . . . . S X=$G(^MAG(2005,D0,4,D4,0))
. . . . . Q:$P($P(X,"^",1),".",1)'=DAY
. . . . . Q:$P(X,"^",2)'=DEST
. . . . . S:$P(X,"^",6)>LSTQ LSTQ=$P(X,"^",6)
. . . . . S:$P(X,"^",5)<FSTX FSTX=$P(X,"^",5)
. . . . . S XMIT=XMIT+$$DELTA($P(X,"^",5),$P(X,"^",1))
. . . . . Q
. . . . Q
. . . S X=$$DELTA(LSTQ,FSTX)
. . . S:X>$G(BUCKET(DAY,DEST,1)) BUCKET(DAY,DEST,1)=X
. . . S X=$S(X<300:1,X<900:2,X<3600:3,1:4)
. . . S BUCKET(DAY,DEST,1,X)=$G(BUCKET(DAY,DEST,1,X))+1
. . . S:XMIT>$G(BUCKET(DAY,DEST,2)) BUCKET(DAY,DEST,2)=XMIT
. . . S X=$S(XMIT<300:1,XMIT<900:2,XMIT<3600:3,1:4)
. . . S BUCKET(DAY,DEST,2,X)=$G(BUCKET(DAY,DEST,2,X))+1
. . . Q
. . Q
. Q
;
S X=$G(^TMP("MAG",$J,"RTD2",0)),P3=+$P(X,"^",3),P4=+$P(X,"^",4)
S DAY="" F S DAY=$O(BUCKET(DAY)) Q:DAY="" D
. S:'$D(^TMP("MAG",$J,"RTD2",DAY)) P4=P4+1,^TMP("MAG",$J,"RTD2",DAY,0)=DAY
. S D1=0,DEST="" F S DEST=$O(BUCKET(DAY,DEST)) Q:DEST="" D
. . S D1=D1+1
. . S X=$G(BUCKET(DAY,DEST,2,1)) ; Less than 5 minutes
. . S X=X_"^"_$G(BUCKET(DAY,DEST,2,2)) ; Less than 15 minutes
. . S X=X_"^"_$G(BUCKET(DAY,DEST,2,3)) ; Less than 1 hour
. . S X=X_"^"_$G(BUCKET(DAY,DEST,2,4)) ; 1 hour or more
. . S X=X_"^"_$G(BUCKET(DAY,DEST,2)) ; Longest
. . S X=X_"^Duration ("_NAME(DEST)_")"
. . S ^TMP("MAG",$J,"RTD2",DAY,1,D1,0)=X
. . S D1=D1+1
. . S X=$G(BUCKET(DAY,DEST,1,1)) ; Less than 5 minutes
. . S X=X_"^"_$G(BUCKET(DAY,DEST,1,2)) ; Less than 15 minutes
. . S X=X_"^"_$G(BUCKET(DAY,DEST,1,3)) ; Less than 1 hour
. . S X=X_"^"_$G(BUCKET(DAY,DEST,1,4)) ; 1 hour or more
. . S X=X_"^"_$G(BUCKET(DAY,DEST,1)) ; Longest
. . S X=X_"^Lag ("_NAME(DEST)_")"
. . S ^TMP("MAG",$J,"RTD2",DAY,1,D1,0)=X
. . Q
. S:DAY>P3 P3=DAY
. Q
; Purge old entries
S R=$G(^MAGDICOM(2006.563,1,"RETAIN ROUTING STATISTICS")) S:R<1 R=30
S DAY=$$HTFM^XLFDT($H-R)
S D0=0 F S D0=$O(^TMP("MAG",$J,"RTD2",D0)) Q:'D0 Q:D0'<DAY D
. K ^TMP("MAG",$J,"RTD2",D0) S P4=P4-1
. Q
;
D ; Get routing statistics
. N A,W
. S (A,DAY)=0 F S DAY=$O(^TMP("MAG",$J,"RTD2",DAY)) Q:'DAY D
. . S:'A N=N+1,OUT(N)="Route",A=1
. . S N=N+1,OUT(N)="RDT="_DAY
. . S W=0 F S W=$O(^TMP("MAG",$J,"RTD2",DAY,1,W)) Q:'W D
. . . S X=$G(^TMP("MAG",$J,"RTD2",DAY,1,W,0))
. . . S N=N+1,OUT(N)="DST="_$P($P($P(X,"^",6),"(",2),")",1)
. . . S W=W+1,$P(X,"^",6,10)=$P($G(^TMP("MAG",$J,"RTD2",DAY,1,W,0)),"^",1,5)
. . . S N=N+1,OUT(N)="RST="_X
. . . Q
. . Q
. S:A N=N+1,OUT(N)="RouteEnd"
. Q
K ^TMP("MAG",$J,"RTD1")
K ^TMP("MAG",$J,"RTD2")
K ^TMP("MAG",$J,"RTD3")
Q
;
DELTA(START,STOP) N D,D1,D2,T1,T2
S D1=$P(START,".",1),D2=$P(STOP,".",1)
S T1=START*1E6#1E6,T2=STOP*1E6#1E6
S T1=T1\10000*60+(T1\100#100)*60+(T1#100)
S T2=T2\10000*60+(T2\100#100)*60+(T2#100)
S D=0 S:D1'=D2 D=$$FMTH^XLFDT(D2)-$$FMTH^XLFDT(D1)
Q D*86400+T2-T1
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMAGDRPC2 9136 printed Sep 23, 2025@19:37:33 Page 2
MAGDRPC2 ;WOIFO/EDM/PMK - Imaging RPCs ; Feb 15, 2022@10:47:46
+1 ;;3.0;IMAGING;**11,30,51,50,54,305**;Mar 19, 2002;Build 3
+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 ;
SERVICE(OUT) ; RPC = MAG DICOM GET SERVICE INFO
+1 NEW D0,X
+2 SET D0=$ORDER(^MAG(2006.1,0))
SET OUT="-1,No Imaging Site Parameters defined"
if 'D0
QUIT
+3 SET X=$GET(^MAG(2006.1,D0,"GW"))
+4 SET OUT=$$ENCRYP^ROUTINE($$DECRYP($PIECE(X,"^",1))_";"_$$DECRYP($PIECE(X,"^",2)))
+5 QUIT
+6 ;
SAME(SET,D0,NODE,PIECE,X) ; Called from FileMan ^DD
+1 NEW L0
+2 SET L0=0
FOR
SET L0=$ORDER(^MAG(2006.1,L0))
if 'L0
QUIT
if L0'=D0
Begin DoDot:1
+3 SET $PIECE(^MAG(2006.1,L0,NODE),"^",PIECE)=$SELECT(SET:X,1:"")
+4 QUIT
End DoDot:1
+5 QUIT
+6 ;
IMAGE(OUT,D0) ; RPC = MAG DICOM GET BASIC IMAGE
+1 NEW I,MSG,TARGET,V,VE,VI,X
+2 KILL OUT
SET I=1
+3 IF '$GET(D0)
SET OUT(1)="-1,Invalid IEN ("_$GET(D0)_")"
QUIT
+4 IF $DATA(^MAG(2005.1,D0,0))
SET OUT(1)="-3,Image #"_D0_" has been deleted."
QUIT
+5 IF '$DATA(^MAG(2005,D0,0))
SET OUT(1)="-2,No data for """_D0_"""."
QUIT
+6 ;
+7 DO GETS^DIQ(2005,D0_",","*","REIN","TARGET","MSG")
+8 SET X=""
FOR
SET X=$ORDER(TARGET(2005,D0_",",X))
if X=""
QUIT
Begin DoDot:1
+9 SET VI=$GET(TARGET(2005,D0_",",X,"I"))
+10 SET VE=$GET(TARGET(2005,D0_",",X,"E"))
+11 SET I=I+1
SET OUT(I)=X_"^"_VI
if VI'=VE
SET OUT(I)=OUT(I)_"^"_VE
+12 QUIT
End DoDot:1
+13 ;
+14 DO FILEFIND^MAGDFB(D0,"FULL",0,0,.X,.V)
+15 if X'<0
SET I=I+1
SET OUT(I)="Full FileName^"_X
+16 if V'<0
SET I=I+1
SET OUT(I)="Full Path+FileName^"_V
+17 ;
+18 DO FILEFIND^MAGDFB(D0,"BIG",0,0,.X,.V)
+19 if X'<0
SET I=I+1
SET OUT(I)="Big FileName^"_X
+20 if V'<0
SET I=I+1
SET OUT(I)="Big Path+FileName^"_V
+21 ;
+22 DO FILEFIND^MAGDFB(D0,"ABSTRACT",0,0,.X,.V)
+23 if X'<0
SET I=I+1
SET OUT(I)="Abstract FileName^"_X
+24 if V'<0
SET I=I+1
SET OUT(I)="Abstract Path+FileName^"_V
+25 ;
+26 SET (V,X)=0
FOR
SET X=$ORDER(^MAG(2005,D0,1,X))
if 'X
QUIT
SET V=V+1
+27 if V
SET I=I+1
SET OUT(I)="# Images^"_V
+28 ;
+29 SET OUT(1)=I-1
+30 QUIT
+31 ;
GRPIMG(OUT,D0) ; RPC = MAG DICOM GET IMAGE GROUP
+1 NEW I,D1,X
+2 ; patient safety
DO CHK^MAGGSQI(.OUT,D0)
IF +$GET(OUT(0))'=1
QUIT
+3 KILL OUT
SET I=1
+4 SET D1=0
FOR
SET D1=$ORDER(^MAG(2005,D0,1,D1))
if 'D1
QUIT
Begin DoDot:1
+5 SET X=$PIECE($GET(^MAG(2005,D0,1,D1,0)),"^",1)
if 'X
QUIT
+6 SET I=I+1
SET OUT(I)=X
+7 QUIT
End DoDot:1
+8 SET OUT(1)=I-1
+9 QUIT
+10 ;
IMAGNEW(OUT,ARTIFACTIX) ; RPC = MAG DICOM GET NEW SOP DB IMAGE - P305 PMK 12/02/2021
+1 NEW ARTIFACTINSTIX,DISKVOLUME,FILEREF,FILEPATH,I,PHYSICALREF
+2 IF '$GET(ARTIFACTIX)
SET OUT="-1,Invalid IEN ("_$GET(ARTIFACTIX)_")"
QUIT
+3 ; get first Artifact Instance pointer
SET ARTIFACTINSTIX=$ORDER(^MAGV(2006.918,"B",ARTIFACTIX,""))
+4 IF ARTIFACTINSTIX=""
SET OUT="-2,No data for """_ARTIFACTIX_"""."
QUIT
+5 ; FILEREF (filename)
SET FILEREF=$$UP^MAGDFCNV($$GET1^DIQ(2006.918,ARTIFACTINSTIX,6))
+6 ; DISK VOLUME
SET DISKVOLUME=$$GET1^DIQ(2006.918,ARTIFACTINSTIX,7,"I")
+7 ; PHYSICAL REFERENCE
SET PHYSICALREF=$$GET1^DIQ(2005.2,DISKVOLUME,1)
+8 ; FILEPATH
SET FILEPATH=$$GET1^DIQ(2006.918,ARTIFACTINSTIX,8)
+9 SET OUT=PHYSICALREF_FILEPATH_FILEREF
+10 QUIT
+11 ;
DECRYP(X) QUIT $SELECT(X="":"",1:$$DECRYP^ROUTINE(X))
+1 ;
IMGVER(OUT) ; RPC = MAG DICOM GET VERSION
+1 NEW D0,DATINS,FME,FML,I,L,N,P,PATCH,X
+2 DO FIND^DIC(9.7,"",".01;2I;51I","QU","MAG*3.0","*","B","","","FML","FME")
+3 SET I=""
FOR
SET I=$ORDER(FML("DILIST","ID",I))
if I=""
QUIT
Begin DoDot:1
+4 SET N=$GET(FML("DILIST","ID",I,.01))
if $PIECE(N,"*",2)'="3.0"
QUIT
+5 SET PATCH=$PIECE(N,"*",3)
if 'PATCH
QUIT
+6 SET PATCH(PATCH)=1
+7 SET DATINS=$GET(FML("DILIST","ID",I,2))
if DATINS=""
QUIT
+8 SET P=$GET(FML("DILIST","ID",I,51))
if P=""
QUIT
+9 SET L(DATINS,PATCH_"-"_P)=""
+10 QUIT
End DoDot:1
+11 ;
+12 SET (DATINS,L,OUT)=""
FOR
SET DATINS=$ORDER(L(DATINS),-1)
if DATINS=""
QUIT
Begin DoDot:1
+13 SET PATCH=""
FOR
SET PATCH=$ORDER(L(DATINS,PATCH))
if PATCH=""
QUIT
Begin DoDot:2
+14 if OUT=""
SET OUT=PATCH
+15 if $GET(PATCH(+PATCH))
SET PATCH(+PATCH)=0
SET L=(+PATCH)_","_L
+16 QUIT
End DoDot:2
+17 QUIT
End DoDot:1
+18 SET OUT=L_OUT
+19 QUIT
+20 ;
PLACE(LOCATION) NEW D0,FST,LST
+1 SET FST=+$ORDER(^MAG(2006.1,0))
SET LST=+$ORDER(^MAG(2006.1," "),-1)
if LST=FST
QUIT FST
+2 SET D0=$ORDER(^MAG(2006.1,"B",+$GET(LOCATION),""))
if D0
QUIT D0
+3 QUIT FST
+4 ;
ROUTEDAY ; Scan for Routing Activity
+1 ;- Daily tallies
NEW BUCKET
+2 ;----- Image pointer for child of current parent
NEW D0
+3 ;----- Pointer to multiple in image file
NEW D1
+4 ;----- Loop counter
NEW D4
+5 ;---- Current FileMan date
NEW DAY
+6 ;- Current FileMan timestamp
NEW DAYTIM
+7 ;--- Destination
NEW DEST
+8 ;-- First date for scan
NEW FIRST
+9 ;--- First transmission for current study
NEW FSTX
+10 ;-- Image Pointer for current image
NEW IMAGE
+11 ;--- Last date for scan
NEW LAST
+12 ;--- Timestamp for last queue entry in current study
NEW LSTQ
+13 ;----- Highest IEN in statistics file
NEW P3
+14 ;----- Number of entries in statistics file
NEW P4
+15 ;- Image Pointer for parent of current image
NEW PARENT
+16 ;------ Retention Period
NEW R
+17 ;------ Scratch
NEW X
+18 ;--- Total duration of transmissions for current study
NEW XMIT
+19 ;
+20 KILL ^TMP("MAG",$JOB,"RTD1")
+21 KILL ^TMP("MAG",$JOB,"RTD2")
+22 KILL ^TMP("MAG",$JOB,"RTD3")
+23 SET FIRST=$$HTFM^XLFDT($HOROLOG-4)
+24 SET LAST=$$HTFM^XLFDT($HOROLOG+2)
+25 ;
+26 SET DEST=""
FOR
SET DEST=$ORDER(^MAG(2005,"ROUTE",DEST))
if DEST=""
QUIT
Begin DoDot:1
+27 SET NAME(DEST)=$PIECE($GET(^MAG(2005.2,DEST,0)," ? "_DEST),"^",1)
+28 SET DAYTIM=FIRST
FOR
Begin DoDot:2
+29 SET DAY=DAYTIM\1
+30 SET IMAGE=""
FOR
SET IMAGE=$ORDER(^MAG(2005,"ROUTE",DEST,DAYTIM,IMAGE))
if IMAGE=""
QUIT
Begin DoDot:3
+31 SET PARENT=$PIECE($GET(^MAG(2005,IMAGE,0)),"^",10)
+32 IF PARENT
IF $GET(^TMP("MAG",$JOB,"RTD3",PARENT))
SET PARENT=0
+33 if PARENT
SET ^TMP("MAG",$JOB,"RTD3",PARENT)=1
+34 SET (XMIT,LSTQ)=0
SET FSTX=1E9
+35 SET D0=IMAGE
SET D1=0
Begin DoDot:4
+36 if 'D0
QUIT
+37 if $DATA(^TMP("MAG",$JOB,"RTD1",D0,D1))
QUIT
+38 SET ^TMP("MAG",$JOB,"RTD1",D0,D1)=""
+39 SET D4=0
FOR
SET D4=$ORDER(^MAG(2005,D0,4,D4))
if 'D4
QUIT
Begin DoDot:5
+40 SET X=$GET(^MAG(2005,D0,4,D4,0))
+41 if $PIECE($PIECE(X,"^",1),".",1)'=DAY
QUIT
+42 if $PIECE(X,"^",2)'=DEST
QUIT
+43 if $PIECE(X,"^",6)>LSTQ
SET LSTQ=$PIECE(X,"^",6)
+44 if $PIECE(X,"^",5)<FSTX
SET FSTX=$PIECE(X,"^",5)
+45 SET XMIT=XMIT+$$DELTA($PIECE(X,"^",5),$PIECE(X,"^",1))
+46 QUIT
End DoDot:5
+47 QUIT
End DoDot:4
IF PARENT
FOR
SET D1=$ORDER(^MAG(2005,PARENT,1,D1))
if 'D1
QUIT
SET D0=+$PIECE($GET(^MAG(2005,PARENT,1,D1,0)),"^",1)
Begin DoDot:4
End DoDot:4
+48 SET X=$$DELTA(LSTQ,FSTX)
+49 if X>$GET(BUCKET(DAY,DEST,1))
SET BUCKET(DAY,DEST,1)=X
+50 SET X=$SELECT(X<300:1,X<900:2,X<3600:3,1:4)
+51 SET BUCKET(DAY,DEST,1,X)=$GET(BUCKET(DAY,DEST,1,X))+1
+52 if XMIT>$GET(BUCKET(DAY,DEST,2))
SET BUCKET(DAY,DEST,2)=XMIT
+53 SET X=$SELECT(XMIT<300:1,XMIT<900:2,XMIT<3600:3,1:4)
+54 SET BUCKET(DAY,DEST,2,X)=$GET(BUCKET(DAY,DEST,2,X))+1
+55 QUIT
End DoDot:3
+56 QUIT
End DoDot:2
SET DAYTIM=$ORDER(^MAG(2005,"ROUTE",DEST,DAYTIM))
if DAYTIM=""
QUIT
if DAYTIM'<LAST
QUIT
+57 QUIT
End DoDot:1
+58 ;
+59 SET X=$GET(^TMP("MAG",$JOB,"RTD2",0))
SET P3=+$PIECE(X,"^",3)
SET P4=+$PIECE(X,"^",4)
+60 SET DAY=""
FOR
SET DAY=$ORDER(BUCKET(DAY))
if DAY=""
QUIT
Begin DoDot:1
+61 if '$DATA(^TMP("MAG",$JOB,"RTD2",DAY))
SET P4=P4+1
SET ^TMP("MAG",$JOB,"RTD2",DAY,0)=DAY
+62 SET D1=0
SET DEST=""
FOR
SET DEST=$ORDER(BUCKET(DAY,DEST))
if DEST=""
QUIT
Begin DoDot:2
+63 SET D1=D1+1
+64 ; Less than 5 minutes
SET X=$GET(BUCKET(DAY,DEST,2,1))
+65 ; Less than 15 minutes
SET X=X_"^"_$GET(BUCKET(DAY,DEST,2,2))
+66 ; Less than 1 hour
SET X=X_"^"_$GET(BUCKET(DAY,DEST,2,3))
+67 ; 1 hour or more
SET X=X_"^"_$GET(BUCKET(DAY,DEST,2,4))
+68 ; Longest
SET X=X_"^"_$GET(BUCKET(DAY,DEST,2))
+69 SET X=X_"^Duration ("_NAME(DEST)_")"
+70 SET ^TMP("MAG",$JOB,"RTD2",DAY,1,D1,0)=X
+71 SET D1=D1+1
+72 ; Less than 5 minutes
SET X=$GET(BUCKET(DAY,DEST,1,1))
+73 ; Less than 15 minutes
SET X=X_"^"_$GET(BUCKET(DAY,DEST,1,2))
+74 ; Less than 1 hour
SET X=X_"^"_$GET(BUCKET(DAY,DEST,1,3))
+75 ; 1 hour or more
SET X=X_"^"_$GET(BUCKET(DAY,DEST,1,4))
+76 ; Longest
SET X=X_"^"_$GET(BUCKET(DAY,DEST,1))
+77 SET X=X_"^Lag ("_NAME(DEST)_")"
+78 SET ^TMP("MAG",$JOB,"RTD2",DAY,1,D1,0)=X
+79 QUIT
End DoDot:2
+80 if DAY>P3
SET P3=DAY
+81 QUIT
End DoDot:1
+82 ; Purge old entries
+83 SET R=$GET(^MAGDICOM(2006.563,1,"RETAIN ROUTING STATISTICS"))
if R<1
SET R=30
+84 SET DAY=$$HTFM^XLFDT($HOROLOG-R)
+85 SET D0=0
FOR
SET D0=$ORDER(^TMP("MAG",$JOB,"RTD2",D0))
if 'D0
QUIT
if D0'<DAY
QUIT
Begin DoDot:1
+86 KILL ^TMP("MAG",$JOB,"RTD2",D0)
SET P4=P4-1
+87 QUIT
End DoDot:1
+88 ;
+89 ; Get routing statistics
Begin DoDot:1
+90 NEW A,W
+91 SET (A,DAY)=0
FOR
SET DAY=$ORDER(^TMP("MAG",$JOB,"RTD2",DAY))
if 'DAY
QUIT
Begin DoDot:2
+92 if 'A
SET N=N+1
SET OUT(N)="Route"
SET A=1
+93 SET N=N+1
SET OUT(N)="RDT="_DAY
+94 SET W=0
FOR
SET W=$ORDER(^TMP("MAG",$JOB,"RTD2",DAY,1,W))
if 'W
QUIT
Begin DoDot:3
+95 SET X=$GET(^TMP("MAG",$JOB,"RTD2",DAY,1,W,0))
+96 SET N=N+1
SET OUT(N)="DST="_$PIECE($PIECE($PIECE(X,"^",6),"(",2),")",1)
+97 SET W=W+1
SET $PIECE(X,"^",6,10)=$PIECE($GET(^TMP("MAG",$JOB,"RTD2",DAY,1,W,0)),"^",1,5)
+98 SET N=N+1
SET OUT(N)="RST="_X
+99 QUIT
End DoDot:3
+100 QUIT
End DoDot:2
+101 if A
SET N=N+1
SET OUT(N)="RouteEnd"
+102 QUIT
End DoDot:1
+103 KILL ^TMP("MAG",$JOB,"RTD1")
+104 KILL ^TMP("MAG",$JOB,"RTD2")
+105 KILL ^TMP("MAG",$JOB,"RTD3")
+106 QUIT
+107 ;
DELTA(START,STOP) NEW D,D1,D2,T1,T2
+1 SET D1=$PIECE(START,".",1)
SET D2=$PIECE(STOP,".",1)
+2 SET T1=START*1E6#1E6
SET T2=STOP*1E6#1E6
+3 SET T1=T1\10000*60+(T1\100#100)*60+(T1#100)
+4 SET T2=T2\10000*60+(T2\100#100)*60+(T2#100)
+5 SET D=0
if D1'=D2
SET D=$$FMTH^XLFDT(D2)-$$FMTH^XLFDT(D1)
+6 QUIT D*86400+T2-T1
+7 ;
