MAGDRPC4 ;WOIFO/EDM,DAC - Imaging RPCs ; Feb 15, 2022@10:29:19
;;3.0;IMAGING;**11,30,51,50,54,49,138,156,180,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
;
LOOKUP(OUT,NUMBER) ; RPC = MAG DICOM LOOKUP STUDY
; Look Up for Radiology, Consults, and Lab (anatomic pathology)
N ACNUMB ;--- Accession Number
N CPTCODE ;-- CPT code for the procedure
N CPTNAME ;-- CPT name for the procedure
N DFN ;------ Patient pointer
N EXAMSTS ;-- Exam status (don't post images to CANCELLED exams)
N EXAMTYPE ;- Type of exam (Rad,Con, or Lab)
N GMRCIEN ;-- Pointer for GMRC
N INFO ;----- return array from $$ACCRPT^RAAPI()
N PROCIEN ;-- Radiology procedure IEN in ^RAMIS(71)
N RAA ;------ Radiology array (for $$ACCFIND)
N RAIX ;----- cross reference subscript for case number lookup
N RADFN ;---- first level subscript in ^RADPT
N RADTI ;---- second level subscript in ^RADPT (after "DT")
N RACNI ;---- third level subscript in ^RADPT (after "P")
N RARPT ;---- Radiology Report pointer
N I,LIST,NOUT,X,Y,Z
;
K OUT S NOUT=1
I $G(NUMBER)="" S OUT(1)="-1,No Case or Consult Number Specified" Q
I $E(NUMBER,2)="`" D Q
. ; lookup the image by the IEN
. D IENLOOK^MAGDRPC9
. Q
;
S EXAMTYPE=$E(NUMBER,1)
I "RCL"[EXAMTYPE S NUMBER=$E(NUMBER,2,$L(NUMBER))
E S OUT(1)="-2,Need to specify Radiology, Consults, or Lab" Q
K DFN
I EXAMTYPE="R" D
. D RADLKUP(.NOUT,.OUT,.ACNUMB,NUMBER) ; radiology lookup
. Q
E I EXAMTYPE="C" D
. D CONLKUP(.NOUT,.OUT,.ACNUMB,NUMBER) ; CPRS consult/procedure lookup
. Q
E D
. D LABLKUP(.NOUT,.OUT,.ACNUMB,NUMBER) ; anatomic pathology lab lookup
. Q
;
D NEWLKUP^MAGDRPCD(.NOUT,.OUT,ACNUMB) ; check if there are any DICOM objects in the new SOP Class database
;
I '$D(OUT(1)) S OUT(1)=NOUT-1 ; allow error messages to be passed back in OUT(1)
Q
;
RADLKUP(NOUT,OUT,ACNUMB,NUMBER) ; Radiology lookup
S ACNUMB=""
S RACNI=0 ; must get this value to find study
I NUMBER?1N.N D I 'RACNI S OUT(1)="-14,Radiology case number not on file" Q
. ; Look for the patient/study in ^RADPT using the Radiology Case Number
. N RAIX ;----- cross reference subscript for case number lookup
. S RAIX=$S($D(^RADPT("C")):"C",1:"AE") ; for Radiology Patch RA*5*7
. S RAIX=$S(NUMBER["-":"ADC",1:RAIX) ; select the cross-reference
. S RADFN=$O(^RADPT(RAIX,NUMBER,"")) Q:'RADFN
. S RADTI=$O(^RADPT(RAIX,NUMBER,RADFN,""))
. S RACNI=$O(^RADPT(RAIX,NUMBER,RADFN,RADTI,""))
. Q
E D I 'RACNI S OUT(1)="-15,Radiology accession number not on file" Q
. ; lookup using Radiololgy Package API
. S X=$$ACCFIND^RAAPI(NUMBER,.RAA)
. I X<0 Q
. S Y=RAA(1)
. S RADFN=$P(Y,"^",1),RADTI=$P(Y,"^",2),RACNI=$P(Y,"^",3)
. Q
I '$D(^RADPT(RADFN,0)) S OUT(1)="-12,No patient demographics file pointer" Q
S DFN=$P(^RADPT(RADFN,0),"^",1)
I '$G(DFN) S OUT(1)="-13,Radiology exam not on file" Q
S EXAMSTS=$P($G(^RADPT(DFN,"DT",RADTI,"P",RACNI,0)),"^",3)
I 'EXAMSTS S OUT(1)="-16,Radiology EXAM STATUS field not present" Q
I $$GET1^DIQ(72,EXAMSTS,3)=0 S OUT(1)="-17,Radiology exam cancelled" Q
D:$D(^RADPT(DFN,"DT",RADTI,0)) ; p305 PMK 03/30/2021
. S RARPT=$P($G(^RADPT(DFN,"DT",RADTI,"P",RACNI,0)),"^",17) Q:'RARPT
. S X=$$ACCRPT^RAAPI(RARPT,.INFO)
. I X<0 S OUT(1)="-11,Radiology Problem: "_X Q
. S ACNUMB=INFO(1)
. S I=0 F S I=$O(^RARPT(RARPT,2005,I)) Q:'I D
. . S X="74^"_RARPT_"^"_$P($G(^RARPT(RARPT,2005,I,0)),"^",1)_"^"_ACNUMB
. . S NOUT=NOUT+1,OUT(NOUT)=X
. . Q
. Q
Q
;
CONLKUP(NOUT,OUT,ACNUMB,NUMBER) ; CPRS Consult/Procedure study lookup
N MAGIEN,MAGPTR,REPORTF,REPORTI,TIUIEN,TIUPTR,TIUXIEN,X
S X=$$GMRCIEN^MAGDFCNV(NUMBER) S GMRCIEN=$S(X:X,1:NUMBER)
S ACNUMB=$$GMRCACN^MAGDFCNV(GMRCIEN)
D
. S DFN=$$GET1^DIQ(123,GMRCIEN,.02,"I") Q:'DFN
. S EXAMSTS=$$GET1^DIQ(123,GMRCIEN,8,"I") ; check acceptable status
. ; EXAMSTS=2 for COMPLETE, 5=PENDING, 6=ACTIVE, 8=SCHEDULED, STATUS=9 for PARTIAL RESULTS
. I EXAMSTS'=2,EXAMSTS'=5,EXAMSTS'=6,EXAMSTS'=8,EXAMSTS'=9 D Q
. . S EXAMSTS=$$GET1^DIQ(123,GMRCIEN,8,"E") ; get name of status
. . S OUT(1)="-4,Consult is "_EXAMSTS Q
. . Q
. Q
I $D(OUT(1)) Q ; bad EXAMSTS
I '$G(DFN) S OUT(1)="-5,Consult/procedure not on file" Q
; Find the images - they can be linked to TIU or imaging file 2006.5839
S MAGPTR=0 ; find in ^MAG(2006.5839) - may not be in ^TIU yet
F S MAGPTR=$O(^MAG(2006.5839,"C",123,GMRCIEN,MAGPTR)) Q:'MAGPTR D
. S X=^MAG(2006.5839,MAGPTR,0)
. S X=$P(X,"^",1)_"^"_$P(X,"^",2)_"^"_$P(X,"^",3)_"^"_ACNUMB
. S NOUT=NOUT+1,OUT(NOUT)=X
. Q
; also try to find images in ^TIU
N I,RESULT,X
D TIUALL^MAGDGMRC(GMRCIEN,.RESULT)
S I="" F S I=$O(RESULT(I)) Q:I="" D
. S X="8925^"_$P(RESULT(I),"^",1)_"^"_$P(RESULT(I),"^",3)_"^"_$P(RESULT(I),"^",2)
. S NOUT=NOUT+1,OUT(NOUT)=X
. Q
Q
;
LABLKUP(NOUT,OUT,ACNUMB,NUMBER) ; Lab (Anatomic Pathology) study lookup
N DFN,FILEDATA,LRDFN,LRI,LRSS,MAGIEN,MAGPTR,PARENTFILE,TIUIEN,TIUXIEN,X
S ACNUMB=NUMBER D LABLKUP^MAGDIR8A
I '$G(DFN) S OUT(1)="-6,Anatomic Pathology case not on file" Q
D SUBFILES^MAGDIR9F(LRSS)
; Find the images - they can be linked to TIU or imaging file 2006.5838
S MAGPTR=$O(^MAG(2006.5838,"C",PARENTFILE,LRDFN,LRI,0))
I MAGPTR D Q ; Found it in ^MAG(2006.5838) - not in ^TIU yet
. S X=^MAG(2006.5838,MAGPTR,0)
. ; separate the two subscripts that point to the study with a comma
. S X=$P(X,"^",1)_"^"_$P(X,"^",2)_","_$P(X,"^",3)_"^"_$P(X,"^",4)_"^"_ACNUMB
. S NOUT=NOUT+1,OUT(NOUT)=X
. Q
D ; Otherwise find images in ^TIU
. S TIUIEN=$$TIUIEN^MAGT7MA(LRSS,LRDFN,LRI)
. I TIUIEN D
. . S TIUXIEN=$O(^TIU(8925.91,"B",TIUIEN,""))
. . I TIUXIEN D
. . . S MAGIEN=$$GET1^DIQ(8925.91,TIUXIEN,.02,"I")
. . . S X="8925^"_TIUIEN_"^"_MAGIEN_"^"_ACNUMB
. . . S NOUT=NOUT+1,OUT(NOUT)=X
. . . Q
. . Q
. Q
Q
;
NEXTIMG(OUT,FROMS,ONLYCHECK,SENT) ; RPC = MAG DICOM GET NEXT QUEUE ENTRY
; Get next file to be DICOM transmitted
N D0,D1,F1,F2,F3,FAILTIME,FROM,GROUP,I,JBTOHD,LOC,N,PRIORITY,SITE,STATE,TYPE,X,XMITTIME
N ARTIFACTIX,ARTIFACTINSTIX,DFN,DISKVOLUME,FILEPATH,PHYSICALREF,STUDYIX
S X=$G(FROMS) S:X FROM(X)=1
S I="" F S I=$O(FROMS(I)) Q:I="" S X=$P($G(FROMS(I)),"^",1) S:X FROM(X)=1
I '$O(FROM("")) S OUT(1)="-1,No Origin Specified" Q
;
L +^MAGDOUTP(2006.574):1E9 ; P305 PMK 09/23/2021 - Lock entire global, RPC MUST wait
;
; First clean up transmitted queue entries
S I="" F S I=$O(SENT(I)) Q:I="" D CLEAN
S SITE=$O(^MAG(2006.1,"B",DUZ(2),"")) ; parameters are defined for the sending site
S XMITTIME=$$GET1^DIQ(2006.1,SITE,208)
S FAILTIME=$$GET1^DIQ(2006.1,SITE,209)
S H=$$SECOND($H)
;
; ONLYCHECK=1 for batch export (^MAGDIWBE) but 0 for a transmission process (^MAGDIWB2)
I 'ONLYCHECK D ; do only when called from a transmission process, not batch export
. ; check for DICOM objects stuck in XMIT state or that previously failed to be transmitted
. S FROM="" F S FROM=$O(FROM(FROM)) Q:FROM="" D
. . S PRIORITY="" F S PRIORITY=$O(^MAGDOUTP(2006.574,"STATE",FROM,PRIORITY)) Q:PRIORITY="" D
. . . D RETRYXMT(FROM,PRIORITY,"XMIT",XMITTIME,0) ; XMIT is disabled by default
. . . D RETRYXMT(FROM,PRIORITY,"FAIL",FAILTIME,300) ; default for FAIL is 5 minutes
. . . Q
. . Q
. Q
;
; Find the highest priority among the selected FROM locations
S FROM="" F S FROM=$O(FROM(FROM)) Q:FROM="" D
. S PRIORITY="" F S PRIORITY=$O(^MAGDOUTP(2006.574,"STATE",FROM,PRIORITY)) Q:PRIORITY="" D
. . S X=$O(^MAGDOUTP(2006.574,"STATE",FROM,PRIORITY,"WAITING","")) S:X PRIORITY(PRIORITY,FROM)=""
. . Q
. Q
K OUT S OUT(1)="",PRIORITY=$O(PRIORITY(""),-1) D:PRIORITY'=""
. S FROM=$O(PRIORITY(PRIORITY,""))
. S D0="" F S D0=$O(^MAGDOUTP(2006.574,"STATE",FROM,PRIORITY,"WAITING",D0)) Q:D0="" D Q:OUT(1)'=""
. . S D1="" F S D1=$O(^MAGDOUTP(2006.574,"STATE",FROM,PRIORITY,"WAITING",D0,D1)) Q:D1="" D Q:OUT(1)'=""
. . . ; ONLYCHECK=1 for batch export; ONLYCHECK=0 for a transmission process
. . . I 'ONLYCHECK D ; do only when called from a transmission process, not batch export
. . . . S $P(^MAGDOUTP(2006.574,D0,1,D1,0),"^",2,3)="XMIT^"_$H
. . . . K ^MAGDOUTP(2006.574,"STATE",FROM,PRIORITY,"WAITING",D0,D1)
. . . . S ^MAGDOUTP(2006.574,"STATE",FROM,PRIORITY,"XMIT",D0,D1)=""
. . . . Q
. . . S OUT(1)=1
. . . S OUT(2)=D0
. . . S OUT(3)=D1
. . . S X=$G(^MAGDOUTP(2006.574,D0,0))
. . . S OUT(4)=$P(X,"^",1) ; Application
. . . S (OUT(5),GROUP)=$P(X,"^",2) ; Group
. . . S (ACNUMB,OUT(6))=$P(X,"^",3) ; Accession Number
. . . S JBTOHD=+$P(X,"^",6)
. . . S OUT(7)=$P(^MAGDOUTP(2006.574,D0,1,D1,0),"^",1) ; Image IEN or Artifact IEN
. . . I GROUP="New SOP Class DB" D
. . . . S ARTIFACTIX=OUT(7) ; ARTIFACT file (#2006.916) IEN
. . . . S OUT(8)=GROUP ; no legacy Object Type (2005 field 3)
. . . . ; get DFN from IMAGE STUDY file (#2005.62) and IMAGING PATIENT REFERENCE file (#2005.61)
. . . . S STUDYIX=$O(^MAGV(2005.62,"D",ACNUMB,"")) ; get IMAGE STUDY pointer
. . . . S DFN=$$GET1^DIQ(2005.62,STUDYIX,13,"E") ; get IMAGING PATIENT REFERENCE (DFN)
. . . . ; there may be multiple artifact instances - use the first one
. . . . ; could check the NETWORK LOCATION file (2005.2) STORAGE TYPE = "TIER 1"
. . . . S ARTIFACTINSTIX=$O(^MAGV(2006.918,"B",ARTIFACTIX,"")) ; get first Artifact Instance pointer
. . . . S F1=$$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 (F2,F3)=PHYSICALREF_FILEPATH_F1
. . . . Q
. . . E D
. . . . S IMAGEIEN=OUT(7)
. . . . S OUT(8)=$P($G(^MAG(2005,IMAGEIEN,0)),"^",6) ; Object Type
. . . . S TYPE=$S($G(^MAG(2005,IMAGEIEN,"FBIG"))'="":"BIG",1:"FULL")
. . . . ; 3rd parameter set to 1 to allow retrieval from jukebox
. . . . D FILEFIND^MAGDFB(IMAGEIEN,TYPE,1,0,.F1,.F2)
. . . . S DFN=$P($G(^MAG(2005,+OUT(7),0)),"^",7) ; P156 DAC - get DFN from image (not group)
. . . . ; get path for *.TXT, always the same as the FULL file
. . . . D FILEFIND^MAGDFB(IMAGEIEN,"FULL",JBTOHD,0,.F1,.F3)
. . . . Q
. . . S OUT(9)=F1 ; file name
. . . S OUT(10)=F2 ; full file path
. . . S OUT(11)=DFN
. . . S OUT(12)=F3 ; full file path
. . . S X=$G(^MAGDOUTP(2006.574,D0,1,0))
. . . S OUT(13)=$P(X,"^",4) ; Object count
. . . Q
. . Q
. Q
I OUT(1)="" D
. S OUT(1)="-2,Nothing to be transmitted."
. D CLEANUP
. Q
L -^MAGDOUTP(2006.574) ; P180 DAC - Unlock global
Q
;
RETRYXMT(FROM,PRIORITY,OLDSTATE,TIMEOUT,DEFAULTTIMEOUT) ; retry transmission
; move images from XMIT or FAIL state to WAITING state
N D0,D1,H,X
;
I TIMEOUT="" S TIMEOUT=DEFAULTTIMEOUT ; XMIT/FAIL timeout not defined
;
I TIMEOUT=0 Q ; retransmission is disabled
;
S H=$$SECOND($H)
S D0="" F S D0=$O(^MAGDOUTP(2006.574,"STATE",FROM,PRIORITY,OLDSTATE,D0)) Q:D0="" D
. S D1="" F S D1=$O(^MAGDOUTP(2006.574,"STATE",FROM,PRIORITY,OLDSTATE,D0,D1)) Q:D1="" D
. . S X=$$SECOND($P($G(^MAGDOUTP(2006.574,D0,1,D1,0),"^^"_$H),"^",3))
. . Q:H-X<TIMEOUT
. . S $P(^MAGDOUTP(2006.574,D0,1,D1,0),"^",2)="WAITING"
. . K ^MAGDOUTP(2006.574,"STATE",FROM,PRIORITY,OLDSTATE,D0,D1)
. . S ^MAGDOUTP(2006.574,"STATE",FROM,PRIORITY,"WAITING",D0,D1)=""
. . Q
. Q
Q
;
CLEANUP ; remove old studies
N D0,D1,I,REQUESTDATETIME,SENT
S REQUESTDATETIME=$$FMADD^XLFDT($$NOW^XLFDT,-15,0,0,0) ; delete anything 15 days older or older
F S REQUESTDATETIME=$O(^MAGDOUTP(2006.574,"C",REQUESTDATETIME),-1) Q:REQUESTDATETIME="" D
. S D0="" F S D0=$O(^MAGDOUTP(2006.574,"C",REQUESTDATETIME,D0)) Q:D0="" D
. . S D1=0 F S D1=$O(^MAGDOUTP(2006.574,D0,1,D1)) Q:D1="" D
. . . S I=1,SENT(1)=D0_"^"_D1_"^" D CLEAN ; STATE=<null>
. . . Q
. . Q
. Q
Q
;
CLEAN ; remove one image entry from the queue
N D0,D1,REQUESTDATETIME,STUID,PRIORITY,STATE,NEWSTATE ; P305 PMK 09/29/2021
S D0=$P(SENT(I),"^",1),D1=$P(SENT(I),"^",2),NEWSTATE=$P(SENT(I),"^",3)
Q:'$D(^MAGDOUTP(2006.574,D0,1,D1))
;
S X=$G(^MAGDOUTP(2006.574,D0,0)),LOC=$P(X,"^",4),PRIORITY=+$P(X,"^",5)
S REQUESTDATETIME=$P(X,"^",7)
S STATE=$P($G(^MAGDOUTP(2006.574,D0,1,D1,0)),"^",2)
;
I NEWSTATE'="" D Q ; just update the status and get out
. S $P(^MAGDOUTP(2006.574,D0,1,D1,0),"^",2)=NEWSTATE,$P(^(0),"^",3)=$H
. ; remove the old xref before setting the new one - P305 PMK 09/29/2021
. I LOC'="",PRIORITY'="",STATE'="" K ^MAGDOUTP(2006.574,"STATE",LOC,PRIORITY,STATE,D0,D1)
. I LOC'="",PRIORITY'="" S ^MAGDOUTP(2006.574,"STATE",LOC,PRIORITY,NEWSTATE,D0,D1)=""
. Q
;
K ^MAGDOUTP(2006.574,D0,1,D1)
I LOC'="",PRIORITY'="",STATE'="" K ^MAGDOUTP(2006.574,"STATE",LOC,PRIORITY,STATE,D0,D1)
S X=$G(^MAGDOUTP(2006.574,D0,1,0))
S $P(X,"^",4)=$P(X,"^",4)-1
S ^MAGDOUTP(2006.574,D0,1,0)=X
;
Q:$O(^MAGDOUTP(2006.574,D0,1,0)) ; don't delete the study node yet
;
S STUID=$G(^MAGDOUTP(2006.574,D0,2))
K ^MAGDOUTP(2006.574,D0)
K:REQUESTDATETIME'="" ^MAGDOUTP(2006.574,"C",REQUESTDATETIME,D0)
K:STUID'="" ^MAGDOUTP(2006.574,"STUDY",STUID)
S X=$G(^MAGDOUTP(2006.574,0))
S $P(X,"^",4)=$P(X,"^",4)-1
S ^MAGDOUTP(2006.574,0)=X
Q
;
FIND(DATE,CASE,NUM) ;
; Use the ADC x-reference in the radiology patient file
N NDATE
S NDATE=$$FMADD^XLFDT(DATE,NUM) Q:NDATE<1 0
Q $O(^RADPT("ADC",$$MMDDYY(NDATE)_"-"_CASE,""))
;
MMDDYY(DAY) ; Convert Fileman date to mmddyy
I DAY'?7N Q 0
Q $E(DAY,4,7)_$E(DAY,2,3)
;
SECOND(H) Q H*86400+$P(H,",",2)
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMAGDRPC4 14598 printed Dec 13, 2024@02:01:23 Page 2
MAGDRPC4 ;WOIFO/EDM,DAC - Imaging RPCs ; Feb 15, 2022@10:29:19
+1 ;;3.0;IMAGING;**11,30,51,50,54,49,138,156,180,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 ;
LOOKUP(OUT,NUMBER) ; RPC = MAG DICOM LOOKUP STUDY
+1 ; Look Up for Radiology, Consults, and Lab (anatomic pathology)
+2 ;--- Accession Number
NEW ACNUMB
+3 ;-- CPT code for the procedure
NEW CPTCODE
+4 ;-- CPT name for the procedure
NEW CPTNAME
+5 ;------ Patient pointer
NEW DFN
+6 ;-- Exam status (don't post images to CANCELLED exams)
NEW EXAMSTS
+7 ;- Type of exam (Rad,Con, or Lab)
NEW EXAMTYPE
+8 ;-- Pointer for GMRC
NEW GMRCIEN
+9 ;----- return array from $$ACCRPT^RAAPI()
NEW INFO
+10 ;-- Radiology procedure IEN in ^RAMIS(71)
NEW PROCIEN
+11 ;------ Radiology array (for $$ACCFIND)
NEW RAA
+12 ;----- cross reference subscript for case number lookup
NEW RAIX
+13 ;---- first level subscript in ^RADPT
NEW RADFN
+14 ;---- second level subscript in ^RADPT (after "DT")
NEW RADTI
+15 ;---- third level subscript in ^RADPT (after "P")
NEW RACNI
+16 ;---- Radiology Report pointer
NEW RARPT
+17 NEW I,LIST,NOUT,X,Y,Z
+18 ;
+19 KILL OUT
SET NOUT=1
+20 IF $GET(NUMBER)=""
SET OUT(1)="-1,No Case or Consult Number Specified"
QUIT
+21 IF $EXTRACT(NUMBER,2)="`"
Begin DoDot:1
+22 ; lookup the image by the IEN
+23 DO IENLOOK^MAGDRPC9
+24 QUIT
End DoDot:1
QUIT
+25 ;
+26 SET EXAMTYPE=$EXTRACT(NUMBER,1)
+27 IF "RCL"[EXAMTYPE
SET NUMBER=$EXTRACT(NUMBER,2,$LENGTH(NUMBER))
+28 IF '$TEST
SET OUT(1)="-2,Need to specify Radiology, Consults, or Lab"
QUIT
+29 KILL DFN
+30 IF EXAMTYPE="R"
Begin DoDot:1
+31 ; radiology lookup
DO RADLKUP(.NOUT,.OUT,.ACNUMB,NUMBER)
+32 QUIT
End DoDot:1
+33 IF '$TEST
IF EXAMTYPE="C"
Begin DoDot:1
+34 ; CPRS consult/procedure lookup
DO CONLKUP(.NOUT,.OUT,.ACNUMB,NUMBER)
+35 QUIT
End DoDot:1
+36 IF '$TEST
Begin DoDot:1
+37 ; anatomic pathology lab lookup
DO LABLKUP(.NOUT,.OUT,.ACNUMB,NUMBER)
+38 QUIT
End DoDot:1
+39 ;
+40 ; check if there are any DICOM objects in the new SOP Class database
DO NEWLKUP^MAGDRPCD(.NOUT,.OUT,ACNUMB)
+41 ;
+42 ; allow error messages to be passed back in OUT(1)
IF '$DATA(OUT(1))
SET OUT(1)=NOUT-1
+43 QUIT
+44 ;
RADLKUP(NOUT,OUT,ACNUMB,NUMBER) ; Radiology lookup
+1 SET ACNUMB=""
+2 ; must get this value to find study
SET RACNI=0
+3 IF NUMBER?1N.N
Begin DoDot:1
+4 ; Look for the patient/study in ^RADPT using the Radiology Case Number
+5 ;----- cross reference subscript for case number lookup
NEW RAIX
+6 ; for Radiology Patch RA*5*7
SET RAIX=$SELECT($DATA(^RADPT("C")):"C",1:"AE")
+7 ; select the cross-reference
SET RAIX=$SELECT(NUMBER["-":"ADC",1:RAIX)
+8 SET RADFN=$ORDER(^RADPT(RAIX,NUMBER,""))
if 'RADFN
QUIT
+9 SET RADTI=$ORDER(^RADPT(RAIX,NUMBER,RADFN,""))
+10 SET RACNI=$ORDER(^RADPT(RAIX,NUMBER,RADFN,RADTI,""))
+11 QUIT
End DoDot:1
IF 'RACNI
SET OUT(1)="-14,Radiology case number not on file"
QUIT
+12 IF '$TEST
Begin DoDot:1
+13 ; lookup using Radiololgy Package API
+14 SET X=$$ACCFIND^RAAPI(NUMBER,.RAA)
+15 IF X<0
QUIT
+16 SET Y=RAA(1)
+17 SET RADFN=$PIECE(Y,"^",1)
SET RADTI=$PIECE(Y,"^",2)
SET RACNI=$PIECE(Y,"^",3)
+18 QUIT
End DoDot:1
IF 'RACNI
SET OUT(1)="-15,Radiology accession number not on file"
QUIT
+19 IF '$DATA(^RADPT(RADFN,0))
SET OUT(1)="-12,No patient demographics file pointer"
QUIT
+20 SET DFN=$PIECE(^RADPT(RADFN,0),"^",1)
+21 IF '$GET(DFN)
SET OUT(1)="-13,Radiology exam not on file"
QUIT
+22 SET EXAMSTS=$PIECE($GET(^RADPT(DFN,"DT",RADTI,"P",RACNI,0)),"^",3)
+23 IF 'EXAMSTS
SET OUT(1)="-16,Radiology EXAM STATUS field not present"
QUIT
+24 IF $$GET1^DIQ(72,EXAMSTS,3)=0
SET OUT(1)="-17,Radiology exam cancelled"
QUIT
+25 ; p305 PMK 03/30/2021
if $DATA(^RADPT(DFN,"DT",RADTI,0))
Begin DoDot:1
+26 SET RARPT=$PIECE($GET(^RADPT(DFN,"DT",RADTI,"P",RACNI,0)),"^",17)
if 'RARPT
QUIT
+27 SET X=$$ACCRPT^RAAPI(RARPT,.INFO)
+28 IF X<0
SET OUT(1)="-11,Radiology Problem: "_X
QUIT
+29 SET ACNUMB=INFO(1)
+30 SET I=0
FOR
SET I=$ORDER(^RARPT(RARPT,2005,I))
if 'I
QUIT
Begin DoDot:2
+31 SET X="74^"_RARPT_"^"_$PIECE($GET(^RARPT(RARPT,2005,I,0)),"^",1)_"^"_ACNUMB
+32 SET NOUT=NOUT+1
SET OUT(NOUT)=X
+33 QUIT
End DoDot:2
+34 QUIT
End DoDot:1
+35 QUIT
+36 ;
CONLKUP(NOUT,OUT,ACNUMB,NUMBER) ; CPRS Consult/Procedure study lookup
+1 NEW MAGIEN,MAGPTR,REPORTF,REPORTI,TIUIEN,TIUPTR,TIUXIEN,X
+2 SET X=$$GMRCIEN^MAGDFCNV(NUMBER)
SET GMRCIEN=$SELECT(X:X,1:NUMBER)
+3 SET ACNUMB=$$GMRCACN^MAGDFCNV(GMRCIEN)
+4 Begin DoDot:1
+5 SET DFN=$$GET1^DIQ(123,GMRCIEN,.02,"I")
if 'DFN
QUIT
+6 ; check acceptable status
SET EXAMSTS=$$GET1^DIQ(123,GMRCIEN,8,"I")
+7 ; EXAMSTS=2 for COMPLETE, 5=PENDING, 6=ACTIVE, 8=SCHEDULED, STATUS=9 for PARTIAL RESULTS
+8 IF EXAMSTS'=2
IF EXAMSTS'=5
IF EXAMSTS'=6
IF EXAMSTS'=8
IF EXAMSTS'=9
Begin DoDot:2
+9 ; get name of status
SET EXAMSTS=$$GET1^DIQ(123,GMRCIEN,8,"E")
+10 SET OUT(1)="-4,Consult is "_EXAMSTS
QUIT
+11 QUIT
End DoDot:2
QUIT
+12 QUIT
End DoDot:1
+13 ; bad EXAMSTS
IF $DATA(OUT(1))
QUIT
+14 IF '$GET(DFN)
SET OUT(1)="-5,Consult/procedure not on file"
QUIT
+15 ; Find the images - they can be linked to TIU or imaging file 2006.5839
+16 ; find in ^MAG(2006.5839) - may not be in ^TIU yet
SET MAGPTR=0
+17 FOR
SET MAGPTR=$ORDER(^MAG(2006.5839,"C",123,GMRCIEN,MAGPTR))
if 'MAGPTR
QUIT
Begin DoDot:1
+18 SET X=^MAG(2006.5839,MAGPTR,0)
+19 SET X=$PIECE(X,"^",1)_"^"_$PIECE(X,"^",2)_"^"_$PIECE(X,"^",3)_"^"_ACNUMB
+20 SET NOUT=NOUT+1
SET OUT(NOUT)=X
+21 QUIT
End DoDot:1
+22 ; also try to find images in ^TIU
+23 NEW I,RESULT,X
+24 DO TIUALL^MAGDGMRC(GMRCIEN,.RESULT)
+25 SET I=""
FOR
SET I=$ORDER(RESULT(I))
if I=""
QUIT
Begin DoDot:1
+26 SET X="8925^"_$PIECE(RESULT(I),"^",1)_"^"_$PIECE(RESULT(I),"^",3)_"^"_$PIECE(RESULT(I),"^",2)
+27 SET NOUT=NOUT+1
SET OUT(NOUT)=X
+28 QUIT
End DoDot:1
+29 QUIT
+30 ;
LABLKUP(NOUT,OUT,ACNUMB,NUMBER) ; Lab (Anatomic Pathology) study lookup
+1 NEW DFN,FILEDATA,LRDFN,LRI,LRSS,MAGIEN,MAGPTR,PARENTFILE,TIUIEN,TIUXIEN,X
+2 SET ACNUMB=NUMBER
DO LABLKUP^MAGDIR8A
+3 IF '$GET(DFN)
SET OUT(1)="-6,Anatomic Pathology case not on file"
QUIT
+4 DO SUBFILES^MAGDIR9F(LRSS)
+5 ; Find the images - they can be linked to TIU or imaging file 2006.5838
+6 SET MAGPTR=$ORDER(^MAG(2006.5838,"C",PARENTFILE,LRDFN,LRI,0))
+7 ; Found it in ^MAG(2006.5838) - not in ^TIU yet
IF MAGPTR
Begin DoDot:1
+8 SET X=^MAG(2006.5838,MAGPTR,0)
+9 ; separate the two subscripts that point to the study with a comma
+10 SET X=$PIECE(X,"^",1)_"^"_$PIECE(X,"^",2)_","_$PIECE(X,"^",3)_"^"_$PIECE(X,"^",4)_"^"_ACNUMB
+11 SET NOUT=NOUT+1
SET OUT(NOUT)=X
+12 QUIT
End DoDot:1
QUIT
+13 ; Otherwise find images in ^TIU
Begin DoDot:1
+14 SET TIUIEN=$$TIUIEN^MAGT7MA(LRSS,LRDFN,LRI)
+15 IF TIUIEN
Begin DoDot:2
+16 SET TIUXIEN=$ORDER(^TIU(8925.91,"B",TIUIEN,""))
+17 IF TIUXIEN
Begin DoDot:3
+18 SET MAGIEN=$$GET1^DIQ(8925.91,TIUXIEN,.02,"I")
+19 SET X="8925^"_TIUIEN_"^"_MAGIEN_"^"_ACNUMB
+20 SET NOUT=NOUT+1
SET OUT(NOUT)=X
+21 QUIT
End DoDot:3
+22 QUIT
End DoDot:2
+23 QUIT
End DoDot:1
+24 QUIT
+25 ;
NEXTIMG(OUT,FROMS,ONLYCHECK,SENT) ; RPC = MAG DICOM GET NEXT QUEUE ENTRY
+1 ; Get next file to be DICOM transmitted
+2 NEW D0,D1,F1,F2,F3,FAILTIME,FROM,GROUP,I,JBTOHD,LOC,N,PRIORITY,SITE,STATE,TYPE,X,XMITTIME
+3 NEW ARTIFACTIX,ARTIFACTINSTIX,DFN,DISKVOLUME,FILEPATH,PHYSICALREF,STUDYIX
+4 SET X=$GET(FROMS)
if X
SET FROM(X)=1
+5 SET I=""
FOR
SET I=$ORDER(FROMS(I))
if I=""
QUIT
SET X=$PIECE($GET(FROMS(I)),"^",1)
if X
SET FROM(X)=1
+6 IF '$ORDER(FROM(""))
SET OUT(1)="-1,No Origin Specified"
QUIT
+7 ;
+8 ; P305 PMK 09/23/2021 - Lock entire global, RPC MUST wait
LOCK +^MAGDOUTP(2006.574):1E9
+9 ;
+10 ; First clean up transmitted queue entries
+11 SET I=""
FOR
SET I=$ORDER(SENT(I))
if I=""
QUIT
DO CLEAN
+12 ; parameters are defined for the sending site
SET SITE=$ORDER(^MAG(2006.1,"B",DUZ(2),""))
+13 SET XMITTIME=$$GET1^DIQ(2006.1,SITE,208)
+14 SET FAILTIME=$$GET1^DIQ(2006.1,SITE,209)
+15 SET H=$$SECOND($HOROLOG)
+16 ;
+17 ; ONLYCHECK=1 for batch export (^MAGDIWBE) but 0 for a transmission process (^MAGDIWB2)
+18 ; do only when called from a transmission process, not batch export
IF 'ONLYCHECK
Begin DoDot:1
+19 ; check for DICOM objects stuck in XMIT state or that previously failed to be transmitted
+20 SET FROM=""
FOR
SET FROM=$ORDER(FROM(FROM))
if FROM=""
QUIT
Begin DoDot:2
+21 SET PRIORITY=""
FOR
SET PRIORITY=$ORDER(^MAGDOUTP(2006.574,"STATE",FROM,PRIORITY))
if PRIORITY=""
QUIT
Begin DoDot:3
+22 ; XMIT is disabled by default
DO RETRYXMT(FROM,PRIORITY,"XMIT",XMITTIME,0)
+23 ; default for FAIL is 5 minutes
DO RETRYXMT(FROM,PRIORITY,"FAIL",FAILTIME,300)
+24 QUIT
End DoDot:3
+25 QUIT
End DoDot:2
+26 QUIT
End DoDot:1
+27 ;
+28 ; Find the highest priority among the selected FROM locations
+29 SET FROM=""
FOR
SET FROM=$ORDER(FROM(FROM))
if FROM=""
QUIT
Begin DoDot:1
+30 SET PRIORITY=""
FOR
SET PRIORITY=$ORDER(^MAGDOUTP(2006.574,"STATE",FROM,PRIORITY))
if PRIORITY=""
QUIT
Begin DoDot:2
+31 SET X=$ORDER(^MAGDOUTP(2006.574,"STATE",FROM,PRIORITY,"WAITING",""))
if X
SET PRIORITY(PRIORITY,FROM)=""
+32 QUIT
End DoDot:2
+33 QUIT
End DoDot:1
+34 KILL OUT
SET OUT(1)=""
SET PRIORITY=$ORDER(PRIORITY(""),-1)
if PRIORITY'=""
Begin DoDot:1
+35 SET FROM=$ORDER(PRIORITY(PRIORITY,""))
+36 SET D0=""
FOR
SET D0=$ORDER(^MAGDOUTP(2006.574,"STATE",FROM,PRIORITY,"WAITING",D0))
if D0=""
QUIT
Begin DoDot:2
+37 SET D1=""
FOR
SET D1=$ORDER(^MAGDOUTP(2006.574,"STATE",FROM,PRIORITY,"WAITING",D0,D1))
if D1=""
QUIT
Begin DoDot:3
+38 ; ONLYCHECK=1 for batch export; ONLYCHECK=0 for a transmission process
+39 ; do only when called from a transmission process, not batch export
IF 'ONLYCHECK
Begin DoDot:4
+40 SET $PIECE(^MAGDOUTP(2006.574,D0,1,D1,0),"^",2,3)="XMIT^"_$HOROLOG
+41 KILL ^MAGDOUTP(2006.574,"STATE",FROM,PRIORITY,"WAITING",D0,D1)
+42 SET ^MAGDOUTP(2006.574,"STATE",FROM,PRIORITY,"XMIT",D0,D1)=""
+43 QUIT
End DoDot:4
+44 SET OUT(1)=1
+45 SET OUT(2)=D0
+46 SET OUT(3)=D1
+47 SET X=$GET(^MAGDOUTP(2006.574,D0,0))
+48 ; Application
SET OUT(4)=$PIECE(X,"^",1)
+49 ; Group
SET (OUT(5),GROUP)=$PIECE(X,"^",2)
+50 ; Accession Number
SET (ACNUMB,OUT(6))=$PIECE(X,"^",3)
+51 SET JBTOHD=+$PIECE(X,"^",6)
+52 ; Image IEN or Artifact IEN
SET OUT(7)=$PIECE(^MAGDOUTP(2006.574,D0,1,D1,0),"^",1)
+53 IF GROUP="New SOP Class DB"
Begin DoDot:4
+54 ; ARTIFACT file (#2006.916) IEN
SET ARTIFACTIX=OUT(7)
+55 ; no legacy Object Type (2005 field 3)
SET OUT(8)=GROUP
+56 ; get DFN from IMAGE STUDY file (#2005.62) and IMAGING PATIENT REFERENCE file (#2005.61)
+57 ; get IMAGE STUDY pointer
SET STUDYIX=$ORDER(^MAGV(2005.62,"D",ACNUMB,""))
+58 ; get IMAGING PATIENT REFERENCE (DFN)
SET DFN=$$GET1^DIQ(2005.62,STUDYIX,13,"E")
+59 ; there may be multiple artifact instances - use the first one
+60 ; could check the NETWORK LOCATION file (2005.2) STORAGE TYPE = "TIER 1"
+61 ; get first Artifact Instance pointer
SET ARTIFACTINSTIX=$ORDER(^MAGV(2006.918,"B",ARTIFACTIX,""))
+62 ; FILEREF (filename)
SET F1=$$UP^MAGDFCNV($$GET1^DIQ(2006.918,ARTIFACTINSTIX,6))
+63 ; DISK VOLUME
SET DISKVOLUME=$$GET1^DIQ(2006.918,ARTIFACTINSTIX,7,"I")
+64 ; PHYSICAL REFERENCE
SET PHYSICALREF=$$GET1^DIQ(2005.2,DISKVOLUME,1)
+65 ; FILEPATH
SET FILEPATH=$$GET1^DIQ(2006.918,ARTIFACTINSTIX,8)
+66 SET (F2,F3)=PHYSICALREF_FILEPATH_F1
+67 QUIT
End DoDot:4
+68 IF '$TEST
Begin DoDot:4
+69 SET IMAGEIEN=OUT(7)
+70 ; Object Type
SET OUT(8)=$PIECE($GET(^MAG(2005,IMAGEIEN,0)),"^",6)
+71 SET TYPE=$SELECT($GET(^MAG(2005,IMAGEIEN,"FBIG"))'="":"BIG",1:"FULL")
+72 ; 3rd parameter set to 1 to allow retrieval from jukebox
+73 DO FILEFIND^MAGDFB(IMAGEIEN,TYPE,1,0,.F1,.F2)
+74 ; P156 DAC - get DFN from image (not group)
SET DFN=$PIECE($GET(^MAG(2005,+OUT(7),0)),"^",7)
+75 ; get path for *.TXT, always the same as the FULL file
+76 DO FILEFIND^MAGDFB(IMAGEIEN,"FULL",JBTOHD,0,.F1,.F3)
+77 QUIT
End DoDot:4
+78 ; file name
SET OUT(9)=F1
+79 ; full file path
SET OUT(10)=F2
+80 SET OUT(11)=DFN
+81 ; full file path
SET OUT(12)=F3
+82 SET X=$GET(^MAGDOUTP(2006.574,D0,1,0))
+83 ; Object count
SET OUT(13)=$PIECE(X,"^",4)
+84 QUIT
End DoDot:3
if OUT(1)'=""
QUIT
+85 QUIT
End DoDot:2
if OUT(1)'=""
QUIT
+86 QUIT
End DoDot:1
+87 IF OUT(1)=""
Begin DoDot:1
+88 SET OUT(1)="-2,Nothing to be transmitted."
+89 DO CLEANUP
+90 QUIT
End DoDot:1
+91 ; P180 DAC - Unlock global
LOCK -^MAGDOUTP(2006.574)
+92 QUIT
+93 ;
RETRYXMT(FROM,PRIORITY,OLDSTATE,TIMEOUT,DEFAULTTIMEOUT) ; retry transmission
+1 ; move images from XMIT or FAIL state to WAITING state
+2 NEW D0,D1,H,X
+3 ;
+4 ; XMIT/FAIL timeout not defined
IF TIMEOUT=""
SET TIMEOUT=DEFAULTTIMEOUT
+5 ;
+6 ; retransmission is disabled
IF TIMEOUT=0
QUIT
+7 ;
+8 SET H=$$SECOND($HOROLOG)
+9 SET D0=""
FOR
SET D0=$ORDER(^MAGDOUTP(2006.574,"STATE",FROM,PRIORITY,OLDSTATE,D0))
if D0=""
QUIT
Begin DoDot:1
+10 SET D1=""
FOR
SET D1=$ORDER(^MAGDOUTP(2006.574,"STATE",FROM,PRIORITY,OLDSTATE,D0,D1))
if D1=""
QUIT
Begin DoDot:2
+11 SET X=$$SECOND($PIECE($GET(^MAGDOUTP(2006.574,D0,1,D1,0),"^^"_$HOROLOG),"^",3))
+12 if H-X<TIMEOUT
QUIT
+13 SET $PIECE(^MAGDOUTP(2006.574,D0,1,D1,0),"^",2)="WAITING"
+14 KILL ^MAGDOUTP(2006.574,"STATE",FROM,PRIORITY,OLDSTATE,D0,D1)
+15 SET ^MAGDOUTP(2006.574,"STATE",FROM,PRIORITY,"WAITING",D0,D1)=""
+16 QUIT
End DoDot:2
+17 QUIT
End DoDot:1
+18 QUIT
+19 ;
CLEANUP ; remove old studies
+1 NEW D0,D1,I,REQUESTDATETIME,SENT
+2 ; delete anything 15 days older or older
SET REQUESTDATETIME=$$FMADD^XLFDT($$NOW^XLFDT,-15,0,0,0)
+3 FOR
SET REQUESTDATETIME=$ORDER(^MAGDOUTP(2006.574,"C",REQUESTDATETIME),-1)
if REQUESTDATETIME=""
QUIT
Begin DoDot:1
+4 SET D0=""
FOR
SET D0=$ORDER(^MAGDOUTP(2006.574,"C",REQUESTDATETIME,D0))
if D0=""
QUIT
Begin DoDot:2
+5 SET D1=0
FOR
SET D1=$ORDER(^MAGDOUTP(2006.574,D0,1,D1))
if D1=""
QUIT
Begin DoDot:3
+6 ; STATE=<null>
SET I=1
SET SENT(1)=D0_"^"_D1_"^"
DO CLEAN
+7 QUIT
End DoDot:3
+8 QUIT
End DoDot:2
+9 QUIT
End DoDot:1
+10 QUIT
+11 ;
CLEAN ; remove one image entry from the queue
+1 ; P305 PMK 09/29/2021
NEW D0,D1,REQUESTDATETIME,STUID,PRIORITY,STATE,NEWSTATE
+2 SET D0=$PIECE(SENT(I),"^",1)
SET D1=$PIECE(SENT(I),"^",2)
SET NEWSTATE=$PIECE(SENT(I),"^",3)
+3 if '$DATA(^MAGDOUTP(2006.574,D0,1,D1))
QUIT
+4 ;
+5 SET X=$GET(^MAGDOUTP(2006.574,D0,0))
SET LOC=$PIECE(X,"^",4)
SET PRIORITY=+$PIECE(X,"^",5)
+6 SET REQUESTDATETIME=$PIECE(X,"^",7)
+7 SET STATE=$PIECE($GET(^MAGDOUTP(2006.574,D0,1,D1,0)),"^",2)
+8 ;
+9 ; just update the status and get out
IF NEWSTATE'=""
Begin DoDot:1
+10 SET $PIECE(^MAGDOUTP(2006.574,D0,1,D1,0),"^",2)=NEWSTATE
SET $PIECE(^(0),"^",3)=$HOROLOG
+11 ; remove the old xref before setting the new one - P305 PMK 09/29/2021
+12 IF LOC'=""
IF PRIORITY'=""
IF STATE'=""
KILL ^MAGDOUTP(2006.574,"STATE",LOC,PRIORITY,STATE,D0,D1)
+13 IF LOC'=""
IF PRIORITY'=""
SET ^MAGDOUTP(2006.574,"STATE",LOC,PRIORITY,NEWSTATE,D0,D1)=""
+14 QUIT
End DoDot:1
QUIT
+15 ;
+16 KILL ^MAGDOUTP(2006.574,D0,1,D1)
+17 IF LOC'=""
IF PRIORITY'=""
IF STATE'=""
KILL ^MAGDOUTP(2006.574,"STATE",LOC,PRIORITY,STATE,D0,D1)
+18 SET X=$GET(^MAGDOUTP(2006.574,D0,1,0))
+19 SET $PIECE(X,"^",4)=$PIECE(X,"^",4)-1
+20 SET ^MAGDOUTP(2006.574,D0,1,0)=X
+21 ;
+22 ; don't delete the study node yet
if $ORDER(^MAGDOUTP(2006.574,D0,1,0))
QUIT
+23 ;
+24 SET STUID=$GET(^MAGDOUTP(2006.574,D0,2))
+25 KILL ^MAGDOUTP(2006.574,D0)
+26 if REQUESTDATETIME'=""
KILL ^MAGDOUTP(2006.574,"C",REQUESTDATETIME,D0)
+27 if STUID'=""
KILL ^MAGDOUTP(2006.574,"STUDY",STUID)
+28 SET X=$GET(^MAGDOUTP(2006.574,0))
+29 SET $PIECE(X,"^",4)=$PIECE(X,"^",4)-1
+30 SET ^MAGDOUTP(2006.574,0)=X
+31 QUIT
+32 ;
FIND(DATE,CASE,NUM) ;
+1 ; Use the ADC x-reference in the radiology patient file
+2 NEW NDATE
+3 SET NDATE=$$FMADD^XLFDT(DATE,NUM)
if NDATE<1
QUIT 0
+4 QUIT $ORDER(^RADPT("ADC",$$MMDDYY(NDATE)_"-"_CASE,""))
+5 ;
MMDDYY(DAY) ; Convert Fileman date to mmddyy
+1 IF DAY'?7N
QUIT 0
+2 QUIT $EXTRACT(DAY,4,7)_$EXTRACT(DAY,2,3)
+3 ;
SECOND(H) QUIT H*86400+$PIECE(H,",",2)
+1 ;
