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