- 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 Jan 18, 2025@03:02:42 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