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 Oct 16, 2024@18:09 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
