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

MAGVIM09.m

Go to the documentation of this file. 
  1. MAGVIM09 ;WOIFO/DAC,MAT,JSJ,RRM,BT,JSL - Utilities for RPC calls for DICOM file processing ; Oct 04, 2022@19:19:13
  1.  ;;3.0;IMAGING;**118,138,332,345,357**;Mar 19, 2002;Build 29
  1.  ;; Per VA Directive 6402, this routine should not be modified.
  1.  ;; +---------------------------------------------------------------+
  1.  ;; | Property of the US Government.                                |
  1.  ;; | No permission to copy or redistribute this software is given. |
  1.  ;; | Use of unreleased versions of this software requires the user |
  1.  ;; | to execute a written test agreement with the VistA Imaging    |
  1.  ;; | Development Office of the Department of Veterans Affairs,     |
  1.  ;; | telephone (301) 734-0100.                                     |
  1.  ;; | The Food and Drug Administration classifies this software as  |
  1.  ;; | a medical device.  As such, it may not be changed in any way. |
  1.  ;; | Modifications to this software may result in an adulterated   |
  1.  ;; | medical device under 21CFR820, the use of which is considered |
  1.  ;; | to be a violation of US Federal Statutes.                     |
  1.  ;; +---------------------------------------------------------------+
  1.  ;;
  1.  Q
  1.  ;
  1.  ; +++++  Get a record from a WORK ITEM file (#2006.941) by IEN 
  1.  ; 
  1.  ; Input parameters
  1.  ; ================
  1.  ; ID = IEN in the file
  1.  ; STARTCNT = starting line in OUT array
  1.  ; 
  1.  ; Return Values
  1.  ; =============
  1.  ;   OUT(STARTCNT)="WorkItemHeader"_delimited "`" fields values
  1.  ;   OUT(STARTCNT+1..n)=Message
  1.  ;   OUT(n+1..m)=Tags`TagName`TagValue
  1.  ;
  1. GETWI(OUT,ID,STOPTAG,SRV) ; Return Work Item record in OUT array
  1.  ; OUT      - array that holds the result
  1.  ; ID       - IEN of the Work Item 
  1.  ; STOPTAG  - The last tag of a record to be returned (optional)
  1.  N FILE,IENS,MAGOUT,ERR,FLD,CNT,TAGS,I,AFLD,DATA
  1.  N SSEP,OSEP,STOP,TAGNAME,TAGVALUE
  1.  S SSEP=$$STATSEP^MAGVIM01,OSEP=$$OUTSEP^MAGVIM01
  1.  S FILE=2006.941
  1.  S IENS=ID_","
  1.  D GETS^DIQ(FILE,ID_",","*","IE","MAGOUT","ERR")
  1.  I $D(ERR) S OUT="-1"_SSEP_$G(ERR("DIERR",1,"TEXT",1)) Q 
  1.  ; Type of the return field values - internal, external, date
  1.  S AFLD(.01)="D"  ; CREATED DATE/TIME
  1.  S AFLD(1)="E"    ; TYPE
  1.  S AFLD(2)="E"    ; SUBTYPE
  1.  S AFLD(3)="E"    ; STATUS
  1.  S AFLD(4)="I"    ; LOCATION
  1.  S AFLD(5)="E"    ; PRIORITY
  1.  S AFLD(8)="IE"   ; CREATING USER
  1.  S AFLD(9)="D"    ; LAST UPDATED DATE/TIME
  1.  S AFLD(10)="IE"  ; LAST UPDATING USER
  1.  S AFLD(14)="E"   ; CREATING APPLICATION
  1.  S AFLD(15)="E"   ; LAST UPDATING APPLICATION
  1.  S AFLD(16)="E"   ; SC TRANSACTION ID
  1.  ;
  1.  ;Convert Institution IEN to Station Number
  1.  I $G(MAGOUT(FILE,IENS,4,"I")) D
  1.  . S MAGOUT(FILE,IENS,4,"I")=$$STA^XUAF4(MAGOUT(FILE,IENS,4,"I")) ;IA #2171 Get station number for an IEN
  1.  . Q
  1.  ;
  1.  S CNT=OUT(0)+1
  1.  S FLD=0
  1.  S OUT(CNT)="WorkItemHeader"_SSEP_ID
  1.  F  S FLD=$O(MAGOUT(FILE,IENS,FLD)) Q:FLD=""  D
  1.  . Q:FLD=13  ; Word-processing field
  1.  . I AFLD(FLD)["D" S OUT(CNT)=OUT(CNT)_OSEP_$$FMTE^XLFDT(MAGOUT(FILE,IENS,FLD,"I"),5)  ; Date fields
  1.  . I AFLD(FLD)["I" S OUT(CNT)=OUT(CNT)_OSEP_MAGOUT(FILE,IENS,FLD,"I")
  1.  . I AFLD(FLD)["E" S OUT(CNT)=OUT(CNT)_OSEP_MAGOUT(FILE,IENS,FLD,"E")
  1.  . Q
  1.  ; Get Message
  1.  S I=0 F  S I=$O(MAGOUT(FILE,IENS,13,I)) Q:I'>0  D
  1.  . S CNT=CNT+1,OUT(CNT)="Message"_SSEP_MAGOUT(FILE,IENS,13,I)
  1.  . Q
  1.  ; Get Tags
  1.  S TAGS=2006.94111,I="",STOP=0
  1.  I $G(SRV)'="" S CNT=CNT+1,OUT(CNT)="Tag"_SSEP_"Service"_OSEP_SRV
  1.  S I=0
  1.  F  S I=$O(^MAGV(2006.941,ID,4,I)) Q:I=""  D  Q:STOP=1
  1.  . S DATA=$G(^MAGV(2006.941,ID,4,I,0))
  1.  . S TAGNAME=$P(DATA,U,1),TAGVALUE=$P(DATA,U,2)
  1.  . S CNT=CNT+1,OUT(CNT)="Tag"_SSEP_TAGNAME_OSEP_TAGVALUE
  1.  . I $G(STOPTAG)'="",STOPTAG=TAGNAME S STOP=1
  1.  S OUT(0)=CNT
  1.  Q
  1.  ;
  1.  ;P332 IMSTATUS moved from MAGVIM01 because routine size was exceeded
  1.  ; RPC: MAGV IMPORT STATUS from MAGVIM01
  1. IMSTATUS(OUT,UIDS) ; Get import status
  1.  N SSEP,STUDYLIST,SOPLIST,STUDYOUT,SOPOUT,I,CNT,STUDYUID,SERUID,SOPUID,ISEP,SOPIEN,SERIEN,STUDIEN,FOUNDUID
  1.  N ONFILESOP
  1.  S SSEP=$$OUTSEP^MAGVIM01,ISEP=$$INPUTSEP^MAGVIM01,I=0,CNT=0 ;P332 add routine to calls
  1.  I '$D(UIDS) S OUT(1)=-6_SSEP_"No UIDs provided" Q
  1.  F  S I=$O(UIDS(I)) Q:I=""  D
  1.  . S CNT=I,FOUNDUID="",ONFILESOP=0
  1.  . S STUDYUID=$P(UIDS(I),ISEP,1),SERUID=$P(UIDS(I),ISEP,2),SOPUID=$P(UIDS(I),ISEP,3)
  1.  . I $G(STUDYUID)="" S OUT(I+1)=-1_SSEP_"No study UID provided" Q
  1.  . I $G(SERUID)="" S OUT(I+1)=-2_SSEP_"No series UID provided" Q
  1.  . I $G(SOPUID)="" S OUT(I+1)=-3_SSEP_"No SOP UID provided" Q
  1.  . S OUT(I+1)=-1_SSEP_UIDS(I)_SSEP_"not on file"
  1.  . S STUDYLIST(1)=1,STUDYLIST(2)=STUDYUID
  1.  . S SOPLIST(1)=1,SOPLIST(2)=SOPUID
  1.  . ; Check ^MAG(2005) for import study status 
  1.  . D CHECKUID^MAGDRPCA(.STUDYOUT,.STUDYLIST,"STUDY")
  1.  . I STUDYOUT(2)'="",(+STUDYOUT(2))'<0 D
  1.  . . D CHECKUID^MAGDRPCA(.SOPOUT,.SOPLIST,"SOP")
  1.  . . I SOPOUT(2)'="",(+SOPOUT(2))'<0 D  S CNT=I
  1.  . . . S OUT(I+1)="0"_SSEP_UIDS(I)_SSEP_"on file"
  1.  . . . S ONFILESOP=1
  1.  . . . Q
  1.  . . Q
  1.  . I $G(STUDYOUT(2))="",$G(ONFILESOP)<1 D SOPCHECK(.UIDS,I) Q:$G(ONFILESOP)
  1.  . S SOPOUT=""
  1.  . ; Check SOP original and UID
  1.  . I ('$D(^MAGV(2005.64,"B",SOPUID)))&('$D(^MAGV(2005.66,"B",SOPUID))) D SOPCHECK(.UIDS,I) Q
  1.  . S SOPIEN=$O(^MAGV(2005.64,"B",SOPUID,""),-1)
  1.  . ;if null try dup(replaced) UID
  1.  . I SOPIEN="" S SOPIEN=$$DUPUID(.UIDS,I,SOPUID,3)  ;P332 Check for replacement
  1.  . Q:SOPIEN=""
  1.  . I $G(^MAGV(2005.64,SOPIEN,11))'="A" Q
  1.  . ; Check Series original and UID
  1.  . I ('$D(^MAGV(2005.63,"B",SERUID)))&('$D(^MAGV(2005.66,"B",SERUID))) D  Q:$G(FOUNDUID)=""
  1.  . . I $G(SOPIEN)'="" S FOUNDUID=$$RECHKFLE(.UIDS,I,SOPUID,2)
  1.  . S SERIEN=$O(^MAGV(2005.63,"B",$S($G(FOUNDUID)'="":FOUNDUID,1:SERUID),""),-1)
  1.  . ;if null try dup(replaced) UID
  1.  . I SERIEN="" S SERIEN=$$DUPUID(.UIDS,I,SERUID,2)  ;P332 Check for replacement
  1.  . Q:SERIEN=""
  1.  . I $G(^MAGV(2005.63,SERIEN,9))'="A" Q
  1.  . ; Check Study original and UID
  1.  . I ('$D(^MAGV(2005.62,"B",STUDYUID)))&('$D(^MAGV(2005.66,"B",STUDYUID))) D  Q:$G(FOUNDUID)=""
  1.  . . I $G(SERIEN)'="" S FOUNDUID=$$RECHKFLE(.UIDS,I,SERUID,1)
  1.  . S STUDIEN=$O(^MAGV(2005.62,"B",$S($G(FOUNDUID)'="":FOUNDUID,1:STUDYUID),""),-1)
  1.  . ;if null try dup(replaced) UID
  1.  . I STUDIEN="" S STUDIEN=$$DUPUID(.UIDS,I,STUDYUID,1)  ;P332 Check for replacement
  1.  . Q:STUDIEN=""
  1.  . I $P($G(^MAGV(2005.62,STUDIEN,5)),U,2)'="A" Q
  1.  . S OUT(I+1)="0"_SSEP_UIDS(I)_SSEP_"on file"
  1.  . I SOPIEN'="" S ONFILESOP=1
  1.  . Q
  1.  ;
  1.  S OUT(1)=0_SSEP_CNT
  1.  Q
  1.  ;
  1. SOPCHECK(UIDS,I) ;
  1.  N MAG2005IEN,MAGPARENTIEN
  1.  S SOPUID=$P(UIDS(I),ISEP,3)
  1.  I $D(^MAG(2005,"P",SOPUID)) D
  1.  . D CHECKUID^MAGDRPCA(.SOPOUT,.SOPLIST,"SOP")
  1.  . I SOPOUT(2)'="",(+SOPOUT(2))'<0 D
  1.  . . D CHECKUID^MAGDRPCA(.STUDYOUT,.STUDYLIST,"STUDY")
  1.  . . I SOPOUT(2)'="",(+SOPOUT(2))'<0 S OUT(I+1)="0"_SSEP_UIDS(I)_SSEP_"on file"
  1.  . . S ONFILESOP=1
  1.  Q
  1.  ;
  1. RECHKFLE(UIDS,I,UID,TYPE) ;
  1.  N FILE,NEWUID
  1.  I TYPE=1 S FILE=2005.63
  1.  I TYPE=2 S FILE=2005.64
  1.  I $D(^MAGV(FILE,"B",UID)) D
  1.  . S IEN=$O(^MAGV(FILE,"B",UID,""))
  1.  . S IEN=$P(^MAGV(FILE,IEN,6),"^")
  1.  . I TYPE=1 D
  1.  . . S NEWUID=$P($G(^MAGV(2005.62,IEN,0)),"^")
  1.  . . ;S $P(UIDS(I),ISEP,TYPE)=NEWUID
  1.  . I TYPE=2 D
  1.  . . S NEWUID=$P($G(^MAGV(2005.63,IEN,0)),"^")
  1.  . . ;S $P(UIDS(I),ISEP,TYPE)=NEWUID
  1.  Q $G(NEWUID)  ;SF prevent UNDEF errors 
  1.  ;
  1.  ;Set replaced UID in UIDS array if found in 2005.66 duplicate file
  1. DUPUID(UIDS,I,UID,TYPE)  ;P332 added sub
  1.  ; UIDS - Array of UIDs
  1.  ; I    - Current array element of UIDS being processed
  1.  ; UID  - Original UID of TYPE being checked for duplicate
  1.  ; TYPE - UID type - 1-STUDY, 2-SERIES, 3-SOP
  1.  I UID=""!(TYPE="") Q ""
  1.  NEW IEN,FILE,REC0,RPLFND,RPLIEN
  1.  S FILE=$P("2005.62,2005.63,2005.64",",",TYPE)
  1.  S (IEN,RPLIEN,RPLFND)=""
  1.  ;loop dup index from latest and quit if a match is found
  1.  F  S RPLIEN=$O(^MAGV(2005.66,"B",UID,RPLIEN),-1) Q:(RPLIEN="")!RPLFND  D
  1.  . S REC0=$G(^MAGV(2005.66,RPLIEN,0))
  1.  . I TYPE'=$P(REC0,U,5) Q   ;UID type mismatch
  1.  . I UID'=$P(REC0,U) Q      ;UID doesn't match orig in dup record
  1.  . ;verify dup UID is in file index and UID matches original UID in FILE
  1.  . S IEN=$O(^MAGV(FILE,"B",$P(REC0,U,2),""),-1)  ;get IEN from file with replaced UID
  1.  . I IEN="" Q                                    ;replaced UID not in FILE index
  1.  . I UID'=$P($G(^MAGV(FILE,IEN,0)),"^",2) Q      ;original UID does not match
  1.  . S $P(UIDS(I),ISEP,TYPE)=$P(REC0,U,2)          ;set replacement UID
  1.  . S RPLFND=1                                    ;quit loop
  1.  Q IEN  ;return FILE IEN for replaced UID (or null if not found)
  1.  ;
  1.  ; RPC: MAGV FIND WORK ITEM  (Calling from FIND^MAGVIM01)
  1. FIND(OUT,TYPE,SUBTYPE,STATUS,PLACEID,PRIORITY,STOPTAG,MAXROWS,TAGS,LASTIEN,ORDER,DTFROM,DTTO) ; Find records with given attributes - return ID
  1.  ;PLACEID is FILE #4's STATION NUMBER
  1.  N IEN,IEN2,J,TAGMATCH,SSEP,ISEP,TAG,WICOUNT,FLD
  1.  N VALUE,FLDS,AFLD,NOMATCH,IENS,MAGOUT,LOCIEN,SRV
  1.  N TAGITM,PATNAME,GLB,FLTITM,RET
  1.  S SSEP=$$STATSEP^MAGVIM01,ISEP=$$INPUTSEP^MAGVIM01
  1.  S:'$G(DTFROM) DTFROM=0
  1.  S:'$G(DTTO) DTTO=9999999
  1.  ;
  1.  I $G(MAXROWS)'="",'(MAXROWS?1N.N) S OUT=-2_SSEP_"Invalid MAXROWS parameter provided" Q
  1.  ;
  1.  I $G(PLACEID)'="" D  Q:$G(OUT)<0
  1.  . S LOCIEN=$$IEN^XUAF4(PLACEID) ;IA #2171 Get Institution IEN for a station number
  1.  . I LOCIEN="" S OUT=-2_SSEP_"Invalid PLACEID parameter provided"
  1.  . Q
  1.  ;
  1.  S OUT(0)=0
  1.  ; AFLD(FLD,"IE") = compare the external or internal value of the field
  1.  S FLDS=""
  1.  I $G(TYPE)'="" S FLDS=FLDS_"1;",AFLD(1)=TYPE,AFLD(1,"IE")="E"
  1.  I $G(SUBTYPE)'="" S FLDS=FLDS_"2;",AFLD(2)=SUBTYPE,AFLD(2,"IE")="E"
  1.  I $G(STATUS)'="" S FLDS=FLDS_"3;",AFLD(3)=STATUS,AFLD(3,"IE")="E"
  1.  I $G(LOCIEN)'="" S FLDS=FLDS_"4;",AFLD(4)=LOCIEN,AFLD(4,"IE")="I"
  1.  I $G(PRIORITY)'="" S FLDS=FLDS_"5;",AFLD(5)=PRIORITY,AFLD(5,"IE")="E"
  1.  ;
  1.  K FLTITM S RET=$$GFLTITM^MAGVIM01(.FLTITM,.TAGS) ;filter Source, Service, Modality, and Procedure 
  1.  I RET S GLB="FLTITM"
  1.  I 'RET S GLB="^MAGV(2006.941)"
  1.  ;
  1.  K ERR
  1.  S:'$G(ORDER) ORDER=1
  1.  I '$G(LASTIEN) D
  1.  . I ORDER=1 S LASTIEN=0
  1.  . I ORDER=-1 S LASTIEN=9999999
  1.  S IEN=LASTIEN,WICOUNT=1
  1.  ;
  1.  F  S IEN=$O(@GLB@(IEN),ORDER) Q:(+IEN=0)!$D(ERR)!(($G(MAXROWS)'="")&(WICOUNT>$G(MAXROWS)))  D
  1.  . Q:'$$DTINRNG^MAGVIM01(IEN,DTFROM,DTTO)
  1.  . S IENS=IEN_"," K ERR,MAGOUT
  1.  . D GETS^DIQ(2006.941,IENS,FLDS,"IE","MAGOUT","ERR")
  1.  . I $D(ERR) K OUT S OUT(0)=-1_SSEP_$G(ERR("DIERR",1,"TEXT",1)) Q  ; Set Error and quit
  1.  . S FLD="",NOMATCH=0
  1.  . F  S FLD=$O(AFLD(FLD)) Q:FLD=""!NOMATCH  D
  1.  . . S:AFLD(FLD)'=MAGOUT("2006.941",IENS,FLD,AFLD(FLD,"IE")) NOMATCH=1
  1.  . . Q
  1.  . Q:NOMATCH  ; get next one if no match
  1.  . ; Tag matching
  1.  . S SRV=$$SRV^MAGVIM01(IEN),J=0,TAGMATCH=1
  1.  . F  S J=$O(TAGS(J)) Q:(J="")!'TAGMATCH  D
  1.  . . S TAG=$P(TAGS(J),ISEP,1),VALUE=$P(TAGS(J),ISEP,2)
  1.  . . I TAG="Procedure",VALUE="[No Procedure]",'$D(^MAGV(2006.941,"H",TAG,IEN)) Q
  1.  . . I TAG="Modality",VALUE="[No Modality]",'$D(^MAGV(2006.941,"H",TAG,IEN)) Q
  1.  . . I TAG="Service",VALUE'="" D  Q
  1.  . . . I VALUE="[No Service]",SRV="" Q
  1.  . . . I SRV'=VALUE S TAGMATCH=0
  1.  . . I TAG="PatientName",VALUE'="",'$D(^MAGV(2006.941,"H",TAG,IEN)) S TAGMATCH=0 Q
  1.  . . I TAG="PatientName",VALUE'="",$D(^MAGV(2006.941,"H",TAG,IEN)) D  Q
  1.  . . . S TAGITM=$O(^MAGV(2006.941,"H",TAG,IEN,"")) I TAGITM="" S TAGMATCH=0 Q
  1.  . . . S PATNAME=$P($G(^MAGV(2006.941,IEN,4,TAGITM,0)),U,2) I PATNAME="" S TAGMATCH=0 Q
  1.  . . . I '$F($$UPCASE(PATNAME),$$UPCASE(VALUE)) S TAGMATCH=0 Q
  1.  . . I VALUE'="",$L(VALUE)<31,'$D(^MAGV(2006.941,"HH",TAG,VALUE,IEN)) S TAGMATCH=0 Q
  1.  . . I VALUE'="",$L(VALUE)<31,$D(^MAGV(2006.941,"HH",TAG,VALUE,IEN)) Q
  1.  . . S IEN2=$O(^MAGV(2006.941,"H",TAG,IEN,""))
  1.  . . I $P($G(^MAGV(2006.941,IEN,4,IEN2,0)),U,2)'=VALUE S TAGMATCH=0
  1.  . . Q
  1.  . I 'TAGMATCH Q
  1.  . ; Add work item header to output array
  1.  . D GETWI^MAGVIM09(.OUT,IEN,"",SRV)  ; Get Work Item Record
  1.  . I +OUT(0)<0 S ERR=""  ; Check for error and set ERR to quit from the loop
  1.  . S WICOUNT=WICOUNT+1
  1.  . S LASTIEN=IEN
  1.  . Q
  1.  ;Save the last IEN processed, used to retrieve more rows
  1.  I IEN,'$D(ERR) S OUT(0)=OUT(0)_SSEP_LASTIEN
  1.  Q
  1.  ;
  1. UPDWI(ID,FDA,MSGUPD) ; Update work item
  1.  ; Return 0|Error`Message error
  1.  ; 
  1.  ; ID - IEN of Work Item
  1.  ; FDA - VA FileMan FDA array
  1.  ; MSGUPD - Message array
  1.  N ERR,SSEP
  1.  S SSEP=$$STATSEP^MAGVIM01
  1.  ;
  1.  D VALIDATE^MAGVIM06(.FDA,.ERR)
  1.  I $D(ERR("DIERR",1,"TEXT",1)) Q -4_SSEP_$G(ERR("DIERR",1,"TEXT",1))
  1.  ;
  1.  K ERR
  1.  D FILE^DIE("E","FDA","ERR")
  1.  I $D(ERR("DIERR",1,"TEXT",1)) Q -3_SSEP_$G(ERR("DIERR",1,"TEXT",1))
  1.  ;
  1.  ; Update Message field
  1.  K ERR
  1.  I $D(MSGUPD) D WP^DIE(2006.941,ID_",",13,"K","MSGUPD","ERR")
  1.  I $D(ERR("DIERR",1,"TEXT",1)) Q -5_SSEP_$G(ERR("DIERR",1,"TEXT",1))
  1.  ;
  1.  Q 0_SSEP_"Work item "_ID_" updated"
  1.  ;
  1. UPCASE(X) ;
  1.  Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
  1.  ;