- 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 Feb 18, 2025@23:27:55 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