MAGVRS41 ;WOIFO/DAC,MLH,NST - Utilities for RPC calls for DICOM file processing ; 08 May 2018 10:41 AM
;;3.0;IMAGING;**118,201**;Mar 19, 2002;Build 4525;May 01, 2013
;; 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
INPUTSEP() ; Name value separator for input data ie. NAME`TESTPATIENT
Q "`"
OUTSEP() ; Name value separator for output data ie. NAME|TESTPATIENT
Q "|"
STATSEP() ; Status and Result separator ie. -3``No record IEN
Q "`"
UPDATE(OUT,FILE,ATTS,OVERRIDE) ; Update Attributes
N FDA,IEN,DATETIME,UIEN,UFILE,FIELDERR
; If File is out of range quit with error
S OSEP=$$OUTSEP,ISEP=$$INPUTSEP,SSEP=$$STATSEP
I (FILE<2005.6)!(FILE>2005.65) S OUT(1)="-1"_SSEP_"File is not in the 2005.6 to 2005.65 range" Q
; If first attribute is not the update record's IEN quit with error
I $P($G(ATTS(1)),ISEP,1)'["IEN" S OUT(1)="-2"_SSEP_"No record IEN" Q
S IEN=$P(ATTS(1),ISEP,2) K ATTS(1)
I (IEN<1)!(IEN>($O(^MAGV(FILE," "),-1))) S OUT(1)="-6"_SSEP_"Invalid IEN" Q
I FILE'=2005.6 D Q:$D(OUT(1)) ; logic for files with parents only!
. I '$G(OVERRIDE) D Q:$D(OUT(1))
. . I $P($G(ATTS(2)),ISEP,1)'["REFERENCE" S OUT(1)="-2"_SSEP_"No record IEN" Q
. . S PIEN=$P(ATTS(2),ISEP,2)
. . Q
. I '$G(IEN) S OUT(1)="-1"_SSEP_"No IEN" Q
. I '$G(OVERRIDE),'$$PARENT(FILE,IEN,PIEN) S OUT(1)="-9"_SSEP_"Parent Record not verified" Q
. ; Check for STATUS INACCESSIBLE
. I $G(PIEN),((FILE=2005.63)!(FILE=2005.64)) D Q:$D(OUT(1))
. . N PFILE,STATUS
. . I FILE=2005.63 S PFILE=2005.62
. . I FILE=2005.64 S PFILE=2005.63
. . S STATUS=$$GET1^DIQ(PFILE,PIEN,"STATUS","I")
. . I STATUS="I" S OUT(1)="-100"_SSEP_"Parent status is Inaccessible."
. . Q
. Q
S ATTS($O(ATTS(" "),-1)+1)="STATUS"_ISEP_"A" ; update always (re)activates
D SETFDA^MAGVRS44(FILE,.ATTS,IEN_",",.FDA,.FIELDERR,1)
D FILE^DIE("","FDA","ERR")
I $D(ERR("DIERR")) S OUT(1)="-6"_SSEP_$G(ERR("DIERR",1,"TEXT",1))
I $D(ERR("DIERR")) Q
K FDA,ERR
I FILE=2005.65,$G(PIEN)'="" D AOFSET(PIEN,IEN)
;Update last update for record and parents
S DATETIME=$$NOW^XLFDT
S UIEN=IEN,UFILE=FILE
F UFILE=UFILE:-.01:2005.62 Q:'UIEN D
. I FILE'=2005.65 D
. . S FDA(UFILE,UIEN_",",$$GETFIELD(UFILE,"LAST UPDATE DATE/TIME"))=DATETIME
. . D FILE^DIE("","FDA","ERR")
. . I $D(ERR("DIERR")) S OUT(1)="-3"_SSEP_$G(ERR("DIERR",1,"TEXT",1))
. . I $D(ERR("DIERR")) Q
. . K FDA,ERR
. . Q
. I UIEN S PIEN=+$G(^MAGV(UFILE,UIEN,6))
. Q
S OUT(1)="0"_SSEP_$G(FIELDERR)_SSEP_IEN
Q
ATTACH(OUT,FILE,ATTS) ; Create record; attach to parent record if applicable
; Input Variables:
; FILE - File number of record
; ATTS - Array of name value pairs separated by an input separator
; Output Variables:
; OUT - Returns success and new record IEN or error and error message
N FDA,OSEP,ISEP,SSEP,NAM,VAL,ATTNAMS,KEYFLD,UATT,IEN,STATUS,NEWATTS,I
N PIEN,PPIEN,PFILE,ERR,CIEN,UID,UIEN,DATETIME,KEYNAM,FIELDERR,DFN,DEVFDA,DEVICE
S OSEP=$$OUTSEP,ISEP=$$INPUTSEP,SSEP=$$STATSEP
; If file out of range quit with error
I (FILE<2005.6)!(FILE>2005.65) S OUT(1)="-4"_SSEP_"File is not in the 2005.6 to 2005.65 range" Q
; If atts not defined quit with error
S I=0
F S I=$O(ATTS(I)) Q:'I D Q:$D(OUT(1))
. S NAM=$P(ATTS(I),ISEP,1),VAL=$P(ATTS(I),ISEP,2)
. I NAM="" S OUT(1)="-64"_SSEP_"Attribute name(s) missing from attribute array" Q
. S ATTNAMS(NAM)=VAL
. Q
Q:$D(OUT(1))
S KEYNAM=$$GET1^DID(FILE,.01,,"LABEL"),(UATT,KEYFLD(.01))=$G(ATTNAMS(KEYNAM))
S KEYFLD(.01,"GSL")=$$GET1^DID(FILE,.01,,"GLOBAL SUBSCRIPT LOCATION")
; Set PIEN (parent IEN)
I FILE=2005.61 S PIEN=$G(ATTNAMS("PATIENT REFERENCE")),PFILE=2005.6
I FILE=2005.62 S PIEN=$G(ATTNAMS("PROCEDURE REFERENCE")),PFILE=2005.61
I FILE=2005.63 S PIEN=$G(ATTNAMS("STUDY REFERENCE")),PFILE=2005.62
I FILE=2005.64 S PIEN=$G(ATTNAMS("SERIES REFERENCE")),PFILE=2005.63
I FILE=2005.65 S PIEN=$G(ATTNAMS("SOP INSTANCE REFERENCE")),PFILE=2005.64
; Check for STATUS INACCESSIBLE
I (FILE=2005.63)!(FILE=2005.64) D Q:$D(OUT(1))
. S STATUS=$$GET1^DIQ(PFILE,PIEN,"STATUS","I")
. I STATUS="I" S OUT(1)="-100"_SSEP_"Parent status is Inaccessible."
. Q
; File DEVICE MANUFACTURER and DEVICE MODEL as ACQUISITION DEVICE in file 2005.63
I FILE=2005.63 D
. ; Remove parentheses from DEVICE MANUFACTOR and DEVICE MODEL and concatenate DEVICE and place model in parentheses
. S DEVMAN=$G(ATTNAMS("DEVICE MANUFACTURER"))
. S DEVMODEL=$G(ATTNAMS("DEVICE MODEL"))
. S DEVICE=DEVMAN_" ("_DEVMODEL_")"
. ; If the device is not in 2006.04 add device
. I '$D(^MAG(2006.04,"B",DEVICE)) D
. . S DEVFDA(2006.04,"+1,",.01)=DEVICE
. . D UPDATE^DIE("","DEVFDA","","DEVERR")
. . Q
. ; If the device is in 2006.04 get IEN of entry
. S DEVIEN=$O(^MAG(2006.04,"B",DEVICE,""))
. S ATTS($O(ATTS(" "),-1)+1)="DEVICE"_ISEP_DEVIEN
. K ATTNAMS("DEVICE MANUFACTURER"),ATTNAMS("DEVICE MODEL")
. Q
D:('$D(ATTNAMS("ARTIFACT ON FILE")))&(FILE'=2005.65)
. S ATTNAMS("ARTIFACT ON FILE")=0
. S ATTS($O(ATTS(" "),-1)+1)="ARTIFACT ON FILE"_ISEP_0
. Q
I $G(UATT)="" S OUT(1)="-5"_SSEP_"Unique identifier not provided" Q
; If a patient ID is assigned by the VA set the PATIENT pointer
I FILE=2005.6,$G(ATTNAMS("ASSIGNING AUTHORITY"))="V" D
. S DFN=$G(ATTNAMS("ENTERPRISE PATIENT ID"))
. I DFN'="" S ATTS($O(ATTS(" "),-1)+1)="PATIENT FILE REFERENCE"_ISEP_DFN
. Q
;
; Quit with error if no assigning authority provided for a Procedure Reference
I FILE=2005.61,$G(ATTNAMS("ASSIGNING AUTHORITY"))="" S OUT(1)="-5"_SSEP_"No ASSIGNING AUTHORITY provided." Q
;
; If entry exists for Patient or Procedure then it is an update
D Q:$G(IEN) Q:$D(OUT(1)) ; Patient or procedure update?
. ; Add multi-key (already checked .01)
. I (FILE=2005.6)!(FILE=2005.61) D ADDMKEYS^MAGVRS46(.OUT,FILE,.ATTNAMS,.KEYFLD) Q:$D(OUT(1))
. ;
. S IEN=$$MATCH^MAGVRS46(FILE,UATT,$G(PIEN),.KEYFLD) ; Find match by keys
. Q:'IEN ; no exact match, create new
. ;
. S STATUS=$$GET1^DIQ(FILE,IEN,"STATUS","I")
. I (FILE>2005.6),(PIEN'=+$G(^MAGV(FILE,IEN,6))) D Q
. . I STATUS="A" S OUT(1)="-66"_SSEP_"Parent IEN does not match parent IEN of record on file"
. . E S IEN="" ; STATUS="I" INACCESSIBLE
. . Q
. I STATUS'="I" S OUT(1)="-63"_SSEP_"Active reference with same unique ID already exists" Q
. S NEWATTS(1)="IEN"_ISEP_IEN
. F I=1:1 Q:'$D(ATTS(I)) S NEWATTS(I+1)=ATTS(I)
. S NEWATTS($O(NEWATTS(" "),-1)+1)="STATUS"_ISEP_"A"
. D UPDATE(.OUT,FILE,.NEWATTS,1)
. Q
Q:$D(OUT(1))
I FILE>2005.6 D Q:$G(OUT(1))'="" ; verify that parent IEN is set
. I PIEN="" S OUT(1)="-1"_SSEP_"No parent record IEN" Q
. I (PIEN<1)!(PIEN>($O(^MAGV(FILE-.01," "),-1))) S OUT(1)="-6"_SSEP_"Invalid parent IEN" Q
. Q
; If a series and a consult, get the current TIU note for the study (parent IEN)
I FILE=2005.63 D Q:$G(OUT(1))<0
. D TIUCHK^MAGVRS43(.OUT,PIEN) Q:$G(OUT(1))<0 ; bail out if fatal exception raised
. I $P(OUT(1),SSEP,1)=0 S ATTS($O(ATTS(" "),-1)+1)="TIU NOTE REFERENCE"_ISEP_$P(OUT(1),SSEP,3)
. K OUT
. Q
S ATTS($O(ATTS(" "),-1)+1)="STATUS"_ISEP_"A"
D SETFDA^MAGVRS44(FILE,.ATTS,"+1,",.FDA,.FIELDERR)
S UID=$G(FDA(FILE,"+1,",.01))
I UID="" S OUT(1)="-2"_SSEP_"No UID" Q
; Attach record
D UPDATE^DIE("","FDA","","ERR")
K FDA
S CIEN=$O(^MAGV(FILE,"B",UID,""),-1) ; New Record IEN
S OUT(1)="0"_SSEP_$G(FIELDERR)_SSEP_CIEN ; Set return output to IEN of new record
I $D(ERR("DIERR")) S OUT(1)="-3"_SSEP_$G(ERR("DIERR",1,"TEXT",1))
I $D(ERR("DIERR")) Q
K ERR
; Update Number of SOP and SERIES Number fields in the Study and Series files
I (FILE=2005.63)!(FILE=2005.64) S PFILE=FILE-.01,FDA(PFILE,PIEN_",",7)=+$G(^MAGV(PFILE,PIEN,4))+1
I FILE=2005.64 S PFILE=2005.62 S PPIEN=+$G(^MAGV(2005.63,PIEN,6)),FDA(2005.62,PPIEN_",",20)=$P($G(^MAGV(2005.62,PPIEN,4)),U,2)+1
D FILE^DIE("","FDA","ERR")
K FDA
I FILE=2005.65 D AOFSET(PIEN,CIEN)
I FILE>2005.6 D Q:$G(OUT(1))'="" ;Update last update for record and parents
. S DATETIME=$$NOW^XLFDT
. S UIEN=CIEN
. F UFILE=FILE:-.01:2005.62 Q:'UIEN D
. . I UFILE'=2005.65 D
. . . S FDA(UFILE,UIEN_",",$$GETFIELD(UFILE,"LAST UPDATE DATE/TIME"))=DATETIME
. . . S:$G(ERR)'="" OUT(1)=ERR
. . . K ERR
. . . D FILE^DIE("","FDA","ERR")
. . . I $D(ERR("DIERR")) S OUT(1)="-5"_SSEP_$G(ERR("DIERR",1,"TEXT",1))
. . . K FDA,ERR
. . . Q
. . I UIEN S UIEN=+$G(^MAGV(UFILE,UIEN,6))
. . Q
. Q
Q
REFRESH(OUT,FILE,IEN,PIEN,OVERRIDE) ; Retrieve specified file data attributes
N OUTI,FIELD,MULTOUT,FDA,ERR,OSEP,ISEP,SSEP,MULTIPLE,DATETIME,UIEN,UFILE,FORMAT,SUBFILE,SUBIEN,FILEMULT,DD
N DEVIEN,DEVNAME,DEVMAN,DEVMODEL,VALUE
S OSEP=$$OUTSEP,ISEP=$$INPUTSEP,SSEP=$$STATSEP K OUT
I $G(FILE)="" S OUT(1)="-9"_SSEP_"Missing file specification" Q
I '$D(^MAGV(FILE)),'$D(^MAGD(FILE)) S OUT(1)="-10"_SSEP_"Invalid file specification ("_$G(FILE)_")" Q
I '$G(IEN) S OUT(1)="-1"_SSEP_"No record IEN" Q
I '$G(OVERRIDE),'$G(PIEN) S OUT(1)="-2"_SSEP_"No parent record IEN" Q
I FILE'=2005.61,'$G(OVERRIDE),'$$PARENT(FILE,IEN,PIEN) S OUT(1)="-3"_SSEP_"Parent Record not verified" Q
I FILE'=2006.575,'$D(^MAGV(FILE,IEN)) S OUT(1)="-4"_SSEP_"IEN does not exist in "_FILE Q
I FILE=2006.575,'$D(^MAGD(FILE,IEN)) S OUT(1)="-5"_SSEP_"IEN does not exist in "_FILE Q
S FIELD=$$GETFIELD(FILE,"STATUS") I FIELD D Q:$D(OUT)
. S STATUS=$$GET1^DIQ(FILE,IEN,FIELD,"I")
. S:STATUS="I" OUT(1)="-11"_SSEP_"No accessible entry for UID found in file "_FILE
. Q
S FIELD="",OUTI=2,FNUM=""
D GETS^DIQ(FILE,IEN_",","**","I","DD")
; Process all non-multiple fields
F D Q:FNUM=""
. S FNUM=$O(DD(FILE,IEN_",",FNUM)) Q:FNUM=""
. I FILE=2005.63,FNUM=18 D Q ; DEVICE returns DEVICE MANUFACTURER and DEVICE MODEL from the ACQUISITION DEVICE file NAME (.01) field
. . S DEVIEN=$G(DD("2005.63",IEN_",","18","I"))
. . Q:$G(DEVIEN)=""
. . S DEVNAME=$P($G(^MAG(2006.04,DEVIEN,0)),U,1)
. . S DEVMAN=$P(DEVNAME," (",1)
. . S DEVMODEL=$TR($P(DEVNAME," (",2),")")
. . S OUT(OUTI)="DEVICE MANUFACTURER"_OSEP_DEVMAN_SSEP
. . S OUT(OUTI+1)="DEVICE MODEL"_OSEP_DEVMODEL_SSEP
. . S OUTI=OUTI+2
. . Q
. S FIELD=$$GET1^DID(FILE,FNUM,,"LABEL")
. S FORMAT=$S((FIELD["INDEX")!(FIELD="SOP CLASS UID")!(FIELD="PHOTOMETRIC INTERPRETATION"):"E",1:"I") ; return internal formats except for index terms and SOP CLASS UID
. I (FIELD["REFERENCE") S FORMAT="I" ; If the field is an IEN pointer return the internal format rather than the UID string
. S VALUE=$$GET1^DIQ(FILE,IEN,FIELD,$G(FORMAT))
. I $$DATETIME(FILE,FIELD) S VALUE=$$FM2IDF^MAGVAF01(VALUE)
. I FILE=2005.63,FIELD="ACQUISITION LOCATION",VALUE'="" S VALUE=$$GETSINST(VALUE)
. I ((FILE=2005.6)!(FILE=2005.61))&(FIELD="SERVICE INSTITUTION REFERENCE"),VALUE'="" S VALUE=$$GETSINST(VALUE),FIELD="CREATING ENTITY"
. S OUT(OUTI)=FIELD_OSEP_VALUE_SSEP
. S OUTI=OUTI+1
. Q
; Process multiple fields
S FILEMULT=FILE
F D Q:FILEMULT=""
. S FILEMULT=$O(DD(FILEMULT)) Q:FILEMULT=""
. S FNUM=$E(FILEMULT,$L(FILE)+1,$L(FILEMULT))
. D GETS^DIQ(FILE,IEN_",",FNUM_"*","","MULTOUT")
. I '$D(MULTOUT) Q
. S FIELD=$$GET1^DID(FILE,FNUM,,"LABEL")
. S SUBFILE=$O(MULTOUT("")),SUBIEN=""
. F D Q:$O(MULTOUT(SUBFILE,SUBIEN))=""
. . S SUBIEN=$O(MULTOUT(SUBFILE,SUBIEN))
. . S OUT(OUTI)=FIELD_OSEP_MULTOUT(SUBFILE,SUBIEN,.01)_SSEP
. . S OUTI=OUTI+1
. . Q
. Q
S OUT(1)="0"_SSEP ; Look up successful
; Update last access date time for study
S DATETIME=$$NOW^XLFDT
S UIEN=IEN
F UFILE=FILE:-.01:2005.62 Q:'UIEN D
. I UFILE=2005.62 D
. . S FDA(UFILE,UIEN_",",$$GETFIELD(UFILE,"LAST ACCESS DATE/TIME"))=DATETIME
. . K ERR
. . D FILE^DIE("","FDA","ERR")
. . S:$G(ERR("DIERR"))'="" OUT(1)="-7"_SSEP_$G(ERR("DIERR",1,"TEXT",1))
. . K FDA,ERR
. . Q
. I UIEN S UIEN=+$G(^MAGV(UFILE,UIEN,6))
. Q
Q
MULTIPLE(FILE,FIELD) ; Process multiple DB entries
N DATATYPE,MULTIPLE,FNUM
S MULTIPLE=$$GET1^DID(FILE,FIELD,,"MULTIPLE-VALUED")
Q +MULTIPLE
NUMERIC(FILE,FIELD) ; Determine if field is numeric
N DATATYPE,NUMERIC
S NUMERIC=0
I $$GET1^DID(FILE,FIELD,"","TYPE")="NUMERIC" S NUMERIC=1
Q NUMERIC
DATETIME(FILE,FIELD) ; Determine if field is date time
N DATATYPE,DATETIME
S DATETIME=0
I $$GET1^DID(FILE,FIELD,"","TYPE")="DATE/TIME" S DATETIME=1
Q DATETIME
GETFIELD(FILE,FNAME) ; Returns a field number given a field name
Q $$FLDNUM^DILFD(FILE,FNAME)
PARENT(FILE,IEN,PIEN) ; Check if provided parent IEN is linked to current record
I PIEN'=+$G(^MAGV(FILE,IEN,6)) Q 0
Q 1
AOFSET(PIEN,IEN) ; Set artifact on file to 1 for all parent nodes of file instance
N AOFFILE,FIELD,FDA,ERR,MAGVIEN,MAGVPIEN,MAGVOUT
S MAGVPIEN=PIEN ; IEN in file #2005.64
S MAGVIEN=IEN ; IEN in file #2005.65
;
F AOFFILE=2005.64,2005.63,2005.62,2005.61,2005.6 D
. S FIELD=$$GETFIELD(AOFFILE,"ARTIFACT ON FILE")
. I $G(FIELD)="" Q
. S FDA(AOFFILE,PIEN_",",FIELD)=1
. D FILE^DIE("","FDA")
. K FDA,ERR
. I AOFFILE>2005.6 S PIEN=+$G(^MAGV(AOFFILE,PIEN,6))
. Q
D NWI34^MAGNWRK1(.MAGVOUT,MAGVPIEN,MAGVIEN) ; add a new storage work item
;
Q
INACTIVT(OUT,FILE,IEN,PIEN,OVERRIDE,REASON) ; Marks the entry indicated by file # and IEN as deleted
N OSEP,ISEP,SSEP,STATUS,PFILE,ERR,FDA,AOF,FIELD,AOFIEN
S OSEP=$$OUTSEP,ISEP=$$INPUTSEP,SSEP=$$STATSEP
I $G(FILE)="" S OUT(1)="-23"_SSEP_"No file number provided" Q
I $G(IEN)="" S OUT(1)="-20"_SSEP_"No IEN provided" Q
I '$G(PIEN)="" S OUT(1)="-21"_SSEP_"No parent IEN provided" Q
I '$D(OVERRIDE) S OUT(1)="-22"_SSEP_"No OVERRIDE flag provided" Q
I '$D(^MAGV(FILE,IEN,0)) S OUT(1)="-1"_SSEP_"Record IEN not found in file" Q
I '$D(REASON) S OUT(1)="-4"_SSEP_"No deletion reason provided" Q
; If record status is already INACCESIBLE quit with error
S FIELD=$$GETFIELD(FILE,"STATUS")
S STATUS=$$GET1^DIQ(FILE,IEN,FIELD,"E")
I STATUS="INACCESSIBLE" S OUT(1)="2"_SSEP_"Record is already inaccessible" Q
; Call INACT to delete identified record and all children
D INACT^MAGVRS44(.OUT,FILE,IEN,$G(PIEN),$G(OVERRIDE),$G(REASON))
I $D(OUT(1)) Q
; Set parent records artifact on file to false if no active child records
S AOFIEN=IEN,AOF=""
F FILE=FILE:2005.61:-.01 Q:AOF'="" D
. F S AOFIEN=+$G(^MAGV(FILE,"C",PIEN,AOFIEN)) Q:(AOF'="")!(AOFIEN="") D
. . S FIELD=$$GETFIELD(FILE,"ARTIFACT ON FILE")
. . S AOF=$$GET1^DIQ(FILE,AOFIEN,FIELD)
. Q
. ;If no child records are on file then set parent to artifact not on file
. I AOF="" D
. . S PFILE=FILE-.01
. . S FIELD=$$GETFIELD(FILE,"ARTIFACT ON FILE")
. . S FDA(PFILE,PIEN_",",FIELD)=""
. . D FILE^DIE("","FDA")
. . K FDA,ERR
. . Q
. Q
I '$D(OUT(1)) S OUT(1)="0"_SSEP_SSEP_IEN
Q
FINDBUID(OUT,FILE,UID) ;Find SOP or series by UID
N STATUS,IEN,OSEP,ISEP,SSEP
S OSEP=$$OUTSEP,ISEP=$$INPUTSEP,SSEP=$$STATSEP
I $G(FILE)="" S OUT="-3"_SSEP_"No file specified" Q
I "^2005.62^2005.63^2005.64^"'[("^"_FILE_"^") S OUT="-4"_SSEP_"Invalid file specified ("_FILE_")" Q
I $G(UID)="" S OUT="-5"_SSEP_"No UID specified" Q
S IEN=$O(^MAGV(FILE,"B",UID,""))
S FIELD=$$GETFIELD(FILE,"STATUS")
S STATUS=$$GET1^DIQ(FILE,IEN,FIELD,"I")
I IEN'="",STATUS'="I" S OUT="0"_SSEP_SSEP_IEN Q
I IEN="" S OUT="-1"_SSEP_"UID not found in file "_FILE Q
I STATUS="I" S OUT="-2"_SSEP_"No active entry for UID found in file "_FILE Q
Q
GETSINST(VALUE) ; Get the service institution value
N IEN,FILE,SITE,X
S SITE="Error - unknown service institution"
S X=$G(^MAGV(2005.8,$G(VALUE),0))
S IEN=$P(X,";",1),FILE=$P(X,";",2)
I FILE="DIC(4," S SITE=$P($$NS^XUAF4(IEN),U,2) ; IA #2171 Get Station Number
Q SITE
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMAGVRS41 16602 printed Nov 22, 2024@17:20:20 Page 2
MAGVRS41 ;WOIFO/DAC,MLH,NST - Utilities for RPC calls for DICOM file processing ; 08 May 2018 10:41 AM
+1 ;;3.0;IMAGING;**118,201**;Mar 19, 2002;Build 4525;May 01, 2013
+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
INPUTSEP() ; Name value separator for input data ie. NAME`TESTPATIENT
+1 QUIT "`"
OUTSEP() ; Name value separator for output data ie. NAME|TESTPATIENT
+1 QUIT "|"
STATSEP() ; Status and Result separator ie. -3``No record IEN
+1 QUIT "`"
UPDATE(OUT,FILE,ATTS,OVERRIDE) ; Update Attributes
+1 NEW FDA,IEN,DATETIME,UIEN,UFILE,FIELDERR
+2 ; If File is out of range quit with error
+3 SET OSEP=$$OUTSEP
SET ISEP=$$INPUTSEP
SET SSEP=$$STATSEP
+4 IF (FILE<2005.6)!(FILE>2005.65)
SET OUT(1)="-1"_SSEP_"File is not in the 2005.6 to 2005.65 range"
QUIT
+5 ; If first attribute is not the update record's IEN quit with error
+6 IF $PIECE($GET(ATTS(1)),ISEP,1)'["IEN"
SET OUT(1)="-2"_SSEP_"No record IEN"
QUIT
+7 SET IEN=$PIECE(ATTS(1),ISEP,2)
KILL ATTS(1)
+8 IF (IEN<1)!(IEN>($ORDER(^MAGV(FILE," "),-1)))
SET OUT(1)="-6"_SSEP_"Invalid IEN"
QUIT
+9 ; logic for files with parents only!
IF FILE'=2005.6
Begin DoDot:1
+10 IF '$GET(OVERRIDE)
Begin DoDot:2
+11 IF $PIECE($GET(ATTS(2)),ISEP,1)'["REFERENCE"
SET OUT(1)="-2"_SSEP_"No record IEN"
QUIT
+12 SET PIEN=$PIECE(ATTS(2),ISEP,2)
+13 QUIT
End DoDot:2
if $DATA(OUT(1))
QUIT
+14 IF '$GET(IEN)
SET OUT(1)="-1"_SSEP_"No IEN"
QUIT
+15 IF '$GET(OVERRIDE)
IF '$$PARENT(FILE,IEN,PIEN)
SET OUT(1)="-9"_SSEP_"Parent Record not verified"
QUIT
+16 ; Check for STATUS INACCESSIBLE
+17 IF $GET(PIEN)
IF ((FILE=2005.63)!(FILE=2005.64))
Begin DoDot:2
+18 NEW PFILE,STATUS
+19 IF FILE=2005.63
SET PFILE=2005.62
+20 IF FILE=2005.64
SET PFILE=2005.63
+21 SET STATUS=$$GET1^DIQ(PFILE,PIEN,"STATUS","I")
+22 IF STATUS="I"
SET OUT(1)="-100"_SSEP_"Parent status is Inaccessible."
+23 QUIT
End DoDot:2
if $DATA(OUT(1))
QUIT
+24 QUIT
End DoDot:1
if $DATA(OUT(1))
QUIT
+25 ; update always (re)activates
SET ATTS($ORDER(ATTS(" "),-1)+1)="STATUS"_ISEP_"A"
+26 DO SETFDA^MAGVRS44(FILE,.ATTS,IEN_",",.FDA,.FIELDERR,1)
+27 DO FILE^DIE("","FDA","ERR")
+28 IF $DATA(ERR("DIERR"))
SET OUT(1)="-6"_SSEP_$GET(ERR("DIERR",1,"TEXT",1))
+29 IF $DATA(ERR("DIERR"))
QUIT
+30 KILL FDA,ERR
+31 IF FILE=2005.65
IF $GET(PIEN)'=""
DO AOFSET(PIEN,IEN)
+32 ;Update last update for record and parents
+33 SET DATETIME=$$NOW^XLFDT
+34 SET UIEN=IEN
SET UFILE=FILE
+35 FOR UFILE=UFILE:-.01:2005.62
if 'UIEN
QUIT
Begin DoDot:1
+36 IF FILE'=2005.65
Begin DoDot:2
+37 SET FDA(UFILE,UIEN_",",$$GETFIELD(UFILE,"LAST UPDATE DATE/TIME"))=DATETIME
+38 DO FILE^DIE("","FDA","ERR")
+39 IF $DATA(ERR("DIERR"))
SET OUT(1)="-3"_SSEP_$GET(ERR("DIERR",1,"TEXT",1))
+40 IF $DATA(ERR("DIERR"))
QUIT
+41 KILL FDA,ERR
+42 QUIT
End DoDot:2
+43 IF UIEN
SET PIEN=+$GET(^MAGV(UFILE,UIEN,6))
+44 QUIT
End DoDot:1
+45 SET OUT(1)="0"_SSEP_$GET(FIELDERR)_SSEP_IEN
+46 QUIT
ATTACH(OUT,FILE,ATTS) ; Create record; attach to parent record if applicable
+1 ; Input Variables:
+2 ; FILE - File number of record
+3 ; ATTS - Array of name value pairs separated by an input separator
+4 ; Output Variables:
+5 ; OUT - Returns success and new record IEN or error and error message
+6 NEW FDA,OSEP,ISEP,SSEP,NAM,VAL,ATTNAMS,KEYFLD,UATT,IEN,STATUS,NEWATTS,I
+7 NEW PIEN,PPIEN,PFILE,ERR,CIEN,UID,UIEN,DATETIME,KEYNAM,FIELDERR,DFN,DEVFDA,DEVICE
+8 SET OSEP=$$OUTSEP
SET ISEP=$$INPUTSEP
SET SSEP=$$STATSEP
+9 ; If file out of range quit with error
+10 IF (FILE<2005.6)!(FILE>2005.65)
SET OUT(1)="-4"_SSEP_"File is not in the 2005.6 to 2005.65 range"
QUIT
+11 ; If atts not defined quit with error
+12 SET I=0
+13 FOR
SET I=$ORDER(ATTS(I))
if 'I
QUIT
Begin DoDot:1
+14 SET NAM=$PIECE(ATTS(I),ISEP,1)
SET VAL=$PIECE(ATTS(I),ISEP,2)
+15 IF NAM=""
SET OUT(1)="-64"_SSEP_"Attribute name(s) missing from attribute array"
QUIT
+16 SET ATTNAMS(NAM)=VAL
+17 QUIT
End DoDot:1
if $DATA(OUT(1))
QUIT
+18 if $DATA(OUT(1))
QUIT
+19 SET KEYNAM=$$GET1^DID(FILE,.01,,"LABEL")
SET (UATT,KEYFLD(.01))=$GET(ATTNAMS(KEYNAM))
+20 SET KEYFLD(.01,"GSL")=$$GET1^DID(FILE,.01,,"GLOBAL SUBSCRIPT LOCATION")
+21 ; Set PIEN (parent IEN)
+22 IF FILE=2005.61
SET PIEN=$GET(ATTNAMS("PATIENT REFERENCE"))
SET PFILE=2005.6
+23 IF FILE=2005.62
SET PIEN=$GET(ATTNAMS("PROCEDURE REFERENCE"))
SET PFILE=2005.61
+24 IF FILE=2005.63
SET PIEN=$GET(ATTNAMS("STUDY REFERENCE"))
SET PFILE=2005.62
+25 IF FILE=2005.64
SET PIEN=$GET(ATTNAMS("SERIES REFERENCE"))
SET PFILE=2005.63
+26 IF FILE=2005.65
SET PIEN=$GET(ATTNAMS("SOP INSTANCE REFERENCE"))
SET PFILE=2005.64
+27 ; Check for STATUS INACCESSIBLE
+28 IF (FILE=2005.63)!(FILE=2005.64)
Begin DoDot:1
+29 SET STATUS=$$GET1^DIQ(PFILE,PIEN,"STATUS","I")
+30 IF STATUS="I"
SET OUT(1)="-100"_SSEP_"Parent status is Inaccessible."
+31 QUIT
End DoDot:1
if $DATA(OUT(1))
QUIT
+32 ; File DEVICE MANUFACTURER and DEVICE MODEL as ACQUISITION DEVICE in file 2005.63
+33 IF FILE=2005.63
Begin DoDot:1
+34 ; Remove parentheses from DEVICE MANUFACTOR and DEVICE MODEL and concatenate DEVICE and place model in parentheses
+35 SET DEVMAN=$GET(ATTNAMS("DEVICE MANUFACTURER"))
+36 SET DEVMODEL=$GET(ATTNAMS("DEVICE MODEL"))
+37 SET DEVICE=DEVMAN_" ("_DEVMODEL_")"
+38 ; If the device is not in 2006.04 add device
+39 IF '$DATA(^MAG(2006.04,"B",DEVICE))
Begin DoDot:2
+40 SET DEVFDA(2006.04,"+1,",.01)=DEVICE
+41 DO UPDATE^DIE("","DEVFDA","","DEVERR")
+42 QUIT
End DoDot:2
+43 ; If the device is in 2006.04 get IEN of entry
+44 SET DEVIEN=$ORDER(^MAG(2006.04,"B",DEVICE,""))
+45 SET ATTS($ORDER(ATTS(" "),-1)+1)="DEVICE"_ISEP_DEVIEN
+46 KILL ATTNAMS("DEVICE MANUFACTURER"),ATTNAMS("DEVICE MODEL")
+47 QUIT
End DoDot:1
+48 if ('$DATA(ATTNAMS("ARTIFACT ON FILE")))&(FILE'=2005.65)
Begin DoDot:1
+49 SET ATTNAMS("ARTIFACT ON FILE")=0
+50 SET ATTS($ORDER(ATTS(" "),-1)+1)="ARTIFACT ON FILE"_ISEP_0
+51 QUIT
End DoDot:1
+52 IF $GET(UATT)=""
SET OUT(1)="-5"_SSEP_"Unique identifier not provided"
QUIT
+53 ; If a patient ID is assigned by the VA set the PATIENT pointer
+54 IF FILE=2005.6
IF $GET(ATTNAMS("ASSIGNING AUTHORITY"))="V"
Begin DoDot:1
+55 SET DFN=$GET(ATTNAMS("ENTERPRISE PATIENT ID"))
+56 IF DFN'=""
SET ATTS($ORDER(ATTS(" "),-1)+1)="PATIENT FILE REFERENCE"_ISEP_DFN
+57 QUIT
End DoDot:1
+58 ;
+59 ; Quit with error if no assigning authority provided for a Procedure Reference
+60 IF FILE=2005.61
IF $GET(ATTNAMS("ASSIGNING AUTHORITY"))=""
SET OUT(1)="-5"_SSEP_"No ASSIGNING AUTHORITY provided."
QUIT
+61 ;
+62 ; If entry exists for Patient or Procedure then it is an update
+63 ; Patient or procedure update?
Begin DoDot:1
+64 ; Add multi-key (already checked .01)
+65 IF (FILE=2005.6)!(FILE=2005.61)
DO ADDMKEYS^MAGVRS46(.OUT,FILE,.ATTNAMS,.KEYFLD)
if $DATA(OUT(1))
QUIT
+66 ;
+67 ; Find match by keys
SET IEN=$$MATCH^MAGVRS46(FILE,UATT,$GET(PIEN),.KEYFLD)
+68 ; no exact match, create new
if 'IEN
QUIT
+69 ;
+70 SET STATUS=$$GET1^DIQ(FILE,IEN,"STATUS","I")
+71 IF (FILE>2005.6)
IF (PIEN'=+$GET(^MAGV(FILE,IEN,6)))
Begin DoDot:2
+72 IF STATUS="A"
SET OUT(1)="-66"_SSEP_"Parent IEN does not match parent IEN of record on file"
+73 ; STATUS="I" INACCESSIBLE
IF '$TEST
SET IEN=""
+74 QUIT
End DoDot:2
QUIT
+75 IF STATUS'="I"
SET OUT(1)="-63"_SSEP_"Active reference with same unique ID already exists"
QUIT
+76 SET NEWATTS(1)="IEN"_ISEP_IEN
+77 FOR I=1:1
if '$DATA(ATTS(I))
QUIT
SET NEWATTS(I+1)=ATTS(I)
+78 SET NEWATTS($ORDER(NEWATTS(" "),-1)+1)="STATUS"_ISEP_"A"
+79 DO UPDATE(.OUT,FILE,.NEWATTS,1)
+80 QUIT
End DoDot:1
if $GET(IEN)
QUIT
if $DATA(OUT(1))
QUIT
+81 if $DATA(OUT(1))
QUIT
+82 ; verify that parent IEN is set
IF FILE>2005.6
Begin DoDot:1
+83 IF PIEN=""
SET OUT(1)="-1"_SSEP_"No parent record IEN"
QUIT
+84 IF (PIEN<1)!(PIEN>($ORDER(^MAGV(FILE-.01," "),-1)))
SET OUT(1)="-6"_SSEP_"Invalid parent IEN"
QUIT
+85 QUIT
End DoDot:1
if $GET(OUT(1))'=""
QUIT
+86 ; If a series and a consult, get the current TIU note for the study (parent IEN)
+87 IF FILE=2005.63
Begin DoDot:1
+88 ; bail out if fatal exception raised
DO TIUCHK^MAGVRS43(.OUT,PIEN)
if $GET(OUT(1))<0
QUIT
+89 IF $PIECE(OUT(1),SSEP,1)=0
SET ATTS($ORDER(ATTS(" "),-1)+1)="TIU NOTE REFERENCE"_ISEP_$PIECE(OUT(1),SSEP,3)
+90 KILL OUT
+91 QUIT
End DoDot:1
if $GET(OUT(1))<0
QUIT
+92 SET ATTS($ORDER(ATTS(" "),-1)+1)="STATUS"_ISEP_"A"
+93 DO SETFDA^MAGVRS44(FILE,.ATTS,"+1,",.FDA,.FIELDERR)
+94 SET UID=$GET(FDA(FILE,"+1,",.01))
+95 IF UID=""
SET OUT(1)="-2"_SSEP_"No UID"
QUIT
+96 ; Attach record
+97 DO UPDATE^DIE("","FDA","","ERR")
+98 KILL FDA
+99 ; New Record IEN
SET CIEN=$ORDER(^MAGV(FILE,"B",UID,""),-1)
+100 ; Set return output to IEN of new record
SET OUT(1)="0"_SSEP_$GET(FIELDERR)_SSEP_CIEN
+101 IF $DATA(ERR("DIERR"))
SET OUT(1)="-3"_SSEP_$GET(ERR("DIERR",1,"TEXT",1))
+102 IF $DATA(ERR("DIERR"))
QUIT
+103 KILL ERR
+104 ; Update Number of SOP and SERIES Number fields in the Study and Series files
+105 IF (FILE=2005.63)!(FILE=2005.64)
SET PFILE=FILE-.01
SET FDA(PFILE,PIEN_",",7)=+$GET(^MAGV(PFILE,PIEN,4))+1
+106 IF FILE=2005.64
SET PFILE=2005.62
SET PPIEN=+$GET(^MAGV(2005.63,PIEN,6))
SET FDA(2005.62,PPIEN_",",20)=$PIECE($GET(^MAGV(2005.62,PPIEN,4)),U,2)+1
+107 DO FILE^DIE("","FDA","ERR")
+108 KILL FDA
+109 IF FILE=2005.65
DO AOFSET(PIEN,CIEN)
+110 ;Update last update for record and parents
IF FILE>2005.6
Begin DoDot:1
+111 SET DATETIME=$$NOW^XLFDT
+112 SET UIEN=CIEN
+113 FOR UFILE=FILE:-.01:2005.62
if 'UIEN
QUIT
Begin DoDot:2
+114 IF UFILE'=2005.65
Begin DoDot:3
+115 SET FDA(UFILE,UIEN_",",$$GETFIELD(UFILE,"LAST UPDATE DATE/TIME"))=DATETIME
+116 if $GET(ERR)'=""
SET OUT(1)=ERR
+117 KILL ERR
+118 DO FILE^DIE("","FDA","ERR")
+119 IF $DATA(ERR("DIERR"))
SET OUT(1)="-5"_SSEP_$GET(ERR("DIERR",1,"TEXT",1))
+120 KILL FDA,ERR
+121 QUIT
End DoDot:3
+122 IF UIEN
SET UIEN=+$GET(^MAGV(UFILE,UIEN,6))
+123 QUIT
End DoDot:2
+124 QUIT
End DoDot:1
if $GET(OUT(1))'=""
QUIT
+125 QUIT
REFRESH(OUT,FILE,IEN,PIEN,OVERRIDE) ; Retrieve specified file data attributes
+1 NEW OUTI,FIELD,MULTOUT,FDA,ERR,OSEP,ISEP,SSEP,MULTIPLE,DATETIME,UIEN,UFILE,FORMAT,SUBFILE,SUBIEN,FILEMULT,DD
+2 NEW DEVIEN,DEVNAME,DEVMAN,DEVMODEL,VALUE
+3 SET OSEP=$$OUTSEP
SET ISEP=$$INPUTSEP
SET SSEP=$$STATSEP
KILL OUT
+4 IF $GET(FILE)=""
SET OUT(1)="-9"_SSEP_"Missing file specification"
QUIT
+5 IF '$DATA(^MAGV(FILE))
IF '$DATA(^MAGD(FILE))
SET OUT(1)="-10"_SSEP_"Invalid file specification ("_$GET(FILE)_")"
QUIT
+6 IF '$GET(IEN)
SET OUT(1)="-1"_SSEP_"No record IEN"
QUIT
+7 IF '$GET(OVERRIDE)
IF '$GET(PIEN)
SET OUT(1)="-2"_SSEP_"No parent record IEN"
QUIT
+8 IF FILE'=2005.61
IF '$GET(OVERRIDE)
IF '$$PARENT(FILE,IEN,PIEN)
SET OUT(1)="-3"_SSEP_"Parent Record not verified"
QUIT
+9 IF FILE'=2006.575
IF '$DATA(^MAGV(FILE,IEN))
SET OUT(1)="-4"_SSEP_"IEN does not exist in "_FILE
QUIT
+10 IF FILE=2006.575
IF '$DATA(^MAGD(FILE,IEN))
SET OUT(1)="-5"_SSEP_"IEN does not exist in "_FILE
QUIT
+11 SET FIELD=$$GETFIELD(FILE,"STATUS")
IF FIELD
Begin DoDot:1
+12 SET STATUS=$$GET1^DIQ(FILE,IEN,FIELD,"I")
+13 if STATUS="I"
SET OUT(1)="-11"_SSEP_"No accessible entry for UID found in file "_FILE
+14 QUIT
End DoDot:1
if $DATA(OUT)
QUIT
+15 SET FIELD=""
SET OUTI=2
SET FNUM=""
+16 DO GETS^DIQ(FILE,IEN_",","**","I","DD")
+17 ; Process all non-multiple fields
+18 FOR
Begin DoDot:1
+19 SET FNUM=$ORDER(DD(FILE,IEN_",",FNUM))
if FNUM=""
QUIT
+20 ; DEVICE returns DEVICE MANUFACTURER and DEVICE MODEL from the ACQUISITION DEVICE file NAME (.01) field
IF FILE=2005.63
IF FNUM=18
Begin DoDot:2
+21 SET DEVIEN=$GET(DD("2005.63",IEN_",","18","I"))
+22 if $GET(DEVIEN)=""
QUIT
+23 SET DEVNAME=$PIECE($GET(^MAG(2006.04,DEVIEN,0)),U,1)
+24 SET DEVMAN=$PIECE(DEVNAME," (",1)
+25 SET DEVMODEL=$TRANSLATE($PIECE(DEVNAME," (",2),")")
+26 SET OUT(OUTI)="DEVICE MANUFACTURER"_OSEP_DEVMAN_SSEP
+27 SET OUT(OUTI+1)="DEVICE MODEL"_OSEP_DEVMODEL_SSEP
+28 SET OUTI=OUTI+2
+29 QUIT
End DoDot:2
QUIT
+30 SET FIELD=$$GET1^DID(FILE,FNUM,,"LABEL")
+31 ; return internal formats except for index terms and SOP CLASS UID
SET FORMAT=$SELECT((FIELD["INDEX")!(FIELD="SOP CLASS UID")!(FIELD="PHOTOMETRIC INTERPRETATION"):"E",1:"I")
+32 ; If the field is an IEN pointer return the internal format rather than the UID string
IF (FIELD["REFERENCE")
SET FORMAT="I"
+33 SET VALUE=$$GET1^DIQ(FILE,IEN,FIELD,$GET(FORMAT))
+34 IF $$DATETIME(FILE,FIELD)
SET VALUE=$$FM2IDF^MAGVAF01(VALUE)
+35 IF FILE=2005.63
IF FIELD="ACQUISITION LOCATION"
IF VALUE'=""
SET VALUE=$$GETSINST(VALUE)
+36 IF ((FILE=2005.6)!(FILE=2005.61))&(FIELD="SERVICE INSTITUTION REFERENCE")
IF VALUE'=""
SET VALUE=$$GETSINST(VALUE)
SET FIELD="CREATING ENTITY"
+37 SET OUT(OUTI)=FIELD_OSEP_VALUE_SSEP
+38 SET OUTI=OUTI+1
+39 QUIT
End DoDot:1
if FNUM=""
QUIT
+40 ; Process multiple fields
+41 SET FILEMULT=FILE
+42 FOR
Begin DoDot:1
+43 SET FILEMULT=$ORDER(DD(FILEMULT))
if FILEMULT=""
QUIT
+44 SET FNUM=$EXTRACT(FILEMULT,$LENGTH(FILE)+1,$LENGTH(FILEMULT))
+45 DO GETS^DIQ(FILE,IEN_",",FNUM_"*","","MULTOUT")
+46 IF '$DATA(MULTOUT)
QUIT
+47 SET FIELD=$$GET1^DID(FILE,FNUM,,"LABEL")
+48 SET SUBFILE=$ORDER(MULTOUT(""))
SET SUBIEN=""
+49 FOR
Begin DoDot:2
+50 SET SUBIEN=$ORDER(MULTOUT(SUBFILE,SUBIEN))
+51 SET OUT(OUTI)=FIELD_OSEP_MULTOUT(SUBFILE,SUBIEN,.01)_SSEP
+52 SET OUTI=OUTI+1
+53 QUIT
End DoDot:2
if $ORDER(MULTOUT(SUBFILE,SUBIEN))=""
QUIT
+54 QUIT
End DoDot:1
if FILEMULT=""
QUIT
+55 ; Look up successful
SET OUT(1)="0"_SSEP
+56 ; Update last access date time for study
+57 SET DATETIME=$$NOW^XLFDT
+58 SET UIEN=IEN
+59 FOR UFILE=FILE:-.01:2005.62
if 'UIEN
QUIT
Begin DoDot:1
+60 IF UFILE=2005.62
Begin DoDot:2
+61 SET FDA(UFILE,UIEN_",",$$GETFIELD(UFILE,"LAST ACCESS DATE/TIME"))=DATETIME
+62 KILL ERR
+63 DO FILE^DIE("","FDA","ERR")
+64 if $GET(ERR("DIERR"))'=""
SET OUT(1)="-7"_SSEP_$GET(ERR("DIERR",1,"TEXT",1))
+65 KILL FDA,ERR
+66 QUIT
End DoDot:2
+67 IF UIEN
SET UIEN=+$GET(^MAGV(UFILE,UIEN,6))
+68 QUIT
End DoDot:1
+69 QUIT
MULTIPLE(FILE,FIELD) ; Process multiple DB entries
+1 NEW DATATYPE,MULTIPLE,FNUM
+2 SET MULTIPLE=$$GET1^DID(FILE,FIELD,,"MULTIPLE-VALUED")
+3 QUIT +MULTIPLE
NUMERIC(FILE,FIELD) ; Determine if field is numeric
+1 NEW DATATYPE,NUMERIC
+2 SET NUMERIC=0
+3 IF $$GET1^DID(FILE,FIELD,"","TYPE")="NUMERIC"
SET NUMERIC=1
+4 QUIT NUMERIC
DATETIME(FILE,FIELD) ; Determine if field is date time
+1 NEW DATATYPE,DATETIME
+2 SET DATETIME=0
+3 IF $$GET1^DID(FILE,FIELD,"","TYPE")="DATE/TIME"
SET DATETIME=1
+4 QUIT DATETIME
GETFIELD(FILE,FNAME) ; Returns a field number given a field name
+1 QUIT $$FLDNUM^DILFD(FILE,FNAME)
PARENT(FILE,IEN,PIEN) ; Check if provided parent IEN is linked to current record
+1 IF PIEN'=+$GET(^MAGV(FILE,IEN,6))
QUIT 0
+2 QUIT 1
AOFSET(PIEN,IEN) ; Set artifact on file to 1 for all parent nodes of file instance
+1 NEW AOFFILE,FIELD,FDA,ERR,MAGVIEN,MAGVPIEN,MAGVOUT
+2 ; IEN in file #2005.64
SET MAGVPIEN=PIEN
+3 ; IEN in file #2005.65
SET MAGVIEN=IEN
+4 ;
+5 FOR AOFFILE=2005.64,2005.63,2005.62,2005.61,2005.6
Begin DoDot:1
+6 SET FIELD=$$GETFIELD(AOFFILE,"ARTIFACT ON FILE")
+7 IF $GET(FIELD)=""
QUIT
+8 SET FDA(AOFFILE,PIEN_",",FIELD)=1
+9 DO FILE^DIE("","FDA")
+10 KILL FDA,ERR
+11 IF AOFFILE>2005.6
SET PIEN=+$GET(^MAGV(AOFFILE,PIEN,6))
+12 QUIT
End DoDot:1
+13 ; add a new storage work item
DO NWI34^MAGNWRK1(.MAGVOUT,MAGVPIEN,MAGVIEN)
+14 ;
+15 QUIT
INACTIVT(OUT,FILE,IEN,PIEN,OVERRIDE,REASON) ; Marks the entry indicated by file # and IEN as deleted
+1 NEW OSEP,ISEP,SSEP,STATUS,PFILE,ERR,FDA,AOF,FIELD,AOFIEN
+2 SET OSEP=$$OUTSEP
SET ISEP=$$INPUTSEP
SET SSEP=$$STATSEP
+3 IF $GET(FILE)=""
SET OUT(1)="-23"_SSEP_"No file number provided"
QUIT
+4 IF $GET(IEN)=""
SET OUT(1)="-20"_SSEP_"No IEN provided"
QUIT
+5 IF '$GET(PIEN)=""
SET OUT(1)="-21"_SSEP_"No parent IEN provided"
QUIT
+6 IF '$DATA(OVERRIDE)
SET OUT(1)="-22"_SSEP_"No OVERRIDE flag provided"
QUIT
+7 IF '$DATA(^MAGV(FILE,IEN,0))
SET OUT(1)="-1"_SSEP_"Record IEN not found in file"
QUIT
+8 IF '$DATA(REASON)
SET OUT(1)="-4"_SSEP_"No deletion reason provided"
QUIT
+9 ; If record status is already INACCESIBLE quit with error
+10 SET FIELD=$$GETFIELD(FILE,"STATUS")
+11 SET STATUS=$$GET1^DIQ(FILE,IEN,FIELD,"E")
+12 IF STATUS="INACCESSIBLE"
SET OUT(1)="2"_SSEP_"Record is already inaccessible"
QUIT
+13 ; Call INACT to delete identified record and all children
+14 DO INACT^MAGVRS44(.OUT,FILE,IEN,$GET(PIEN),$GET(OVERRIDE),$GET(REASON))
+15 IF $DATA(OUT(1))
QUIT
+16 ; Set parent records artifact on file to false if no active child records
+17 SET AOFIEN=IEN
SET AOF=""
+18 FOR FILE=FILE:2005.61:-.01
if AOF'=""
QUIT
Begin DoDot:1
+19 FOR
SET AOFIEN=+$GET(^MAGV(FILE,"C",PIEN,AOFIEN))
if (AOF'="")!(AOFIEN="")
QUIT
Begin DoDot:2
+20 SET FIELD=$$GETFIELD(FILE,"ARTIFACT ON FILE")
+21 SET AOF=$$GET1^DIQ(FILE,AOFIEN,FIELD)
End DoDot:2
+22 QUIT
+23 ;If no child records are on file then set parent to artifact not on file
+24 IF AOF=""
Begin DoDot:2
+25 SET PFILE=FILE-.01
+26 SET FIELD=$$GETFIELD(FILE,"ARTIFACT ON FILE")
+27 SET FDA(PFILE,PIEN_",",FIELD)=""
+28 DO FILE^DIE("","FDA")
+29 KILL FDA,ERR
+30 QUIT
End DoDot:2
+31 QUIT
End DoDot:1
+32 IF '$DATA(OUT(1))
SET OUT(1)="0"_SSEP_SSEP_IEN
+33 QUIT
FINDBUID(OUT,FILE,UID) ;Find SOP or series by UID
+1 NEW STATUS,IEN,OSEP,ISEP,SSEP
+2 SET OSEP=$$OUTSEP
SET ISEP=$$INPUTSEP
SET SSEP=$$STATSEP
+3 IF $GET(FILE)=""
SET OUT="-3"_SSEP_"No file specified"
QUIT
+4 IF "^2005.62^2005.63^2005.64^"'[("^"_FILE_"^")
SET OUT="-4"_SSEP_"Invalid file specified ("_FILE_")"
QUIT
+5 IF $GET(UID)=""
SET OUT="-5"_SSEP_"No UID specified"
QUIT
+6 SET IEN=$ORDER(^MAGV(FILE,"B",UID,""))
+7 SET FIELD=$$GETFIELD(FILE,"STATUS")
+8 SET STATUS=$$GET1^DIQ(FILE,IEN,FIELD,"I")
+9 IF IEN'=""
IF STATUS'="I"
SET OUT="0"_SSEP_SSEP_IEN
QUIT
+10 IF IEN=""
SET OUT="-1"_SSEP_"UID not found in file "_FILE
QUIT
+11 IF STATUS="I"
SET OUT="-2"_SSEP_"No active entry for UID found in file "_FILE
QUIT
+12 QUIT
GETSINST(VALUE) ; Get the service institution value
+1 NEW IEN,FILE,SITE,X
+2 SET SITE="Error - unknown service institution"
+3 SET X=$GET(^MAGV(2005.8,$GET(VALUE),0))
+4 SET IEN=$PIECE(X,";",1)
SET FILE=$PIECE(X,";",2)
+5 ; IA #2171 Get Station Number
IF FILE="DIC(4,"
SET SITE=$PIECE($$NS^XUAF4(IEN),U,2)
+6 QUIT SITE
