- MAGQBPRG ;WOIOFO/RMP - Magnetic Server Purge processes ; 07 Jun 2013 9:53 AM
- ;;3.0;IMAGING;**7,3,8,20,81,39,135**;Mar 19, 2002;Build 5238;Jul 17, 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
- FILEREF(RESULT,FILEPATH,FNAM,EXT,NETLOC) ; 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 )
- ; 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: FILETYPE
- ; 0 = foreign
- ; 1 = abstract
- ; 2 = full
- ; 3 = big
- ; 4 = photo id
- ; 5 = advance directive
- ;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,RIEN,ZNODE
- N FTYPE,CPTR,JBPTR,CPOK,BNODE,ALTPATH,NMSPC,PLACE,XX,FT,MAGDA
- N X S X="ERR^MAGQBTM",@^%ZOSF("TRAP")
- S PLACE=$$PLACE^MAGBAPI(+$G(DUZ(2)))
- S U="^",(MAGFILE2,RESULT)=""
- S FNAM=$$UPPER^MAGQE4(FNAM)
- S EXT=$$UPPER^MAGQE4(EXT)
- S ^TMP("MAGQ",$J,"PRG","LAST")=FILEPATH_U_FNAM_U_EXT_U_NETLOC
- I FNAM'?1.5A1.13N1"."1.3E D Q ;LATER ADD EXT VERIFY USING 2005.02
- . D ELOG(FNAM,FILEPATH,"Not a VistA Imaging file") S RESULT="-3^0^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,"Foreign Image file") S RESULT="-3^0^10" Q ;FOREIGN FILE
- S (IEN,MAGDA)=$O(^MAG(2005,"F",$P(FNAM,"."),""))
- I 'IEN S IEN=$O(^MAG(2005.1,"F",$P(FNAM,"."),""))
- ; Patch 39 - added logging
- I 'IEN D Q
- . D ELOG(FNAM,FILEPATH,"Record neither in 2005 nor 2005.1")
- . S RESULT="-3^0^9^^^"_IEN
- . Q
- S FTYPE=$$FTYPE(EXT,IEN)
- S FT=$S(FTYPE="ABS":"1",FTYPE="FULL":"2",FTYPE="BIG":"3",FTYPE="PHOTOID":"4",FTYPE="ADIRECT":"5",1:"2")
- S JBPTR=$$JBPTR(IEN,FTYPE)
- ;PURGE UNCONDITIONALLY IF NO 2005 or 2005.1 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,+$$JBPTR^MAGBAPI(PLACE),0)),U,6)="1")) D
- . . . S XX=$$JUKEBOX^MAGBAPI(IEN,PLACE)
- . . . S RESULT="-2^"_FT_"^9^^^"_IEN
- . . . Q
- . . E D
- . . . I JBPTR S RESULT="5^"_FT_"^16^"_$$JBPATH(FNAM,JBPTR)_U_$$JBPATH(FNAM,JBPTR)_U_IEN
- . . . E S RESULT="-1^"_FT_"^17"
- . . . Q
- . E S RESULT="1^"_FT_"^9^^^"_IEN
- . Q
- I PLACE'=$$PLACE^MAGBAPI(+$P($G(^MAG(2005,IEN,100)),U,3)) D Q
- . S RESULT="-3^"_FT_"^15" Q ;Foreign Place
- S ZNODE=^MAG(2005,IEN,0)
- I $P(ZNODE,U,12)="1" S RESULT="-1^"_FT_"^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,EXT)
- I 'CPTR D Q
- . D CPUPD(FTYPE,IEN,FILEPATH,FNAM,EXT)
- . I 'JBPTR,$P($G(^MAG(2005.2,+$$JBPTR^MAGBAPI(PLACE),0)),U,6)="1" D
- . . S XX=$$JUKEBOX^MAGBAPI(IEN,PLACE)
- . S RESULT="-1^"_FT_"^7^^"_JBPTR_U_IEN ;$S(JBPTR:JBPTR,1:XX)_U_IEN
- S CPOK=$S('CPTR:0,1:$$CPOK(FTYPE,.ALTPATH,FILEPATH,IEN,EXT))
- S ALTPATH=ALTPATH_FNAM
- I 'CPOK,JBPTR D Q
- . S RESULT="3^"_FT_"^6^"_ALTPATH_U_$$JBPATH(FNAM,JBPTR)_U_IEN
- I 'JBPTR D Q
- . I $P($G(^MAG(2005.2,+$$JBPTR^MAGBAPI(PLACE),0)),U,6)="1" D
- . . S XX=$$JUKEBOX^MAGBAPI(IEN,PLACE)
- . . S RESULT="-1^"_FT_"^7^^"_JBPTR_U_IEN ;$S(JBPTR:JBPTR,1:XX)_U_IEN
- . . Q
- . E S RESULT="-1^"_FT_"^17"
- . Q
- S RESULT="1^"_FT_"^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
- FTYPE(FEXT,IEN) ;
- ; Patch 39 : checking for ABS in FULL
- N FILE
- S FILE=$S($D(^MAG(2005,IEN,0)):"2005",1:"2005.1")
- S FEXT=$$UPPER^MAGQE4(FEXT)
- I "^ABS^"[("^"_FEXT_"^") Q "ABS"
- I $P($G(^MAG(FILE,IEN,40)),U,3)=$O(^MAG(2005.83,"B","PHOTO ID","")) Q "PHOTOID"
- I $P($G(^MAG(FILE,IEN,0)),U,6)=$O(^MAG(2005.02,"B","PATIENT PHOTO","")) Q "PHOTOID"
- I $P($G(^MAG(FILE,IEN,40)),U,3)=$O(^MAG(2005.83,"B","ADVANCE DIRECTIVE","")) Q "ADIRECT"
- I $$UPPER^MAGQE4($P($G(^MAG(FILE,IEN,0)),U,2))[".ABS" Q "FULL"
- I "^BIG^"[("^"_FEXT_"^") Q "BIG"
- I "^"_$P($G(^MAG(FILE,IEN,"FBIG")),U,3)_"^"[("^"_FEXT_"^") Q "BIG"
- Q "FULL"
- CHKCP(NODE,TYPE,EXT) ;
- N PIECE,CP
- S PIECE=$S(TYPE="ABS":4,TYPE="BIG":1,TYPE="FULL":3,"^PHOTOID^ADIRECT^"[("^"_TYPE_"^"):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)
- CPOK(TYPE,ALTPATH,FILEPATH,IEN,EXT) ;
- ; Patch 39: initializing ALTPATH, checking nodes of either 2005 or 2005.1
- N MAGXX,PIECE,NODE,LOC,FILE
- S EXT=$$UPPER^MAGQE4(EXT)
- S MAGXX=IEN
- S ALTPATH=""
- S PIECE=$S(TYPE="ABS":4,TYPE="BIG":1,TYPE="FULL":3,"^PHOTOID^ADIRECT^"[("^"_TYPE_"^"):3,1:0)
- S NODE=$S(TYPE="BIG":"FBIG",1:0)
- S FILE=$S($D(^MAG(2005,IEN,0)):"2005",1:"2005.1")
- S LOC=$P($G(^MAG(FILE,IEN,NODE)),U,PIECE)
- Q:'$D(^MAG(2005.2,+LOC,0)) 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,EXT) ;
- ; Patch 39 - Update : Error log type, and using FILE in case an Archive file
- N PIECE,CP,NODE,LOC,FILE
- S EXT=$S('$D(EXT):"",1:$$UPPER^MAGQE4(EXT))
- S PIECE=$S(TYPE="ABS":4,TYPE="BIG":1,TYPE="FULL":3,"^PHOTOID^ADIRECT^"[("^"_TYPE_"^"):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,"RAID pointer indeterminate") Q
- S FILE=$S($D(^MAG(2005,IEN,0)):"2005",1:"2005.1")
- S $P(^MAG(FILE,IEN,NODE),U,PIECE)=LOC
- Q
- CUPD(RESULT,FILEPATH,FILENAME,EXT,IEN) ; RPC[MAGQ CUPDTE]
- N TYPE ; called from the BP Purge
- N X S X="ERR^MAGQBTM",@^%ZOSF("TRAP")
- S TYPE=$$FTYPE(EXT,IEN)
- D CPUPD(TYPE,IEN,FILEPATH,FILENAME,EXT)
- 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,MESSAGE) ;
- N INDX
- N X S X="ERR^MAGQBTM",@^%ZOSF("TRAP")
- S INDX=+$O(^TMP("MAGQ",$J,"PRG",99999),-1)+1
- S ^TMP("MAGQ",$J,"PRG",INDX)=MESSAGE_"^"_FN_"^"_FP
- Q
- ELOGR(RESULT,LIMIT) ;[MAGQ ELOGR] - Error log report and purge
- ; Please test this
- N FN,INDX,CNT
- N X S X="ERR^MAGQBTM",@^%ZOSF("TRAP")
- S CNT=0,INDX=""
- F S INDX=$O(^TMP("MAGQ",$J,"PRG",INDX)) Q:INDX'?1N.N Q:CNT=LIMIT D
- . S CNT=CNT+1,RESULT(CNT)=^TMP("MAGQ",$J,"PRG",INDX)
- . K ^TMP("MAGQ",$J,"PRG",INDX)
- . Q
- S RESULT(0)=CNT
- S INDX=$O(^TMP("MAGQ",$J,"PRG",""))
- I INDX?1N.N S RESULT(0)=RESULT(0)_U_"MORE"
- Q
- SHNAM(SHARE,HASH) ;
- N NUM,ONLINE,ZNODE
- S (NUM,ONLINE)=0
- 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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMAGQBPRG 9538 printed Feb 18, 2025@23:34:19 Page 2
- 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
- +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
- FILEREF(RESULT,FILEPATH,FNAM,EXT,NETLOC) ; RPC[MAGQBP FREF]
- +1 ;VALIDATES THAT THE FILEPATH IS CONSISTENT WITH VISTA MAGFILE REFERENCE
- +2 ;SET THE SECOND PIECE TO "PACS" IF IT REPRESENTS DICOM
- +3 ;VALIDATES THAT A JUKEBOX POINTER EXISTS
- +4 ;RESULT VALUES
- +5 ;PIECE 1:-3 = FOREIGN FILE, DO NOT PURGE
- +6 ; -2 = QUEUED FOR JUKEBOX COPY, DO NOT PURGE
- +7 ; -1 = DO NOT PURGE
- +8 ; **0 = PURGE('MAG 2005 ENTRY)!('JUKEBOX PTRS )
- +9 ; 1 = PURGE GIVEN NORMAL DATE CRITERIA (NDC) + CONFIRMED ON JB
- +10 ; **2 = PURGE GIVEN NDC IF TGA PRESENT
- +11 ; 3 = PURGE IF FILE IS AT ALTERNATE NETWORK LOCATION SITE
- +12 ; ELSE PURGE IF AGED & UPDATE FILE REFERENCES
- +13 ; **4 = (**NA**)AGE PURGE IF ON JUKEBOX, UPDATE FILE REFERENCES
- +14 ; ELSE UPDATE FILEREFENCES, QUEUE JUKEBOX COPY
- +15 ; 5 = PURGE IF AT ALTERNATE SITE,QUEUE JUKEBOX IF NOT ON JB
- +16 ; **6 = PURGE GIVEN NORMAL DATE CRITERIA
- +17 ;PIECE ** 2: FILETYPE
- +18 ; 0 = foreign
- +19 ; 1 = abstract
- +20 ; 2 = full
- +21 ; 3 = big
- +22 ; 4 = photo id
- +23 ; 5 = advance directive
- +24 ;PIECE 3: RECORD CATEGORY
- +25 ; 1 = 'NO 2005 ENTRY
- +26 ; **2 = RADIOLOGY HOLD
- +27 ; 3 = NO JUKEBOX/JUKEBOX PTRS
- +28 ; 4 = JUKEBOX - NO JUKEBOX PTRS (P/EXCEPT)ELSE QUEUE
- +29 ; 5 = JUKEBOX/JUKEBOX PTRS, NO CACHE PTRS,PURGE IF CONFIRMED
- +30 ; 6 = JUKEBOX/JUKEBOX PTRS, WRONG CACHE PTRS PURGE IF AT ALT
- +31 ; 7 = JUKEBOX/JUKEBOX PTRS, NO CACHE PTRS, FIX PTRS
- +32 ; 8 = JUKEBOX/JUKEBOX PTRS, CACHE PTRS, AGE (IF CONFIRMED)
- +33 ; 9 = RECORD NOT IN THE IMAGE FILE
- +34 ; 10 = FOREIGN IMAGE FILE
- +35 ; 11 = NOT AN IMAGE FILE
- +36 ; 12 = FILE LOCATION NOT VALID
- +37 ; 13 = DELETE 2005 ENTRY (LAST LOCATION REFERENCED)
- +38 ; 14 = Duplicate 2005/2005.1 entry
- +39 ; 15 = Foreign Place
- +40 ; 16 = Record in Archive file
- +41 ; 17 = Jukebox offline
- +42 NEW FILEXT,IEN,SITEID,MAGXX,MAGFILE,MAGFILE1,MAGFILE2,RIEN,ZNODE
- +43 NEW FTYPE,CPTR,JBPTR,CPOK,BNODE,ALTPATH,NMSPC,PLACE,XX,FT,MAGDA
- +44 NEW X
- SET X="ERR^MAGQBTM"
- SET @^%ZOSF("TRAP")
- +45 SET PLACE=$$PLACE^MAGBAPI(+$GET(DUZ(2)))
- +46 SET U="^"
- SET (MAGFILE2,RESULT)=""
- +47 SET FNAM=$$UPPER^MAGQE4(FNAM)
- +48 SET EXT=$$UPPER^MAGQE4(EXT)
- +49 SET ^TMP("MAGQ",$JOB,"PRG","LAST")=FILEPATH_U_FNAM_U_EXT_U_NETLOC
- +50 ;LATER ADD EXT VERIFY USING 2005.02
- IF FNAM'?1.5A1.13N1"."1.3E
- Begin DoDot:1
- +51 ;'IMAGE FILE
- DO ELOG(FNAM,FILEPATH,"Not a VistA Imaging file")
- SET RESULT="-3^0^11"
- QUIT
- End DoDot:1
- QUIT
- +52 SET SITEID=$$UPPER^MAGQE4($$INIS^MAGQBPG2(PLACE))
- +53 SET NMSPC=$TRANSLATE($PIECE(FNAM,"."),"0123456789","")
- +54 SET FILEPATH=$$UPPER^MAGQE4(FILEPATH)
- +55 ;FOREIGN FILE
- IF SITEID'[NMSPC
- DO ELOG(FNAM,FILEPATH,"Foreign Image file")
- SET RESULT="-3^0^10"
- QUIT
- +56 SET (IEN,MAGDA)=$ORDER(^MAG(2005,"F",$PIECE(FNAM,"."),""))
- +57 IF 'IEN
- SET IEN=$ORDER(^MAG(2005.1,"F",$PIECE(FNAM,"."),""))
- +58 ; Patch 39 - added logging
- +59 IF 'IEN
- Begin DoDot:1
- +60 DO ELOG(FNAM,FILEPATH,"Record neither in 2005 nor 2005.1")
- +61 SET RESULT="-3^0^9^^^"_IEN
- +62 QUIT
- End DoDot:1
- QUIT
- +63 SET FTYPE=$$FTYPE(EXT,IEN)
- +64 SET FT=$SELECT(FTYPE="ABS":"1",FTYPE="FULL":"2",FTYPE="BIG":"3",FTYPE="PHOTOID":"4",FTYPE="ADIRECT":"5",1:"2")
- +65 SET JBPTR=$$JBPTR(IEN,FTYPE)
- +66 ;PURGE UNCONDITIONALLY IF NO 2005 or 2005.1 ENTRY
- +67 IF '$DATA(^MAG(2005,IEN,0))
- Begin DoDot:1
- +68 IF $DATA(^MAG(2005.1,IEN,0))
- Begin DoDot:2
- +69 IF ('JBPTR&($PIECE($GET(^MAG(2005.2,+$$JBPTR^MAGBAPI(PLACE),0)),U,6)="1"))
- Begin DoDot:3
- +70 SET XX=$$JUKEBOX^MAGBAPI(IEN,PLACE)
- +71 SET RESULT="-2^"_FT_"^9^^^"_IEN
- +72 QUIT
- End DoDot:3
- +73 IF '$TEST
- Begin DoDot:3
- +74 IF JBPTR
- SET RESULT="5^"_FT_"^16^"_$$JBPATH(FNAM,JBPTR)_U_$$JBPATH(FNAM,JBPTR)_U_IEN
- +75 IF '$TEST
- SET RESULT="-1^"_FT_"^17"
- +76 QUIT
- End DoDot:3
- End DoDot:2
- QUIT
- +77 IF '$TEST
- SET RESULT="1^"_FT_"^9^^^"_IEN
- +78 QUIT
- End DoDot:1
- QUIT
- +79 IF PLACE'=$$PLACE^MAGBAPI(+$PIECE($GET(^MAG(2005,IEN,100)),U,3))
- Begin DoDot:1
- +80 ;Foreign Place
- SET RESULT="-3^"_FT_"^15"
- QUIT
- End DoDot:1
- QUIT
- +81 SET ZNODE=^MAG(2005,IEN,0)
- +82 ; Duplicate Image/Archive entry
- IF $PIECE(ZNODE,U,12)="1"
- SET RESULT="-1^"_FT_"^14"
- QUIT
- +83 SET BNODE=$SELECT(FTYPE="BIG":$GET(^MAG(2005,IEN,"FBIG")),1:"")
- +84 ; NEXT PROCESS MAGNETIC PTR~LESS
- +85 SET CPTR=$$CHKCP($SELECT(FTYPE="BIG":BNODE,1:ZNODE),FTYPE,EXT)
- +86 IF 'CPTR
- Begin DoDot:1
- +87 DO CPUPD(FTYPE,IEN,FILEPATH,FNAM,EXT)
- +88 IF 'JBPTR
- IF $PIECE($GET(^MAG(2005.2,+$$JBPTR^MAGBAPI(PLACE),0)),U,6)="1"
- Begin DoDot:2
- +89 SET XX=$$JUKEBOX^MAGBAPI(IEN,PLACE)
- End DoDot:2
- +90 ;$S(JBPTR:JBPTR,1:XX)_U_IEN
- SET RESULT="-1^"_FT_"^7^^"_JBPTR_U_IEN
- End DoDot:1
- QUIT
- +91 SET CPOK=$SELECT('CPTR:0,1:$$CPOK(FTYPE,.ALTPATH,FILEPATH,IEN,EXT))
- +92 SET ALTPATH=ALTPATH_FNAM
- +93 IF 'CPOK
- IF JBPTR
- Begin DoDot:1
- +94 SET RESULT="3^"_FT_"^6^"_ALTPATH_U_$$JBPATH(FNAM,JBPTR)_U_IEN
- End DoDot:1
- QUIT
- +95 IF 'JBPTR
- Begin DoDot:1
- +96 IF $PIECE($GET(^MAG(2005.2,+$$JBPTR^MAGBAPI(PLACE),0)),U,6)="1"
- Begin DoDot:2
- +97 SET XX=$$JUKEBOX^MAGBAPI(IEN,PLACE)
- +98 ;$S(JBPTR:JBPTR,1:XX)_U_IEN
- SET RESULT="-1^"_FT_"^7^^"_JBPTR_U_IEN
- +99 QUIT
- End DoDot:2
- +100 IF '$TEST
- SET RESULT="-1^"_FT_"^17"
- +101 QUIT
- End DoDot:1
- QUIT
- +102 SET RESULT="1^"_FT_"^8^^"_$$JBPATH(FNAM,JBPTR)_U_IEN
- +103 QUIT
- +104 ;
- LASTNP(TYPE) ;
- +1 IF TYPE="BIG"
- QUIT $SELECT($PIECE(ZNODE,U,3,4)="^":1,1:0)
- +2 IF TYPE="ABS"
- QUIT $SELECT((($PIECE(ZNODE,U,3)="")&($PIECE(BNODE,U)="")):1,1:0)
- +3 QUIT $SELECT((($PIECE(ZNODE,U,4)="")&($PIECE(BNODE,U)="")):1,1:0)
- JBPATH(FN,NL) ;
- +1 QUIT $PIECE($GET(^MAG(2005.2,NL,0)),U,2)_$$DIRHASH^MAGFILEB(FN,NL)_FN
- FTYPE(FEXT,IEN) ;
- +1 ; Patch 39 : checking for ABS in FULL
- +2 NEW FILE
- +3 SET FILE=$SELECT($DATA(^MAG(2005,IEN,0)):"2005",1:"2005.1")
- +4 SET FEXT=$$UPPER^MAGQE4(FEXT)
- +5 IF "^ABS^"[("^"_FEXT_"^")
- QUIT "ABS"
- +6 IF $PIECE($GET(^MAG(FILE,IEN,40)),U,3)=$ORDER(^MAG(2005.83,"B","PHOTO ID",""))
- QUIT "PHOTOID"
- +7 IF $PIECE($GET(^MAG(FILE,IEN,0)),U,6)=$ORDER(^MAG(2005.02,"B","PATIENT PHOTO",""))
- QUIT "PHOTOID"
- +8 IF $PIECE($GET(^MAG(FILE,IEN,40)),U,3)=$ORDER(^MAG(2005.83,"B","ADVANCE DIRECTIVE",""))
- QUIT "ADIRECT"
- +9 IF $$UPPER^MAGQE4($PIECE($GET(^MAG(FILE,IEN,0)),U,2))[".ABS"
- QUIT "FULL"
- +10 IF "^BIG^"[("^"_FEXT_"^")
- QUIT "BIG"
- +11 IF "^"_$PIECE($GET(^MAG(FILE,IEN,"FBIG")),U,3)_"^"[("^"_FEXT_"^")
- QUIT "BIG"
- +12 QUIT "FULL"
- CHKCP(NODE,TYPE,EXT) ;
- +1 NEW PIECE,CP
- +2 SET PIECE=$SELECT(TYPE="ABS":4,TYPE="BIG":1,TYPE="FULL":3,"^PHOTOID^ADIRECT^"[("^"_TYPE_"^"):3,1:0)
- +3 QUIT $PIECE(NODE,U,PIECE)
- JBPTR(MAGIEN,TYPE) ;
- +1 NEW PTR
- +2 IF TYPE="BIG"
- Begin DoDot:1
- +3 SET PTR=+$PIECE($GET(^MAG(2005,MAGIEN,"FBIG")),"^",2)
- +4 if 'PTR
- SET PTR=+$PIECE($GET(^MAG(2005.1,MAGIEN,"FBIG")),"^",2)
- End DoDot:1
- +5 IF '$TEST
- Begin DoDot:1
- +6 SET PTR=+$PIECE($GET(^MAG(2005,MAGIEN,0)),"^",5)
- +7 if 'PTR
- SET PTR=+$PIECE($GET(^MAG(2005.1,MAGIEN,"FBIG")),"^",2)
- End DoDot:1
- +8 QUIT $SELECT($PIECE($GET(^MAG(2005.2,PTR,0)),U,6)=1:PTR,1:0)
- CPOK(TYPE,ALTPATH,FILEPATH,IEN,EXT) ;
- +1 ; Patch 39: initializing ALTPATH, checking nodes of either 2005 or 2005.1
- +2 NEW MAGXX,PIECE,NODE,LOC,FILE
- +3 SET EXT=$$UPPER^MAGQE4(EXT)
- +4 SET MAGXX=IEN
- +5 SET ALTPATH=""
- +6 SET PIECE=$SELECT(TYPE="ABS":4,TYPE="BIG":1,TYPE="FULL":3,"^PHOTOID^ADIRECT^"[("^"_TYPE_"^"):3,1:0)
- +7 SET NODE=$SELECT(TYPE="BIG":"FBIG",1:0)
- +8 SET FILE=$SELECT($DATA(^MAG(2005,IEN,0)):"2005",1:"2005.1")
- +9 SET LOC=$PIECE($GET(^MAG(FILE,IEN,NODE)),U,PIECE)
- +10 if '$DATA(^MAG(2005.2,+LOC,0))
- QUIT 0
- +11 SET ALTPATH=$$UPPER^MAGQE4($PIECE($GET(^MAG(2005.2,LOC,0)),U,2)_$$DIRHASH^MAGFILEB(FNAM,LOC))
- +12 QUIT $SELECT(ALTPATH=FILEPATH:1,1:0)
- CPUPD(TYPE,IEN,FP,FN,EXT) ;
- +1 ; Patch 39 - Update : Error log type, and using FILE in case an Archive file
- +2 NEW PIECE,CP,NODE,LOC,FILE
- +3 SET EXT=$SELECT('$DATA(EXT):"",1:$$UPPER^MAGQE4(EXT))
- +4 SET PIECE=$SELECT(TYPE="ABS":4,TYPE="BIG":1,TYPE="FULL":3,"^PHOTOID^ADIRECT^"[("^"_TYPE_"^"):3,1:0)
- +5 SET NODE=$SELECT(TYPE="BIG":"FBIG",1:0)
- +6 SET LOC=$$UNHASH(FN,FP)
- +7 IF (PIECE=0)!(+LOC=0)
- DO ELOG(FN,FP,"RAID pointer indeterminate")
- QUIT
- +8 SET FILE=$SELECT($DATA(^MAG(2005,IEN,0)):"2005",1:"2005.1")
- +9 SET $PIECE(^MAG(FILE,IEN,NODE),U,PIECE)=LOC
- +10 QUIT
- CUPD(RESULT,FILEPATH,FILENAME,EXT,IEN) ; RPC[MAGQ CUPDTE]
- +1 ; called from the BP Purge
- NEW TYPE
- +2 NEW X
- SET X="ERR^MAGQBTM"
- SET @^%ZOSF("TRAP")
- +3 SET TYPE=$$FTYPE(EXT,IEN)
- +4 DO CPUPD(TYPE,IEN,FILEPATH,FILENAME,EXT)
- +5 QUIT
- UNHASH(FN,FP) ; RETURN NETWORK LOCATION NUMBER
- +1 NEW SHARE,HASH
- +2 SET SHARE=$SELECT(FP[":":$PIECE(FP,"\",1,2)_"\",1:$PIECE(FP,"\",1,4)_"\")
- +3 SET HASH=$SELECT($PIECE(FP,SHARE,2)["\":"Y",1:"")
- +4 QUIT $$SHNAM(SHARE,HASH)
- ELOG(FN,FP,MESSAGE) ;
- +1 NEW INDX
- +2 NEW X
- SET X="ERR^MAGQBTM"
- SET @^%ZOSF("TRAP")
- +3 SET INDX=+$ORDER(^TMP("MAGQ",$JOB,"PRG",99999),-1)+1
- +4 SET ^TMP("MAGQ",$JOB,"PRG",INDX)=MESSAGE_"^"_FN_"^"_FP
- +5 QUIT
- ELOGR(RESULT,LIMIT) ;[MAGQ ELOGR] - Error log report and purge
- +1 ; Please test this
- +2 NEW FN,INDX,CNT
- +3 NEW X
- SET X="ERR^MAGQBTM"
- SET @^%ZOSF("TRAP")
- +4 SET CNT=0
- SET INDX=""
- +5 FOR
- SET INDX=$ORDER(^TMP("MAGQ",$JOB,"PRG",INDX))
- if INDX'?1N.N
- QUIT
- if CNT=LIMIT
- QUIT
- Begin DoDot:1
- +6 SET CNT=CNT+1
- SET RESULT(CNT)=^TMP("MAGQ",$JOB,"PRG",INDX)
- +7 KILL ^TMP("MAGQ",$JOB,"PRG",INDX)
- +8 QUIT
- End DoDot:1
- +9 SET RESULT(0)=CNT
- +10 SET INDX=$ORDER(^TMP("MAGQ",$JOB,"PRG",""))
- +11 IF INDX?1N.N
- SET RESULT(0)=RESULT(0)_U_"MORE"
- +12 QUIT
- SHNAM(SHARE,HASH) ;
- +1 NEW NUM,ONLINE,ZNODE
- +2 SET (NUM,ONLINE)=0
- +3 FOR
- SET NUM=$ORDER(^MAG(2005.2,"AC",SHARE,NUM))
- if 'NUM
- QUIT
- Begin DoDot:1
- +4 SET ZNODE=^MAG(2005.2,NUM,0)
- +5 if ($PIECE(ZNODE,"^",6)'="1")
- QUIT
- +6 if ($PIECE(ZNODE,"^",8)'=HASH)
- QUIT
- +7 SET ONLINE="1"
- End DoDot:1
- if ONLINE
- QUIT
- +8 QUIT NUM