- MAGSFTCH ;WOIFO/JSL - IMAGE STORAGE COPY UTILITY PROGRAM ; July 01, 2010 1:06 PM
- ;;3.0;IMAGING;**98**;Mar 19, 2002;Build 1849;Sep 22, 2010
- ;; 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. |
- ;; +---------------------------------------------------------------+
- ;;
- FETCH(OUT,MAGIEN,DATE,NETLOC) ;RPC = MAG STORAGE FETCH
- ;; OUT() : result - code,message
- ;; for example: OUT(1) = "0, Done", OUT(1)= "Ien1: Ien2, copy command line"
- ;; MAGIEN : fetching IEN (start ien) | (stop ien)
- ;; DATE : image saved date (start date) | (stop date)
- ;; NETLOC : FROM | TO - network location | remove source file | WinZip option
- N CNT,CMD,DT1,DT2,DTOUT,ENDIM,EXT,FILE,FNAME,FROM,FRMLOC,IEN1,IEN2,IM,IN,IN1,IN2,JBLOC,LOC,LOCN,LNO
- N M,MOVOLD,WZIP,NTLOC,OK,PS,PLACE,RDLOC,SITE,START,STOP,STYP,TLOC,TO,TP,X,X0,X1,X2,XBIG,Y,WRTLOC,LOGTIME,BTMOUT
- K OUT S OUT(1)=0,OK=0,U="^",LNO=0
- S LOGTIME=$$NOW^XLFDT(),BTMOUT=+$P(^MAG(2006.1,$$PLACE^MAGBAPI(+$G(DUZ(2))),"KEYS"),U,2) I $G(XWBTIME) S:BTMOUT>XWBTIME BTMOUT=XWBTIME ;broker time out
- I $G(MAGIEN) S:'$G(DATE) DATE=$P($$NOW^XLFDT,"."),DT2="2800101" S IM=+$G(MAGIEN),ENDIM=$P($G(MAGIEN),":",2) ;ien range - IM ~ ENDIM
- E S DATE=$G(DATE),DT2=$P(DATE,"|",2),DATE=+DATE ;DT2 fetch end date
- ;DATE range iens, find one
- I '$G(IM) S IM=$S($G(DATE):$$FINDIEN(DATE),1:$O(^MAG(2005," "),-1))
- I '$G(ENDIM) S ENDIM=$S($G(DT2):$$FINDIEN(DT2),$G(DATE):$$FINDIEN(DATE-1),1:0)
- NEXT ;IEN range in reverse order, find matched IEN to fetch/copy
- S X0=$G(^MAG(2005,IM,0))
- I $P(X0,U,2)'["." I IM>1 F CNT=1:1:100000 S IM=$O(^MAG(2005,IM),-1) Q:'IM!(IM<ENDIM) S X0=$G(^MAG(2005,IM,0)) I $P(X0,U,2)["." Q ;find next
- I IM I ($$NOW^XLFDT-$G(^MAG(2005,IM,2)))<1 S IM=$O(^MAG(2005,IM),-1) G NEXT ;exclude today image(s) IM
- I (IM'<ENDIM),($P(X0,U,2)[".") D FETCH1
- I OK S OUT(1)=IM_":"_ENDIM_",CMD summit "_LNO_U_WRTLOC_U_$G(FRMLOC)_U_DT1_U_$G(MOVOLD)_"@"_DATE_"|"_DT2_"|"_$G(STYP)_"|"_FNAME_"|"_+$G(XBIG,0)
- I $P(OUT(1),",",1)=-1 Q ;error occured
- I 'OK I ($$FMDIFF^XLFDT($$NOW^XLFDT(),LOGTIME,2)+1)>$G(BTMOUT) D Q ;before BK time out, still not finding any image
- . S OUT(1)="-2,Cannot find image file on selected Source location to copy within IEN range("_IM_"~"_+$G(MAGIEN)_") after broker timeout"_$S($G(BTMOUT):" of "_BTMOUT_" sec.",1:".")
- . Q
- I 'OK,$G(OUT(2))="" S IM=$O(^MAG(2005,IM),-1) K OUT(2) G:IM>0 NEXT
- S:IM<1 OUT(1)=0_",Done"
- Q
- ;
- FETCH1 ;Find the image file from share
- S XBIG=$G(^MAG(2005,IM,"FBIG"))
- S X2=$G(^MAG(2005,IM,2)),DT1=$P(X2,U) ;D/T image saved
- I DT1 I DT1<DT2 S:(DT1-DATE)<-1 IM=-1 Q ;early than fetch end date, or stop the loop $O()
- S OUT(1)=IM_":"_ENDIM ;last fetching IEN
- S LNO=1 ;LN number of OUT()
- S SITE=$P($G(^MAG(2005,IM,100)),U,3) ;SITE ID
- S PLACE=+$S(SITE:$O(^MAG(2006.1,"B",SITE,0)),1:$O(^MAG(2006.1,0))) S:'PLACE PLACE=1
- S FRMLOC=+$P($G(NETLOC),"|"),WRTLOC=+$P($G(NETLOC),"|",2),MOVOLD=$P($G(NETLOC),"|",3),WZIP=$P($G(NETLOC),"|",4)
- I WRTLOC="" S OUT(1)="-1,Can't Find 'TO' write network location" Q
- S FNAME=$P(X0,U,2),FILE=$P(FNAME,"."),EXT=$P(FNAME,".",2) Q:FILE=""
- I $L(FILE)>8 I $L(FILE)'=14 I FRMLOC=$P(X0,U,3) D MAGFIX93(.OUT,IM) S X0=^MAG(2005,IM,0),FNAME=$P(X0,U,2),FILE=$P(FNAME,".") ;valid 8.3, 14.3
- I FRMLOC=$P(X0,U,5) D FULL Q
- I FRMLOC=$P(X0,U,3) D FULL Q
- I FRMLOC=$P(X0,U,4) D FULL Q
- I $L(XBIG) I (FRMLOC=$P(XBIG,U))!(FRMLOC=$P(XBIG,U,2)) D FULL Q
- I $P($G(NETLOC),"|")="*" D ALLCPY Q
- E I (FRMLOC'=$P(X0,U,3))&(FRMLOC'=$P(X0,U,5)) S OK=0,OUT(1)=0,OUT(2)="" Q ;Not on selected share
- S:'WRTLOC WRTLOC=$P($G(^MAG(2006.1,PLACE,0)),U,3) ;current write location vs Site ID
- I 'WRTLOC S OUT(1)="-1,Can't Find Current Write Location for ("_MAGIEN_")" Q
- Q
- ;
- ALLCPY ;copy ALL set image files to JB
- N MKDIR,X1,NO S LNO=$S($D(OUT(2)):$O(OUT(" "),-1),1:2)
- S LOCN=$P(XBIG,U) S:LOCN LOCN(LOCN)=1 F PS=3,4 S LOCN=$P(X0,U,PS) S:LOCN LOCN(LOCN)=PS ;all possible RAID loc
- I '$O(LOCN(0)) S OUT(1)="-1,Can't Find Current Image Location for ("_MAGIEN_")" Q
- S LOCN=0 F S LOCN=$O(LOCN(LOCN)) Q:'LOCN D
- . S LOC=$G(^MAG(2005.2,LOCN,0)) Q:'$L(LOC)
- . I LOCN I LOCN'=$P(X0,U,5) I LOCN'=$P(X0,U,3) Q ;not on RAID share nor JB
- . S STYP=$S($P(LOC,U,7)="MAG":"R",1:"J") ;storage type
- . I $P(^MAG(2005.2,LOCN,0),U,10) Q:PLACE'=$P(^MAG(2005.2,LOCN,0),U,10) ;chk PLACE
- . S TLOC=$G(^MAG(2005.2,WRTLOC,0)) Q:'$L(TLOC)
- . I $P(TLOC,U,8)'="Y" S OUT(1)="-1,WRITE Location is not hashed" Q
- . S STYP="RJ"
- . S JBLOC=$P(LOC,U,2),RDLOC=$P(^MAG(2005.2,WRTLOC,0),U,2) ;phyical location
- . S FROM=$$DIRHASH^MAGFILEB(FNAME,LOCN),FROM=$$CHKDIR(FROM) ;JB hash dir
- . S TO=$$DIRHASH^MAGFILEB(FNAME,WRTLOC),TO=$$CHKDIR(TO) ;RD hash dir
- . I '$G(MKDIR) D
- . . S:'$D(OUT(2)) OUT(2)="DIR "_JBLOC_FROM_FILE_".*" ;chk file exist
- . . I $F(TO,"\") F NO=1:1 S X1=$P(TO,"\",NO) Q:X1="" S LNO=LNO+1,OUT(LNO)="MKDIR "_RDLOC_$P(TO,"\",1,NO)
- . . E S LNO=LNO+1,OUT(LNO)="MKDIR "_RDLOC_TO
- . . S MKDIR=1 ;create hash folder
- . . Q
- . D @STYP
- Q
- ;
- FULL ;copy all images full set
- N X1,NO S LNO=$S($D(OUT(2)):$O(OUT(" "),-1),1:2)
- S LOCN=FRMLOC S:'LOCN LOCN=$P(X0,U,5) S:'LOCN LOCN=$P(X0,U,3) S:'LOCN LOCN=$P(X0,U,4) Q:'LOCN
- S LOC=$G(^MAG(2005.2,LOCN,0)) Q:'$L(LOC)
- I LOCN I LOCN'=$P(X0,U,5) I LOCN'=$P(X0,U,3) I LOCN'=$P(X0,U,4) I '(FRMLOC=$P(XBIG,U)) I '(FRMLOC=$P(XBIG,U,2)) Q ;not on RAID share nor JB
- S STYP=$S($P(LOC,U,7)="MAG":"R",1:"J") ;storage type
- I $P(^MAG(2005.2,LOCN,0),U,10) Q:PLACE'=$P(^MAG(2005.2,LOCN,0),U,10) ;chk PLACE
- S TLOC=$G(^MAG(2005.2,WRTLOC,0)) Q:'$L(TLOC)
- I $P(TLOC,U,8)'="Y" S OUT(1)="-1,WRITE Location is not hashed" Q
- S STYP=STYP_$S($P(TLOC,U,7)="MAG":"R",1:"J")
- S JBLOC=$P(LOC,U,2),RDLOC=$P(^MAG(2005.2,WRTLOC,0),U,2) ;phyical location
- S FROM=$$DIRHASH^MAGFILEB(FNAME,LOCN),FROM=$$CHKDIR(FROM) ;JB hash dir
- S TO=$$DIRHASH^MAGFILEB(FNAME,WRTLOC),TO=$$CHKDIR(TO) ;RD hash dir
- S:'$D(OUT(2)) OUT(2)="DIR "_JBLOC_FROM_FILE_".*" ;chk file exist
- I $F(TO,"\") F NO=1:1 S X1=$P(TO,"\",NO) Q:X1="" S LNO=LNO+1,OUT(LNO)="MKDIR "_RDLOC_$P(TO,"\",1,NO)
- E S LNO=LNO+1,OUT(LNO)="MKDIR "_RDLOC_TO ;create hashed dir
- I '(FRMLOC=$P(XBIG,U)) I '(FRMLOC=$P(XBIG,U,2)) S XBIG="" ;no BIG copy
- D @STYP
- Q
- ;
- STYP ;; COPY image - JB->RAID (e.g.:Fetching JB)
- ;; JB->JB (e.g.:Hashing/Media Copy)
- ;; RAID->JB (e.g.:Archive JB)
- ;; RAID->RAID (e.g.: Media Copy)
- JR ;JB to RAID
- D COPYCMD
- S OK=1
- Q
- ;
- JJ ;JB to JB
- D COPYCMD
- S OK=1
- Q
- ;
- RJ ;RAID to JB
- I $G(MOVOLD)=1 D MOVECMD S OK=1 Q
- D COPYCMD
- S OK=1
- Q
- ;
- RR ;RAID to RAID
- I $G(MOVOLD)=1 D MOVECMD S OK=1 Q
- D COPYCMD
- S OK=1
- Q
- COPYCMD ;create each copy cmd line for GUI (called by FETCH1/JR/JJ/RJ/RR)
- N SRC S CMD="",SRC=$$CHKSRC(STYP,X0,$G(XBIG))
- I $P(SRC,U,1) S CMD="COPY/Y /V "_JBLOC_FROM_FILE_".TXT "_RDLOC_TO_FILE_".TXT ",LNO=LNO+1,OUT(LNO)=CMD
- I $P(SRC,U,2) S CMD="COPY/Y /V "_JBLOC_FROM_FILE_".ABS "_RDLOC_TO_FILE_".ABS ",LNO=LNO+1,OUT(LNO)=CMD
- I $P(SRC,U,3) S CMD="COPY/Y /V "_JBLOC_FROM_FILE_"."_EXT_" "_RDLOC_TO_FILE_"."_EXT_" ",LNO=LNO+1,OUT(LNO)=CMD
- I $P(SRC,U,4) S CMD="COPY/Y /V "_JBLOC_FROM_FILE_".BIG "_RDLOC_TO_FILE_".BIG ",LNO=LNO+1,OUT(LNO)=CMD
- I CMD="" S OUT(1)="-1,Can't find image set for IEN("_MAGIEN_")" Q
- Q
- MOVECMD ;create each Move cmd line for GUI
- N SRC S CMD="",SRC=$$CHKSRC(STYP,X0,$G(XBIG))
- I $P(SRC,U,1) S CMD="MOVE/Y "_JBLOC_FROM_FILE_".TXT "_RDLOC_TO_FILE_".TXT ",LNO=LNO+1,OUT(LNO)=CMD
- I $P(SRC,U,2) S CMD="MOVE/Y "_JBLOC_FROM_FILE_".ABS "_RDLOC_TO_FILE_".ABS ",LNO=LNO+1,OUT(LNO)=CMD
- I $P(SRC,U,3) S CMD="MOVE/Y "_JBLOC_FROM_FILE_"."_EXT_" "_RDLOC_TO_FILE_"."_EXT_" ",LNO=LNO+1,OUT(LNO)=CMD
- I $P(SRC,U,4) S CMD="MOVE/Y "_JBLOC_FROM_FILE_".BIG "_RDLOC_TO_FILE_".BIG ",LNO=LNO+1,OUT(LNO)=CMD
- I CMD="" S OUT(1)="-1,Can't find image set for IEN("_MAGIEN_")" Q
- Q
- CHKSRC(STYP,X0,XBIG) ;check if source files exist for copy
- ;; STYP = storage types, X0 = 2005 entry, XBIG = 2005 FBIG entry
- N ABS,BIG,TGA,TXT S (ABS,BIG,TGA,TXT)=0
- I (STYP="RR") S:(LOCN=$P(X0,U,3)) (TXT,TGA)=1 S:(LOCN=$P(X0,U,4)) (TXT,ABS)=1 S:(LOCN=$P(XBIG,U)) (TXT,BIG)=1
- I (STYP="RJ") S:(LOCN=$P(X0,U,3))!(LOCN=$P(X0,U,4)) (TGA,ABS,TXT)=1 S:(LOCN=$P(XBIG,U)) (TXT,BIG)=1
- I (STYP="JJ") S:(LOCN=$P(X0,U,5)) (TGA,ABS,TXT)=1 S:(LOCN=$P(XBIG,U,2)) (TXT,BIG)=1
- I (STYP="JR") S:(LOCN=$P(X0,U,5)) (TGA,ABS,TXT)=1 S:(LOCN=$P(XBIG,U,2)) (TXT,BIG)=1
- Q TXT_U_ABS_U_TGA_U_BIG
- ;---------------------------------------------------------------------
- SETLOC(OUT,IM,NTLOC) ;RPC = MAG STORAGE FETCH SET
- ;; Set the RAID location piece(NTLOC) in MAG(2005,IM includes 3,4 & FBIG
- ;; OUT(1)= 1 success | IM = ien IMAGE file #2005
- ;; 0 no action | NTLOC = network loction ien+(opt:overwrt "*" full or "@" .ABS or "b" .BIG) + (| source location)
- ;; -1 error |
- N OK,X,XBIG,Y,SRC
- K OUT S OUT(1)=0,OK=0,U="^"
- S SRC=+$P($G(NTLOC),"|",2) ;source location ien
- I '$G(IM) S OUT(1)="-1,No IMAGE IEN Specified ("_$G(IM)_")" Q
- I $G(NTLOC)="" S OUT(1)="-1,No Network Location Specified" Q
- S X=$G(^MAG(2005.2,+NTLOC,0)) Q:$P(X,U,9) ;no Set for router
- I $P(X,U,2)="" S OUT(1)="-1,Invalid Network Location "_NTLOC Q
- I $P(X,U,7)["WORM" D SETJBL Q
- I $P(X,U,7)'="MAG" S OUT(1)="0,Not a RAID/MAG nor a JB/WORM NETWORK LOCATION type - IEN "_NTLOC Q
- S (X,Y)=$G(^MAG(2005,IM,0)) I X="" S OUT(1)="-1,No IMAGE File entry - IEN "_IM Q
- S XBIG=$G(^MAG(2005,IM,"FBIG"))
- I SRC>0 D Q ;with the file(s) source info, use it to set RAID pt
- . I ($P(X,U,4)=SRC)!($P(X,U,5)=SRC) S $P(Y,U,4)=+NTLOC,OK=1 ;ABS
- . I ($P(X,U,3)=SRC)!($P(X,U,5)=SRC) S $P(Y,U,3)=+NTLOC,OK=1 ;full
- . I OK S ^MAG(2005,IM,0)=Y,OUT(1)="1,Set RAID pointer for 2005 IMAGE IEN "_IM
- . I ($P(XBIG,U)=SRC)!($P(XBIG,U,2)=SRC) S $P(^MAG(2005,IM,"FBIG"),"^")=+NTLOC,OUT(1)=$S(OK:OUT(1)_" w/FBIG",1:"1,Set RAID(FBIG) pointer for 2005 IMAGE IEN "_IM)
- . Q
- I (NTLOC["b") G SETLOC4B ;BIG file only
- I (NTLOC["@") S $P(Y,U,4)=+NTLOC,OK=1 ;set ABS only
- E D
- . I '$P(X,U,4)!(NTLOC["*") S:'(NTLOC["r") $P(Y,U,4)=+NTLOC,OK=1 ;r : p3 only
- . I '$P(X,U,3)!(NTLOC["*")!(NTLOC["r") S $P(Y,U,3)=+NTLOC,OK=1 ;set FULL
- . Q
- I OK S ^MAG(2005,IM,0)=Y,OUT(1)="1,Set RAID pointer for 2005 IMAGE IEN ,"_IM
- I OK=0,$P(X,U,3) I (+NTLOC)'=$P(X,U,3) S OUT(1)="-1,Not setting #"_NTLOC_" already exist other network location #"_$P(X,U,3) Q
- Q:XBIG=""!(XBIG="^")!(NTLOC["@") ;no BIG file to set
- SETLOC4B ;BIG file RAID
- S $P(^MAG(2005,IM,"FBIG"),"^")=+NTLOC,OUT(1)=$S(OK:OUT(1)_" w/FBIG",1:"1,Set RAID(FBIG) pointer for 2005 IMAGE IEN "_IM)
- Q
- ;
- SETJBL ;SET JB location
- I '$G(NTLOC)="" S OUT(1)="-1,No Network Location Specified" Q
- S (X,Y)=$G(^MAG(2005,IM,0)) I X="" S OUT(1)="-1,No Image File"_IM Q
- S XBIG=$G(^MAG(2005,IM,"FBIG"))
- I SRC>0 D Q ;with the source info, use it to set new jukebox pt
- . I ($P(X,U,3)=SRC)!($P(X,U,4)=SRC)!($P(X,U,5)=SRC) S $P(Y,U,5)=+NTLOC,OK=1 ;JB
- . I OK S ^MAG(2005,IM,0)=Y,OUT(1)="1,Set JB pointer for 2005 IMAGE IEN "_IM
- . I ($P(XBIG,U)=SRC)!($P(XBIG,U,2)=SRC) S $P(^MAG(2005,IM,"FBIG"),"^",2)=+NTLOC,OUT(1)=$S(OK:OUT(1)_" w/FBIG",1:"1,Set JB(FIBG) pointer for 2005 IMAGE IEN "_IM)
- . Q
- I $P(X,U,5)'=NTLOC S $P(Y,U,5)=+NTLOC,OK=1 ;set FULL
- I OK S ^MAG(2005,IM,0)=Y,OUT(1)="1,Set JB pointer for 2005 IMAGE IEN "_IM
- Q:XBIG=""!(XBIG="^") ;no BIG
- I SRC>0 I $P(XBIG,U)'=SRC I $P(XBIG,U,2)'=SRC Q ;not same source loc
- S $P(^MAG(2005,IM,"FBIG"),"^",2)=+NTLOC,OUT(1)=$S(OK:OUT(1)_" w/FBIG",1:"1,Set JB(FIBG) pointer for 2005 IMAGE IEN "_IM)
- Q
- ;
- FINDIEN(DT1) ; Find last IEN mark(IN) to process on DT1
- S IN1=0,IN2=$O(^MAG(2005,"A"),-1),IN=(IN1+IN2)\2
- LOOP ;check image saved date
- S Y=$G(^MAG(2005,IN,2)) I Y="" S IN=IN+1 I IN<IN2 G LOOP
- I +Y>DT1 S IN2=IN,IN=(IN1+IN2)\2
- E S IN1=IN,IN=(IN1+IN2)\2
- I IN1'=IN,IN2'=IN G LOOP
- Q IN
- ;
- MAGFIX93(OUT,IEN) ;API - MAG UTIL FIX9.3, fix 9.3 10.3 file format (call by FETCH1)
- ;; OUT() : result - DOS commands to rename(move) the 9.3 or 10.3 file name to 14.3
- ;; for example: OUT(1) = "move abc123456.abs abc0\00\00\12\34\abc00000123456.abs"
- ;; IEN : image file IEN
- ;;
- N NWNAME,NO,OFNAME,X,Y,LOCN,LOC,ODIR,EXT,NFNAME,NDIR,CMD,DIE,DA,DR,EXT1,CMD,X1,SITE
- S:'$D(U) U="^"
- S SITE=+$P($G(^MAG(2005,IEN,100)),U,3) ;SITE ID
- S:'$D(PLACE) PLACE=+$S(SITE:$O(^MAG(2006.1,"B",SITE,0)),1:$O(^MAG(2006.1,0))) S:'PLACE PLACE=1
- S LNO=2,NWNAME=$P(^MAG(2006.1,PLACE,0),U,2) ;current site namespace
- S X=$G(^MAG(2005,IEN,0)) I $L(X) D
- . S Y=$P(X,U,2) Q:Y="" ;GROUP no file reference
- . S OFNAME=$P(Y,".") I ($L(OFNAME)=8)!(OFNAME="")!($L(OFNAME)=14) Q ;8.3 14.3 format
- . S LOCN=$P(X,U,3) Q:'LOCN ;RAID location
- . ;;I $P(X,U,5) Q ;don't change file name w/ JB(WORM) copy
- . S LOC=$P($G(^MAG(2005.2,LOCN,0)),U,2) Q:'$L(LOC)
- . S ODIR=$$DIRHASH(OFNAME,LOCN),ODIR=$$CHKDIR(ODIR)
- . S EXT=$P(Y,".",2) Q:EXT="" ;no extn?
- . S NFNAME=NWNAME_$$PRE0(IEN)_IEN ;correct img file name
- . S NDIR=$$DIRHASH(NFNAME,LOCN),NDIR=$$CHKDIR(NDIR)
- . S OUT(2)="DIR "_LOC_ODIR_OFNAME_".*" ;chk file exist
- . I $F(NDIR,"\") F NO=1:1 S X1=$P(NDIR,"\",NO) Q:X1="" S LNO=LNO+1,OUT(LNO)="MKDIR "_LOC_$P(NDIR,"\",1,NO) ; make sub dir
- . E S LNO=LNO+1,OUT(LNO)="MKDIR "_LOC_NDIR
- . S EXT1="" F EXT1="ABS","TXT","BIG",EXT D ;copy all possible extn types
- . . I EXT1="BIG" I ($G(XBIG)="")!($G(XBIG)="^") Q
- . . S LNO=LNO+1,OUT(LNO)="MOVE/Y "_LOC_ODIR_OFNAME_"."_EXT1_" "_LOC_NDIR_NFNAME_"."_EXT1
- . . Q
- . S DA=+IEN,DR="1///"_NFNAME_"."_EXT,DIE="^MAG(2005," D ^DIE ;chg "F" X-REF
- . D ENTRY^MAGLOG("MAG UTIL",$G(DUZ),IEN,"MAG UTIL FIX9.3","","1",OFNAME_"=>"_NFNAME)
- . Q
- Q
- ;
- PRE0(IEN) ;pre '0' for 14 characters => Namespace_nnnnnnnn_ien'
- N NO,J
- S:$G(NWNAME)="" NWNAME=$P(^MAG(2006.1,PLACE,0),"^",2)
- S NO="" F J=1:1:(14-$L(IEN)-$L(NWNAME)) S NO=NO_"0"
- Q NO
- ;
- CHKDIR(DIR) ; chk "\\"
- N L S L=$L(DIR) I $E(DIR,L-1,L)="\\" S DIR=$E(DIR,1,L-1) ;trim \\ at end
- Q DIR
- ;
- DIRHASH(FILENAME,NETLOCN) ; determine the hierarchical file directory hash
- ; Input Variables:
- ; FILENAME -- the name of the file, with or without the extension
- ; NETLOCN --- the network location file internal entry number
- ; Return Value: the hierarchical file directory hash
- N FN,HASHFLAG,HASH,I
- S HASHFLAG=$P(^MAG(2005.2,NETLOCN,0),"^",8)
- I HASHFLAG="Y" D ; calculate the hierarchical directory hash
- . ; for an 8.3 filename AB123456.XYZ, the directory hash is AB\12\34
- . ; for a 14.3 filename BALT1234567890.XYZ, its BALT\12\34\56\78
- . S FN=$P(FILENAME,".") ; strip off the extension
- . I $L(FN)=8 S HASH=$E(FN,1,2)_"\"_$E(FN,3,4)_"\"_$E(FN,5,6)
- . E S HASH=$E(FN,1,4) F I=5,7,9,11 S HASH=HASH_"\"_$E(FN,I,I+1)
- . S HASH=HASH_"\" ; add the trailing directory separator
- . Q
- E S HASH="" ; flat directory structure, no hierarchical hashing
- Q HASH
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMAGSFTCH 15723 printed Feb 18, 2025@23:34:47 Page 2
- MAGSFTCH ;WOIFO/JSL - IMAGE STORAGE COPY UTILITY PROGRAM ; July 01, 2010 1:06 PM
- +1 ;;3.0;IMAGING;**98**;Mar 19, 2002;Build 1849;Sep 22, 2010
- +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 ;;
- FETCH(OUT,MAGIEN,DATE,NETLOC) ;RPC = MAG STORAGE FETCH
- +1 ;; OUT() : result - code,message
- +2 ;; for example: OUT(1) = "0, Done", OUT(1)= "Ien1: Ien2, copy command line"
- +3 ;; MAGIEN : fetching IEN (start ien) | (stop ien)
- +4 ;; DATE : image saved date (start date) | (stop date)
- +5 ;; NETLOC : FROM | TO - network location | remove source file | WinZip option
- +6 NEW CNT,CMD,DT1,DT2,DTOUT,ENDIM,EXT,FILE,FNAME,FROM,FRMLOC,IEN1,IEN2,IM,IN,IN1,IN2,JBLOC,LOC,LOCN,LNO
- +7 NEW M,MOVOLD,WZIP,NTLOC,OK,PS,PLACE,RDLOC,SITE,START,STOP,STYP,TLOC,TO,TP,X,X0,X1,X2,XBIG,Y,WRTLOC,LOGTIME,BTMOUT
- +8 KILL OUT
- SET OUT(1)=0
- SET OK=0
- SET U="^"
- SET LNO=0
- +9 ;broker time out
- SET LOGTIME=$$NOW^XLFDT()
- SET BTMOUT=+$PIECE(^MAG(2006.1,$$PLACE^MAGBAPI(+$GET(DUZ(2))),"KEYS"),U,2)
- IF $GET(XWBTIME)
- if BTMOUT>XWBTIME
- SET BTMOUT=XWBTIME
- +10 ;ien range - IM ~ ENDIM
- IF $GET(MAGIEN)
- if '$GET(DATE)
- SET DATE=$PIECE($$NOW^XLFDT,".")
- SET DT2="2800101"
- SET IM=+$GET(MAGIEN)
- SET ENDIM=$PIECE($GET(MAGIEN),":",2)
- +11 ;DT2 fetch end date
- IF '$TEST
- SET DATE=$GET(DATE)
- SET DT2=$PIECE(DATE,"|",2)
- SET DATE=+DATE
- +12 ;DATE range iens, find one
- +13 IF '$GET(IM)
- SET IM=$SELECT($GET(DATE):$$FINDIEN(DATE),1:$ORDER(^MAG(2005," "),-1))
- +14 IF '$GET(ENDIM)
- SET ENDIM=$SELECT($GET(DT2):$$FINDIEN(DT2),$GET(DATE):$$FINDIEN(DATE-1),1:0)
- NEXT ;IEN range in reverse order, find matched IEN to fetch/copy
- +1 SET X0=$GET(^MAG(2005,IM,0))
- +2 ;find next
- IF $PIECE(X0,U,2)'["."
- IF IM>1
- FOR CNT=1:1:100000
- SET IM=$ORDER(^MAG(2005,IM),-1)
- if 'IM!(IM<ENDIM)
- QUIT
- SET X0=$GET(^MAG(2005,IM,0))
- IF $PIECE(X0,U,2)["."
- QUIT
- +3 ;exclude today image(s) IM
- IF IM
- IF ($$NOW^XLFDT-$G(^MAG(2005,IM,2)))<1
- SET IM=$ORDER(^MAG(2005,IM),-1)
- GOTO NEXT
- +4 IF (IM'<ENDIM)
- IF ($PIECE(X0,U,2)[".")
- DO FETCH1
- +5 IF OK
- SET OUT(1)=IM_":"_ENDIM_",CMD summit "_LNO_U_WRTLOC_U_$GET(FRMLOC)_U_DT1_U_$GET(MOVOLD)_"@"_DATE_"|"_DT2_"|"_$GET(STYP)_"|"_FNAME_"|"_+$GET(XBIG,0)
- +6 ;error occured
- IF $PIECE(OUT(1),",",1)=-1
- QUIT
- +7 ;before BK time out, still not finding any image
- IF 'OK
- IF ($$FMDIFF^XLFDT($$NOW^XLFDT(),LOGTIME,2)+1)>$GET(BTMOUT)
- Begin DoDot:1
- +8 SET OUT(1)="-2,Cannot find image file on selected Source location to copy within IEN range("_IM_"~"_+$GET(MAGIEN)_") after broker timeout"_$SELECT($GET(BTMOUT):" of "_BTMOUT_" sec.",1:".")
- +9 QUIT
- End DoDot:1
- QUIT
- +10 IF 'OK
- IF $GET(OUT(2))=""
- SET IM=$ORDER(^MAG(2005,IM),-1)
- KILL OUT(2)
- if IM>0
- GOTO NEXT
- +11 if IM<1
- SET OUT(1)=0_",Done"
- +12 QUIT
- +13 ;
- FETCH1 ;Find the image file from share
- +1 SET XBIG=$GET(^MAG(2005,IM,"FBIG"))
- +2 ;D/T image saved
- SET X2=$GET(^MAG(2005,IM,2))
- SET DT1=$PIECE(X2,U)
- +3 ;early than fetch end date, or stop the loop $O()
- IF DT1
- IF DT1<DT2
- if (DT1-DATE)<-1
- SET IM=-1
- QUIT
- +4 ;last fetching IEN
- SET OUT(1)=IM_":"_ENDIM
- +5 ;LN number of OUT()
- SET LNO=1
- +6 ;SITE ID
- SET SITE=$PIECE($GET(^MAG(2005,IM,100)),U,3)
- +7 SET PLACE=+$SELECT(SITE:$ORDER(^MAG(2006.1,"B",SITE,0)),1:$ORDER(^MAG(2006.1,0)))
- if 'PLACE
- SET PLACE=1
- +8 SET FRMLOC=+$PIECE($GET(NETLOC),"|")
- SET WRTLOC=+$PIECE($GET(NETLOC),"|",2)
- SET MOVOLD=$PIECE($GET(NETLOC),"|",3)
- SET WZIP=$PIECE($GET(NETLOC),"|",4)
- +9 IF WRTLOC=""
- SET OUT(1)="-1,Can't Find 'TO' write network location"
- QUIT
- +10 SET FNAME=$PIECE(X0,U,2)
- SET FILE=$PIECE(FNAME,".")
- SET EXT=$PIECE(FNAME,".",2)
- if FILE=""
- QUIT
- +11 ;valid 8.3, 14.3
- IF $LENGTH(FILE)>8
- IF $LENGTH(FILE)'=14
- IF FRMLOC=$PIECE(X0,U,3)
- DO MAGFIX93(.OUT,IM)
- SET X0=^MAG(2005,IM,0)
- SET FNAME=$PIECE(X0,U,2)
- SET FILE=$PIECE(FNAME,".")
- +12 IF FRMLOC=$PIECE(X0,U,5)
- DO FULL
- QUIT
- +13 IF FRMLOC=$PIECE(X0,U,3)
- DO FULL
- QUIT
- +14 IF FRMLOC=$PIECE(X0,U,4)
- DO FULL
- QUIT
- +15 IF $LENGTH(XBIG)
- IF (FRMLOC=$PIECE(XBIG,U))!(FRMLOC=$PIECE(XBIG,U,2))
- DO FULL
- QUIT
- +16 IF $PIECE($GET(NETLOC),"|")="*"
- DO ALLCPY
- QUIT
- +17 ;Not on selected share
- IF '$TEST
- IF (FRMLOC'=$PIECE(X0,U,3))&(FRMLOC'=$PIECE(X0,U,5))
- SET OK=0
- SET OUT(1)=0
- SET OUT(2)=""
- QUIT
- +18 ;current write location vs Site ID
- if 'WRTLOC
- SET WRTLOC=$PIECE($GET(^MAG(2006.1,PLACE,0)),U,3)
- +19 IF 'WRTLOC
- SET OUT(1)="-1,Can't Find Current Write Location for ("_MAGIEN_")"
- QUIT
- +20 QUIT
- +21 ;
- ALLCPY ;copy ALL set image files to JB
- +1 NEW MKDIR,X1,NO
- SET LNO=$SELECT($DATA(OUT(2)):$ORDER(OUT(" "),-1),1:2)
- +2 ;all possible RAID loc
- SET LOCN=$PIECE(XBIG,U)
- if LOCN
- SET LOCN(LOCN)=1
- FOR PS=3,4
- SET LOCN=$PIECE(X0,U,PS)
- if LOCN
- SET LOCN(LOCN)=PS
- +3 IF '$ORDER(LOCN(0))
- SET OUT(1)="-1,Can't Find Current Image Location for ("_MAGIEN_")"
- QUIT
- +4 SET LOCN=0
- FOR
- SET LOCN=$ORDER(LOCN(LOCN))
- if 'LOCN
- QUIT
- Begin DoDot:1
- +5 SET LOC=$GET(^MAG(2005.2,LOCN,0))
- if '$LENGTH(LOC)
- QUIT
- +6 ;not on RAID share nor JB
- IF LOCN
- IF LOCN'=$PIECE(X0,U,5)
- IF LOCN'=$PIECE(X0,U,3)
- QUIT
- +7 ;storage type
- SET STYP=$SELECT($PIECE(LOC,U,7)="MAG":"R",1:"J")
- +8 ;chk PLACE
- IF $PIECE(^MAG(2005.2,LOCN,0),U,10)
- if PLACE'=$PIECE(^MAG(2005.2,LOCN,0),U,10)
- QUIT
- +9 SET TLOC=$GET(^MAG(2005.2,WRTLOC,0))
- if '$LENGTH(TLOC)
- QUIT
- +10 IF $PIECE(TLOC,U,8)'="Y"
- SET OUT(1)="-1,WRITE Location is not hashed"
- QUIT
- +11 SET STYP="RJ"
- +12 ;phyical location
- SET JBLOC=$PIECE(LOC,U,2)
- SET RDLOC=$PIECE(^MAG(2005.2,WRTLOC,0),U,2)
- +13 ;JB hash dir
- SET FROM=$$DIRHASH^MAGFILEB(FNAME,LOCN)
- SET FROM=$$CHKDIR(FROM)
- +14 ;RD hash dir
- SET TO=$$DIRHASH^MAGFILEB(FNAME,WRTLOC)
- SET TO=$$CHKDIR(TO)
- +15 IF '$GET(MKDIR)
- Begin DoDot:2
- +16 ;chk file exist
- if '$DATA(OUT(2))
- SET OUT(2)="DIR "_JBLOC_FROM_FILE_".*"
- +17 IF $FIND(TO,"\")
- FOR NO=1:1
- SET X1=$PIECE(TO,"\",NO)
- if X1=""
- QUIT
- SET LNO=LNO+1
- SET OUT(LNO)="MKDIR "_RDLOC_$PIECE(TO,"\",1,NO)
- +18 IF '$TEST
- SET LNO=LNO+1
- SET OUT(LNO)="MKDIR "_RDLOC_TO
- +19 ;create hash folder
- SET MKDIR=1
- +20 QUIT
- End DoDot:2
- +21 DO @STYP
- End DoDot:1
- +22 QUIT
- +23 ;
- FULL ;copy all images full set
- +1 NEW X1,NO
- SET LNO=$SELECT($DATA(OUT(2)):$ORDER(OUT(" "),-1),1:2)
- +2 SET LOCN=FRMLOC
- if 'LOCN
- SET LOCN=$PIECE(X0,U,5)
- if 'LOCN
- SET LOCN=$PIECE(X0,U,3)
- if 'LOCN
- SET LOCN=$PIECE(X0,U,4)
- if 'LOCN
- QUIT
- +3 SET LOC=$GET(^MAG(2005.2,LOCN,0))
- if '$LENGTH(LOC)
- QUIT
- +4 ;not on RAID share nor JB
- IF LOCN
- IF LOCN'=$PIECE(X0,U,5)
- IF LOCN'=$PIECE(X0,U,3)
- IF LOCN'=$PIECE(X0,U,4)
- IF '(FRMLOC=$PIECE(XBIG,U))
- IF '(FRMLOC=$PIECE(XBIG,U,2))
- QUIT
- +5 ;storage type
- SET STYP=$SELECT($PIECE(LOC,U,7)="MAG":"R",1:"J")
- +6 ;chk PLACE
- IF $PIECE(^MAG(2005.2,LOCN,0),U,10)
- if PLACE'=$PIECE(^MAG(2005.2,LOCN,0),U,10)
- QUIT
- +7 SET TLOC=$GET(^MAG(2005.2,WRTLOC,0))
- if '$LENGTH(TLOC)
- QUIT
- +8 IF $PIECE(TLOC,U,8)'="Y"
- SET OUT(1)="-1,WRITE Location is not hashed"
- QUIT
- +9 SET STYP=STYP_$SELECT($PIECE(TLOC,U,7)="MAG":"R",1:"J")
- +10 ;phyical location
- SET JBLOC=$PIECE(LOC,U,2)
- SET RDLOC=$PIECE(^MAG(2005.2,WRTLOC,0),U,2)
- +11 ;JB hash dir
- SET FROM=$$DIRHASH^MAGFILEB(FNAME,LOCN)
- SET FROM=$$CHKDIR(FROM)
- +12 ;RD hash dir
- SET TO=$$DIRHASH^MAGFILEB(FNAME,WRTLOC)
- SET TO=$$CHKDIR(TO)
- +13 ;chk file exist
- if '$DATA(OUT(2))
- SET OUT(2)="DIR "_JBLOC_FROM_FILE_".*"
- +14 IF $FIND(TO,"\")
- FOR NO=1:1
- SET X1=$PIECE(TO,"\",NO)
- if X1=""
- QUIT
- SET LNO=LNO+1
- SET OUT(LNO)="MKDIR "_RDLOC_$PIECE(TO,"\",1,NO)
- +15 ;create hashed dir
- IF '$TEST
- SET LNO=LNO+1
- SET OUT(LNO)="MKDIR "_RDLOC_TO
- +16 ;no BIG copy
- IF '(FRMLOC=$PIECE(XBIG,U))
- IF '(FRMLOC=$PIECE(XBIG,U,2))
- SET XBIG=""
- +17 DO @STYP
- +18 QUIT
- +19 ;
- STYP ;; COPY image - JB->RAID (e.g.:Fetching JB)
- +1 ;; JB->JB (e.g.:Hashing/Media Copy)
- +2 ;; RAID->JB (e.g.:Archive JB)
- +3 ;; RAID->RAID (e.g.: Media Copy)
- JR ;JB to RAID
- +1 DO COPYCMD
- +2 SET OK=1
- +3 QUIT
- +4 ;
- JJ ;JB to JB
- +1 DO COPYCMD
- +2 SET OK=1
- +3 QUIT
- +4 ;
- RJ ;RAID to JB
- +1 IF $GET(MOVOLD)=1
- DO MOVECMD
- SET OK=1
- QUIT
- +2 DO COPYCMD
- +3 SET OK=1
- +4 QUIT
- +5 ;
- RR ;RAID to RAID
- +1 IF $GET(MOVOLD)=1
- DO MOVECMD
- SET OK=1
- QUIT
- +2 DO COPYCMD
- +3 SET OK=1
- +4 QUIT
- COPYCMD ;create each copy cmd line for GUI (called by FETCH1/JR/JJ/RJ/RR)
- +1 NEW SRC
- SET CMD=""
- SET SRC=$$CHKSRC(STYP,X0,$GET(XBIG))
- +2 IF $PIECE(SRC,U,1)
- SET CMD="COPY/Y /V "_JBLOC_FROM_FILE_".TXT "_RDLOC_TO_FILE_".TXT "
- SET LNO=LNO+1
- SET OUT(LNO)=CMD
- +3 IF $PIECE(SRC,U,2)
- SET CMD="COPY/Y /V "_JBLOC_FROM_FILE_".ABS "_RDLOC_TO_FILE_".ABS "
- SET LNO=LNO+1
- SET OUT(LNO)=CMD
- +4 IF $PIECE(SRC,U,3)
- SET CMD="COPY/Y /V "_JBLOC_FROM_FILE_"."_EXT_" "_RDLOC_TO_FILE_"."_EXT_" "
- SET LNO=LNO+1
- SET OUT(LNO)=CMD
- +5 IF $PIECE(SRC,U,4)
- SET CMD="COPY/Y /V "_JBLOC_FROM_FILE_".BIG "_RDLOC_TO_FILE_".BIG "
- SET LNO=LNO+1
- SET OUT(LNO)=CMD
- +6 IF CMD=""
- SET OUT(1)="-1,Can't find image set for IEN("_MAGIEN_")"
- QUIT
- +7 QUIT
- MOVECMD ;create each Move cmd line for GUI
- +1 NEW SRC
- SET CMD=""
- SET SRC=$$CHKSRC(STYP,X0,$GET(XBIG))
- +2 IF $PIECE(SRC,U,1)
- SET CMD="MOVE/Y "_JBLOC_FROM_FILE_".TXT "_RDLOC_TO_FILE_".TXT "
- SET LNO=LNO+1
- SET OUT(LNO)=CMD
- +3 IF $PIECE(SRC,U,2)
- SET CMD="MOVE/Y "_JBLOC_FROM_FILE_".ABS "_RDLOC_TO_FILE_".ABS "
- SET LNO=LNO+1
- SET OUT(LNO)=CMD
- +4 IF $PIECE(SRC,U,3)
- SET CMD="MOVE/Y "_JBLOC_FROM_FILE_"."_EXT_" "_RDLOC_TO_FILE_"."_EXT_" "
- SET LNO=LNO+1
- SET OUT(LNO)=CMD
- +5 IF $PIECE(SRC,U,4)
- SET CMD="MOVE/Y "_JBLOC_FROM_FILE_".BIG "_RDLOC_TO_FILE_".BIG "
- SET LNO=LNO+1
- SET OUT(LNO)=CMD
- +6 IF CMD=""
- SET OUT(1)="-1,Can't find image set for IEN("_MAGIEN_")"
- QUIT
- +7 QUIT
- CHKSRC(STYP,X0,XBIG) ;check if source files exist for copy
- +1 ;; STYP = storage types, X0 = 2005 entry, XBIG = 2005 FBIG entry
- +2 NEW ABS,BIG,TGA,TXT
- SET (ABS,BIG,TGA,TXT)=0
- +3 IF (STYP="RR")
- if (LOCN=$PIECE(X0,U,3))
- SET (TXT,TGA)=1
- if (LOCN=$PIECE(X0,U,4))
- SET (TXT,ABS)=1
- if (LOCN=$PIECE(XBIG,U))
- SET (TXT,BIG)=1
- +4 IF (STYP="RJ")
- if (LOCN=$PIECE(X0,U,3))!(LOCN=$PIECE(X0,U,4))
- SET (TGA,ABS,TXT)=1
- if (LOCN=$PIECE(XBIG,U))
- SET (TXT,BIG)=1
- +5 IF (STYP="JJ")
- if (LOCN=$PIECE(X0,U,5))
- SET (TGA,ABS,TXT)=1
- if (LOCN=$PIECE(XBIG,U,2))
- SET (TXT,BIG)=1
- +6 IF (STYP="JR")
- if (LOCN=$PIECE(X0,U,5))
- SET (TGA,ABS,TXT)=1
- if (LOCN=$PIECE(XBIG,U,2))
- SET (TXT,BIG)=1
- +7 QUIT TXT_U_ABS_U_TGA_U_BIG
- +8 ;---------------------------------------------------------------------
- SETLOC(OUT,IM,NTLOC) ;RPC = MAG STORAGE FETCH SET
- +1 ;; Set the RAID location piece(NTLOC) in MAG(2005,IM includes 3,4 & FBIG
- +2 ;; OUT(1)= 1 success | IM = ien IMAGE file #2005
- +3 ;; 0 no action | NTLOC = network loction ien+(opt:overwrt "*" full or "@" .ABS or "b" .BIG) + (| source location)
- +4 ;; -1 error |
- +5 NEW OK,X,XBIG,Y,SRC
- +6 KILL OUT
- SET OUT(1)=0
- SET OK=0
- SET U="^"
- +7 ;source location ien
- SET SRC=+$PIECE($GET(NTLOC),"|",2)
- +8 IF '$GET(IM)
- SET OUT(1)="-1,No IMAGE IEN Specified ("_$GET(IM)_")"
- QUIT
- +9 IF $GET(NTLOC)=""
- SET OUT(1)="-1,No Network Location Specified"
- QUIT
- +10 ;no Set for router
- SET X=$GET(^MAG(2005.2,+NTLOC,0))
- if $PIECE(X,U,9)
- QUIT
- +11 IF $PIECE(X,U,2)=""
- SET OUT(1)="-1,Invalid Network Location "_NTLOC
- QUIT
- +12 IF $PIECE(X,U,7)["WORM"
- DO SETJBL
- QUIT
- +13 IF $PIECE(X,U,7)'="MAG"
- SET OUT(1)="0,Not a RAID/MAG nor a JB/WORM NETWORK LOCATION type - IEN "_NTLOC
- QUIT
- +14 SET (X,Y)=$GET(^MAG(2005,IM,0))
- IF X=""
- SET OUT(1)="-1,No IMAGE File entry - IEN "_IM
- QUIT
- +15 SET XBIG=$GET(^MAG(2005,IM,"FBIG"))
- +16 ;with the file(s) source info, use it to set RAID pt
- IF SRC>0
- Begin DoDot:1
- +17 ;ABS
- IF ($PIECE(X,U,4)=SRC)!($PIECE(X,U,5)=SRC)
- SET $PIECE(Y,U,4)=+NTLOC
- SET OK=1
- +18 ;full
- IF ($PIECE(X,U,3)=SRC)!($PIECE(X,U,5)=SRC)
- SET $PIECE(Y,U,3)=+NTLOC
- SET OK=1
- +19 IF OK
- SET ^MAG(2005,IM,0)=Y
- SET OUT(1)="1,Set RAID pointer for 2005 IMAGE IEN "_IM
- +20 IF ($PIECE(XBIG,U)=SRC)!($PIECE(XBIG,U,2)=SRC)
- SET $PIECE(^MAG(2005,IM,"FBIG"),"^")=+NTLOC
- SET OUT(1)=$SELECT(OK:OUT(1)_" w/FBIG",1:"1,Set RAID(FBIG) pointer for 2005 IMAGE IEN "_IM)
- +21 QUIT
- End DoDot:1
- QUIT
- +22 ;BIG file only
- IF (NTLOC["b")
- GOTO SETLOC4B
- +23 ;set ABS only
- IF (NTLOC["@")
- SET $PIECE(Y,U,4)=+NTLOC
- SET OK=1
- +24 IF '$TEST
- Begin DoDot:1
- +25 ;r : p3 only
- IF '$PIECE(X,U,4)!(NTLOC["*")
- if '(NTLOC["r")
- SET $PIECE(Y,U,4)=+NTLOC
- SET OK=1
- +26 ;set FULL
- IF '$PIECE(X,U,3)!(NTLOC["*")!(NTLOC["r")
- SET $PIECE(Y,U,3)=+NTLOC
- SET OK=1
- +27 QUIT
- End DoDot:1
- +28 IF OK
- SET ^MAG(2005,IM,0)=Y
- SET OUT(1)="1,Set RAID pointer for 2005 IMAGE IEN ,"_IM
- +29 IF OK=0
- IF $PIECE(X,U,3)
- IF (+NTLOC)'=$PIECE(X,U,3)
- SET OUT(1)="-1,Not setting #"_NTLOC_" already exist other network location #"_$PIECE(X,U,3)
- QUIT
- +30 ;no BIG file to set
- if XBIG=""!(XBIG="^")!(NTLOC["@")
- QUIT
- SETLOC4B ;BIG file RAID
- +1 SET $PIECE(^MAG(2005,IM,"FBIG"),"^")=+NTLOC
- SET OUT(1)=$SELECT(OK:OUT(1)_" w/FBIG",1:"1,Set RAID(FBIG) pointer for 2005 IMAGE IEN "_IM)
- +2 QUIT
- +3 ;
- SETJBL ;SET JB location
- +1 IF '$GET(NTLOC)=""
- SET OUT(1)="-1,No Network Location Specified"
- QUIT
- +2 SET (X,Y)=$GET(^MAG(2005,IM,0))
- IF X=""
- SET OUT(1)="-1,No Image File"_IM
- QUIT
- +3 SET XBIG=$GET(^MAG(2005,IM,"FBIG"))
- +4 ;with the source info, use it to set new jukebox pt
- IF SRC>0
- Begin DoDot:1
- +5 ;JB
- IF ($PIECE(X,U,3)=SRC)!($PIECE(X,U,4)=SRC)!($PIECE(X,U,5)=SRC)
- SET $PIECE(Y,U,5)=+NTLOC
- SET OK=1
- +6 IF OK
- SET ^MAG(2005,IM,0)=Y
- SET OUT(1)="1,Set JB pointer for 2005 IMAGE IEN "_IM
- +7 IF ($PIECE(XBIG,U)=SRC)!($PIECE(XBIG,U,2)=SRC)
- SET $PIECE(^MAG(2005,IM,"FBIG"),"^",2)=+NTLOC
- SET OUT(1)=$SELECT(OK:OUT(1)_" w/FBIG",1:"1,Set JB(FIBG) pointer for 2005 IMAGE IEN "_IM)
- +8 QUIT
- End DoDot:1
- QUIT
- +9 ;set FULL
- IF $PIECE(X,U,5)'=NTLOC
- SET $PIECE(Y,U,5)=+NTLOC
- SET OK=1
- +10 IF OK
- SET ^MAG(2005,IM,0)=Y
- SET OUT(1)="1,Set JB pointer for 2005 IMAGE IEN "_IM
- +11 ;no BIG
- if XBIG=""!(XBIG="^")
- QUIT
- +12 ;not same source loc
- IF SRC>0
- IF $PIECE(XBIG,U)'=SRC
- IF $PIECE(XBIG,U,2)'=SRC
- QUIT
- +13 SET $PIECE(^MAG(2005,IM,"FBIG"),"^",2)=+NTLOC
- SET OUT(1)=$SELECT(OK:OUT(1)_" w/FBIG",1:"1,Set JB(FIBG) pointer for 2005 IMAGE IEN "_IM)
- +14 QUIT
- +15 ;
- FINDIEN(DT1) ; Find last IEN mark(IN) to process on DT1
- +1 SET IN1=0
- SET IN2=$ORDER(^MAG(2005,"A"),-1)
- SET IN=(IN1+IN2)\2
- LOOP ;check image saved date
- +1 SET Y=$GET(^MAG(2005,IN,2))
- IF Y=""
- SET IN=IN+1
- IF IN<IN2
- GOTO LOOP
- +2 IF +Y>DT1
- SET IN2=IN
- SET IN=(IN1+IN2)\2
- +3 IF '$TEST
- SET IN1=IN
- SET IN=(IN1+IN2)\2
- +4 IF IN1'=IN
- IF IN2'=IN
- GOTO LOOP
- +5 QUIT IN
- +6 ;
- MAGFIX93(OUT,IEN) ;API - MAG UTIL FIX9.3, fix 9.3 10.3 file format (call by FETCH1)
- +1 ;; OUT() : result - DOS commands to rename(move) the 9.3 or 10.3 file name to 14.3
- +2 ;; for example: OUT(1) = "move abc123456.abs abc0\00\00\12\34\abc00000123456.abs"
- +3 ;; IEN : image file IEN
- +4 ;;
- +5 NEW NWNAME,NO,OFNAME,X,Y,LOCN,LOC,ODIR,EXT,NFNAME,NDIR,CMD,DIE,DA,DR,EXT1,CMD,X1,SITE
- +6 if '$DATA(U)
- SET U="^"
- +7 ;SITE ID
- SET SITE=+$PIECE($GET(^MAG(2005,IEN,100)),U,3)
- +8 if '$DATA(PLACE)
- SET PLACE=+$SELECT(SITE:$ORDER(^MAG(2006.1,"B",SITE,0)),1:$ORDER(^MAG(2006.1,0)))
- if 'PLACE
- SET PLACE=1
- +9 ;current site namespace
- SET LNO=2
- SET NWNAME=$PIECE(^MAG(2006.1,PLACE,0),U,2)
- +10 SET X=$GET(^MAG(2005,IEN,0))
- IF $LENGTH(X)
- Begin DoDot:1
- +11 ;GROUP no file reference
- SET Y=$PIECE(X,U,2)
- if Y=""
- QUIT
- +12 ;8.3 14.3 format
- SET OFNAME=$PIECE(Y,".")
- IF ($LENGTH(OFNAME)=8)!(OFNAME="")!($LENGTH(OFNAME)=14)
- QUIT
- +13 ;RAID location
- SET LOCN=$PIECE(X,U,3)
- if 'LOCN
- QUIT
- +14 ;;I $P(X,U,5) Q ;don't change file name w/ JB(WORM) copy
- +15 SET LOC=$PIECE($GET(^MAG(2005.2,LOCN,0)),U,2)
- if '$LENGTH(LOC)
- QUIT
- +16 SET ODIR=$$DIRHASH(OFNAME,LOCN)
- SET ODIR=$$CHKDIR(ODIR)
- +17 ;no extn?
- SET EXT=$PIECE(Y,".",2)
- if EXT=""
- QUIT
- +18 ;correct img file name
- SET NFNAME=NWNAME_$$PRE0(IEN)_IEN
- +19 SET NDIR=$$DIRHASH(NFNAME,LOCN)
- SET NDIR=$$CHKDIR(NDIR)
- +20 ;chk file exist
- SET OUT(2)="DIR "_LOC_ODIR_OFNAME_".*"
- +21 ; make sub dir
- IF $FIND(NDIR,"\")
- FOR NO=1:1
- SET X1=$PIECE(NDIR,"\",NO)
- if X1=""
- QUIT
- SET LNO=LNO+1
- SET OUT(LNO)="MKDIR "_LOC_$PIECE(NDIR,"\",1,NO)
- +22 IF '$TEST
- SET LNO=LNO+1
- SET OUT(LNO)="MKDIR "_LOC_NDIR
- +23 ;copy all possible extn types
- SET EXT1=""
- FOR EXT1="ABS","TXT","BIG",EXT
- Begin DoDot:2
- +24 IF EXT1="BIG"
- IF ($GET(XBIG)="")!($GET(XBIG)="^")
- QUIT
- +25 SET LNO=LNO+1
- SET OUT(LNO)="MOVE/Y "_LOC_ODIR_OFNAME_"."_EXT1_" "_LOC_NDIR_NFNAME_"."_EXT1
- +26 QUIT
- End DoDot:2
- +27 ;chg "F" X-REF
- SET DA=+IEN
- SET DR="1///"_NFNAME_"."_EXT
- SET DIE="^MAG(2005,"
- DO ^DIE
- +28 DO ENTRY^MAGLOG("MAG UTIL",$GET(DUZ),IEN,"MAG UTIL FIX9.3","","1",OFNAME_"=>"_NFNAME)
- +29 QUIT
- End DoDot:1
- +30 QUIT
- +31 ;
- PRE0(IEN) ;pre '0' for 14 characters => Namespace_nnnnnnnn_ien'
- +1 NEW NO,J
- +2 if $GET(NWNAME)=""
- SET NWNAME=$PIECE(^MAG(2006.1,PLACE,0),"^",2)
- +3 SET NO=""
- FOR J=1:1:(14-$LENGTH(IEN)-$LENGTH(NWNAME))
- SET NO=NO_"0"
- +4 QUIT NO
- +5 ;
- CHKDIR(DIR) ; chk "\\"
- +1 ;trim \\ at end
- NEW L
- SET L=$LENGTH(DIR)
- IF $EXTRACT(DIR,L-1,L)="\\"
- SET DIR=$EXTRACT(DIR,1,L-1)
- +2 QUIT DIR
- +3 ;
- DIRHASH(FILENAME,NETLOCN) ; determine the hierarchical file directory hash
- +1 ; Input Variables:
- +2 ; FILENAME -- the name of the file, with or without the extension
- +3 ; NETLOCN --- the network location file internal entry number
- +4 ; Return Value: the hierarchical file directory hash
- +5 NEW FN,HASHFLAG,HASH,I
- +6 SET HASHFLAG=$PIECE(^MAG(2005.2,NETLOCN,0),"^",8)
- +7 ; calculate the hierarchical directory hash
- IF HASHFLAG="Y"
- Begin DoDot:1
- +8 ; for an 8.3 filename AB123456.XYZ, the directory hash is AB\12\34
- +9 ; for a 14.3 filename BALT1234567890.XYZ, its BALT\12\34\56\78
- +10 ; strip off the extension
- SET FN=$PIECE(FILENAME,".")
- +11 IF $LENGTH(FN)=8
- SET HASH=$EXTRACT(FN,1,2)_"\"_$EXTRACT(FN,3,4)_"\"_$EXTRACT(FN,5,6)
- +12 IF '$TEST
- SET HASH=$EXTRACT(FN,1,4)
- FOR I=5,7,9,11
- SET HASH=HASH_"\"_$EXTRACT(FN,I,I+1)
- +13 ; add the trailing directory separator
- SET HASH=HASH_"\"
- +14 QUIT
- End DoDot:1
- +15 ; flat directory structure, no hierarchical hashing
- IF '$TEST
- SET HASH=""
- +16 QUIT HASH