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

MAGDRPC1.m

Go to the documentation of this file.
  1. MAGDRPC1 ;WOIFO/EDM,DAC - Imaging RPCs ; Feb 15, 2022@10:28:27
  1. ;;3.0;IMAGING;**11,30,51,50,54,49,122,138,239,305**;Mar 19, 2002;Build 3
  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. ; Supported IA #3065 reference $$HLNAME^XLFNAME function call
  1. ;
  1. Q
  1. ;
  1. GETPID(OUT) ; RPC = MAG DICOM GET PROCESS ID
  1. S OUT=$J
  1. Q
  1. ;
  1. GETID(OUT,HOSTNAME) ; RPC = MAG DICOM GET MACHINE ID
  1. N D0,I,LO,N,UP,X
  1. S HOSTNAME=$TR($G(HOSTNAME),"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
  1. I HOSTNAME="" S OUT="-1,No Hostname Specified" Q
  1. S OUT=$O(^MAGDICOM(2006.5641,"C",HOSTNAME,""))
  1. Q:OUT>0
  1. L +^MAGDICOM(2006.5641,0):1E9 ; Background process MUST wait
  1. S D0=$O(^MAGDICOM(2006.5641," "),-1)+1
  1. S ^MAGDICOM(2006.5641,D0,0)=D0_"^"_HOSTNAME_"^"_$H
  1. S ^MAGDICOM(2006.5641,"B",D0,D0)=""
  1. S ^MAGDICOM(2006.5641,"C",HOSTNAME,D0)=""
  1. S (N,I,D0)=0 F S D0=$O(^MAGDICOM(2006.5641,D0)) Q:'D0 S N=N+1,I=D0
  1. S ^MAGDICOM(2006.5641,0)="DICOM GATEWAY MACHINE ID^2006.5641^"_I_"^"_N
  1. L -^MAGDICOM(2006.5641,0)
  1. S OUT=D0
  1. Q
  1. ;
  1. DOMAIN(OUT) ; RPC = MAG DICOM GET DOMAIN
  1. N X
  1. S OUT=$$KSP^XUPARAM("WHERE") Q:OUT'="" ; ICR 2541
  1. ; The coding standards frown upon the line below,
  1. ; but it is the best we can do when the line above cannot be used.
  1. S X=^DD("SITE") S:X'[".DOMAIN.EXT" X=X_".DOMAIN.EXT"
  1. S OUT=X
  1. Q
  1. ;
  1. AGENCY(OUT) ; RPC = MAG DICOM GET AGENCY
  1. S OUT=$G(DUZ("AG")) ;P123
  1. Q
  1. ;
  1. INFO(OUT,LOCATION) ; RPC = MAG DICOM ET PHONE HOME
  1. N FST,N,X
  1. K OUT
  1. S FST=$$FMADD^XLFDT(DT,-25)
  1. S N=2
  1. ;
  1. ; Site-ID
  1. D DOMAIN(.X)
  1. S OUT(N)=X
  1. ;
  1. D ROUTEDAY^MAGDRPC2 ; Get routing statistics
  1. ;
  1. D ; Text Gateway Statistics
  1. . N A,C,D0,D2,M,X
  1. . S A=0,D0=FST F S D0=$O(^MAGDAUDT(2006.5761,D0)) Q:'D0 D
  1. . . S D2=0 F S D2=$O(^MAGDAUDT(2006.5761,D0,1,LOCATION,1,D2)) Q:'D2 D
  1. . . . S X=$G(^MAGDAUDT(2006.5761,D0,1,LOCATION,1,D2,0))
  1. . . . S M=$P(X,"^",2) Q:'M
  1. . . . S:'A N=N+1,OUT(N)="Audit",A=1
  1. . . . S N=N+1,OUT(N)="STTX="_D0_"^"_$P(X,"^",1)_"^"_M
  1. . . . Q
  1. . . Q
  1. . Q
  1. ;
  1. S OUT(1)=N-1
  1. Q
  1. ;
  1. STATION(OUT,STATION,VERSION) ; RPC = MAG DICOM WORKSTATION VERSION
  1. N D0,X
  1. I $G(STATION)="" S OUT="-1,No Station Identifier Specified" Q
  1. ;
  1. S D0=$O(^MAG(2006.83,"B",STATION,"")) D:'D0
  1. . L +^MAG(2006.83,0):1E9 ; Background process must wait for LOCK
  1. . S X=$G(^MAG(2006.83,0))
  1. . S $P(X,"^",1,2)="DICOM WORKSTATION^2006.83"
  1. . S D0=$O(^MAG(2006.83," "),-1)+1
  1. . S $P(X,"^",3)=D0
  1. . S $P(X,"^",4)=$P(X,"^",4)+1
  1. . S ^MAG(2006.83,0)=X,^MAG(2006.83,D0,0)=STATION
  1. . S ^MAG(2006.83,"B",STATION,D0)=""
  1. . L -^MAG(2006.83,0)
  1. . Q
  1. S $P(^MAG(2006.83,D0,0),"^",3)=VERSION
  1. S X=$P(^MAG(2006.83,D0,0),"^",2)
  1. S $P(^MAG(2006.83,D0,0),"^",2)=$$NOW^XLFDT()
  1. S OUT=D0
  1. Q
  1. ;
  1. FMGET(OUT,FILE,D0,FIELD) ; RPC = MAG DICOM FILEMAN GET
  1. ; Get the value of a data field
  1. S OUT=$$GET1^DIQ(FILE,D0,FIELD)
  1. Q
  1. ;
  1. CUTOFF(OUT,D0) ; RPC = MAG DICOM PACS CUTOFF DATE
  1. ; Retention Period for PACS
  1. N X
  1. I '$$CONSOLID^MAGBAPI() D Q
  1. . ; Non-consolidated site
  1. . I '$D(^MAG(2006.1,"APACS")) S OUT="-2,No PACS Installed" Q
  1. . ;
  1. . S X=$G(^MAG(2006.1,"AIMDELPACS"))
  1. . I X="" S OUT="-3,PACS Retention Parameter not defined" Q
  1. . S OUT=X
  1. . Q
  1. ; Consolidated site:
  1. I '$P($G(^MAG(2006.1,D0,"PACS")),"^",1) S OUT="-2,No PACS Installed" Q
  1. ;
  1. S X=$P($G(^MAG(2006.1,D0,1)),"^",5)
  1. I X="" S OUT="-3,PACS Retention Parameter not defined" Q
  1. S OUT=X
  1. Q
  1. ;
  1. MINSPACE(OUT,D0) ; RPC = MAG DICOM PACS MINIMUM SPACE
  1. ; Minimum Percentage of Free Disk Space
  1. N X
  1. I '$$CONSOLID^MAGBAPI() D Q
  1. . ; Non-consolidated site
  1. . I '$D(^MAG(2006.1,"APACS")) S OUT="-2,No PACS Installed" Q
  1. . ;
  1. . S X=$G(^MAG(2006.1,"AIMDELPACS2"))
  1. . I X="" S OUT="-3,PACS Minimum Space Percentage Parameter not defined" Q
  1. . S OUT=X
  1. . Q
  1. ; Consolidated site:
  1. I '$P($G(^MAG(2006.1,D0,"PACS")),"^",1) S OUT="-2,No PACS Installed" Q
  1. ;
  1. S X=$P($G(^MAG(2006.1,D0,3)),"^",5)
  1. I X="" S OUT="-3,PACS Minimum Space Percentage Parameter not defined" Q
  1. S OUT=X
  1. Q
  1. ;
  1. HL7PURGE(OUT,CUTOFF) ; RPC = MAG DICOM PURGE HL7
  1. ; Purge HL7 transactions
  1. N D,D0,P,T,X
  1. S OUT=0
  1. S D="" F S D=$O(^MAGDHL7(2006.5,"B",D)) Q:'D Q:D'<CUTOFF D
  1. . S D0="" F S D0=$O(^MAGDHL7(2006.5,"B",D,D0)) Q:'D0 D
  1. . . S X=$G(^MAGDHL7(2006.5,D0,0)),P=$P(X,"^",4),T=$P(X,"^",3)
  1. . . K ^MAGDHL7(2006.5,D0)
  1. . . K ^MAGDHL7(2006.5,"B",D,D0)
  1. . . K:T'="" ^MAGDHL7(2006.5,"C",T,D0)
  1. . . K:P'="" ^MAGDHL7(2006.5,"D",P,D0)
  1. . . S OUT=OUT+1
  1. . . Q
  1. . Q
  1. D:OUT
  1. . L +^MAGDHL7(2006.5,0):1E9
  1. . S X=$G(^MAGDHL7(2006.5,0))
  1. . S $P(X,"^",1,2)="PACS MESSAGES^2006.5D"
  1. . S $P(X,"^",4)=$P(X,"^",4)-OUT
  1. . S ^MAGDHL7(2006.5,0)=X
  1. . L -^MAGDHL7(2006.5,0)
  1. . Q
  1. Q
  1. ;
  1. VALDEST(OUT,NAME) ; RPC = MAG DICOM ROUTE VALID DEST
  1. N D0,PLACE,X
  1. ; This function is also called from various routines
  1. ; that belong to automated routing.
  1. ;
  1. S OUT="-1,"""_NAME_""" is not a valid destination"
  1. ;
  1. I $D(^MAG(2005.2,"B")) D Q
  1. . S D0=$O(^MAG(2005.2,"B",NAME,"")) Q:'D0
  1. . S:$P($G(^MAG(2005.2,D0,0)),"^",9) OUT=D0
  1. . Q
  1. ;
  1. S D0=""
  1. S PLACE="" F S PLACE=$O(^MAG(2005.2,"D",PLACE)) Q:PLACE="" D Q:OUT>0
  1. . S D0=$O(^MAG(2005.2,"D",PLACE,NAME,""))
  1. . S:$P($G(^MAG(2005.2,D0,0)),"^",9) OUT=D0
  1. . Q
  1. Q
  1. ;
  1. PAT(OUT,DFN) ; RPC = MAG DICOM GET PATIENT
  1. N DIQUIET,I,N,VA,VADM,VAIN,VAPA,VASD
  1. K OUT
  1. I '$G(DFN) S OUT(1)="-1,No Patient Identified" Q
  1. S N=1,DIQUIET=1
  1. D DEM^VADPT,VA("DEM","VADM","") D VA("ID","VA","")
  1. D ADD^VADPT,VA("ADD","VAPA","")
  1. D INP^VADPT,VA("INP","VAIN","")
  1. D SDA^VADPT,VA("SDA","VASD","")
  1. I $T(GETICN^MPIF001)'="" S X=$$GETICN^MPIF001(DFN) S:X'<0 N=N+1,OUT(N)="ICN^1^"_X
  1. S N=N+1,OUT(N)="Site-DFN^1^"_$$STATNUMB^MAGDFCNV()_"-"_DFN
  1. S OUT(1)=N-1
  1. Q
  1. ;
  1. DCMNAME(OUT,DFN,DELIM) ; RPC = MAG GET DICOM FMT PATIENT NAME
  1. ; P239 DAC - New RPC added
  1. ; HL7: family ^ given ^ middle ^ suffix ^ prefix ^ degree
  1. ; DICOM: family ^ given ^ middle ^ prefix ^ suffix (4 & 5 swapped, no degree)
  1. N DGNAME,DICOMNAME,HL7NAME
  1. K OUT
  1. I '$G(DFN) S OUT="-1,No Patient Identified" Q
  1. S DGNAME("FILE")=2,DGNAME("IENS")=DFN,DGNAME("FIELD")=.01
  1. S HL7NAME=$$HLNAME^XLFNAME(.DGNAME,"","^") ; get HL7 formatted name
  1. I HL7NAME="" S OUT="-2,No patient found with DFN="_DFN Q
  1. ; convert to DICOM format by swapping 4th and 5th components
  1. S DICOMNAME=$P(HL7NAME,"^",1,3) ; family ^ given ^ middle
  1. S $P(DICOMNAME,"^",4)=$P(HL7NAME,"^",5) ; prefix (e.g., DR)
  1. S $P(DICOMNAME,"^",5)=$P(HL7NAME,"^",4) ; suffix (e.g., JR or III)
  1. I $D(DELIM) S DICOMNAME=$TR(DICOMNAME,"^",DELIM)
  1. S OUT=DICOMNAME
  1. Q
  1. ;
  1. VA(PRE,ARR,SUB) N A,I,X
  1. S I="" F S I=$O(@ARR@(I)) Q:I="" D
  1. . S A=$NAME(@ARR@(I))
  1. . S X=$G(@A) S:X'="" N=N+1,OUT(N)=PRE_"^"_SUB_I_"^"_X
  1. . D:$D(@A)>9 VA(PRE,A,SUB_I_",")
  1. . Q
  1. Q
  1. ;
  1. RARPTO(OUT,TYPE,D0,F,D1) ; RPC = MAG DICOM GET RAD RPT INFO
  1. S TYPE=$G(TYPE),D0=$G(D0),F=$G(F,1),D1=+$G(D1)
  1. I TYPE="O1" S OUT=+$O(^RARPT(D0),F) Q
  1. I TYPE="O2" S OUT=+$O(^RARPT(D0,F,D1)) Q
  1. I TYPE="G1" S OUT=$G(^RARPT(D0,0)) Q
  1. I TYPE="G2" S OUT=$G(^RARPT(D0,F,D1,0)) Q
  1. S OUT="-1,Invalid request type ("""_TYPE_""")"
  1. Q
  1. ;
  1. LISTORIG(OUT) ; RPC = MAG GET DICOM XMIT ORIGIN
  1. N FROM,MSG,N,PRI,RTN
  1. S N=1,OUT(1)="No entries in transmission queue"
  1. S FROM="" F S FROM=$O(^MAGDOUTP(2006.574,"STATE",FROM)) Q:FROM="" D
  1. . D GETS^DIQ(4,FROM,.01,"","RTN","MSG")
  1. . S N=N+1,OUT(N)=FROM_"^"_$G(RTN(4,FROM_",",.01))
  1. . Q
  1. S:N>1 OUT(1)=N
  1. Q
  1. ;