MAGDRPC3 ;WOIFO/EDM,SAF,DAC - Imaging RPCs ; Apr 20, 2022@12:50:41
;;3.0;IMAGING;**11,30,51,50,85,54,49,123,138,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
;
RADLKUP(OUT,CASENUMB,STUDYDAT) ; RPC = MAG DICOM LOOKUP RAD STUDY
; Radiology patient/study lookup
; STUDYDAT is a vestigial input parameter, it is not used
N ACNUMB ;--- Accession Number
N CPTCODE ;-- CPT code for the procedure
N CPTNAME ;-- CPT name for the procedure
N DATETIME ;- Timestamp
N DIVISION ;- pointer to INSTITUTION file (#4)
N EXAMSTS ;-- Exam status (don't post images to CANCELLED exams)
N PROCDESC ;- Procedure description
N PROCIEN ;-- radiology procedure ien in ^RAMIS(71)
N RAA ;------ array for returned value
N RAIX ;----- cross reference subscript for case number lookup
N RADPT1 ;--- first level subscript in ^RADPT
N RADPT2 ;--- second level subscript in ^RADPT (after "DT")
N RADPT3 ;--- third level subscript in ^RADPT (after "P")
N D1,I,LIST,X,Z
;
; find the patient/study in ^RADPT using the Radiology Case Number
K OUT
;
I $G(CASENUMB)="" S OUT(1)="-1,No Case Number Specified" Q
;
S X=$$ACCFIND^RAAPI(CASENUMB,.RAA) ; IA 5020
;
I X<0 S OUT(1)="-2,Error in Accession Number Lookup: <<"_X_">>" Q
;
S RADPT1=$P(RAA(1),"^",1),RADPT2=$P(RAA(1),"^",2),RADPT3=$P(RAA(1),"^",3)
;
I RADPT1="" S OUT(1)="-3,Null RADPT1 entry returned by $$ACCFIND^RAAPI" Q
I RADPT2="" S OUT(1)="-4,Null RADPT2 entry returned by $$ACCFIND^RAAPI" Q
I RADPT3="" S OUT(1)="-5,Null RADPT3 entry returned by $$ACCFIND^RAAPI" Q
;
I '$D(^RADPT(RADPT1,0)) S OUT(1)="-6,No patient demographics file pointer" Q
;
; get patient demographics file pointer
S DFN=$P(^RADPT(RADPT1,0),"^",1)
;
I '$D(^RADPT(RADPT1,"DT",RADPT2,0)) S OUT(1)="-7,No date/time level" Q
;
; get date and time of examination
S DATETIME=$P($G(^RADPT(RADPT1,"DT",RADPT2,0)),"^",1)
; get case info
;
I '$D(^RADPT(RADPT1,"DT",RADPT2,"P",RADPT3,0)) S OUT(1)="-8,No study level" Q
;
S X=^RADPT(RADPT1,"DT",RADPT2,"P",RADPT3,0)
S Z=$P(X,"^",17) I Z S Z=$$ACCRPT^RAAPI(Z,.RAA) S ACNUMB=RAA(1)
S PROCIEN=$P(X,"^",2),EXAMSTS=$P(X,"^",3)
S:EXAMSTS EXAMSTS=$$GET1^DIQ(72,EXAMSTS,.01)
S (PROCDESC,CPTNAME,CPTCODE)=""
;
; need PROCIEN to do lookup in ^RAMIS
I 'PROCIEN S OUT(1)="-9,No procedure identifier" Q
;
S Z=$G(^RAMIS(71,PROCIEN,0))
S PROCDESC=$P(Z,"^",1),CPTCODE=$P(Z,"^",9)
S CPTNAME=$P($$CPT^ICPTCOD(+CPTCODE),"^",3) ; IA 1995
S:CPTNAME="" CPTNAME=PROCDESC
S OUT(2)=$G(RADPT1)
S OUT(3)=$G(RADPT2)
S OUT(4)=$G(RADPT3)
S OUT(5)=$G(PROCIEN)
S OUT(6)=$G(CPTCODE)
S OUT(7)=$G(CPTNAME)
S OUT(8)=$G(Z)
S OUT(9)=$G(EXAMSTS)
S OUT(10)=$G(DFN)
S OUT(11)=$G(DATETIME)
S OUT(12)=$G(PROCDESC)
S X=""
I $G(PROCIEN) S D1=0 F S D1=$O(^RAMIS(71,PROCIEN,"MDL",D1)) Q:'D1 D
. S Z=+$P($G(^RAMIS(71,PROCIEN,"MDL",D1,0)),"^",1) Q:'Z
. S Z=$P($G(^RAMIS(73.1,Z,0)),"^",1) Q:Z=""
. S:X'="" X=X_"," S X=X_Z
. Q
S OUT(13)=X ; List of Modality-codes
S X="" I $G(RADPT1),$G(RADPT2) S X=$G(^RADPT(RADPT1,"DT",RADPT2,0))
S DIVISION=$P(X,"^",3) ; pointer to INSTITUTION file (#4) for division
S OUT(14)=$S($$ISIHS^MAGSPID():$P($$SITE^VASITE(),"^",3),1:$E($$GET1^DIQ(4,DIVISION,99),1,3)) ; station number, exclusive of any modifiers
; Patient's pregnancy status at the time of the exam
S X="" I $G(DFN),$G(RADPT2),$G(RADPT3) S X=$G(^RADPT(DFN,"DT",RADPT2,"P",RADPT3,0))
S OUT(15)=$P($G(^RAO(75.1,+$P(X,"^",11),0)),"^",13)
S OUT(16)=$G(ACNUMB)
S OUT(1)=1 ; OK
Q
;
QUEUE(OUT,IMAGE,APPNAM,LOCATION,ACNUMB,REASON,EMAIL,PRIORITY,JBTOHD) ; RPC = MAG DICOM QUEUE IMAGE
; Add the DICOM study send image request to the queue
N COUNT,D0,D1,DFN,LOG,OK,P,PROBLEM,REQUESTDATETIME,STUDYUID,TYPE,X
;
K OUT ; RPC return variable
;
I $G(IMAGE)="New SOP Class DB" D Q ; P305 PMK 04/05/2021
. ; queue new SOP Class database requests
. D QUEUE^MAGDRPCD(.OUT,IMAGE,APPNAM,LOCATION,ACNUMB,REASON,EMAIL,PRIORITY,JBTOHD)
. Q
;
I '$G(IMAGE) S OUT="-1,No Image specified" Q
I $G(APPNAM)="" S OUT="-2,No Destination specified" Q
I '$G(LOCATION) S OUT="-3,No Origin specified" Q
S PRIORITY=+$G(PRIORITY) S:'PRIORITY PRIORITY=500
S JBTOHD=$S($G(JBTOHD):1,1:0)
;
S X=$G(^MAG(2005,IMAGE,0))
S TYPE=+$P(X,"^",6),DFN=$P(X,"^",7)
I " 0 11 3 100 "'[(" "_TYPE_" ") D Q
. S OUT="-4,Cannot Queue Image Object Type """_TYPE_"""."
. Q
;
Q:$D(OUT) ; problem with accesion number lookup
;
L +^MAGDOUTP(2006.574):1E9 ; P180 DAC - Lock global, background process MUST wait
S P=$P($G(^MAG(2005,IMAGE,0)),"^",10),P=$S(P:P,1:IMAGE)
S STUDYUID=$P($G(^MAG(2005,P,"PACS")),"^",1) S:STUDYUID="" STUDYUID="?"
S OK=0,D0="" F S D0=$O(^MAGDOUTP(2006.574,"STUDY",STUDYUID,"LEGACY",D0)) Q:'D0 D Q:OK
. Q:'$D(^MAGDOUTP(2006.574,"STATE",LOCATION,PRIORITY,"WAITING",D0))
. Q:$P($G(^MAGDOUTP(2006.574,D0,0)),"^",1)'=APPNAM
. S OK=D0
. Q
S D0=OK
I D0 S OUT=D0 ; return the existing pointer to the DICOM OBJECT EXPORT (file #2006.574) queue
E D ; get the next pointer to the queue
. I $G(ACNUMB)="" D Q:$D(OUT) ; get the accession number (it's sometimes not passed)
. . N RESULT
. . D LOOKUP^MAGDRPCA(.RESULT,P)
. . I RESULT<0 S OUT="-4,Accession Number Lookup Problem: "_RESULT
. . E S ACNUMB=$P(RESULT,"^",8)
. . Q
. S X=$G(^MAGDOUTP(2006.574,0))
. S $P(X,"^",1,2)="DICOM OBJECT EXPORT^2006.574"
. S D0=$O(^MAGDOUTP(2006.574," "),-1)+1 ; Next number
. S $P(X,"^",3)=D0
. S $P(X,"^",4)=$P(X,"^",4)+1 ; Total count
. S ^MAGDOUTP(2006.574,0)=X
. S REQUESTDATETIME=$$NOW^XLFDT
. S ^MAGDOUTP(2006.574,D0,0)=APPNAM_"^"_P_"^"_ACNUMB_"^"_LOCATION_"^"_PRIORITY_"^"_JBTOHD_"^"_REQUESTDATETIME_"^LEGACY"
. S ^MAGDOUTP(2006.574,"C",REQUESTDATETIME,D0)="" ; cross reference to delete old studies
. S ^MAGDOUTP(2006.574,D0,2)=STUDYUID
. S ^MAGDOUTP(2006.574,"STUDY",STUDYUID,"LEGACY",D0)=""
. S ^MAGDOUTP(2006.574,"D",ACNUMB,D0)="" ; P305 PMK 03/22/2021
. ;
. S OUT=D0 ; return a pointer to the DICOM OBJECT EXPORT (file #2006.574) queue
. ;
. Q
L -^MAGDOUTP(2006.574)
S COUNT=0,PROBLEM=3
I (TYPE=3)!(TYPE=100) D ; Single XRAY or DICOM image
. S COUNT=COUNT+$$ENQUEUE(IMAGE,D0,PRIORITY)
. Q
I TYPE=11 D ; Process all the images in an XRAY group
. S D1=0 F S D1=$O(^MAG(2005,IMAGE,1,D1)) Q:'D1 D
. . S COUNT=COUNT+$$ENQUEUE($P($G(^MAG(2005,IMAGE,1,D1,0)),"^",1),D0,PRIORITY)
. . Q
. Q
;
S LOG="DICOM transmit to "_APPNAM_" for reason "_REASON
D:COUNT ENTRY^MAGLOG($C(REASON+64),DUZ,IMAGE,"DICOM Gateway",DFN,COUNT,LOG)
D:PROBLEM>3
. N XMERR,XMID,XMSUB,XMY,XMZ
. S PROBLEM(1)="Error while queueing image for Transmission:"
. S PROBLEM(2)=LOG
. S PROBLEM(3)=" "
. ; --- send MailMan message...
. S XMID=$G(DUZ) S:'XMID XMID=.5
. S XMY(XMID)=""
. S:$G(EMAIL)'="" XMY(EMAIL)=""
. S XMSUB=$E("Cannot transmit image(s) to "_APPNAM,1,63)
. D SENDMSG^XMXAPI(XMID,XMSUB,"PROBLEM",.XMY,,.XMZ,)
. Q:'$G(XMERR)
. M XMERR=^TMP("XMERR",$J) S $EC=",U13-Cannot send MailMan message,"
. Q
Q
;
ENQUEUE(IMAGE,D0,PRIORITY,NEWSOPCLASS) ; Add an image to the DICOM send image request queue sub-file
S NEWSOPCLASS=$G(NEWSOPCLASS,0) ; only set in MAGDRPCD
I 'NEWSOPCLASS Q:'IMAGE 0 ; check for legacy 2005 image ien
N D1,I,OLD,X
;
; if IMAGE is a legacy 2005 IEN, do CHK^MAGGSQI
; if IMAGE is a new SOP Class DB token, skip the check
I 'NEWSOPCLASS D CHK^MAGGSQI(.X,IMAGE) I +$G(X(0))'=1 D Q 0
. S PROBLEM=PROBLEM+1,PROBLEM(PROBLEM)=" "
. S PROBLEM=PROBLEM+1,PROBLEM(PROBLEM)="Image # "_IMAGE_":"
. S I="" F S I=$O(X(I)) Q:I="" S PROBLEM=PROBLEM+1,PROBLEM(PROBLEM)=X(I)
. Q
;
; Enter each image at most once in each transmission request
S (D1,OLD)=0 F S D1=$O(^MAGDOUTP(2006.574,D0,1,D1)) Q:'D1 D Q:OLD
. S:$P($G(^MAGDOUTP(2006.574,D0,1,D1,0)),"^",1)=IMAGE OLD=1
. Q
Q:OLD 1
;
L +^MAGDOUTP(2006.574):1E9 ; P180 DAC - Lock global, background Process MUST wait
S X=$G(^MAGDOUTP(2006.574,D0,1,0))
S $P(X,"^",1,2)="^2006.5744"
S D1=$O(^MAGDOUTP(2006.574,D0,1," "),-1)+1,$P(X,"^",3)=D1
S $P(X,"^",4)=$P(X,"^",4)+1
S ^MAGDOUTP(2006.574,D0,1,0)=X
S ^MAGDOUTP(2006.574,D0,1,D1,0)=IMAGE_"^WAITING^"_$H
S ^MAGDOUTP(2006.574,"STATE",LOCATION,PRIORITY,"WAITING",D0,D1)=""
L -^MAGDOUTP(2006.574)
Q 1
;
FIND(DATE,CASE,NUM) ; ADC x-reference (Radiology patient file)
N X
Q:'$G(DATE) 0
S X=DATE S:$G(NUM) X=$$FMADD^XLFDT(DATE,NUM) Q:X<1 0
Q $O(^RADPT("ADC",$$MMDDYY(X)_"-"_CASE,""))
;
MMDDYY(DAY) ; YYYMMDD --> MMDDYY
I DAY'?7N Q 0
Q $E(DAY,4,7)_$E(DAY,2,3)
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMAGDRPC3 9573 printed Apr 09, 2024@21:03:20 Page 2
MAGDRPC3 ;WOIFO/EDM,SAF,DAC - Imaging RPCs ; Apr 20, 2022@12:50:41
+1 ;;3.0;IMAGING;**11,30,51,50,85,54,49,123,138,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 ;
RADLKUP(OUT,CASENUMB,STUDYDAT) ; RPC = MAG DICOM LOOKUP RAD STUDY
+1 ; Radiology patient/study lookup
+2 ; STUDYDAT is a vestigial input parameter, it is not used
+3 ;--- Accession Number
NEW ACNUMB
+4 ;-- CPT code for the procedure
NEW CPTCODE
+5 ;-- CPT name for the procedure
NEW CPTNAME
+6 ;- Timestamp
NEW DATETIME
+7 ;- pointer to INSTITUTION file (#4)
NEW DIVISION
+8 ;-- Exam status (don't post images to CANCELLED exams)
NEW EXAMSTS
+9 ;- Procedure description
NEW PROCDESC
+10 ;-- radiology procedure ien in ^RAMIS(71)
NEW PROCIEN
+11 ;------ array for returned value
NEW RAA
+12 ;----- cross reference subscript for case number lookup
NEW RAIX
+13 ;--- first level subscript in ^RADPT
NEW RADPT1
+14 ;--- second level subscript in ^RADPT (after "DT")
NEW RADPT2
+15 ;--- third level subscript in ^RADPT (after "P")
NEW RADPT3
+16 NEW D1,I,LIST,X,Z
+17 ;
+18 ; find the patient/study in ^RADPT using the Radiology Case Number
+19 KILL OUT
+20 ;
+21 IF $GET(CASENUMB)=""
SET OUT(1)="-1,No Case Number Specified"
QUIT
+22 ;
+23 ; IA 5020
SET X=$$ACCFIND^RAAPI(CASENUMB,.RAA)
+24 ;
+25 IF X<0
SET OUT(1)="-2,Error in Accession Number Lookup: <<"_X_">>"
QUIT
+26 ;
+27 SET RADPT1=$PIECE(RAA(1),"^",1)
SET RADPT2=$PIECE(RAA(1),"^",2)
SET RADPT3=$PIECE(RAA(1),"^",3)
+28 ;
+29 IF RADPT1=""
SET OUT(1)="-3,Null RADPT1 entry returned by $$ACCFIND^RAAPI"
QUIT
+30 IF RADPT2=""
SET OUT(1)="-4,Null RADPT2 entry returned by $$ACCFIND^RAAPI"
QUIT
+31 IF RADPT3=""
SET OUT(1)="-5,Null RADPT3 entry returned by $$ACCFIND^RAAPI"
QUIT
+32 ;
+33 IF '$DATA(^RADPT(RADPT1,0))
SET OUT(1)="-6,No patient demographics file pointer"
QUIT
+34 ;
+35 ; get patient demographics file pointer
+36 SET DFN=$PIECE(^RADPT(RADPT1,0),"^",1)
+37 ;
+38 IF '$DATA(^RADPT(RADPT1,"DT",RADPT2,0))
SET OUT(1)="-7,No date/time level"
QUIT
+39 ;
+40 ; get date and time of examination
+41 SET DATETIME=$PIECE($GET(^RADPT(RADPT1,"DT",RADPT2,0)),"^",1)
+42 ; get case info
+43 ;
+44 IF '$DATA(^RADPT(RADPT1,"DT",RADPT2,"P",RADPT3,0))
SET OUT(1)="-8,No study level"
QUIT
+45 ;
+46 SET X=^RADPT(RADPT1,"DT",RADPT2,"P",RADPT3,0)
+47 SET Z=$PIECE(X,"^",17)
IF Z
SET Z=$$ACCRPT^RAAPI(Z,.RAA)
SET ACNUMB=RAA(1)
+48 SET PROCIEN=$PIECE(X,"^",2)
SET EXAMSTS=$PIECE(X,"^",3)
+49 if EXAMSTS
SET EXAMSTS=$$GET1^DIQ(72,EXAMSTS,.01)
+50 SET (PROCDESC,CPTNAME,CPTCODE)=""
+51 ;
+52 ; need PROCIEN to do lookup in ^RAMIS
+53 IF 'PROCIEN
SET OUT(1)="-9,No procedure identifier"
QUIT
+54 ;
+55 SET Z=$GET(^RAMIS(71,PROCIEN,0))
+56 SET PROCDESC=$PIECE(Z,"^",1)
SET CPTCODE=$PIECE(Z,"^",9)
+57 ; IA 1995
SET CPTNAME=$PIECE($$CPT^ICPTCOD(+CPTCODE),"^",3)
+58 if CPTNAME=""
SET CPTNAME=PROCDESC
+59 SET OUT(2)=$GET(RADPT1)
+60 SET OUT(3)=$GET(RADPT2)
+61 SET OUT(4)=$GET(RADPT3)
+62 SET OUT(5)=$GET(PROCIEN)
+63 SET OUT(6)=$GET(CPTCODE)
+64 SET OUT(7)=$GET(CPTNAME)
+65 SET OUT(8)=$GET(Z)
+66 SET OUT(9)=$GET(EXAMSTS)
+67 SET OUT(10)=$GET(DFN)
+68 SET OUT(11)=$GET(DATETIME)
+69 SET OUT(12)=$GET(PROCDESC)
+70 SET X=""
+71 IF $GET(PROCIEN)
SET D1=0
FOR
SET D1=$ORDER(^RAMIS(71,PROCIEN,"MDL",D1))
if 'D1
QUIT
Begin DoDot:1
+72 SET Z=+$PIECE($GET(^RAMIS(71,PROCIEN,"MDL",D1,0)),"^",1)
if 'Z
QUIT
+73 SET Z=$PIECE($GET(^RAMIS(73.1,Z,0)),"^",1)
if Z=""
QUIT
+74 if X'=""
SET X=X_","
SET X=X_Z
+75 QUIT
End DoDot:1
+76 ; List of Modality-codes
SET OUT(13)=X
+77 SET X=""
IF $GET(RADPT1)
IF $GET(RADPT2)
SET X=$GET(^RADPT(RADPT1,"DT",RADPT2,0))
+78 ; pointer to INSTITUTION file (#4) for division
SET DIVISION=$PIECE(X,"^",3)
+79 ; station number, exclusive of any modifiers
SET OUT(14)=$SELECT($$ISIHS^MAGSPID():$PIECE($$SITE^VASITE(),"^",3),1:$EXTRACT($$GET1^DIQ(4,DIVISION,99),1,3))
+80 ; Patient's pregnancy status at the time of the exam
+81 SET X=""
IF $GET(DFN)
IF $GET(RADPT2)
IF $GET(RADPT3)
SET X=$GET(^RADPT(DFN,"DT",RADPT2,"P",RADPT3,0))
+82 SET OUT(15)=$PIECE($GET(^RAO(75.1,+$PIECE(X,"^",11),0)),"^",13)
+83 SET OUT(16)=$GET(ACNUMB)
+84 ; OK
SET OUT(1)=1
+85 QUIT
+86 ;
QUEUE(OUT,IMAGE,APPNAM,LOCATION,ACNUMB,REASON,EMAIL,PRIORITY,JBTOHD) ; RPC = MAG DICOM QUEUE IMAGE
+1 ; Add the DICOM study send image request to the queue
+2 NEW COUNT,D0,D1,DFN,LOG,OK,P,PROBLEM,REQUESTDATETIME,STUDYUID,TYPE,X
+3 ;
+4 ; RPC return variable
KILL OUT
+5 ;
+6 ; P305 PMK 04/05/2021
IF $GET(IMAGE)="New SOP Class DB"
Begin DoDot:1
+7 ; queue new SOP Class database requests
+8 DO QUEUE^MAGDRPCD(.OUT,IMAGE,APPNAM,LOCATION,ACNUMB,REASON,EMAIL,PRIORITY,JBTOHD)
+9 QUIT
End DoDot:1
QUIT
+10 ;
+11 IF '$GET(IMAGE)
SET OUT="-1,No Image specified"
QUIT
+12 IF $GET(APPNAM)=""
SET OUT="-2,No Destination specified"
QUIT
+13 IF '$GET(LOCATION)
SET OUT="-3,No Origin specified"
QUIT
+14 SET PRIORITY=+$GET(PRIORITY)
if 'PRIORITY
SET PRIORITY=500
+15 SET JBTOHD=$SELECT($GET(JBTOHD):1,1:0)
+16 ;
+17 SET X=$GET(^MAG(2005,IMAGE,0))
+18 SET TYPE=+$PIECE(X,"^",6)
SET DFN=$PIECE(X,"^",7)
+19 IF " 0 11 3 100 "'[(" "_TYPE_" ")
Begin DoDot:1
+20 SET OUT="-4,Cannot Queue Image Object Type """_TYPE_"""."
+21 QUIT
End DoDot:1
QUIT
+22 ;
+23 ; problem with accesion number lookup
if $DATA(OUT)
QUIT
+24 ;
+25 ; P180 DAC - Lock global, background process MUST wait
LOCK +^MAGDOUTP(2006.574):1E9
+26 SET P=$PIECE($GET(^MAG(2005,IMAGE,0)),"^",10)
SET P=$SELECT(P:P,1:IMAGE)
+27 SET STUDYUID=$PIECE($GET(^MAG(2005,P,"PACS")),"^",1)
if STUDYUID=""
SET STUDYUID="?"
+28 SET OK=0
SET D0=""
FOR
SET D0=$ORDER(^MAGDOUTP(2006.574,"STUDY",STUDYUID,"LEGACY",D0))
if 'D0
QUIT
Begin DoDot:1
+29 if '$DATA(^MAGDOUTP(2006.574,"STATE",LOCATION,PRIORITY,"WAITING",D0))
QUIT
+30 if $PIECE($GET(^MAGDOUTP(2006.574,D0,0)),"^",1)'=APPNAM
QUIT
+31 SET OK=D0
+32 QUIT
End DoDot:1
if OK
QUIT
+33 SET D0=OK
+34 ; return the existing pointer to the DICOM OBJECT EXPORT (file #2006.574) queue
IF D0
SET OUT=D0
+35 ; get the next pointer to the queue
IF '$TEST
Begin DoDot:1
+36 ; get the accession number (it's sometimes not passed)
IF $GET(ACNUMB)=""
Begin DoDot:2
+37 NEW RESULT
+38 DO LOOKUP^MAGDRPCA(.RESULT,P)
+39 IF RESULT<0
SET OUT="-4,Accession Number Lookup Problem: "_RESULT
+40 IF '$TEST
SET ACNUMB=$PIECE(RESULT,"^",8)
+41 QUIT
End DoDot:2
if $DATA(OUT)
QUIT
+42 SET X=$GET(^MAGDOUTP(2006.574,0))
+43 SET $PIECE(X,"^",1,2)="DICOM OBJECT EXPORT^2006.574"
+44 ; Next number
SET D0=$ORDER(^MAGDOUTP(2006.574," "),-1)+1
+45 SET $PIECE(X,"^",3)=D0
+46 ; Total count
SET $PIECE(X,"^",4)=$PIECE(X,"^",4)+1
+47 SET ^MAGDOUTP(2006.574,0)=X
+48 SET REQUESTDATETIME=$$NOW^XLFDT
+49 SET ^MAGDOUTP(2006.574,D0,0)=APPNAM_"^"_P_"^"_ACNUMB_"^"_LOCATION_"^"_PRIORITY_"^"_JBTOHD_"^"_REQUESTDATETIME_"^LEGACY"
+50 ; cross reference to delete old studies
SET ^MAGDOUTP(2006.574,"C",REQUESTDATETIME,D0)=""
+51 SET ^MAGDOUTP(2006.574,D0,2)=STUDYUID
+52 SET ^MAGDOUTP(2006.574,"STUDY",STUDYUID,"LEGACY",D0)=""
+53 ; P305 PMK 03/22/2021
SET ^MAGDOUTP(2006.574,"D",ACNUMB,D0)=""
+54 ;
+55 ; return a pointer to the DICOM OBJECT EXPORT (file #2006.574) queue
SET OUT=D0
+56 ;
+57 QUIT
End DoDot:1
+58 LOCK -^MAGDOUTP(2006.574)
+59 SET COUNT=0
SET PROBLEM=3
+60 ; Single XRAY or DICOM image
IF (TYPE=3)!(TYPE=100)
Begin DoDot:1
+61 SET COUNT=COUNT+$$ENQUEUE(IMAGE,D0,PRIORITY)
+62 QUIT
End DoDot:1
+63 ; Process all the images in an XRAY group
IF TYPE=11
Begin DoDot:1
+64 SET D1=0
FOR
SET D1=$ORDER(^MAG(2005,IMAGE,1,D1))
if 'D1
QUIT
Begin DoDot:2
+65 SET COUNT=COUNT+$$ENQUEUE($PIECE($GET(^MAG(2005,IMAGE,1,D1,0)),"^",1),D0,PRIORITY)
+66 QUIT
End DoDot:2
+67 QUIT
End DoDot:1
+68 ;
+69 SET LOG="DICOM transmit to "_APPNAM_" for reason "_REASON
+70 if COUNT
DO ENTRY^MAGLOG($CHAR(REASON+64),DUZ,IMAGE,"DICOM Gateway",DFN,COUNT,LOG)
+71 if PROBLEM>3
Begin DoDot:1
+72 NEW XMERR,XMID,XMSUB,XMY,XMZ
+73 SET PROBLEM(1)="Error while queueing image for Transmission:"
+74 SET PROBLEM(2)=LOG
+75 SET PROBLEM(3)=" "
+76 ; --- send MailMan message...
+77 SET XMID=$GET(DUZ)
if 'XMID
SET XMID=.5
+78 SET XMY(XMID)=""
+79 if $GET(EMAIL)'=""
SET XMY(EMAIL)=""
+80 SET XMSUB=$EXTRACT("Cannot transmit image(s) to "_APPNAM,1,63)
+81 DO SENDMSG^XMXAPI(XMID,XMSUB,"PROBLEM",.XMY,,.XMZ,)
+82 if '$GET(XMERR)
QUIT
+83 MERGE XMERR=^TMP("XMERR",$JOB)
SET $ECODE=",U13-Cannot send MailMan message,"
+84 QUIT
End DoDot:1
+85 QUIT
+86 ;
ENQUEUE(IMAGE,D0,PRIORITY,NEWSOPCLASS) ; Add an image to the DICOM send image request queue sub-file
+1 ; only set in MAGDRPCD
SET NEWSOPCLASS=$GET(NEWSOPCLASS,0)
+2 ; check for legacy 2005 image ien
IF 'NEWSOPCLASS
if 'IMAGE
QUIT 0
+3 NEW D1,I,OLD,X
+4 ;
+5 ; if IMAGE is a legacy 2005 IEN, do CHK^MAGGSQI
+6 ; if IMAGE is a new SOP Class DB token, skip the check
+7 IF 'NEWSOPCLASS
DO CHK^MAGGSQI(.X,IMAGE)
IF +$GET(X(0))'=1
Begin DoDot:1
+8 SET PROBLEM=PROBLEM+1
SET PROBLEM(PROBLEM)=" "
+9 SET PROBLEM=PROBLEM+1
SET PROBLEM(PROBLEM)="Image # "_IMAGE_":"
+10 SET I=""
FOR
SET I=$ORDER(X(I))
if I=""
QUIT
SET PROBLEM=PROBLEM+1
SET PROBLEM(PROBLEM)=X(I)
+11 QUIT
End DoDot:1
QUIT 0
+12 ;
+13 ; Enter each image at most once in each transmission request
+14 SET (D1,OLD)=0
FOR
SET D1=$ORDER(^MAGDOUTP(2006.574,D0,1,D1))
if 'D1
QUIT
Begin DoDot:1
+15 if $PIECE($GET(^MAGDOUTP(2006.574,D0,1,D1,0)),"^",1)=IMAGE
SET OLD=1
+16 QUIT
End DoDot:1
if OLD
QUIT
+17 if OLD
QUIT 1
+18 ;
+19 ; P180 DAC - Lock global, background Process MUST wait
LOCK +^MAGDOUTP(2006.574):1E9
+20 SET X=$GET(^MAGDOUTP(2006.574,D0,1,0))
+21 SET $PIECE(X,"^",1,2)="^2006.5744"
+22 SET D1=$ORDER(^MAGDOUTP(2006.574,D0,1," "),-1)+1
SET $PIECE(X,"^",3)=D1
+23 SET $PIECE(X,"^",4)=$PIECE(X,"^",4)+1
+24 SET ^MAGDOUTP(2006.574,D0,1,0)=X
+25 SET ^MAGDOUTP(2006.574,D0,1,D1,0)=IMAGE_"^WAITING^"_$HOROLOG
+26 SET ^MAGDOUTP(2006.574,"STATE",LOCATION,PRIORITY,"WAITING",D0,D1)=""
+27 LOCK -^MAGDOUTP(2006.574)
+28 QUIT 1
+29 ;
FIND(DATE,CASE,NUM) ; ADC x-reference (Radiology patient file)
+1 NEW X
+2 if '$GET(DATE)
QUIT 0
+3 SET X=DATE
if $GET(NUM)
SET X=$$FMADD^XLFDT(DATE,NUM)
if X<1
QUIT 0
+4 QUIT $ORDER(^RADPT("ADC",$$MMDDYY(X)_"-"_CASE,""))
+5 ;
MMDDYY(DAY) ; YYYMMDD --> MMDDYY
+1 IF DAY'?7N
QUIT 0
+2 QUIT $EXTRACT(DAY,4,7)_$EXTRACT(DAY,2,3)
+3 ;
