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

MAGQBPRG.m

Go to the documentation of this file.
  1. MAGQBPRG ;WOIOFO/RMP - Magnetic Server Purge processes ; 07 Jun 2013 9:53 AM
  1. ;;3.0;IMAGING;**7,3,8,20,81,39,135**;Mar 19, 2002;Build 5238;Jul 17, 2013
  1. ;; Per VHA Directive 2004-038, 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. FILEREF(RESULT,FILEPATH,FNAM,EXT,NETLOC) ; RPC[MAGQBP FREF]
  1. ;VALIDATES THAT THE FILEPATH IS CONSISTENT WITH VISTA MAGFILE REFERENCE
  1. ;SET THE SECOND PIECE TO "PACS" IF IT REPRESENTS DICOM
  1. ;VALIDATES THAT A JUKEBOX POINTER EXISTS
  1. ;RESULT VALUES
  1. ;PIECE 1:-3 = FOREIGN FILE, DO NOT PURGE
  1. ; -2 = QUEUED FOR JUKEBOX COPY, DO NOT PURGE
  1. ; -1 = DO NOT PURGE
  1. ; **0 = PURGE('MAG 2005 ENTRY)!('JUKEBOX PTRS )
  1. ; 1 = PURGE GIVEN NORMAL DATE CRITERIA (NDC) + CONFIRMED ON JB
  1. ; **2 = PURGE GIVEN NDC IF TGA PRESENT
  1. ; 3 = PURGE IF FILE IS AT ALTERNATE NETWORK LOCATION SITE
  1. ; ELSE PURGE IF AGED & UPDATE FILE REFERENCES
  1. ; **4 = (**NA**)AGE PURGE IF ON JUKEBOX, UPDATE FILE REFERENCES
  1. ; ELSE UPDATE FILEREFENCES, QUEUE JUKEBOX COPY
  1. ; 5 = PURGE IF AT ALTERNATE SITE,QUEUE JUKEBOX IF NOT ON JB
  1. ; **6 = PURGE GIVEN NORMAL DATE CRITERIA
  1. ;PIECE ** 2: FILETYPE
  1. ; 0 = foreign
  1. ; 1 = abstract
  1. ; 2 = full
  1. ; 3 = big
  1. ; 4 = photo id
  1. ; 5 = advance directive
  1. ;PIECE 3: RECORD CATEGORY
  1. ; 1 = 'NO 2005 ENTRY
  1. ; **2 = RADIOLOGY HOLD
  1. ; 3 = NO JUKEBOX/JUKEBOX PTRS
  1. ; 4 = JUKEBOX - NO JUKEBOX PTRS (P/EXCEPT)ELSE QUEUE
  1. ; 5 = JUKEBOX/JUKEBOX PTRS, NO CACHE PTRS,PURGE IF CONFIRMED
  1. ; 6 = JUKEBOX/JUKEBOX PTRS, WRONG CACHE PTRS PURGE IF AT ALT
  1. ; 7 = JUKEBOX/JUKEBOX PTRS, NO CACHE PTRS, FIX PTRS
  1. ; 8 = JUKEBOX/JUKEBOX PTRS, CACHE PTRS, AGE (IF CONFIRMED)
  1. ; 9 = RECORD NOT IN THE IMAGE FILE
  1. ; 10 = FOREIGN IMAGE FILE
  1. ; 11 = NOT AN IMAGE FILE
  1. ; 12 = FILE LOCATION NOT VALID
  1. ; 13 = DELETE 2005 ENTRY (LAST LOCATION REFERENCED)
  1. ; 14 = Duplicate 2005/2005.1 entry
  1. ; 15 = Foreign Place
  1. ; 16 = Record in Archive file
  1. ; 17 = Jukebox offline
  1. N FILEXT,IEN,SITEID,MAGXX,MAGFILE,MAGFILE1,MAGFILE2,RIEN,ZNODE
  1. N FTYPE,CPTR,JBPTR,CPOK,BNODE,ALTPATH,NMSPC,PLACE,XX,FT,MAGDA
  1. N X S X="ERR^MAGQBTM",@^%ZOSF("TRAP")
  1. S PLACE=$$PLACE^MAGBAPI(+$G(DUZ(2)))
  1. S U="^",(MAGFILE2,RESULT)=""
  1. S FNAM=$$UPPER^MAGQE4(FNAM)
  1. S EXT=$$UPPER^MAGQE4(EXT)
  1. S ^TMP("MAGQ",$J,"PRG","LAST")=FILEPATH_U_FNAM_U_EXT_U_NETLOC
  1. I FNAM'?1.5A1.13N1"."1.3E D Q ;LATER ADD EXT VERIFY USING 2005.02
  1. . D ELOG(FNAM,FILEPATH,"Not a VistA Imaging file") S RESULT="-3^0^11" Q ;'IMAGE FILE
  1. S SITEID=$$UPPER^MAGQE4($$INIS^MAGQBPG2(PLACE))
  1. S NMSPC=$TR($P(FNAM,"."),"0123456789","")
  1. S FILEPATH=$$UPPER^MAGQE4(FILEPATH)
  1. I SITEID'[NMSPC D ELOG(FNAM,FILEPATH,"Foreign Image file") S RESULT="-3^0^10" Q ;FOREIGN FILE
  1. S (IEN,MAGDA)=$O(^MAG(2005,"F",$P(FNAM,"."),""))
  1. I 'IEN S IEN=$O(^MAG(2005.1,"F",$P(FNAM,"."),""))
  1. ; Patch 39 - added logging
  1. I 'IEN D Q
  1. . D ELOG(FNAM,FILEPATH,"Record neither in 2005 nor 2005.1")
  1. . S RESULT="-3^0^9^^^"_IEN
  1. . Q
  1. S FTYPE=$$FTYPE(EXT,IEN)
  1. S FT=$S(FTYPE="ABS":"1",FTYPE="FULL":"2",FTYPE="BIG":"3",FTYPE="PHOTOID":"4",FTYPE="ADIRECT":"5",1:"2")
  1. S JBPTR=$$JBPTR(IEN,FTYPE)
  1. ;PURGE UNCONDITIONALLY IF NO 2005 or 2005.1 ENTRY
  1. I '$D(^MAG(2005,IEN,0)) D Q
  1. . I $D(^MAG(2005.1,IEN,0)) D Q
  1. . . I ('JBPTR&($P($G(^MAG(2005.2,+$$JBPTR^MAGBAPI(PLACE),0)),U,6)="1")) D
  1. . . . S XX=$$JUKEBOX^MAGBAPI(IEN,PLACE)
  1. . . . S RESULT="-2^"_FT_"^9^^^"_IEN
  1. . . . Q
  1. . . E D
  1. . . . I JBPTR S RESULT="5^"_FT_"^16^"_$$JBPATH(FNAM,JBPTR)_U_$$JBPATH(FNAM,JBPTR)_U_IEN
  1. . . . E S RESULT="-1^"_FT_"^17"
  1. . . . Q
  1. . E S RESULT="1^"_FT_"^9^^^"_IEN
  1. . Q
  1. I PLACE'=$$PLACE^MAGBAPI(+$P($G(^MAG(2005,IEN,100)),U,3)) D Q
  1. . S RESULT="-3^"_FT_"^15" Q ;Foreign Place
  1. S ZNODE=^MAG(2005,IEN,0)
  1. I $P(ZNODE,U,12)="1" S RESULT="-1^"_FT_"^14" Q ; Duplicate Image/Archive entry
  1. S BNODE=$S(FTYPE="BIG":$G(^MAG(2005,IEN,"FBIG")),1:"")
  1. ; NEXT PROCESS MAGNETIC PTR~LESS
  1. S CPTR=$$CHKCP($S(FTYPE="BIG":BNODE,1:ZNODE),FTYPE,EXT)
  1. I 'CPTR D Q
  1. . D CPUPD(FTYPE,IEN,FILEPATH,FNAM,EXT)
  1. . I 'JBPTR,$P($G(^MAG(2005.2,+$$JBPTR^MAGBAPI(PLACE),0)),U,6)="1" D
  1. . . S XX=$$JUKEBOX^MAGBAPI(IEN,PLACE)
  1. . S RESULT="-1^"_FT_"^7^^"_JBPTR_U_IEN ;$S(JBPTR:JBPTR,1:XX)_U_IEN
  1. S CPOK=$S('CPTR:0,1:$$CPOK(FTYPE,.ALTPATH,FILEPATH,IEN,EXT))
  1. S ALTPATH=ALTPATH_FNAM
  1. I 'CPOK,JBPTR D Q
  1. . S RESULT="3^"_FT_"^6^"_ALTPATH_U_$$JBPATH(FNAM,JBPTR)_U_IEN
  1. I 'JBPTR D Q
  1. . I $P($G(^MAG(2005.2,+$$JBPTR^MAGBAPI(PLACE),0)),U,6)="1" D
  1. . . S XX=$$JUKEBOX^MAGBAPI(IEN,PLACE)
  1. . . S RESULT="-1^"_FT_"^7^^"_JBPTR_U_IEN ;$S(JBPTR:JBPTR,1:XX)_U_IEN
  1. . . Q
  1. . E S RESULT="-1^"_FT_"^17"
  1. . Q
  1. S RESULT="1^"_FT_"^8^^"_$$JBPATH(FNAM,JBPTR)_U_IEN
  1. Q
  1. ;
  1. LASTNP(TYPE) ;
  1. I TYPE="BIG" Q $S($P(ZNODE,U,3,4)="^":1,1:0)
  1. I TYPE="ABS" Q $S((($P(ZNODE,U,3)="")&($P(BNODE,U)="")):1,1:0)
  1. Q $S((($P(ZNODE,U,4)="")&($P(BNODE,U)="")):1,1:0)
  1. JBPATH(FN,NL) ;
  1. Q $P($G(^MAG(2005.2,NL,0)),U,2)_$$DIRHASH^MAGFILEB(FN,NL)_FN
  1. FTYPE(FEXT,IEN) ;
  1. ; Patch 39 : checking for ABS in FULL
  1. N FILE
  1. S FILE=$S($D(^MAG(2005,IEN,0)):"2005",1:"2005.1")
  1. S FEXT=$$UPPER^MAGQE4(FEXT)
  1. I "^ABS^"[("^"_FEXT_"^") Q "ABS"
  1. I $P($G(^MAG(FILE,IEN,40)),U,3)=$O(^MAG(2005.83,"B","PHOTO ID","")) Q "PHOTOID"
  1. I $P($G(^MAG(FILE,IEN,0)),U,6)=$O(^MAG(2005.02,"B","PATIENT PHOTO","")) Q "PHOTOID"
  1. I $P($G(^MAG(FILE,IEN,40)),U,3)=$O(^MAG(2005.83,"B","ADVANCE DIRECTIVE","")) Q "ADIRECT"
  1. I $$UPPER^MAGQE4($P($G(^MAG(FILE,IEN,0)),U,2))[".ABS" Q "FULL"
  1. I "^BIG^"[("^"_FEXT_"^") Q "BIG"
  1. I "^"_$P($G(^MAG(FILE,IEN,"FBIG")),U,3)_"^"[("^"_FEXT_"^") Q "BIG"
  1. Q "FULL"
  1. CHKCP(NODE,TYPE,EXT) ;
  1. N PIECE,CP
  1. S PIECE=$S(TYPE="ABS":4,TYPE="BIG":1,TYPE="FULL":3,"^PHOTOID^ADIRECT^"[("^"_TYPE_"^"):3,1:0)
  1. Q $P(NODE,U,PIECE)
  1. JBPTR(MAGIEN,TYPE) ;
  1. N PTR
  1. I TYPE="BIG" D
  1. . S PTR=+$P($G(^MAG(2005,MAGIEN,"FBIG")),"^",2)
  1. . S:'PTR PTR=+$P($G(^MAG(2005.1,MAGIEN,"FBIG")),"^",2)
  1. E D
  1. . S PTR=+$P($G(^MAG(2005,MAGIEN,0)),"^",5)
  1. . S:'PTR PTR=+$P($G(^MAG(2005.1,MAGIEN,"FBIG")),"^",2)
  1. Q $S($P($G(^MAG(2005.2,PTR,0)),U,6)=1:PTR,1:0)
  1. CPOK(TYPE,ALTPATH,FILEPATH,IEN,EXT) ;
  1. ; Patch 39: initializing ALTPATH, checking nodes of either 2005 or 2005.1
  1. N MAGXX,PIECE,NODE,LOC,FILE
  1. S EXT=$$UPPER^MAGQE4(EXT)
  1. S MAGXX=IEN
  1. S ALTPATH=""
  1. S PIECE=$S(TYPE="ABS":4,TYPE="BIG":1,TYPE="FULL":3,"^PHOTOID^ADIRECT^"[("^"_TYPE_"^"):3,1:0)
  1. S NODE=$S(TYPE="BIG":"FBIG",1:0)
  1. S FILE=$S($D(^MAG(2005,IEN,0)):"2005",1:"2005.1")
  1. S LOC=$P($G(^MAG(FILE,IEN,NODE)),U,PIECE)
  1. Q:'$D(^MAG(2005.2,+LOC,0)) 0
  1. S ALTPATH=$$UPPER^MAGQE4($P($G(^MAG(2005.2,LOC,0)),U,2)_$$DIRHASH^MAGFILEB(FNAM,LOC))
  1. Q $S(ALTPATH=FILEPATH:1,1:0)
  1. CPUPD(TYPE,IEN,FP,FN,EXT) ;
  1. ; Patch 39 - Update : Error log type, and using FILE in case an Archive file
  1. N PIECE,CP,NODE,LOC,FILE
  1. S EXT=$S('$D(EXT):"",1:$$UPPER^MAGQE4(EXT))
  1. S PIECE=$S(TYPE="ABS":4,TYPE="BIG":1,TYPE="FULL":3,"^PHOTOID^ADIRECT^"[("^"_TYPE_"^"):3,1:0)
  1. S NODE=$S(TYPE="BIG":"FBIG",1:0)
  1. S LOC=$$UNHASH(FN,FP)
  1. I (PIECE=0)!(+LOC=0) D ELOG(FN,FP,"RAID pointer indeterminate") Q
  1. S FILE=$S($D(^MAG(2005,IEN,0)):"2005",1:"2005.1")
  1. S $P(^MAG(FILE,IEN,NODE),U,PIECE)=LOC
  1. Q
  1. CUPD(RESULT,FILEPATH,FILENAME,EXT,IEN) ; RPC[MAGQ CUPDTE]
  1. N TYPE ; called from the BP Purge
  1. N X S X="ERR^MAGQBTM",@^%ZOSF("TRAP")
  1. S TYPE=$$FTYPE(EXT,IEN)
  1. D CPUPD(TYPE,IEN,FILEPATH,FILENAME,EXT)
  1. Q
  1. UNHASH(FN,FP) ; RETURN NETWORK LOCATION NUMBER
  1. N SHARE,HASH
  1. S SHARE=$S(FP[":":$P(FP,"\",1,2)_"\",1:$P(FP,"\",1,4)_"\")
  1. S HASH=$S($P(FP,SHARE,2)["\":"Y",1:"")
  1. Q $$SHNAM(SHARE,HASH)
  1. ELOG(FN,FP,MESSAGE) ;
  1. N INDX
  1. N X S X="ERR^MAGQBTM",@^%ZOSF("TRAP")
  1. S INDX=+$O(^TMP("MAGQ",$J,"PRG",99999),-1)+1
  1. S ^TMP("MAGQ",$J,"PRG",INDX)=MESSAGE_"^"_FN_"^"_FP
  1. Q
  1. ELOGR(RESULT,LIMIT) ;[MAGQ ELOGR] - Error log report and purge
  1. ; Please test this
  1. N FN,INDX,CNT
  1. N X S X="ERR^MAGQBTM",@^%ZOSF("TRAP")
  1. S CNT=0,INDX=""
  1. F S INDX=$O(^TMP("MAGQ",$J,"PRG",INDX)) Q:INDX'?1N.N Q:CNT=LIMIT D
  1. . S CNT=CNT+1,RESULT(CNT)=^TMP("MAGQ",$J,"PRG",INDX)
  1. . K ^TMP("MAGQ",$J,"PRG",INDX)
  1. . Q
  1. S RESULT(0)=CNT
  1. S INDX=$O(^TMP("MAGQ",$J,"PRG",""))
  1. I INDX?1N.N S RESULT(0)=RESULT(0)_U_"MORE"
  1. Q
  1. SHNAM(SHARE,HASH) ;
  1. N NUM,ONLINE,ZNODE
  1. S (NUM,ONLINE)=0
  1. F S NUM=$O(^MAG(2005.2,"AC",SHARE,NUM)) Q:'NUM D Q:ONLINE
  1. . S ZNODE=^MAG(2005.2,NUM,0)
  1. . Q:($P(ZNODE,"^",6)'="1")
  1. . Q:($P(ZNODE,"^",8)'=HASH)
  1. . S ONLINE="1"
  1. Q NUM