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

MAGDRPCA.m

Go to the documentation of this file.
  1. MAGDRPCA ;WOIFO/PMK/MLS/SG/DAC/JSL - Imaging RPCs for Importer ; 26 Jan 2016 7:03 PM
  1. ;;3.0;IMAGING;**53,123,118,142,138,162**;Mar 19, 2002;Build 22
  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. Q
  1. ;
  1. CHECKUID(OUT,UIDLIST,LEVEL) ; RPC = MAG DICOM IMPORTER CHECK UIDS
  1. N COUNT,DUPCOUNT,DUPUID,ERROR,I,MAG0,MAGIEN,OBJECT
  1. I '$D(UIDLIST) S OUT(1)="-1,A list of UIDs must be supplied." Q
  1. I '$D(LEVEL) S OUT(1)="-2,Study or SOP Instance level must be specified." Q
  1. I LEVEL'="STUDY",LEVEL'="SOP" D Q
  1. . S OUT(1)="-3,Level must be either ""STUDY"" or ""SOP -- """
  1. . S OUT(1)=OUT(1)_"the value """_LEVEL_""" was specified."
  1. . Q
  1. S COUNT=$G(UIDLIST(1)),ERROR=0
  1. I COUNT'>0 S OUT(1)="-4,Count of UIDs in list must be greater than zero." Q
  1. F I=2:1:COUNT+1 S UID=UIDLIST(I) D
  1. . S MAGIEN=$O(^MAG(2005,"P",UID,""))
  1. . I MAGIEN D
  1. . . S MAG0=$G(^MAG(2005,MAGIEN,0)),OBJECT=$P(MAG0,"^",6),DFN=$P(MAG0,"^",7)
  1. . . I LEVEL="STUDY" D ; Study Instance UID
  1. . . . I OBJECT'=11 D Q
  1. . . . . S OUT(I)="-5,Study Instance UID not pointing to an XRAY Group -- "
  1. . . . . S OUT(I)=OUT(I)_"MAGIEN = "_MAGIEN,ERROR=ERROR+1
  1. . . . . Q
  1. . . . S OUT(I)=$$LOOKUP1(MAGIEN)_"^"_$$DUPUID(LEVEL,UID)
  1. . . . Q
  1. . . E D ; SOP Instance UID
  1. . . . I OBJECT'=3,OBJECT'=100 D Q
  1. . . . . S OUT(I)="-6,SOP Instance UID not pointing to an XRAY or a DICOM object -- "
  1. . . . . S OUT(I)=OUT(I)_"MAGIEN = "_MAGIEN,ERROR=ERROR+1
  1. . . . . Q
  1. . . . S OUT(I)=$$LOOKUP1(MAGIEN)_"^"_$$DUPUID(LEVEL,UID)
  1. . . . Q
  1. . . Q
  1. . E S OUT(I)=""
  1. . Q
  1. I ERROR>1 S OUT(1)="-100,There were "_ERROR_" database inconsistency errors detected. Look at returned data."
  1. E I ERROR=1 S OUT(1)="-100,A database inconsistency error was detected. Look at returned data."
  1. E S OUT(1)=COUNT
  1. Q
  1. ;
  1. DUPUID(LEVEL,UID) ; return a list of ^MAG(2005) entries with dup uids
  1. N COUNT,DFN,DUPUID,I,MAG0,MAG2,MAGIEN,PARENT,RETURN,XREF,XREFLIST
  1. S MAGIEN=""
  1. F S MAGIEN=$O(^MAG(2005,"P",UID,MAGIEN)) Q:MAGIEN="" D
  1. . S MAG0=$G(^MAG(2005,MAGIEN,0)),DFN=$P(MAG0,"^",7)
  1. . S MAG2=$G(^MAG(2005,MAGIEN,2))
  1. . S PARENT="" F I=6,7,8,10 S PARENT=PARENT_"^"_$P(MAG2,"^",I)
  1. . S DUPUID(MAGIEN)=DFN_PARENT
  1. . S XREFLIST(DFN_PARENT,MAGIEN)=""
  1. . Q
  1. . ; remove duplicate Study UIDs for different groups for the same study
  1. I LEVEL="STUDY" D
  1. . S COUNT=0,XREF=""
  1. . F S XREF=$O(XREFLIST(XREF)) Q:XREF="" S COUNT=COUNT+1
  1. . I COUNT=1 K DUPUID
  1. . Q
  1. S COUNT=0,(MAGIEN,RETURN)=""
  1. F S MAGIEN=$O(DUPUID(MAGIEN)) Q:MAGIEN="" D
  1. . S RETURN=RETURN_"^"_MAGIEN,COUNT=COUNT+1
  1. . Q
  1. Q COUNT_RETURN
  1. ;
  1. LOOKUP(OUT,MAGIEN) ; RPC = MAG DICOM IMPORTER LOOKUP
  1. S OUT=$$LOOKUP1(MAGIEN)
  1. Q
  1. ;
  1. LOOKUP1(MAGIEN) ; patient and accession number lookup
  1. N DFN,I,MAG0,MAG2,NUMBER,OUT,TMP,VA,VADM,X
  1. S MAG0=$G(^MAG(2005,MAGIEN,0)),MAG2=$G(^(2))
  1. S DFN=+$P(MAG0,"^",7)
  1. D ; Protect variables that are referenced by the DEM^VADPT
  1. . N A,I,J,K,K1,NC,NF,NQ,T,VAHOW,VAPTYP,VAROOT,X
  1. . D DEM^VADPT ; Supported IA (#10061)
  1. . Q
  1. S X="^"_DFN ; piece 1 is for an error message
  1. S X=X_"^"_VADM(1) ; patient name
  1. S X=X_"^"_VA("PID") ; patient id
  1. S TMP=$S(VADM(3)>0:17000000+VADM(3),1:"-1,Invalid date of birth")
  1. S X=X_"^"_TMP ; Patient DOB
  1. S X=X_"^"_$P(VADM(5),"^",1) ; patient sex
  1. ; $$GETICN^MPIF001 can return error code and message separated
  1. ; by "^". If this happens, the "^" is replaced by comma.
  1. S TMP=$S($T(GETICN^MPIF001)'="":$$GETICN^MPIF001(DFN),1:"-1^NO MPI") ; Supported IA (#2701)
  1. S X=X_"^"_$TR(TMP,"^",",") ; ICN
  1. I $P(MAG2,"^",6)=2006.5839 D ; temporary consult association
  1. . N ACNUMB,GMRCIEN,MODIFIER,PROCNAME,STUDYDAT
  1. . S GMRCIEN=$P(MAG2,"^",7),ACNUMB=$$GMRCACN^MAGDFCNV(GMRCIEN)
  1. . S TMP=$$GET1^DIQ(123,GMRCIEN,.01,"I")\1
  1. . S STUDYDAT=$S(TMP>0:17000000+TMP,1:"-1,Invalid study date")
  1. . S PROCNAME=$$GET1^DIQ(123,GMRCIEN,1) ; TO SERVICE
  1. . S MODIFIER=$$GET1^DIQ(123,GMRCIEN,4) ; PROCEDURE
  1. . S X=X_"^"_ACNUMB_"^"_STUDYDAT_"^"_PROCNAME_"^"_MODIFIER
  1. . Q
  1. E D ; regular association
  1. . S NUMBER="`"_MAGIEN D IENLOOK^MAGDRPC9 ; lookup accession number
  1. . I OUT(1)<0 S X=OUT(1)_" detected in IENLOOK^MAGDRPC9"
  1. . E S X=X_"^"_$P(OUT(2),"^",4,7) ; accession number, study date, procedure
  1. . Q
  1. Q X
  1. ;
  1. ;
  1. ;
  1. GETDFN(OUT,ICN) ; RPC = MAG DICOM GET DFN
  1. S OUT=$S($T(GETDFN^MPIF001)'="":$$GETDFN^MPIF001(ICN),1:"-1^NO MPI") ; Supported IA (#2701)
  1. Q
  1. ;
  1. ;
  1. ;
  1. ACNUMB(OUT,ACNUMB) ; RPC = MAG DICOM GET RAD INFO BY ACN
  1. N RADFN,RADTI,LIST,STATUS
  1. S STATUS=$$ACCFIND^RAAPI(ACNUMB,.LIST) ; Private IA (#5020)
  1. I STATUS<0 S OUT=STATUS Q
  1. S OUT=STATUS_"^"_LIST(1)
  1. ; add the imaging location as 5th piece of the results
  1. S RADFN=$P(LIST(1),"^",1),RADTI=$P(LIST(1),"^",2)
  1. S OUT=OUT_"^"_$$GET1^DIQ(79.1,$P(^RADPT(RADFN,"DT",RADTI,0),"^",4),.01)
  1. Q
  1. ;
  1. ;
  1. ;
  1. DELETE(OUT,IMAGEUID,MACHID,FILEPATH) ; RPC = MAG DICOM IMPORTER DELETE
  1. S OUT=$$DELETE^MAGDIR8R(IMAGEUID,MACHID,FILEPATH)
  1. Q
  1. ;
  1. ;***** RETURNS THE LIST OF RADIOLOGY PROCEDURES
  1. ; RPC: MAG DICOM RADIOLOGY PROCEDURES
  1. ;
  1. ; .ARRAY Reference to a local variable where results
  1. ; are returned to.
  1. ;
  1. ; DIV IEN of a record in the INSTITUTION file (#4)
  1. ;
  1. PROC(ARRAY,DIV,FILTER) ;
  1. N IMAGTYPE ; IEN of the imaging type (file #79.2)
  1. N INACTDAT ; Inactivation date of the procedure
  1. N OMLDAT ; Outside imaging location data (file #2006.5759)
  1. N OMLIEN ; IEN in OUTSIDE IMAGING LOCATION file (#2006.5759)
  1. N RADPROC ; Radiology procedure data (file #71)
  1. N TODAY ; today's date in Fileman format
  1. N PROCTYPE ; Type of procedure
  1. N DIVSN ; Division Station Number
  1. ;
  1. N BUF,ERROR,IEN,Z
  1. K ARRAY
  1. ;
  1. ;--- Validate parameters
  1. S DIV=$G(DIV)
  1. I ($$STA^XUAF4(DIV)="")!(DIV'=+DIV) D Q:$D(ARRAY) ; P142 DAC - Accept IEN or STATION NUMBER
  1. . S DIVSN=$$IEN^XUAF4(DIV) ; Check STATION NUMBER
  1. . I DIVSN="" S ARRAY(1)="-2,Institution "_DIV_" does not exist." Q
  1. . S DIV=DIVSN
  1. . Q
  1. S ERROR=$$DISPLAY^MAGDAIRG(0)
  1. I ERROR=-1 D Q
  1. . S ARRAY(1)="-3,""No Credit"" entries must be added to the IMAGING LOCATIONS file (#79.1)"
  1. . S ARRAY(2)=""
  1. . S ARRAY(3)="Use the IMPORTER MENU option CHECK OUTSIDE IMAGING LOCATION FILE"
  1. . S ARRAY(4)="on the VistA system to correct the problem."
  1. . Q
  1. I ERROR=-2 D Q
  1. . S ARRAY(1)="-4,Entries must be added to the OUTSIDE IMAGING LOCATIONS file (#2006.5759)"
  1. . S ARRAY(2)=""
  1. . S ARRAY(3)="Use the IMPORTER MENU option BUILD OUTSIDE IMAGING LOCATION FILE"
  1. . S ARRAY(4)="on the VistA system to correct the problem."
  1. . Q
  1. I ERROR'=0 D Q
  1. . S ARRAY(1)="-5,Unexpected error #"_ERROR_" returned by $$DISPLAY^MAGDAIRG(0)"
  1. . Q
  1. ;
  1. S (ARRAY(1),IEN)=0,TODAY=$$DT^XLFDT()
  1. F S IEN=$O(^RAMIS(71,IEN)) Q:'IEN D ; Private IA (#1174)
  1. . S RADPROC=^RAMIS(71,IEN,0),IMAGTYPE=+$P(RADPROC,U,12)
  1. . ;--- Get outside imaging location associated
  1. . ;--- with the imaging type of the procedure
  1. . S OMLIEN=$O(^MAGD(2006.5759,"D",DIV,IMAGTYPE,"")) Q:'OMLIEN
  1. . S OMLDAT=$G(^MAGD(2006.5759,OMLIEN,0))
  1. . Q:$P(OMLDAT,U,4)'=DIV ; Has to be in the same Division
  1. . ;--- Prepare the procedure descriptor
  1. . S BUF=$P(RADPROC,U)_U_IEN ; Procedure Name and IEN
  1. . S PROCTYPE=$P(RADPROC,U,6) ; Type of Procedure
  1. . I $G(FILTER)=1,(PROCTYPE="B")!(PROCTYPE="P") Q
  1. . S $P(BUF,U,3)=PROCTYPE ; Type of Procedure
  1. . S $P(BUF,U,4)=$P(RADPROC,U,9) ; CPT Code (file #81)
  1. . S $P(BUF,U,5)=IMAGTYPE ; Type of Imaging (file #79.2)
  1. . S INACTDAT=$P($G(^RAMIS(71,IEN,"I")),U)
  1. . I INACTDAT,INACTDAT<TODAY Q ; ignore inactive procedures
  1. . S $P(BUF,U,6)=INACTDAT ; Inactivation Date
  1. . S $P(BUF,U,7)=$P(OMLDAT,U) ; Imaging Location (file #79.1)
  1. . S Z=$P(OMLDAT,U,3)
  1. . S $P(BUF,U,8)=Z ; Hospital Location (file #44) - IEN
  1. . S $P(BUF,U,9)=$$GET1^DIQ(44,Z,.01) ; Hospital Location (file #44) - NAME
  1. . ;--- Add the descriptor to the result array
  1. . S ARRAY(1)=ARRAY(1)+1,ARRAY(ARRAY(1)+1)=BUF
  1. . Q
  1. Q
  1. ;
  1. ;***** RETURNS THE LIST OF RADIOLOGY PROCEDURE MODIFIERS
  1. ; RPC: MAG DICOM RADIOLOGY MODIFIERS
  1. ;
  1. ; .ARRAY Reference to a local variable where results
  1. ; are returned to.
  1. ;
  1. MOD(ARRAY) ;
  1. N IEN ; IEN in the PROCEDURE MODIFIERS file (#71.2)
  1. N IEN2 ; IEN in the TYPE OF IMAGING subfile (#71.23)
  1. N IMAGTYPE ; Imaging type (#79.2)
  1. N MODIFIER ; Radiology procedure modifier name (71.2,.01)
  1. N PROCMOD ; Radiology procedure modifier data
  1. ;
  1. K ARRAY
  1. ;
  1. S (ARRAY(1),IEN)=0
  1. F S IEN=$O(^RAMIS(71.2,IEN)) Q:'IEN D ; Private IA (#4197)
  1. . S PROCMOD=^RAMIS(71.2,IEN,0),MODIFIER=$P(PROCMOD,U)
  1. . S IEN2=0
  1. . F S IEN2=$O(^RAMIS(71.2,IEN,1,IEN2)) Q:'IEN2 D
  1. . . S IMAGTYPE=+$G(^RAMIS(71.2,IEN,1,IEN2,0)) Q:'IMAGTYPE
  1. . . S ARRAY(1)=ARRAY(1)+1
  1. . . S ARRAY(ARRAY(1)+1)=MODIFIER_U_IEN_U_IMAGTYPE
  1. . . Q
  1. . Q
  1. Q