source: WorldVistAEHR/trunk/r/IMAGING-MAG-ZMAG/MAGQBPRG.m@ 1800

MAGQBPRG ;WOIOFO/RMP Magnetic Server Purge processes [ 06/29/2001 18:28 ]
 ;;3.0;IMAGING;**7,3,8,20**;Apr 12, 2006
 ;; +---------------------------------------------------------------+
 ;; | 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.                     |
 ;; +---------------------------------------------------------------+
 ;;
FILEREF(RESULT,FILEPATH,FNAM,EXT,NETLOC,RADHOLD) ; RPC[MAGQBP FREF]
 ;VALIDATES THAT THE FILEPATH IS CONSISTENT WITH VISTA MAGFILE REFERENCE
 ;SET THE SECOND PIECE TO "PACS" IF IT REPRESENTS DICOM
 ;VALIDATES THAT A JUKEBOX POINTER EXISTS
 ;RESULT VALUES
 ;PIECE  1:-3 = FOREIGN FILE, DO NOT PURGE
 ;         -2 = QUEUED FOR JUKEBOX COPY, DO NOT PURGE
 ;         -1 = DO NOT PURGE
 ;          0 = PURGE('MAG 2005 ENTRY)!('JUKEBOX PTRS & 'EXCEPTIONS)
 ;          1 = PURGE GIVEN NORMAL DATE CRITERIA (NDC) + CONFIRMED ON JB
 ;          2 = PURGE GIVEN NDC IF TGA PRESENT
 ;          3 = PURGE IF FILE IS AT ALTERNATE NETWORK LOCATION SITE
 ;              ELSE PURGE IF AGED & UPDATE FILE REFERENCES
 ;        **4 = (**NA**)AGE PURGE IF ON JUKEBOX, UPDATE FILE REFERENCES
 ;              ELSE UPDATE FILEREFENCES, QUEUE JUKEBOX COPY
 ;          5 = PURGE IF AT ALTERNATE SITE,QUEUE JUKEBOX IF NOT ON JB
 ;          6 = PURGE GIVEN NORMAL DATE CRITERIA
 ;PIECE   2:0 = NONPACS
 ;         :1 = PACS
 ;PIECE    3: RECORD CATEGORY
 ;         1 = 'NO 2005 ENTRY
 ;         2 = RADIOLOGY HOLD
 ;         3 = NO JUKEBOX/JUKEBOX PTRS
 ;         4 = JUKEBOX - NO JUKEBOX PTRS (P/EXCEPT)ELSE QUEUE
 ;         5 = JUKEBOX/JUKEBOX PTRS, NO CACHE PTRS,PURGE IF CONFIRMED
 ;         6 = JUKEBOX/JUKEBOX PTRS, WRONG CACHE PTRS PURGE IF AT ALT
 ;         7 = JUKEBOX/JUKEBOX PTRS, NO CACHE PTRS, FIX PTRS
 ;         8 = JUKEBOX/JUKEBOX PTRS, CACHE PTRS, AGE (IF CONFIRMED)
 ;         9 = RECORD NOT IN THE IMAGE FILE
 ;        10 = FOREIGN IMAGE FILE
 ;        11 = NOT AN IMAGE FILE
 ;        12 = FILE LOCATION NOT VALID 
 ;        13 = DELETE 2005 ENTRY (LAST LOCATION REFERENCED)
 ;        14 = Duplicate 2005/2005.1 entry
 ;        15 = Foreign Place
 ;        16 = Record in Archive file
 ;        17 = Jukebox offline
 N FILEXT,IEN,SITEID,MAGXX,MAGFILE,MAGFILE1,MAGFILE2,PACS,RIEN,ZNODE
 N FILETYPE,CPTR,JBPTR,CPOK,BNODE,ALTPATH,NMSPC,PLACE,RDHOLD
 S X="ERR^MAGQBTM",@^%ZOSF("TRAP")
 S PLACE=$$PLACE^MAGBAPI(+$G(DUZ(2)))
 S U="^",(MAGFILE2,RESULT)=""
 S FNAM=$$UPPER^MAGQE4(FNAM)
 S ^TMP("MAGQ",$J,"PRG","LAST")=FILEPATH_U_FNAM_U_EXT_U_NETLOC_U_RADHOLD
 I FNAM'?1.5A1.13N1"."1.3E  D  Q  ;LATER ADD EXT VERIFY USING 2005.02
 . D ELOG(FNAM,FILEPATH) S RESULT="-3^^11" Q  ;'IMAGE FILE
 S SITEID=$$UPPER^MAGQE4($$INIS^MAGQBPG2(PLACE))
 S NMSPC=$TR($P(FNAM,"."),"0123456789","")
 S FILEPATH=$$UPPER^MAGQE4(FILEPATH)
 I SITEID'[NMSPC D ELOG(FNAM,FILEPATH) S RESULT="-3^^10" Q  ;FOREIGN FILE
 S IEN=$O(^MAG(2005,"F",$P(FNAM,"."),""))
 S:'IEN IEN=$O(^MAG(2005.1,"F",$P(FNAM,"."),""))
 I 'IEN S RESULT="1^^9^^^"_IEN Q
 S FTYPE=$$FTYPE(EXT)
 S JBPTR=$$JBPTR(IEN,FTYPE)
 ;PURGE UNCONDITIONALLY IF NO 2005 ENTRY
 I '$D(^MAG(2005,IEN,0)) D  Q
 . I $D(^MAG(2005.1,IEN,0)) D  Q
 . . I ('JBPTR&($P($G(^MAG(2005.2,+$$CWP^MAGBAPI(PLACE),0)),U,6)="1"))  D
 . . . S XX=$$JUKEBOX^MAGBAPI(IEN,PLACE)
 . . . S RESULT="-2^^9^^^"_IEN
 . . . Q
 . . E  D 
 . . . I JBPTR S RESULT="5^^16^"_$$JBPATH(FNAM,JBPTR)_U_$$JBPATH(FNAM,JBPTR)_U_IEN
 . . . E  S RESULT="-1^^17"
 . . . Q
 . E  S RESULT="1^^9^^^"_IEN
 . Q
 I PLACE'=$$PLACE^MAGBAPI($P($G(^MAG(2005,IEN,100)),U,3)) D  Q
 . S RESULT="-3^^15" Q  ;Foreign Place
 S ZNODE=^MAG(2005,IEN,0)
 I $P(ZNODE,U,12)="1" S RESULT="-1^^14" Q  ; Duplicate Image/Archive entry 
 S BNODE=$S(FTYPE="BIG":$G(^MAG(2005,IEN,"FBIG")),1:"")
 ; NEXT PROCESS MAGNETIC PTR~LESS
 S CPTR=$$CHKCP($S(FTYPE="BIG":BNODE,1:ZNODE),FTYPE)
 I 'CPTR D  Q
 . D CPUPD(FTYPE,IEN,FILEPATH,FNAM)
 . I 'JBPTR,$P($G(^MAG(2005.2,+$$CWP^MAGBAPI(PLACE),0)),U,6)="1" D
 . . S XX=$$JUKEBOX^MAGBAPI(IEN,PLACE)
 . S RESULT="-1^^7^^"_JBPTR_U_IEN ;$S(JBPTR:JBPTR,1:XX)_U_IEN
 S CPOK=$S('CPTR:0,1:$$CPOK(FTYPE,.ALTPATH,FILEPATH,IEN))
 S ALTPATH=ALTPATH_FNAM
 S PACS=$S($D(^MAG(2005,IEN,"PACS")):1,1:0)
 I 'CPOK,JBPTR D  Q
 . S RESULT="3^"_PACS_"^6^"_ALTPATH_U_$$JBPATH(FNAM,JBPTR)_U_IEN
 I 'JBPTR D  Q
 . I $P($G(^MAG(2005.2,+$$CWP^MAGBAPI(PLACE),0)),U,6)="1" D
 . . S XX=$$JUKEBOX^MAGBAPI(IEN,PLACE)
 . . S RESULT="-1^^7^^"_JBPTR_U_IEN ;$S(JBPTR:JBPTR,1:XX)_U_IEN
 . . Q
 . E  S RESULT="-1^^17"
 . Q
 S RESULT="1^"_PACS_"^8^^"_$$JBPATH(FNAM,JBPTR)_U_IEN
 Q
 ;
LASTNP(TYPE) ;
 I TYPE="BIG" Q $S($P(ZNODE,U,3,4)="^":1,1:0)
 I TYPE="ABS" Q $S((($P(ZNODE,U,3)="")&($P(BNODE,U)="")):1,1:0)
 Q $S((($P(ZNODE,U,4)="")&($P(BNODE,U)="")):1,1:0)
JBPATH(FN,NL) ;
 Q $P($G(^MAG(2005.2,NL,0)),U,2)_$$DIRHASH^MAGFILEB(FN,NL)_FN
WXCPT(RESULT,XPACS,TYPE) ;Check for Worm Exceptions
 ;                        when no Worm reference in 2005
 ;NO JUKEBOX Q:1 ????
 ;SITE PARAMETER EXCEPTIONS
 ; ALL           "JBEX";1
 ; ALL PACS      "JBEX";2
 ; ALL PACS BIG  "JBEX";3
 ; ALL PACS BIG IF TGA PRESENT ON MAGNETIC
 ; ALL BIG NON PACS "JBEX";4
 N PARNODE,RY
 ; I '$D(^MAG(2006.1,PLACE,"JBEX")) D  Q
 S $P(RESULT,U)="-2^"_XPACS_"^4"  ;NO WXCPT - We no longer support this activity
 S PARNODE=$G(^MAG(2006.1,1,"JBEX"))
 I +$P(PARNODE,U)?1"1" S $P(RESULT,U)="6^"_XPACS_"^4" Q  ;ALL
 I +$P(PARNODE,U)?1"2" S $P(RESULT,U)="6^"_XPACS_"^4" D  Q  ;ALL
 . S ^XUSEC("MAG DELETE",DUZ)=""
 . D DELETE^MAGGTID(.RY,IEN,0)
 . S ^TMP("MAGQ",$J,IEN)=RY(0)
 . K RY
 I XPACS D  Q
 . I $P(PARNODE,U,2) S $P(RESULT,U)="6^1^4" Q  ;ALL PACS
 . I TYPE="BIG" D 
 . . I +$P(PARNODE,U,3) S $P(RESULT,U)="6^1^4" Q  ;ALL BIG PACS
 . . I +$P(PARNODE,U,6) S $P(RESULT,U)="2^1^4" Q  ;BIG PACS IF TGA 
 . I $P(RESULT,U)="" D
 . . I $P($G(^MAG(2005.2,+$$CWP^MAGBAPI(PLACE),0)),U,6)'="1" S RESULT="-1" Q
 . . S RESULT="-2^1^4"
 ;NON PACS
 I ((TYPE="BIG")&(+$P(PARNODE,U,4))) S RESULT="6^0^4" Q
 I $P($G(^MAG(2005.2,+$$CWP^MAGBAPI(PLACE),0)),U,6)'="1" S RESULT="-1^0^4" Q
 S RESULT="-2^0^4"
 Q
 ;
FTYPE(FEXT) ;
 S FEXT=$$UPPER^MAGQE4(FEXT)
 I "^ABS^"[("^"_FEXT_"^") Q "ABS"
 I "^BIG^"[("^"_FEXT_"^") Q "BIG"
 Q "FULL"
CHKCP(NODE,TYPE) ;
 N PIECE,CP
 S PIECE=$S(TYPE="ABS":4,TYPE="BIG":1,TYPE="FULL":3,1:0)
 Q $P(NODE,U,PIECE)
JBPTR(MAGIEN,TYPE) ;
 N PTR
 I TYPE="BIG" D
 . S PTR=+$P($G(^MAG(2005,MAGIEN,"FBIG")),"^",2)
 . S:'PTR PTR=+$P($G(^MAG(2005.1,MAGIEN,"FBIG")),"^",2)
 E  D
 . S PTR=+$P($G(^MAG(2005,MAGIEN,0)),"^",5)
 . S:'PTR PTR=+$P($G(^MAG(2005.1,MAGIEN,"FBIG")),"^",2)
 Q $S($P($G(^MAG(2005.2,PTR,0)),U,6)=1:PTR,1:0)
RDHOLD(IEN) ;
 N HOLD,RIEN
 S RIEN=$G(^MAG(2005,IEN,2))
 Q:$P(RIEN,"^",6)'=74 0
 S HOLD=$G(^RARPT($P(RIEN,"^",7),"NOPURGE"))
 Q $S($$UPPER^MAGQE4(HOLD)="N":1,1:0)
CPOK(TYPE,ALTPATH,FILEPATH,IEN) ;
 N MAGXX,PIECE,NODE,LOC
 S MAGXX=IEN
 S PIECE=$S(TYPE="ABS":4,TYPE="BIG":1,TYPE="FULL":3,1:0)
 S NODE=$S(TYPE="BIG":"FBIG",1:0)
 S LOC=$P($G(^MAG(2005,IEN,NODE)),U,PIECE)
 Q:'LOC 0
 S ALTPATH=$$UPPER^MAGQE4($P($G(^MAG(2005.2,LOC,0)),U,2)_$$DIRHASH^MAGFILEB(FNAM,LOC))
 Q $S(ALTPATH=FILEPATH:1,1:0)
CPUPD(TYPE,IEN,FP,FN) ;
 N PIECE,CP,NODE,LOC
 S PIECE=$S(TYPE="ABS":4,TYPE="BIG":1,TYPE="FULL":3,1:0)
 S NODE=$S(TYPE="BIG":"FBIG",1:0)
 S LOC=$$UNHASH(FN,FP)
 I (PIECE=0)!(+LOC=0) D ELOG(FN,FP) Q
 S $P(^MAG(2005,IEN,NODE),U,PIECE)=LOC
 Q
CUPD(RESULT,FILEPATH,FILENAME,EXT,IEN) ; RPC[MAGQ CUPDTE]
 N TYPE
 S X="ERR^MAGQBTM",@^%ZOSF("TRAP")
 S TYPE=$$FTYPE(EXT)
 D CPUPD(TYPE,IEN,FILEPATH,FILENAME)
 Q
UNHASH(FN,FP) ; RETURN NETWORK LOCATION NUMBER
 N SHARE,HASH
 S SHARE=$S(FP[":":$P(FP,"\",1,2)_"\",1:$P(FP,"\",1,4)_"\")
 S HASH=$S($P(FP,SHARE,2)["\":"Y",1:"")
 Q $$SHNAM(SHARE,HASH)
ELOG(FN,FP) ;
 N INDX
 S X="ERR^MAGQBTM",@^%ZOSF("TRAP")
 S INDX=+$O(^TMP("MAGQ",$J,"PRG",FN,99999),-1)+1
 S ^TMP("MAGQ",$J,"PRG",FN,INDX)=FN_"^"_FP
 Q
ELOGR(RESULT) ;[MAGQ ELOGR] - Error log report and purge
 N FN,INDX,CNT
 S X="ERR^MAGQBTM",@^%ZOSF("TRAP")
 S FN="",CNT=0
 F  S FN=$O(^TMP("MAGQ",$J,"PRG",FN)) Q:FN=""  D
 . S INDX=""
 . F  S INDX=$O(^TMP("MAGQ",$J,"PRG",FN,INDX)) Q:INDX'?1N.N  D
 . . S CNT=CNT+1,RESULT(CNT)=^TMP("MAGQ",$J,"PRG",FN,INDX)
 S RESULT(0)=CNT
 K ^TMP("MAGQ",$J,"PRG")
 Q
SHNAM(SHARE,HASH) ;
 N NUM,ONLINE,ZNODE
 S (NUM,ONLINE)=0
 Q:((SHARE="")!(SHARE[":")) ""
 F  S NUM=$O(^MAG(2005.2,"AC",SHARE,NUM)) Q:'NUM  D  Q:ONLINE
 . S ZNODE=^MAG(2005.2,NUM,0)
 . Q:($P(ZNODE,"^",6)'="1")
 . Q:($P(ZNODE,"^",8)'=HASH)
 . S ONLINE="1"
 Q NUM