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

MAGDRPC9.m

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