- 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 Jan 18, 2025@03:02:34 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 ;