- 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 Jan 18, 2025@03:11:29 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