MAGDRPC9 ;WOIFO/EDM/MLH/JSL/SAF/DAC/PMK/JSJ - Imaging RPCs ; Jun 23, 2022@15:30:40
;;3.0;IMAGING;**50,54,53,49,123,118,138,180,190,239,280,305,307**;Mar 19, 2002;Build 28
;; 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. |
;; +---------------------------------------------------------------+
;;
;
; Reference to FIND1^DIC in ICR #2051
; Reference to GET1^DIQ in ICR #2056
; Reference to ^RA(74 in ICR #1171
; Reference to ^RA(70 in ICR #1172
; Reference to ACCFIND^RAAPI in ICR #5020
; Reference to HDIFF^XLFDT in ICR #10103
; Reference to HTFM^XLFDT in ICR #10103
; Reference to GETICN^MPIF001 in ICR #2701
;
Q
;
UIDROOT(OUT) ; RPC = MAG DICOM GET UID ROOT
S OUT=$G(^MAGD(2006.15,1,"UID ROOT"))
Q
;
NEWUID(OUT,OLD,NEW,IMAGE,DBTYPE) ; RPC = MAG NEW SOP INSTANCE UID
N D0,L,X,SOPREC,ORIGSOP
S DBTYPE=$G(DBTYPE,"OLD")
S IMAGE=+$G(IMAGE),OLD=$G(OLD)
S:$G(NEW)="" NEW=OLD
D:DBTYPE="OLD"
. S D0=IMAGE
. I 'D0 S OUT="-2,Cannot find image with UID "_OLD Q
. S OUT=$P($G(^MAG(2005,D0,"SOP")),"^",2) Q:OUT'=""
. S L=$L(NEW,".")-1,X=$P(NEW,".",L+1),L=$P(NEW,".",1,L)_"."
. L +^MAG(2005,"P"):1E9 ; Background process MUST wait
. S OUT="" F D Q:OUT'=""
. . S OUT=L_X
. . I $L(OUT)>64 S OUT="-3,Cannot use "_NEW_" to create valid UID" Q
. . I $D(^MAG(2005,"P",OUT)) S OUT="",X=X+1 Q
. . S $P(^MAG(2005,D0,"SOP"),"^",2)=OUT
. . S ^MAG(2005,"P",OUT,D0)=1
. . Q
. L -^MAG(2005,"P")
. Q
D:DBTYPE="NEW"
. S D0=0 S:OLD'="" D0=$O(^MAGV(2005.64,"B",OLD,""))
. I IMAGE,D0,IMAGE'=D0 S OUT="-1,UID cannot belong to multiple images ("_IMAGE_"/"_D0_")" Q
. I IMAGE,'D0 S D0=IMAGE
. S SOPREC=$G(^MAGV(2005.64,D0,0))
. I SOPREC="" S OUT="-2,IMAGE SOP INSTANCE record not found ("_D0_")" Q
. S ORIGSOP=$P(SOPREC,"^",2)
. I ORIGSOP'="" D Q
. . I OLD=ORIGSOP S OUT=$P(SOPREC,"^",1) Q
. . S OUT="-3,ORIGINAL SOP INSTANCE UID for image ("_ORIGSOP
. . S OUT=OUT_") does not match value sent ("_OLD
. . Q
. ; need to verify and store the new SOP
. S L=$L(NEW,".")-1,X=$P(NEW,".",L+1),L=$P(NEW,".",1,L)_"."
. L +^MAGV(2005.64,"B"):1E9 ; Background process MUST wait
. S OUT="" F D Q:OUT'=""
. . S OUT=L_X
. . I $L(OUT)>64 S OUT="-3,Cannot use "_NEW_" to create valid UID" Q
. . I $D(^MAGV(2005.64,"B",OUT)) S OUT="",X=X+1 Q
. . S $P(SOPREC,"^",2)=$P(SOPREC,"^",1) K ^MAGV(2005.64,"B",$P(SOPREC,"^",1),D0)
. . S $P(SOPREC,"^",1)=OUT,^MAGV(2005.64,"B",OUT,D0)=""
. . S ^MAGV(2005.64,D0,0)=SOPREC
. . Q
. L -^MAGV(2005.64,"B")
. Q
Q
;
QRNEWUID(IDX,DBTYPE) ; Get updated UID for Query/Retrieve - P280 DAC - Modified to reflect that index can be Image or SOP
N DATE,DH,FAIL,I,OLD,OUT,NEW,LASTUID,NEXTUID,TIME,X,Y
S DBTYPE=$G(DBTYPE,"OLD")
; P280 DAC - Modified to set the indexes based on the type of data base referenced
I DBTYPE="OLD" S IMAGE=+$G(IDX)
I DBTYPE="NEW" S SOPIX=+$G(IDX)
D:DBTYPE="OLD" ; find new UID, if any, in legacy DB
. S NEW=$P($G(^MAG(2005,IMAGE,"PACS")),"^",1) ; P239 DAC - Modified to pull from PACS node (not SOP)
. Q
D:DBTYPE="NEW" ; find new UID, if any, in P34 DB
. ; P280 DAC - Modified to use the SOP index instead of the Image index
. S NEW="" S:$P($G(^MAGV(2005.64,SOPIX,0)),"^",2)'="" NEW=$P(^(0),"^",1)
. Q
Q:NEW'="" NEW
; Generate the next UID using date/time and counter
L +^MAGDICOM(2006.563,1,"MACHINE ID"):1E9 ; Background process must wait
S LASTUID=$G(^MAGDICOM(2006.563,1,"LAST UID"))
; Can't use D NOW^XLFDT to set DH because it is incorrect at midnight
S DH=$H,X=$$HTFM^XLFDT(DH,1),DATE=X+17000000
S X=$P(DH,",",2) D
. N H,M,S
. S H=X\3600,M=X\60#60,S=X#60
. S TIME=H*100+M*100+S
. Q
S NEXTUID=$G(^MAGD(2006.15,1,"UID ROOT"))
I NEXTUID="" S $EC=",13:No UID Root defined - Run INIT^MAGDRUID," ; Fatal Error
; UID type = 7, Machine ID = 0
S NEXTUID=NEXTUID_".1.7."_(+$G(DUZ(2)))_".0."_DATE_"."_TIME_".0"
; Remove leading 0s from UID components
F I=1:1:$L(NEXTUID,".") S $P(NEXTUID,".",I)=+$P(NEXTUID,".",I)
I $P(NEXTUID,".",1,10)=$P(LASTUID,".",1,10) D
. S NEXTUID=LASTUID
. S $P(NEXTUID,".",11)=$P(NEXTUID,".",11)+1
. Q
S ^MAGDICOM(2006.563,1,"LAST UID")=NEXTUID
L -^MAGDICOM(2006.563,1,"MACHINE ID")
; P280 DAC - Modified new data structure to use the SOP index instead of the Image index
S OLD=$S(DBTYPE="OLD":$P($G(^MAG(2005,IMAGE,"PACS")),"^",1),1:$P($G(^MAGV(2005.64,SOPIX,0)),"^",1))
; P280 DAC - Modifed to send the correct index type for each both DB types
D NEWUID(.OUT,OLD,NEXTUID,IDX,DBTYPE) ; Store the new UID with the image
Q OUT
;
NEXT(OUT,SEED,DIR) ; RPC = MAG RAD GET NEXT RPT BY DATE
N D2,DFN,EXAMDATE,NAME
;
; ^RADPT(DFN,"DT",D1,"P",D2,0) = Data, $P(17) = pointer to report
; ^RADPT("AR",9999999.9999-D1,DFN,D1)="" ; IA # 65
;
; OUT = report_pointer ^ ExamDate ^ Patient ^ D2
;
S SEED=$G(SEED),DIR=$S($G(DIR)<0:-1,1:1) ; default is ascending order
S EXAMDATE=$P(SEED,"^",1),DFN=$P(SEED,"^",2),D2=$P(SEED,"^",3)
S OUT=0 F D Q:OUT
. I EXAMDATE="" S EXAMDATE=$O(^RADPT("AR",""),DIR),DFN="" ; IA # 65
. I EXAMDATE="" S OUT=-1 Q
. I DFN="" S DFN=$O(^RADPT("AR",EXAMDATE,""),DIR) ; IA # 65
. I DFN="" S EXAMDATE=$O(^RADPT("AR",EXAMDATE),DIR),D2="" Q ; IA # 65
. S:'D2 D2=$S(DIR>0:0,1:" ")
. S D2=$O(^RADPT(DFN,"DT",9999999.9999-EXAMDATE,"P",D2),DIR) ; IA # 1172
. I 'D2 D Q
. . S DFN=$O(^RADPT("AR",EXAMDATE,DFN),DIR),D2="" ; IA # 65
. . I 'DFN D
. . . S EXAMDATE=$O(^RADPT("AR",EXAMDATE),DIR),DFN="" ; IA # 65
. . . I EXAMDATE="" S OUT=-1
. . . Q
. . Q
. S OUT=$P($G(^RADPT(DFN,"DT",9999999.9999-EXAMDATE,"P",D2,0)),"^",17) ; IA # 1172
. S:OUT OUT=OUT_"^"_EXAMDATE_"^"_DFN_"^"_D2
. Q
Q
;
NXTPTRPT(OUT,DFN,RARPT1,DIR) ; RPC = MAG RAD GET NEXT RPT BY PT
S DFN=$G(DFN)
I 'DFN S OUT="-1,Patient DFN not passed" Q
I '$D(^RARPT("C",DFN)) S OUT="-2,Patient does not have any radiology reports" Q ; IA # 2442
S RARPT1=$G(RARPT1),DIR=$S($G(DIR)<0:-1,1:1) ; default is ascending order
S OUT=$O(^RARPT("C",DFN,RARPT1),DIR) ; IA # 2442
Q
;
GETICN(OUT,DFN) ; RPC = MAG DICOM GET ICN
S OUT=$S($T(GETICN^MPIF001)'="":$$GETICN^MPIF001(DFN),1:"-1^NO MPI")
Q
;
INIT(OUT,LOCATION,COUNTONLY) ; RPC = MAG DICOM QUEUE INIT (moved from ^MAGDRPC4)
N ACNUMB,COUNT,D0,D1,IMAGEDB,N,PRIORITY,REQUESTDATETIME,STATE,STUDYUID,X,Y ; P305 PMK 05/12/2021
I $G(LOCATION)="" S OUT="-3,No origin specified." Q
I '$D(^MAGDOUTP(2006.574,0)) S OUT="-1,No entries at all in queue." Q
S COUNTONLY=$G(COUNTONLY,0) ; P305 PMK 11/17/2021
;
; check for deleting the entire DICOM OBJECT EXPORT file - P305 PMK 01/07/2022
I LOCATION="ALL" D Q
. S N=$P($G(^MAGDOUTP(2006.574,0)),"^",4)
. I COUNTONLY D
. . I N D
. . . S OUT=$S(N=1:"One entry is",1:N_" entries are")
. . . S OUT=OUT_" present in the Image Transmission Queues for all locations."
. . . Q
. . E S OUT="-2,No entries are present in the Image Transmission Queue."
. . Q
. E D
. . L +^MAGDOUTP(2006.574):1E9
. . K ^MAGDOUTP(2006.574)
. . S ^MAGDOUTP(2006.574,0)="DICOM OBJECT EXPORT^2006.574^0^0"
. . L -^MAGDOUTP(2006.574)
. . S OUT="Image Transmission Queue completely initialized, "
. . S OUT=OUT_$S(N=1:"one entry was",1:N_" entries were")_" deleted."
. . Q
. Q
;
; deleting only a single location
S N=0,OUT="-2,No entries are present in"
L +^MAGDOUTP(2006.574):1E9 ; P180 DAC - Lock entire global, background process MUST wait
S D0=0 F S D0=$O(^MAGDOUTP(2006.574,D0)) Q:'D0 S X=$G(^(D0,0)) Q:$P(X,"^",4)'=LOCATION D
. S N=N+1 Q:COUNTONLY
. S ACNUMB=$P(X,"^",3),PRIORITY=$P(X,"^",5)
. S REQUESTDATETIME=$P(X,"^",7),IMAGEDB=$P(X,"^",8)
. S STUDYUID=$G(^MAGDOUTP(2006.574,D0,2))
. S D1=0 F S D1=$O(^MAGDOUTP(2006.574,D0,1,D1)) Q:'D1 S Y=$G(^(D1,0)) D
. . S STATE=$P(Y,"^",2)
. . K ^MAGDOUTP(2006.567,D0,1,D1)
. . K ^MAGDOUTP(2006.574,"STATE",LOCATION,PRIORITY,STATE,D0,D1)
. . Q
. K ^MAGDOUTP(2006.574,D0)
. K:REQUESTDATETIME'="" ^MAGDOUTP(2006.574,"C",REQUESTDATETIME,D0)
. K:ACNUMB'="" ^MAGDOUTP(2006.574,"D",ACNUMB,D0) ; P305 PMK 05/12/2021
. I STUDYUID'="",IMAGEDB'="" K ^MAGDOUTP(2006.574,"STUDY",STUDYUID,IMAGEDB,D0)
. Q
I N D
. I COUNTONLY S OUT=$S(N=1:"One entry is",1:N_" entries are")_" present in"
. E D
. . S COUNT=$P(^MAGDOUTP(2006.574,0),"^",4)-N
. . I COUNT<0 S COUNT=0 ; don't let count become negative
. . S $P(^MAGDOUTP(2006.574,0),"^",4)=COUNT ; P305 PMK 05/12/2021
. . S $P(^MAGDOUTP(2006.574,0),"^",3)=0 ; P305 PMK 05/12/2021
. . S OUT=$S(N=1:"One entry has",1:N_" entries have been")_" deleted from"
. . Q
. Q
S OUT=OUT_" the queue for "_$$GET1^DIQ(4,LOCATION,.01)_"."
L -^MAGDOUTP(2006.574) ; P180 DAC - Unlock global
Q
;
IENLOOK ; Overflow from MAGDRPC4
; lookup image by the IEN
N ACNUMB,D0,DFN,GROUPIEN,MODIFIER,P,PROCNAME,STUDYDAT,X,Y
S NUMBER=+$P(NUMBER,"`",2)
; patient safety checks
D CHK^MAGGSQI(.X,NUMBER) I +$G(X(0))'=1 D Q
. S OUT(1)="-9,"_$P(X(0),"^",2,999)
. Q
S GROUPIEN=$P($G(^MAG(2005,NUMBER,0)),"^",10)
I GROUPIEN D CHK^MAGGSQI(.X,GROUPIEN) I +$G(X(0))'=1 D Q
. S OUT(1)="-10,Group #"_GROUPIEN_": "_$P(X(0),"^",2,999)
. Q
;
S X=$G(^MAG(2005,NUMBER,2)),P=$P(X,"^",6),D0=$P(X,"^",7)
I 'P!'D0 D ; get parent from group
. S:GROUPIEN X=$G(^MAG(2005,GROUPIEN,2)),P=$P(X,"^",6),D0=$P(X,"^",7)
. Q
;
S OUT(2)=P_"^"_D0_"^"_NUMBER_"^" ; result w/o Accession Number
I 'P!'D0 S OUT(1)="-6,Warning - Parent file entry is not present - no Accession Number."
E I P=74 D
. N DATETIME,I,INFO,PROC,RADPT0,RADPT1,RADPT2,RADPT3,RARPT0
. S X=$$ACCRPT^RAAPI(D0,.INFO)
. I X<0 S OUT(1)="-11,Radiology Problem: "_X Q
. S ACNUMB=INFO(1)
. S RARPT0=$G(^RARPT(D0,0)) ; IA # 1171
. S RADPT1=$P(RARPT0,"^",2),DATETIME=$P(RARPT0,"^",3)
. S RADPT2=9999999.9999-DATETIME,RADPT3=1
. S RADPT0=$G(^RADPT(RADPT1,"DT",RADPT2,"P",RADPT3,0))
. S PROCNAME=$$GET1^DIQ(71,$P(RADPT0,"^",2),.01)
. S STUDYDAT=17000000+(DATETIME\1)
. S MODIFIER=""
. S I=0 F S I=$O(^RADPT(RADPT1,"DT",RADPT2,"P",RADPT3,"M",I)) Q:'I D
. . S X=^RADPT(RADPT1,"DT",RADPT2,"P",RADPT3,"M",I,0)
. . S:I>1 MODIFIER=MODIFIER_", " S MODIFIER=MODIFIER_$$GET1^DIQ(71.2,X,.01)
. . Q
. S X=P_"^"_D0_"^"_NUMBER_"^"_ACNUMB_"^"_STUDYDAT_"^"_PROCNAME_"^"_MODIFIER
. S OUT(1)=1,OUT(2)=X
. Q
E I P=8925 D
. N GMRCIEN,LABINFO
. ; get pointer from TIU to consult request
. S X=$$GET1^DIQ(8925,D0,1405,"I") ; IA ???
. I $P(X,";",2)="GMR(123," D
. . S GMRCIEN=$P(X,";"),ACNUMB=$$GMRCACN^MAGDFCNV(GMRCIEN)
. . S STUDYDAT=17000000+($$GET1^DIQ(123,GMRCIEN,.01,"I")\1)
. . S PROCNAME=$$GET1^DIQ(123,GMRCIEN,1) ; TO SERVICE
. . S MODIFIER=$$GET1^DIQ(123,GMRCIEN,4) ; PROCEDURE
. . S X=P_"^"_D0_"^"_NUMBER_"^"_ACNUMB_"^"_STUDYDAT_"^"_PROCNAME_"^"_MODIFIER
. . S OUT(1)=1,OUT(2)=X
. . Q
. S X=$$GET1^DIQ(8925,D0,.04,"E")
. I X="LR ANATOMIC PATHOLOGY" D
. . D GETINFO(.LABINFO,D0)
. . I $D(LABINFO) D
. . S X=P_"^"_D0_"^"_NUMBER_"^"_LABINFO("ACNUMB")
. . S X=X_"^"_LABINFO("DATE")
. . S X=X_"^"_LABINFO("LAB")_"^"
. . S OUT(1)=1,OUT(2)=X
. . Q
. ; P190 DAC - Next line modified to fix consult look ups that reported errors even though they were succesful
. I $G(OUT(1))'=1 S OUT(1)="-8,Problem with parent file "_P_", internal entry number "_D0_" - no Accession Number."
. Q
E S OUT(1)="-7,Parent file "_P_" not yet supported - no Accession Number."
Q
;
GETINFO(INFO,TIUIEN) ; scan the TIU document and try to extract the accession number
N FILE ; ---- LAB DATA subfile numbers and other info
N ERRSTAT S ERRSTAT=0 ; error status - assume nothing to repor
N ABBR,ERROR,I,LRAA,LRSS,IENS,TEXT,X ;P307
S IENS=TIUIEN_","
D GETS^DIQ(8925,IENS,2,"I","TEXT","ERROR")
F I=1:1 Q:'$D(TEXT(8925,IENS,2,I)) S X=TEXT(8925,IENS,2,I) D
. I '$D(INFO("ACNUMB")),X["Accession No." D
. . S INFO("ACNUMB")=$P(X,"Accession No. ",2)
. . S ABBR=$P(INFO("ACNUMB")," ") ;P307
. . S LRAA=$$FIND1^DIC(68,"","BX",ABBR,"","","ERR") ; get lab area index ;P307
. . S LRSS=$$GET1^DIQ(68,LRAA,.02,"I") ;P307
. . S ERRSTAT=$$GETFILE^MAGT7MA(LRSS) I ERRSTAT S INFO("LAB")="" Q
. . S INFO("LAB")=FILE("NAME")
. . Q
. I '$D(INFO("DATE")),X["Date obtained: " S INFO("DATE")=$P(X,"Date obtained: ",2)
. Q
Q
;
STATS(OUT,SITE) ; RPC = MAG DICOM GET EXPORT QUEUE STS
N COUNT,D0,D1,NOUT,NOW,PRIORITY,STATE,TIME,WAIT,X,Y
K OUT
;
I '$G(SITE) S OUT(1)="-1,Location not specified" Q
;
S NOUT=1,OUT(NOUT)=0
;
S NOUT=1,NOW=$H
S PRIORITY="" F S PRIORITY=$O(^MAGDOUTP(2006.574,"STATE",SITE,PRIORITY)) Q:PRIORITY="" D
. ; Ignore states SUCCESS, NOT ON FILE, IGNORE, and HOLD
. F STATE="FAIL","WAITING","XMIT" D
. . S D0=0 F S D0=$O(^MAGDOUTP(2006.574,"STATE",SITE,PRIORITY,STATE,D0)) Q:'D0 D
. . . S Y=^MAGDOUTP(2006.574,D0,0)
. . . S D1=0 F S D1=$O(^MAGDOUTP(2006.574,"STATE",SITE,PRIORITY,STATE,D0,D1)) Q:'D1 D
. . . . S X=$G(^MAGDOUTP(2006.574,D0,1,D1,0))
. . . . S COUNT(D0,STATE)=($G(COUNT(D0,STATE))+1)_"^^"_Y
. . . . S TIME=$P(X,"^",3)
. . . . S WAIT=$$TIMEDIFF(NOW,TIME)
. . . . I $P(COUNT(D0,STATE),"^",2)<WAIT S $P(COUNT(D0,STATE),"^",2)=WAIT
. . . . Q
. . . Q
. . Q
. Q
;
; save output
S D0=0 F S D0=$O(COUNT(D0)) Q:D0="" D
. S STATE="" F S STATE=$O(COUNT(D0,STATE)) Q:STATE="" D
. . S NOUT=NOUT+1,OUT(1)=NOUT
. . S OUT(NOUT)=D0_"^"_STATE_"^"_COUNT(D0,STATE)
. . Q
. Q
;
Q
;
TIMEDIFF(T1,T2) ; formatted time difference
N RETURN,TIMEDIFF
S TIMEDIFF=$$HDIFF^XLFDT(T1,T2,2)
I TIMEDIFF>86400 D ; greater than a day
. S RETURN=$$HDIFF^XLFDT(T1,T2,1)_" days"
. Q
E I TIMEDIFF>3600 D ; greater than an hour
. S RETURN=(TIMEDIFF+1800)\3600_" hours"
. Q
E I TIMEDIFF>60 D ; greater than a minute
. S RETURN=(TIMEDIFF+30)\60_" min."
. Q
E S RETURN=TIMEDIFF_" sec."
Q RETURN
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMAGDRPC9 14696 printed Mar 10, 2023@00:07:14 Page 2
MAGDRPC9 ;WOIFO/EDM/MLH/JSL/SAF/DAC/PMK/JSJ - Imaging RPCs ; Jun 23, 2022@15:30:40
+1 ;;3.0;IMAGING;**50,54,53,49,123,118,138,180,190,239,280,305,307**;Mar 19, 2002;Build 28
+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 ;
+18 ; Reference to FIND1^DIC in ICR #2051
+19 ; Reference to GET1^DIQ in ICR #2056
+20 ; Reference to ^RA(74 in ICR #1171
+21 ; Reference to ^RA(70 in ICR #1172
+22 ; Reference to ACCFIND^RAAPI in ICR #5020
+23 ; Reference to HDIFF^XLFDT in ICR #10103
+24 ; Reference to HTFM^XLFDT in ICR #10103
+25 ; Reference to GETICN^MPIF001 in ICR #2701
+26 ;
+27 QUIT
+28 ;
UIDROOT(OUT) ; RPC = MAG DICOM GET UID ROOT
+1 SET OUT=$GET(^MAGD(2006.15,1,"UID ROOT"))
+2 QUIT
+3 ;
NEWUID(OUT,OLD,NEW,IMAGE,DBTYPE) ; RPC = MAG NEW SOP INSTANCE UID
+1 NEW D0,L,X,SOPREC,ORIGSOP
+2 SET DBTYPE=$GET(DBTYPE,"OLD")
+3 SET IMAGE=+$GET(IMAGE)
SET OLD=$GET(OLD)
+4 if $GET(NEW)=""
SET NEW=OLD
+5 if DBTYPE="OLD"
Begin DoDot:1
+6 SET D0=IMAGE
+7 IF 'D0
SET OUT="-2,Cannot find image with UID "_OLD
QUIT
+8 SET OUT=$PIECE($GET(^MAG(2005,D0,"SOP")),"^",2)
if OUT'=""
QUIT
+9 SET L=$LENGTH(NEW,".")-1
SET X=$PIECE(NEW,".",L+1)
SET L=$PIECE(NEW,".",1,L)_"."
+10 ; Background process MUST wait
LOCK +^MAG(2005,"P"):1E9
+11 SET OUT=""
FOR
Begin DoDot:2
+12 SET OUT=L_X
+13 IF $LENGTH(OUT)>64
SET OUT="-3,Cannot use "_NEW_" to create valid UID"
QUIT
+14 IF $DATA(^MAG(2005,"P",OUT))
SET OUT=""
SET X=X+1
QUIT
+15 SET $PIECE(^MAG(2005,D0,"SOP"),"^",2)=OUT
+16 SET ^MAG(2005,"P",OUT,D0)=1
+17 QUIT
End DoDot:2
if OUT'=""
QUIT
+18 LOCK -^MAG(2005,"P")
+19 QUIT
End DoDot:1
+20 if DBTYPE="NEW"
Begin DoDot:1
+21 SET D0=0
if OLD'=""
SET D0=$ORDER(^MAGV(2005.64,"B",OLD,""))
+22 IF IMAGE
IF D0
IF IMAGE'=D0
SET OUT="-1,UID cannot belong to multiple images ("_IMAGE_"/"_D0_")"
QUIT
+23 IF IMAGE
IF 'D0
SET D0=IMAGE
+24 SET SOPREC=$GET(^MAGV(2005.64,D0,0))
+25 IF SOPREC=""
SET OUT="-2,IMAGE SOP INSTANCE record not found ("_D0_")"
QUIT
+26 SET ORIGSOP=$PIECE(SOPREC,"^",2)
+27 IF ORIGSOP'=""
Begin DoDot:2
+28 IF OLD=ORIGSOP
SET OUT=$PIECE(SOPREC,"^",1)
QUIT
+29 SET OUT="-3,ORIGINAL SOP INSTANCE UID for image ("_ORIGSOP
+30 SET OUT=OUT_") does not match value sent ("_OLD
+31 QUIT
End DoDot:2
QUIT
+32 ; need to verify and store the new SOP
+33 SET L=$LENGTH(NEW,".")-1
SET X=$PIECE(NEW,".",L+1)
SET L=$PIECE(NEW,".",1,L)_"."
+34 ; Background process MUST wait
LOCK +^MAGV(2005.64,"B"):1E9
+35 SET OUT=""
FOR
Begin DoDot:2
+36 SET OUT=L_X
+37 IF $LENGTH(OUT)>64
SET OUT="-3,Cannot use "_NEW_" to create valid UID"
QUIT
+38 IF $DATA(^MAGV(2005.64,"B",OUT))
SET OUT=""
SET X=X+1
QUIT
+39 SET $PIECE(SOPREC,"^",2)=$PIECE(SOPREC,"^",1)
KILL ^MAGV(2005.64,"B",$PIECE(SOPREC,"^",1),D0)
+40 SET $PIECE(SOPREC,"^",1)=OUT
SET ^MAGV(2005.64,"B",OUT,D0)=""
+41 SET ^MAGV(2005.64,D0,0)=SOPREC
+42 QUIT
End DoDot:2
if OUT'=""
QUIT
+43 LOCK -^MAGV(2005.64,"B")
+44 QUIT
End DoDot:1
+45 QUIT
+46 ;
QRNEWUID(IDX,DBTYPE) ; Get updated UID for Query/Retrieve - P280 DAC - Modified to reflect that index can be Image or SOP
+1 NEW DATE,DH,FAIL,I,OLD,OUT,NEW,LASTUID,NEXTUID,TIME,X,Y
+2 SET DBTYPE=$GET(DBTYPE,"OLD")
+3 ; P280 DAC - Modified to set the indexes based on the type of data base referenced
+4 IF DBTYPE="OLD"
SET IMAGE=+$GET(IDX)
+5 IF DBTYPE="NEW"
SET SOPIX=+$GET(IDX)
+6 ; find new UID, if any, in legacy DB
if DBTYPE="OLD"
Begin DoDot:1
+7 ; P239 DAC - Modified to pull from PACS node (not SOP)
SET NEW=$PIECE($GET(^MAG(2005,IMAGE,"PACS")),"^",1)
+8 QUIT
End DoDot:1
+9 ; find new UID, if any, in P34 DB
if DBTYPE="NEW"
Begin DoDot:1
+10 ; P280 DAC - Modified to use the SOP index instead of the Image index
+11 SET NEW=""
if $PIECE($GET(^MAGV(2005.64,SOPIX,0)),"^",2)'=""
SET NEW=$PIECE(^(0),"^",1)
+12 QUIT
End DoDot:1
+13 if NEW'=""
QUIT NEW
+14 ; Generate the next UID using date/time and counter
+15 ; Background process must wait
LOCK +^MAGDICOM(2006.563,1,"MACHINE ID"):1E9
+16 SET LASTUID=$GET(^MAGDICOM(2006.563,1,"LAST UID"))
+17 ; Can't use D NOW^XLFDT to set DH because it is incorrect at midnight
+18 SET DH=$HOROLOG
SET X=$$HTFM^XLFDT(DH,1)
SET DATE=X+17000000
+19 SET X=$PIECE(DH,",",2)
Begin DoDot:1
+20 NEW H,M,S
+21 SET H=X\3600
SET M=X\60#60
SET S=X#60
+22 SET TIME=H*100+M*100+S
+23 QUIT
End DoDot:1
+24 SET NEXTUID=$GET(^MAGD(2006.15,1,"UID ROOT"))
+25 ; Fatal Error
IF NEXTUID=""
SET $ECODE=",13:No UID Root defined - Run INIT^MAGDRUID,"
+26 ; UID type = 7, Machine ID = 0
+27 SET NEXTUID=NEXTUID_".1.7."_(+$GET(DUZ(2)))_".0."_DATE_"."_TIME_".0"
+28 ; Remove leading 0s from UID components
+29 FOR I=1:1:$LENGTH(NEXTUID,".")
SET $PIECE(NEXTUID,".",I)=+$PIECE(NEXTUID,".",I)
+30 IF $PIECE(NEXTUID,".",1,10)=$PIECE(LASTUID,".",1,10)
Begin DoDot:1
+31 SET NEXTUID=LASTUID
+32 SET $PIECE(NEXTUID,".",11)=$PIECE(NEXTUID,".",11)+1
+33 QUIT
End DoDot:1
+34 SET ^MAGDICOM(2006.563,1,"LAST UID")=NEXTUID
+35 LOCK -^MAGDICOM(2006.563,1,"MACHINE ID")
+36 ; P280 DAC - Modified new data structure to use the SOP index instead of the Image index
+37 SET OLD=$SELECT(DBTYPE="OLD":$PIECE($GET(^MAG(2005,IMAGE,"PACS")),"^",1),1:$PIECE($GET(^MAGV(2005.64,SOPIX,0)),"^",1))
+38 ; P280 DAC - Modifed to send the correct index type for each both DB types
+39 ; Store the new UID with the image
DO NEWUID(.OUT,OLD,NEXTUID,IDX,DBTYPE)
+40 QUIT OUT
+41 ;
NEXT(OUT,SEED,DIR) ; RPC = MAG RAD GET NEXT RPT BY DATE
+1 NEW D2,DFN,EXAMDATE,NAME
+2 ;
+3 ; ^RADPT(DFN,"DT",D1,"P",D2,0) = Data, $P(17) = pointer to report
+4 ; ^RADPT("AR",9999999.9999-D1,DFN,D1)="" ; IA # 65
+5 ;
+6 ; OUT = report_pointer ^ ExamDate ^ Patient ^ D2
+7 ;
+8 ; default is ascending order
SET SEED=$GET(SEED)
SET DIR=$SELECT($GET(DIR)<0:-1,1:1)
+9 SET EXAMDATE=$PIECE(SEED,"^",1)
SET DFN=$PIECE(SEED,"^",2)
SET D2=$PIECE(SEED,"^",3)
+10 SET OUT=0
FOR
Begin DoDot:1
+11 ; IA # 65
IF EXAMDATE=""
SET EXAMDATE=$ORDER(^RADPT("AR",""),DIR)
SET DFN=""
+12 IF EXAMDATE=""
SET OUT=-1
QUIT
+13 ; IA # 65
IF DFN=""
SET DFN=$ORDER(^RADPT("AR",EXAMDATE,""),DIR)
+14 ; IA # 65
IF DFN=""
SET EXAMDATE=$ORDER(^RADPT("AR",EXAMDATE),DIR)
SET D2=""
QUIT
+15 if 'D2
SET D2=$SELECT(DIR>0:0,1:" ")
+16 ; IA # 1172
SET D2=$ORDER(^RADPT(DFN,"DT",9999999.9999-EXAMDATE,"P",D2),DIR)
+17 IF 'D2
Begin DoDot:2
+18 ; IA # 65
SET DFN=$ORDER(^RADPT("AR",EXAMDATE,DFN),DIR)
SET D2=""
+19 IF 'DFN
Begin DoDot:3
+20 ; IA # 65
SET EXAMDATE=$ORDER(^RADPT("AR",EXAMDATE),DIR)
SET DFN=""
+21 IF EXAMDATE=""
SET OUT=-1
+22 QUIT
End DoDot:3
+23 QUIT
End DoDot:2
QUIT
+24 ; IA # 1172
SET OUT=$PIECE($GET(^RADPT(DFN,"DT",9999999.9999-EXAMDATE,"P",D2,0)),"^",17)
+25 if OUT
SET OUT=OUT_"^"_EXAMDATE_"^"_DFN_"^"_D2
+26 QUIT
End DoDot:1
if OUT
QUIT
+27 QUIT
+28 ;
NXTPTRPT(OUT,DFN,RARPT1,DIR) ; RPC = MAG RAD GET NEXT RPT BY PT
+1 SET DFN=$GET(DFN)
+2 IF 'DFN
SET OUT="-1,Patient DFN not passed"
QUIT
+3 ; IA # 2442
IF '$DATA(^RARPT("C",DFN))
SET OUT="-2,Patient does not have any radiology reports"
QUIT
+4 ; default is ascending order
SET RARPT1=$GET(RARPT1)
SET DIR=$SELECT($GET(DIR)<0:-1,1:1)
+5 ; IA # 2442
SET OUT=$ORDER(^RARPT("C",DFN,RARPT1),DIR)
+6 QUIT
+7 ;
GETICN(OUT,DFN) ; RPC = MAG DICOM GET ICN
+1 SET OUT=$SELECT($TEXT(GETICN^MPIF001)'="":$$GETICN^MPIF001(DFN),1:"-1^NO MPI")
+2 QUIT
+3 ;
INIT(OUT,LOCATION,COUNTONLY) ; RPC = MAG DICOM QUEUE INIT (moved from ^MAGDRPC4)
+1 ; P305 PMK 05/12/2021
NEW ACNUMB,COUNT,D0,D1,IMAGEDB,N,PRIORITY,REQUESTDATETIME,STATE,STUDYUID,X,Y
+2 IF $GET(LOCATION)=""
SET OUT="-3,No origin specified."
QUIT
+3 IF '$DATA(^MAGDOUTP(2006.574,0))
SET OUT="-1,No entries at all in queue."
QUIT
+4 ; P305 PMK 11/17/2021
SET COUNTONLY=$GET(COUNTONLY,0)
+5 ;
+6 ; check for deleting the entire DICOM OBJECT EXPORT file - P305 PMK 01/07/2022
+7 IF LOCATION="ALL"
Begin DoDot:1
+8 SET N=$PIECE($GET(^MAGDOUTP(2006.574,0)),"^",4)
+9 IF COUNTONLY
Begin DoDot:2
+10 IF N
Begin DoDot:3
+11 SET OUT=$SELECT(N=1:"One entry is",1:N_" entries are")
+12 SET OUT=OUT_" present in the Image Transmission Queues for all locations."
+13 QUIT
End DoDot:3
+14 IF '$TEST
SET OUT="-2,No entries are present in the Image Transmission Queue."
+15 QUIT
End DoDot:2
+16 IF '$TEST
Begin DoDot:2
+17 LOCK +^MAGDOUTP(2006.574):1E9
+18 KILL ^MAGDOUTP(2006.574)
+19 SET ^MAGDOUTP(2006.574,0)="DICOM OBJECT EXPORT^2006.574^0^0"
+20 LOCK -^MAGDOUTP(2006.574)
+21 SET OUT="Image Transmission Queue completely initialized, "
+22 SET OUT=OUT_$SELECT(N=1:"one entry was",1:N_" entries were")_" deleted."
+23 QUIT
End DoDot:2
+24 QUIT
End DoDot:1
QUIT
+25 ;
+26 ; deleting only a single location
+27 SET N=0
SET OUT="-2,No entries are present in"
+28 ; P180 DAC - Lock entire global, background process MUST wait
LOCK +^MAGDOUTP(2006.574):1E9
+29 SET D0=0
FOR
SET D0=$ORDER(^MAGDOUTP(2006.574,D0))
if 'D0
QUIT
SET X=$GET(^(D0,0))
if $PIECE(X,"^",4)'=LOCATION
QUIT
Begin DoDot:1
+30 SET N=N+1
if COUNTONLY
QUIT
+31 SET ACNUMB=$PIECE(X,"^",3)
SET PRIORITY=$PIECE(X,"^",5)
+32 SET REQUESTDATETIME=$PIECE(X,"^",7)
SET IMAGEDB=$PIECE(X,"^",8)
+33 SET STUDYUID=$GET(^MAGDOUTP(2006.574,D0,2))
+34 SET D1=0
FOR
SET D1=$ORDER(^MAGDOUTP(2006.574,D0,1,D1))
if 'D1
QUIT
SET Y=$GET(^(D1,0))
Begin DoDot:2
+35 SET STATE=$PIECE(Y,"^",2)
+36 KILL ^MAGDOUTP(2006.567,D0,1,D1)
+37 KILL ^MAGDOUTP(2006.574,"STATE",LOCATION,PRIORITY,STATE,D0,D1)
+38 QUIT
End DoDot:2
+39 KILL ^MAGDOUTP(2006.574,D0)
+40 if REQUESTDATETIME'=""
KILL ^MAGDOUTP(2006.574,"C",REQUESTDATETIME,D0)
+41 ; P305 PMK 05/12/2021
if ACNUMB'=""
KILL ^MAGDOUTP(2006.574,"D",ACNUMB,D0)
+42 IF STUDYUID'=""
IF IMAGEDB'=""
KILL ^MAGDOUTP(2006.574,"STUDY",STUDYUID,IMAGEDB,D0)
+43 QUIT
End DoDot:1
+44 IF N
Begin DoDot:1
+45 IF COUNTONLY
SET OUT=$SELECT(N=1:"One entry is",1:N_" entries are")_" present in"
+46 IF '$TEST
Begin DoDot:2
+47 SET COUNT=$PIECE(^MAGDOUTP(2006.574,0),"^",4)-N
+48 ; don't let count become negative
IF COUNT<0
SET COUNT=0
+49 ; P305 PMK 05/12/2021
SET $PIECE(^MAGDOUTP(2006.574,0),"^",4)=COUNT
+50 ; P305 PMK 05/12/2021
SET $PIECE(^MAGDOUTP(2006.574,0),"^",3)=0
+51 SET OUT=$SELECT(N=1:"One entry has",1:N_" entries have been")_" deleted from"
+52 QUIT
End DoDot:2
+53 QUIT
End DoDot:1
+54 SET OUT=OUT_" the queue for "_$$GET1^DIQ(4,LOCATION,.01)_"."
+55 ; P180 DAC - Unlock global
LOCK -^MAGDOUTP(2006.574)
+56 QUIT
+57 ;
IENLOOK ; Overflow from MAGDRPC4
+1 ; lookup image by the IEN
+2 NEW ACNUMB,D0,DFN,GROUPIEN,MODIFIER,P,PROCNAME,STUDYDAT,X,Y
+3 SET NUMBER=+$PIECE(NUMBER,"`",2)
+4 ; patient safety checks
+5 DO CHK^MAGGSQI(.X,NUMBER)
IF +$GET(X(0))'=1
Begin DoDot:1
+6 SET OUT(1)="-9,"_$PIECE(X(0),"^",2,999)
+7 QUIT
End DoDot:1
QUIT
+8 SET GROUPIEN=$PIECE($GET(^MAG(2005,NUMBER,0)),"^",10)
+9 IF GROUPIEN
DO CHK^MAGGSQI(.X,GROUPIEN)
IF +$GET(X(0))'=1
Begin DoDot:1
+10 SET OUT(1)="-10,Group #"_GROUPIEN_": "_$PIECE(X(0),"^",2,999)
+11 QUIT
End DoDot:1
QUIT
+12 ;
+13 SET X=$GET(^MAG(2005,NUMBER,2))
SET P=$PIECE(X,"^",6)
SET D0=$PIECE(X,"^",7)
+14 ; get parent from group
IF 'P!'D0
Begin DoDot:1
+15 if GROUPIEN
SET X=$GET(^MAG(2005,GROUPIEN,2))
SET P=$PIECE(X,"^",6)
SET D0=$PIECE(X,"^",7)
+16 QUIT
End DoDot:1
+17 ;
+18 ; result w/o Accession Number
SET OUT(2)=P_"^"_D0_"^"_NUMBER_"^"
+19 IF 'P!'D0
SET OUT(1)="-6,Warning - Parent file entry is not present - no Accession Number."
+20 IF '$TEST
IF P=74
Begin DoDot:1
+21 NEW DATETIME,I,INFO,PROC,RADPT0,RADPT1,RADPT2,RADPT3,RARPT0
+22 SET X=$$ACCRPT^RAAPI(D0,.INFO)
+23 IF X<0
SET OUT(1)="-11,Radiology Problem: "_X
QUIT
+24 SET ACNUMB=INFO(1)
+25 ; IA # 1171
SET RARPT0=$GET(^RARPT(D0,0))
+26 SET RADPT1=$PIECE(RARPT0,"^",2)
SET DATETIME=$PIECE(RARPT0,"^",3)
+27 SET RADPT2=9999999.9999-DATETIME
SET RADPT3=1
+28 SET RADPT0=$GET(^RADPT(RADPT1,"DT",RADPT2,"P",RADPT3,0))
+29 SET PROCNAME=$$GET1^DIQ(71,$PIECE(RADPT0,"^",2),.01)
+30 SET STUDYDAT=17000000+(DATETIME\1)
+31 SET MODIFIER=""
+32 SET I=0
FOR
SET I=$ORDER(^RADPT(RADPT1,"DT",RADPT2,"P",RADPT3,"M",I))
if 'I
QUIT
Begin DoDot:2
+33 SET X=^RADPT(RADPT1,"DT",RADPT2,"P",RADPT3,"M",I,0)
+34 if I>1
SET MODIFIER=MODIFIER_", "
SET MODIFIER=MODIFIER_$$GET1^DIQ(71.2,X,.01)
+35 QUIT
End DoDot:2
+36 SET X=P_"^"_D0_"^"_NUMBER_"^"_ACNUMB_"^"_STUDYDAT_"^"_PROCNAME_"^"_MODIFIER
+37 SET OUT(1)=1
SET OUT(2)=X
+38 QUIT
End DoDot:1
+39 IF '$TEST
IF P=8925
Begin DoDot:1
+40 NEW GMRCIEN,LABINFO
+41 ; get pointer from TIU to consult request
+42 ; IA ???
SET X=$$GET1^DIQ(8925,D0,1405,"I")
+43 IF $PIECE(X,";",2)="GMR(123,"
Begin DoDot:2
+44 SET GMRCIEN=$PIECE(X,";")
SET ACNUMB=$$GMRCACN^MAGDFCNV(GMRCIEN)
+45 SET STUDYDAT=17000000+($$GET1^DIQ(123,GMRCIEN,.01,"I")\1)
+46 ; TO SERVICE
SET PROCNAME=$$GET1^DIQ(123,GMRCIEN,1)
+47 ; PROCEDURE
SET MODIFIER=$$GET1^DIQ(123,GMRCIEN,4)
+48 SET X=P_"^"_D0_"^"_NUMBER_"^"_ACNUMB_"^"_STUDYDAT_"^"_PROCNAME_"^"_MODIFIER
+49 SET OUT(1)=1
SET OUT(2)=X
+50 QUIT
End DoDot:2
+51 SET X=$$GET1^DIQ(8925,D0,.04,"E")
+52 IF X="LR ANATOMIC PATHOLOGY"
Begin DoDot:2
+53 DO GETINFO(.LABINFO,D0)
+54 IF $DATA(LABINFO)
Begin DoDot:3
End DoDot:3
+55 SET X=P_"^"_D0_"^"_NUMBER_"^"_LABINFO("ACNUMB")
+56 SET X=X_"^"_LABINFO("DATE")
+57 SET X=X_"^"_LABINFO("LAB")_"^"
+58 SET OUT(1)=1
SET OUT(2)=X
+59 QUIT
End DoDot:2
+60 ; P190 DAC - Next line modified to fix consult look ups that reported errors even though they were succesful
+61 IF $GET(OUT(1))'=1
SET OUT(1)="-8,Problem with parent file "_P_", internal entry number "_D0_" - no Accession Number."
+62 QUIT
End DoDot:1
+63 IF '$TEST
SET OUT(1)="-7,Parent file "_P_" not yet supported - no Accession Number."
+64 QUIT
+65 ;
GETINFO(INFO,TIUIEN) ; scan the TIU document and try to extract the accession number
+1 ; ---- LAB DATA subfile numbers and other info
NEW FILE
+2 ; error status - assume nothing to repor
NEW ERRSTAT
SET ERRSTAT=0
+3 ;P307
NEW ABBR,ERROR,I,LRAA,LRSS,IENS,TEXT,X
+4 SET IENS=TIUIEN_","
+5 DO GETS^DIQ(8925,IENS,2,"I","TEXT","ERROR")
+6 FOR I=1:1
if '$DATA(TEXT(8925,IENS,2,I))
QUIT
SET X=TEXT(8925,IENS,2,I)
Begin DoDot:1
+7 IF '$DATA(INFO("ACNUMB"))
IF X["Accession No."
Begin DoDot:2
+8 SET INFO("ACNUMB")=$PIECE(X,"Accession No. ",2)
+9 ;P307
SET ABBR=$PIECE(INFO("ACNUMB")," ")
+10 ; get lab area index ;P307
SET LRAA=$$FIND1^DIC(68,"","BX",ABBR,"","","ERR")
+11 ;P307
SET LRSS=$$GET1^DIQ(68,LRAA,.02,"I")
+12 SET ERRSTAT=$$GETFILE^MAGT7MA(LRSS)
IF ERRSTAT
SET INFO("LAB")=""
QUIT
+13 SET INFO("LAB")=FILE("NAME")
+14 QUIT
End DoDot:2
+15 IF '$DATA(INFO("DATE"))
IF X["Date obtained: "
SET INFO("DATE")=$PIECE(X,"Date obtained: ",2)
+16 QUIT
End DoDot:1
+17 QUIT
+18 ;
STATS(OUT,SITE) ; RPC = MAG DICOM GET EXPORT QUEUE STS
+1 NEW COUNT,D0,D1,NOUT,NOW,PRIORITY,STATE,TIME,WAIT,X,Y
+2 KILL OUT
+3 ;
+4 IF '$GET(SITE)
SET OUT(1)="-1,Location not specified"
QUIT
+5 ;
+6 SET NOUT=1
SET OUT(NOUT)=0
+7 ;
+8 SET NOUT=1
SET NOW=$HOROLOG
+9 SET PRIORITY=""
FOR
SET PRIORITY=$ORDER(^MAGDOUTP(2006.574,"STATE",SITE,PRIORITY))
if PRIORITY=""
QUIT
Begin DoDot:1
+10 ; Ignore states SUCCESS, NOT ON FILE, IGNORE, and HOLD
+11 FOR STATE="FAIL","WAITING","XMIT"
Begin DoDot:2
+12 SET D0=0
FOR
SET D0=$ORDER(^MAGDOUTP(2006.574,"STATE",SITE,PRIORITY,STATE,D0))
if 'D0
QUIT
Begin DoDot:3
+13 SET Y=^MAGDOUTP(2006.574,D0,0)
+14 SET D1=0
FOR
SET D1=$ORDER(^MAGDOUTP(2006.574,"STATE",SITE,PRIORITY,STATE,D0,D1))
if 'D1
QUIT
Begin DoDot:4
+15 SET X=$GET(^MAGDOUTP(2006.574,D0,1,D1,0))
+16 SET COUNT(D0,STATE)=($GET(COUNT(D0,STATE))+1)_"^^"_Y
+17 SET TIME=$PIECE(X,"^",3)
+18 SET WAIT=$$TIMEDIFF(NOW,TIME)
+19 IF $PIECE(COUNT(D0,STATE),"^",2)<WAIT
SET $PIECE(COUNT(D0,STATE),"^",2)=WAIT
+20 QUIT
End DoDot:4
+21 QUIT
End DoDot:3
+22 QUIT
End DoDot:2
+23 QUIT
End DoDot:1
+24 ;
+25 ; save output
+26 SET D0=0
FOR
SET D0=$ORDER(COUNT(D0))
if D0=""
QUIT
Begin DoDot:1
+27 SET STATE=""
FOR
SET STATE=$ORDER(COUNT(D0,STATE))
if STATE=""
QUIT
Begin DoDot:2
+28 SET NOUT=NOUT+1
SET OUT(1)=NOUT
+29 SET OUT(NOUT)=D0_"^"_STATE_"^"_COUNT(D0,STATE)
+30 QUIT
End DoDot:2
+31 QUIT
End DoDot:1
+32 ;
+33 QUIT
+34 ;
TIMEDIFF(T1,T2) ; formatted time difference
+1 NEW RETURN,TIMEDIFF
+2 SET TIMEDIFF=$$HDIFF^XLFDT(T1,T2,2)
+3 ; greater than a day
IF TIMEDIFF>86400
Begin DoDot:1
+4 SET RETURN=$$HDIFF^XLFDT(T1,T2,1)_" days"
+5 QUIT
End DoDot:1
+6 ; greater than an hour
IF '$TEST
IF TIMEDIFF>3600
Begin DoDot:1
+7 SET RETURN=(TIMEDIFF+1800)\3600_" hours"
+8 QUIT
End DoDot:1
+9 ; greater than a minute
IF '$TEST
IF TIMEDIFF>60
Begin DoDot:1
+10 SET RETURN=(TIMEDIFF+30)\60_" min."
+11 QUIT
End DoDot:1
+12 IF '$TEST
SET RETURN=TIMEDIFF_" sec."
+13 QUIT RETURN
