MAGQBUT6 ;WIOFO/RMP,JSL - Utility to Consolidate Redundant Network Location file Entries ; 17 JUL 2014 3:21 PM
;;3.0;IMAGING;**39,154**;Mar 19, 2002;Build 9;JUL 17, 2014
;; 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
CHKNAM(MAG) ; This is the input transform for the PLACE field in the Network location file.
N IEN,PLACE,VALUE
Q:'$D(MAG)
I 'DUZ(2) D K X Q
. D EN^DDIOL("You may only edit records for the configuration to which your login is associated!")
. Q
S PLACE=$$PLACE^MAGBAPI(+$G(DUZ(2)))
I $D(DA),$P($G(^MAG(2005.2,DA,0)),U,10),PLACE'=$P($G(^MAG(2005.2,DA,0)),U,10) D K X Q
. D EN^DDIOL("You may only edit records for the configuration to which your login is associated!")
. Q
S IEN="",VALUE=MAG
F S IEN=$O(^MAG(2005.2,"B",VALUE,IEN)) Q:'IEN D
. Q:$G(DA)=IEN
. I $P($G(^MAG(2005.2,IEN,0)),U,10)=PLACE D
. . D EN^DDIOL("Duplicate NAMES within the same VistA Imaging configuration (PLACE) is not allowed.")
. . K X
. . Q
. Q
Q
CHKNET(MAG) ; This is the input transform for the share path (PHYSICAL REFERENCE FIELD #1) in the network location file.
N UPPER,VALUE,PLACE,TABLE,IEN,TEMP,FAILED ; should convert all physical reference values to upper case
Q:'$D(MAG)
I '$G(DUZ(2)) D K X Q
. D EN^DDIOL("You may only edit records for the configuration to which your login is associated!")
. Q
S VALUE="",PLACE=$$PLACE^MAGBAPI(+$G(DUZ(2)))
I PLACE'=$P($G(^MAG(2005.2,DA,0)),U,10),DA'["+1" D K X Q
. D EN^DDIOL("You may only edit records for the configuration to which your login is associated!")
. Q
S UPPER=$$UPPER^MAGQE4(MAG),FAILED=""
Q:$P($G(^MAG(2005.2,DA,0)),U,7)["EKG" ;Allow to shared duplicate MUSE
F S VALUE=$O(^MAG(2005.2,"G",PLACE,VALUE)) Q:VALUE="" D Q:'$D(X)
. I UPPER=$$UPPER^MAGQE4(VALUE) D
. . S IEN=""
. . F S IEN=$O(^MAG(2005.2,"G",PLACE,VALUE,IEN)) Q:'IEN D Q:FAILED
. . . S TEMP=$P(^MAG(2005.2,IEN,0),U,7)_U_$P(^MAG(2005.2,IEN,0),U,8)_U_$P(^MAG(2005.2,IEN,0),U,9)
. . . I $D(TABLE(TEMP)) S FAILED=1 Q
. . . S TABLE(TEMP)=""
. . . Q
. . I +FAILED D Q
. . D EN^DDIOL("Duplicate PHYSICAL REFERENCE values within the same VistA Imaging configuration (PLACE) is not allowed.")
. . K X
. . Q
. Q
K TABLE
Q
CONSHR ; This is the interface for the Consolidate redundant shares utility
N LIST,EN,ENTRY,FLDAR,PLACE
S PLACE=$O(^MAG(2006.1,"B",$$KSP^XUPARAM("INST"),""))
D GETRL^MAGQBU6A(.LIST) ; Get Redundant List (of shares) where the path is the same.
S EN=$O(LIST("")) I EN="" D Q
. D PMSG("======================================================================")
. D DFNIQ^MAGQBPG1(""," Production Account: "_$$PROD^XUPROD("1"),0,PLACE,"Consolidate Shares")
. D PMSG(" Imaging patch MAG*3.0*39 found no redundant Network Location shares to consolidate.")
. D DFNIQ^MAGQBPG1("","Installation: Redundant Network Location Utility",1,PLACE,"Consolidate Shares")
. Q
D PMSG("======================================================================")
D DFNIQ^MAGQBPG1(""," Production Account: "_$$PROD^XUPROD("1"),0,PLACE,"Consolidate Shares")
D PMSG("Redundant Share List ")
D PMSG("(Share ^ Hash ^ Place) Prime IEN ^ 2nd IEN ...")
S EN="" F S EN=$O(LIST(EN)) Q:EN="" D PMSG("("_EN_")"_LIST(EN))
D PMSG("======================================================================")
D PMSG("")
D PMSG("Here is the list of shares that will be consolidated")
D PMSG("The share references that exist in both the 2005, 2005.1 & 2006.035 files")
D PMSG("will be reset to the PRIME share entry. ")
D DSPNL^MAGQBU6A ; Display the original Network Location file
D FAR(.FLDAR) ; Setup File/Node/Piece Table for FieldNumbers
;The following is being performed during the post install phase.
;D PRIME(.LIST) ; If any like shares are on - set the prime shares on
D SFRP(.LIST) ; DESTINATION field (#1) of the SEND QUEUE File (#2006.035)
;The following is being performed during the post install phase.
;D SPRR(.LIST) ; Site Parameter file re-reference (#.03,.07,.08,1.02,1.03,2.01,52,53,55)
S ENTRY=0 D RSREF(.LIST,ENTRY) ; Consolidate references
D RLOC^MAGQBU6A(.LIST) ; Delete Network Location file entry
D REQDUP^MAGQBU6A ; rename any duplicate .01 network location entries.
D REPNAM^MAGQBU6A ;Report residual duplicate names
D DFNIQ^MAGQBPG1("","Installation: Redundant Network Location Utility",1,PLACE,"Consolidate Shares")
K LIST
K ^TMP($J,"MAGQDFN")
Q
PRIME(LIST) ; If any like shares are on - set the prime shares on
N EMSG,EN,PC,FDA,MSG,PTMP,TMP
S EN="" F S EN=$O(LIST(EN)) Q:EN="" D
. S PTMP=$P(^MAG(2005.2,($P(LIST(EN),U)),0),U,6) Q:PTMP D
. . S FDA(2005.2,$P(LIST(EN),U,1)_",",5)="1"
. . D FILE^DIE("I","FDA","MSG")
. . I $D(MSG("DIERR")) D PMSG("Prime entry: '"_IEN_" failed to be set online. "_MSG("DIERR",1,"TEXT",1)) D Q
. . . K FDA,MSG
. . . Q
. . S EMSG="Prime entry "_$P(^MAG(2005.2,$P(LIST(EN),U),0),U)_", ^MAG(2005.2,"_$P(LIST(EN),U)_",0), was set to Online."
. . D DFNIQ^MAGQBPG1("",EMSG,0,PLACE,"Consolidate Shares")
. . K FDA,MSG
. . Q
. Q
Q
SPRR(LIST) ; Site Parameter file re-reference (#.03,.07,.08,1.02,1.03,2.01,52,53,55)
N EN,FDA,NEW,MSG,OLD,PC,MSG,TMP,VALUE
S EN=0 F S EN=$O(^MAG(2006.1,EN)) Q:'EN D
. ; fields: .03,.07,.08
. F PC=3,7,8 S (VALUE,TMP)=$P($G(^MAG(2006.1,EN,0)),U,PC) D
. . S VALUE=$$FRP(VALUE,.LIST) I VALUE D
. . . S FDA(2006.1,EN_",",FLDAR(2006.1,0,PC))=VALUE
. . . D FILE^DIE("I","FDA","MSG")
. . . I $D(MSG("DIERR")) D Q
. . . . D PMSG("Site Parameter Filing Error for IEN: "_IEN_MSG("DIERR",1,"TEXT",1)) K FDA,MSG
. . . . Q
. . . S FLD=$P(FLDAR(2006.1,0,PC),"^"),OLD=$P(^MAG(2005.2,TMP,0),"^"),NEW=$P(^MAG(2005.2,VALUE,0),"^")
. . . D PMSG("Field #"_FLDAR(2006.1,0,PC)_" Value: "_OLD_" Changed to New Value: "_NEW)
. . . D PMSG("^MAG(2006.1,"_EN_",0)"_" Piece "_PC) K FDA,MSG
. . . Q
. . Q
. ; fields: 1.02, 1.03
. F PC=2,3 S (VALUE,TMP)=$P($G(^MAG(2006.1,EN,"PACS")),U,PC) D
. . S VALUE=$$FRP(VALUE,.LIST) I VALUE D
. . . S FDA(2006.1,EN_",",FLDAR(2006.1,"PACS",PC))=VALUE
. . . D FILE^DIE("I","FDA","MSG")
. . . I $D(MSG("DIERR")) D Q
. . . . D PMSG("Site Parameter Filing Error for IEN: "_EN_MSG("DIERR",1,"TEXT",1)) K FDA,MSG
. . . . Q
. . . S OLD=$P(^MAG(2005.2,TMP,0),"^"),NEW=$P(^MAG(2005.2,VALUE,0),"^")
. . . D PMSG("Field #"_FLDAR(2006.1,"PACS",PC)_" Value: "_OLD_" Changed to New Value: "_NEW)
. . . D PMSG("^MAG(2006.1,"_EN_",PACS)"_" Piece "_PC) K FDA,MSG
. . . Q
. . Q
. ; field: 2.01
. S (VALUE,TMP)=$P($G(^MAG(2006.1,EN,1)),U,6) D
. . S VALUE=$$FRP(VALUE,.LIST) I VALUE D
. . . S FDA(2006.1,EN_",",FLDAR(2006.1,1,6))=VALUE
. . . D FILE^DIE("I","FDA","MSG")
. . . I $D(MSG("DIERR")) D Q
. . . . D PMSG("Site Parameter Filing Error for IEN: "_EN_" "_MSG("DIERR",1,"TEXT",1)) K FDA,MSG
. . . . Q
. . . S OLD=$P(^MAG(2005.2,TMP,0),"^"),NEW=$P(^MAG(2005.2,VALUE,0),"^")
. . . D PMSG("Field #"_FLDAR(2006.1,1,6)_" Value: "_OLD_" Changed to New Value: "_NEW)
. . . D PMSG("^MAG(2006.1,"_EN_",1)"_" Piece "_6) K FDA,MSG
. . . Q
. . Q
. ; fields: 52,53,55
. F PC=3,4,5 S (VALUE,TMP)=$P($G(^MAG(2006.1,EN,"NET")),U,PC) D
. . S VALUE=$$FRP(VALUE,.LIST) I VALUE D
. . . S FDA(2006.1,EN_",",FLDAR(2006.1,"NET",PC))=VALUE
. . . D FILE^DIE("I","FDA","MSG")
. . . I $D(MSG("DIERR")) D Q
. . . . D PMSG("Site Parameter Filing Error for IEN: "_EN_" "_MSG("DIERR",1,"TEXT",1)) K FDA,MSG
. . . . Q
. . . S OLD=$P(^MAG(2005.2,TMP,0),"^"),NEW=$P(^MAG(2005.2,VALUE,0),"^")
. . . D PMSG("Field #"_FLDAR(2006.1,"NET",PC)_" Value: "_OLD_" Changed to New Value: "_NEW)
. . . D PMSG("^MAG(2006.1,"_EN_",NET)"_" Piece "_PC) K FDA,MSG
. . . Q
. . Q
. Q
Q
SFRP(LIST) ; DESTINATION field (#1) of the SEND QUEUE File (#2006.035).
N EN,VALUE,TMP,FDA,MSG,TEXT,TMP,OLD
S EN=0 F S EN=$O(^MAGQUEUE(2006.035,EN)) Q:'EN D
. I $P($P($G(^MAGQUEUE(2006.035,EN,0)),U,2),";",2)="MAG(2005.2," D
. . S (VALUE,TMP)=$P($P($G(^MAGQUEUE(2006.035,EN,0)),U,2),";",1)
. . S VALUE=$$FRP(VALUE,.LIST) I VALUE D
. . . S TMP=$P($G(^MAGQUEUE(2006.035,EN,0)),U,2),OLD=$P(TMP,";"),$P(TMP,";")=VALUE
. . . S $P(^MAGQUEUE(2006.035,EN,0),U,2)=TMP,OLD=$P(^MAG(2005.2,OLD,0),U),NEW=$P(^MAG(2005.2,VALUE,0),U)
. . . S TEXT=("DESTINATION (#1) value: "_OLD_" changed to: "_NEW)
. . . S ^XTMP("MAGP39","IMAGEFILE",2006.035,EN,1)=TEXT
. . . Q
. . Q
. Q
Q
RSREF(LIST,IEN) ; Consolidate references
N GL,IEN,IENS,NODE,PIECE,FNUM,VALUE,SIEN,SPIECE,SNODE,FLD,SUB,MSG,FDA,TMP,TEXT
S GL="",IEN=$S(+$G(IEN):IEN,1:0)
F D SCAN^MAGQBPG1(.IEN,"F",.GL) D Q:'IEN
. Q:'IEN
. S FNUM=$S(GL[2005.1:2005.1,GL[2005:2005,1:"")
. S NODE=$G(^MAG(FNUM,IEN,0))
. F PIECE=3,4,5 S (VALUE,TMP)=$P(NODE,U,PIECE) D:VALUE
. . S VALUE=$$FRP(VALUE,.LIST) I VALUE D
. . . S FDA(FNUM,IEN_",",FLDAR(FNUM,0,PIECE))=VALUE
. . . D FILE^DIE("I","FDA","MSG")
. . . I $D(MSG("DIERR")) D Q
. . . . D PMSG($S(FNUM=2005:"Image File",1:"Image Archive")_" Filing Error for entry: "_IEN_MSG("DIERR",1,"TEXT",1)) K FDA,MSG
. . . . Q
. . . S TEXT="FIELD #"_FLDAR(FNUM,0,PIECE)_" value: "_TMP_" changed to: "_VALUE
. . . S ^XTMP("MAGP39","IMAGEFILE",FNUM,IEN,$G(FLDAR(FNUM,0,PIECE)))=TEXT
. . . Q
. . Q
. S NODE=$G(^MAG(FNUM,IEN,"FBIG"))
. F PIECE=1,2 S VALUE=$P(NODE,U,PIECE) D:VALUE
. . S (VALUE,TMP)=$$FRP(VALUE,.LIST) I VALUE D
. . . S FDA(FNUM,IEN_",",FLDAR(FNUM,"FBIG",PIECE))=VALUE
. . . D FILE^DIE("I","FDA","MSG")
. . . I $D(MSG("DIERR")) D Q
. . . . D PMSG($S(FNUM=2005:"Image File",1:"Image Archive")_" Filing Error for IEN: "_IEN_MSG("DIERR",1,"TEXT",1)) K FDA,MSG
. . . . Q
. . . S TEXT="FIELD #"_FLDAR(FNUM,"FBIG",PIECE)_" Value: "_TMP_" changed to: "_VALUE
. . . S ^XTMP("MAGP39","IMAGEFILE",FNUM,IEN,$G(FLDAR(FNUM,"FBIG",PIECE)))=TEXT
. . . Q
. . Q
. F SNODE=4,5,6 I $D(^MAG(FNUM,IEN,SNODE)) D ;ROUTING TIMESTAMP, EXPORT LOCATION, ROUTING LOG
. . S SIEN=0,SPIECE=$S(SNODE=4:2,SNODE=5:1,SNODE=6:2) F S SIEN=$O(^MAG(FNUM,IEN,SNODE,SIEN)) Q:'SIEN D
. . . S (VALUE,TMP)=$P($G(^MAG(FNUM,IEN,SNODE,SIEN,0)),U,SPIECE)
. . . S VALUE=$$FRP(VALUE,.LIST) I VALUE D
. . . . I SNODE=4,FNUM=2005 S SUB=2005.0106
. . . . I SNODE=4,FNUM=2005.1 S SUB=2005.1106
. . . . I SNODE=5,FNUM=2005 S SUB=2005.01
. . . . I SNODE=5,FNUM=2005.1 S SUB=2005.11
. . . . I SNODE=6,FNUM=2005 S SUB=2005.0111
. . . . I SNODE=6,FNUM=2005.1 S SUB=2005.1111
. . . . S IENS=SIEN_","_IEN_","
. . . . S FDA(SUB,IENS,FLDAR(SUB,0,SPIECE))=VALUE
. . . . D FILE^DIE("I","FDA","MSG")
. . . . I $D(MSG("DIERR")) D Q
. . . . . D PMSG($S(FNUM=2005:"Image File",1:"Image Archive")_" Filing Error for IEN: "_IEN_MSG("DIERR",1,"TEXT",1)) K FDA,MSG
. . . . . Q
. . . . S TEXT=SUB_" FIELD #"_FLDAR(SUB,0,SPIECE)_" value: "_TMP_" changed to: "_VALUE
. . . . S ^XTMP("MAGP39","IMAGEFILE",FNUM,IEN,SUB_$G(FLDAR(SUB,0,SPIECE)))=TEXT
. . . . Q
. . . Q
. . Q
. S ^XTMP("MAGP39","DUPSHARE","LAST")=IEN
. Q
Q
FRP(IEN,LIST) ;Find entry number in list and return the primary
N EN,PN,PC
S EN="",PN=0 F S EN=$O(LIST(EN)) Q:EN="" D Q:PN
. I (U_$P(LIST(EN),U,2,99)_U)[(U_IEN_U) S PN=$P(LIST(EN),U)
. Q
Q PN
PMSG(TXT) ; Display to Screen and Build E-MAIL content
D DFNIQ^MAGQBPG1("",TXT,0,PLACE,"Consolidate Shares")
Q
FAR(FLDAR) ; Setup File/Node/Piece Table for FieldNumbers
S FLDAR(2006.1,0,3)=.03
S FLDAR(2006.1,0,7)=.07
S FLDAR(2006.1,0,8)=.08
S FLDAR(2006.1,1,6)=2.01
S FLDAR(2006.1,"PACS",2)=1.02
S FLDAR(2006.1,"PACS",3)=1.03
S FLDAR(2006.1,"NET",3)=52
S FLDAR(2006.1,"NET",4)=53
S FLDAR(2006.1,"NET",5)=55
S FLDAR(2005,0,3)=2
S FLDAR(2005,0,4)=2.1
S FLDAR(2005,0,5)=2.2
S FLDAR(2005,"FBIG",1)=102
S FLDAR(2005,"FBIG",2)=103
S FLDAR(2005.1,0,3)=2
S FLDAR(2005.1,0,4)=2.1
S FLDAR(2005.1,0,5)=2.2
S FLDAR(2005.1,"FBIG",1)=102
S FLDAR(2005.1,"FBIG",2)=103
S FLDAR(2005.0106,0,2)=2
S FLDAR(2005.1106,0,2)=2
S FLDAR(2005.01,0,1)=.01
S FLDAR(2005.11,0,1)=.01
S FLDAR(2005.0111,0,2)=2
S FLDAR(2005.1111,0,2)=2
Q
RTRS ;Check to see if any network locations are routers & send an email
N EN,IEN,IENS,NLIST,PRIME,RTR,SITE
D GETRL^MAGQBU6A(.NLIST) S PLACE=$O(^MAG(2006.1,"B",$$KSP^XUPARAM("INST"),""))
S EN=$O(NLIST("")) I EN="" Q ;No duplicate network locations.
S (RTR,EN)="" F S EN=$O(NLIST(EN)) Q:EN="" F PC=2:1:$L(NLIST(EN),U) D
. I $P(^MAG(2005.2,+$P(NLIST(EN),U,PC),0),U,9) S RTR(EN)=$G(NLIST(EN)) Q
. Q
S EN=$O(RTR("")) I EN="" Q ;No duplicate router network locations.
D RMSG S EN="" F S EN=$O(RTR(EN)) Q:EN="" D
. S IEN=$P(RTR(EN),U),PRIME=$P(^MAG(2005.2,+IEN,0),U),SITE=$P(^MAG(2005.2,+IEN,0),U,10)
. D PMSG("Prime entry is IEN:"_IEN_" Name: "_PRIME_" "_$P(^MAG(2005.2,+IEN,0),U,2)_" SITE: "_$P(^MAG(2006.1,+SITE,0),U))
. D PMSG(" Duplicate entries that are marked for deletion: ") F PC=2:1:$L(RTR(EN),U) D
. . D PMSG(" IEN: "_+$P(RTR(EN),U,PC)_" Name: "_$P(^MAG(2005.2,+$P(RTR(EN),"^",PC),0),U))
. . Q
. Q
D:$G(PRIME)]"" DFNIQ^MAGQBPG1("","Installation: Possible Duplicate Router Shares",1,PLACE,"Consolidate Shares")
Q
RMSG ;
D PMSG("The following entries may be defined as 'ROUTERS'.")
D PMSG("Review the ROUTE.DIC file on each Routing DICOM Gateway")
D PMSG("and replace any duplicate entries with prime entries.")
D PMSG("======================================================================")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMAGQBUT6 14350 printed Dec 13, 2024@02:07:59 Page 2
MAGQBUT6 ;WIOFO/RMP,JSL - Utility to Consolidate Redundant Network Location file Entries ; 17 JUL 2014 3:21 PM
+1 ;;3.0;IMAGING;**39,154**;Mar 19, 2002;Build 9;JUL 17, 2014
+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
CHKNAM(MAG) ; This is the input transform for the PLACE field in the Network location file.
+1 NEW IEN,PLACE,VALUE
+2 if '$DATA(MAG)
QUIT
+3 IF 'DUZ(2)
Begin DoDot:1
+4 DO EN^DDIOL("You may only edit records for the configuration to which your login is associated!")
+5 QUIT
End DoDot:1
KILL X
QUIT
+6 SET PLACE=$$PLACE^MAGBAPI(+$GET(DUZ(2)))
+7 IF $DATA(DA)
IF $PIECE($GET(^MAG(2005.2,DA,0)),U,10)
IF PLACE'=$PIECE($GET(^MAG(2005.2,DA,0)),U,10)
Begin DoDot:1
+8 DO EN^DDIOL("You may only edit records for the configuration to which your login is associated!")
+9 QUIT
End DoDot:1
KILL X
QUIT
+10 SET IEN=""
SET VALUE=MAG
+11 FOR
SET IEN=$ORDER(^MAG(2005.2,"B",VALUE,IEN))
if 'IEN
QUIT
Begin DoDot:1
+12 if $GET(DA)=IEN
QUIT
+13 IF $PIECE($GET(^MAG(2005.2,IEN,0)),U,10)=PLACE
Begin DoDot:2
+14 DO EN^DDIOL("Duplicate NAMES within the same VistA Imaging configuration (PLACE) is not allowed.")
+15 KILL X
+16 QUIT
End DoDot:2
+17 QUIT
End DoDot:1
+18 QUIT
CHKNET(MAG) ; This is the input transform for the share path (PHYSICAL REFERENCE FIELD #1) in the network location file.
+1 ; should convert all physical reference values to upper case
NEW UPPER,VALUE,PLACE,TABLE,IEN,TEMP,FAILED
+2 if '$DATA(MAG)
QUIT
+3 IF '$GET(DUZ(2))
Begin DoDot:1
+4 DO EN^DDIOL("You may only edit records for the configuration to which your login is associated!")
+5 QUIT
End DoDot:1
KILL X
QUIT
+6 SET VALUE=""
SET PLACE=$$PLACE^MAGBAPI(+$GET(DUZ(2)))
+7 IF PLACE'=$PIECE($GET(^MAG(2005.2,DA,0)),U,10)
IF DA'["+1"
Begin DoDot:1
+8 DO EN^DDIOL("You may only edit records for the configuration to which your login is associated!")
+9 QUIT
End DoDot:1
KILL X
QUIT
+10 SET UPPER=$$UPPER^MAGQE4(MAG)
SET FAILED=""
+11 ;Allow to shared duplicate MUSE
if $PIECE($GET(^MAG(2005.2,DA,0)),U,7)["EKG"
QUIT
+12 FOR
SET VALUE=$ORDER(^MAG(2005.2,"G",PLACE,VALUE))
if VALUE=""
QUIT
Begin DoDot:1
+13 IF UPPER=$$UPPER^MAGQE4(VALUE)
Begin DoDot:2
+14 SET IEN=""
+15 FOR
SET IEN=$ORDER(^MAG(2005.2,"G",PLACE,VALUE,IEN))
if 'IEN
QUIT
Begin DoDot:3
+16 SET TEMP=$PIECE(^MAG(2005.2,IEN,0),U,7)_U_$PIECE(^MAG(2005.2,IEN,0),U,8)_U_$PIECE(^MAG(2005.2,IEN,0),U,9)
+17 IF $DATA(TABLE(TEMP))
SET FAILED=1
QUIT
+18 SET TABLE(TEMP)=""
+19 QUIT
End DoDot:3
if FAILED
QUIT
+20 IF +FAILED
Begin DoDot:3
End DoDot:3
QUIT
+21 DO EN^DDIOL("Duplicate PHYSICAL REFERENCE values within the same VistA Imaging configuration (PLACE) is not allowed.")
+22 KILL X
+23 QUIT
End DoDot:2
+24 QUIT
End DoDot:1
if '$DATA(X)
QUIT
+25 KILL TABLE
+26 QUIT
CONSHR ; This is the interface for the Consolidate redundant shares utility
+1 NEW LIST,EN,ENTRY,FLDAR,PLACE
+2 SET PLACE=$ORDER(^MAG(2006.1,"B",$$KSP^XUPARAM("INST"),""))
+3 ; Get Redundant List (of shares) where the path is the same.
DO GETRL^MAGQBU6A(.LIST)
+4 SET EN=$ORDER(LIST(""))
IF EN=""
Begin DoDot:1
+5 DO PMSG("======================================================================")
+6 DO DFNIQ^MAGQBPG1(""," Production Account: "_$$PROD^XUPROD("1"),0,PLACE,"Consolidate Shares")
+7 DO PMSG(" Imaging patch MAG*3.0*39 found no redundant Network Location shares to consolidate.")
+8 DO DFNIQ^MAGQBPG1("","Installation: Redundant Network Location Utility",1,PLACE,"Consolidate Shares")
+9 QUIT
End DoDot:1
QUIT
+10 DO PMSG("======================================================================")
+11 DO DFNIQ^MAGQBPG1(""," Production Account: "_$$PROD^XUPROD("1"),0,PLACE,"Consolidate Shares")
+12 DO PMSG("Redundant Share List ")
+13 DO PMSG("(Share ^ Hash ^ Place) Prime IEN ^ 2nd IEN ...")
+14 SET EN=""
FOR
SET EN=$ORDER(LIST(EN))
if EN=""
QUIT
DO PMSG("("_EN_")"_LIST(EN))
+15 DO PMSG("======================================================================")
+16 DO PMSG("")
+17 DO PMSG("Here is the list of shares that will be consolidated")
+18 DO PMSG("The share references that exist in both the 2005, 2005.1 & 2006.035 files")
+19 DO PMSG("will be reset to the PRIME share entry. ")
+20 ; Display the original Network Location file
DO DSPNL^MAGQBU6A
+21 ; Setup File/Node/Piece Table for FieldNumbers
DO FAR(.FLDAR)
+22 ;The following is being performed during the post install phase.
+23 ;D PRIME(.LIST) ; If any like shares are on - set the prime shares on
+24 ; DESTINATION field (#1) of the SEND QUEUE File (#2006.035)
DO SFRP(.LIST)
+25 ;The following is being performed during the post install phase.
+26 ;D SPRR(.LIST) ; Site Parameter file re-reference (#.03,.07,.08,1.02,1.03,2.01,52,53,55)
+27 ; Consolidate references
SET ENTRY=0
DO RSREF(.LIST,ENTRY)
+28 ; Delete Network Location file entry
DO RLOC^MAGQBU6A(.LIST)
+29 ; rename any duplicate .01 network location entries.
DO REQDUP^MAGQBU6A
+30 ;Report residual duplicate names
DO REPNAM^MAGQBU6A
+31 DO DFNIQ^MAGQBPG1("","Installation: Redundant Network Location Utility",1,PLACE,"Consolidate Shares")
+32 KILL LIST
+33 KILL ^TMP($JOB,"MAGQDFN")
+34 QUIT
PRIME(LIST) ; If any like shares are on - set the prime shares on
+1 NEW EMSG,EN,PC,FDA,MSG,PTMP,TMP
+2 SET EN=""
FOR
SET EN=$ORDER(LIST(EN))
if EN=""
QUIT
Begin DoDot:1
+3 SET PTMP=$PIECE(^MAG(2005.2,($PIECE(LIST(EN),U)),0),U,6)
if PTMP
QUIT
Begin DoDot:2
+4 SET FDA(2005.2,$PIECE(LIST(EN),U,1)_",",5)="1"
+5 DO FILE^DIE("I","FDA","MSG")
+6 IF $DATA(MSG("DIERR"))
DO PMSG("Prime entry: '"_IEN_" failed to be set online. "_MSG("DIERR",1,"TEXT",1))
Begin DoDot:3
+7 KILL FDA,MSG
+8 QUIT
End DoDot:3
QUIT
+9 SET EMSG="Prime entry "_$PIECE(^MAG(2005.2,$PIECE(LIST(EN),U),0),U)_", ^MAG(2005.2,"_$PIECE(LIST(EN),U)_",0), was set to Online."
+10 DO DFNIQ^MAGQBPG1("",EMSG,0,PLACE,"Consolidate Shares")
+11 KILL FDA,MSG
+12 QUIT
End DoDot:2
+13 QUIT
End DoDot:1
+14 QUIT
SPRR(LIST) ; Site Parameter file re-reference (#.03,.07,.08,1.02,1.03,2.01,52,53,55)
+1 NEW EN,FDA,NEW,MSG,OLD,PC,MSG,TMP,VALUE
+2 SET EN=0
FOR
SET EN=$ORDER(^MAG(2006.1,EN))
if 'EN
QUIT
Begin DoDot:1
+3 ; fields: .03,.07,.08
+4 FOR PC=3,7,8
SET (VALUE,TMP)=$PIECE($GET(^MAG(2006.1,EN,0)),U,PC)
Begin DoDot:2
+5 SET VALUE=$$FRP(VALUE,.LIST)
IF VALUE
Begin DoDot:3
+6 SET FDA(2006.1,EN_",",FLDAR(2006.1,0,PC))=VALUE
+7 DO FILE^DIE("I","FDA","MSG")
+8 IF $DATA(MSG("DIERR"))
Begin DoDot:4
+9 DO PMSG("Site Parameter Filing Error for IEN: "_IEN_MSG("DIERR",1,"TEXT",1))
KILL FDA,MSG
+10 QUIT
End DoDot:4
QUIT
+11 SET FLD=$PIECE(FLDAR(2006.1,0,PC),"^")
SET OLD=$PIECE(^MAG(2005.2,TMP,0),"^")
SET NEW=$PIECE(^MAG(2005.2,VALUE,0),"^")
+12 DO PMSG("Field #"_FLDAR(2006.1,0,PC)_" Value: "_OLD_" Changed to New Value: "_NEW)
+13 DO PMSG("^MAG(2006.1,"_EN_",0)"_" Piece "_PC)
KILL FDA,MSG
+14 QUIT
End DoDot:3
+15 QUIT
End DoDot:2
+16 ; fields: 1.02, 1.03
+17 FOR PC=2,3
SET (VALUE,TMP)=$PIECE($GET(^MAG(2006.1,EN,"PACS")),U,PC)
Begin DoDot:2
+18 SET VALUE=$$FRP(VALUE,.LIST)
IF VALUE
Begin DoDot:3
+19 SET FDA(2006.1,EN_",",FLDAR(2006.1,"PACS",PC))=VALUE
+20 DO FILE^DIE("I","FDA","MSG")
+21 IF $DATA(MSG("DIERR"))
Begin DoDot:4
+22 DO PMSG("Site Parameter Filing Error for IEN: "_EN_MSG("DIERR",1,"TEXT",1))
KILL FDA,MSG
+23 QUIT
End DoDot:4
QUIT
+24 SET OLD=$PIECE(^MAG(2005.2,TMP,0),"^")
SET NEW=$PIECE(^MAG(2005.2,VALUE,0),"^")
+25 DO PMSG("Field #"_FLDAR(2006.1,"PACS",PC)_" Value: "_OLD_" Changed to New Value: "_NEW)
+26 DO PMSG("^MAG(2006.1,"_EN_",PACS)"_" Piece "_PC)
KILL FDA,MSG
+27 QUIT
End DoDot:3
+28 QUIT
End DoDot:2
+29 ; field: 2.01
+30 SET (VALUE,TMP)=$PIECE($GET(^MAG(2006.1,EN,1)),U,6)
Begin DoDot:2
+31 SET VALUE=$$FRP(VALUE,.LIST)
IF VALUE
Begin DoDot:3
+32 SET FDA(2006.1,EN_",",FLDAR(2006.1,1,6))=VALUE
+33 DO FILE^DIE("I","FDA","MSG")
+34 IF $DATA(MSG("DIERR"))
Begin DoDot:4
+35 DO PMSG("Site Parameter Filing Error for IEN: "_EN_" "_MSG("DIERR",1,"TEXT",1))
KILL FDA,MSG
+36 QUIT
End DoDot:4
QUIT
+37 SET OLD=$PIECE(^MAG(2005.2,TMP,0),"^")
SET NEW=$PIECE(^MAG(2005.2,VALUE,0),"^")
+38 DO PMSG("Field #"_FLDAR(2006.1,1,6)_" Value: "_OLD_" Changed to New Value: "_NEW)
+39 DO PMSG("^MAG(2006.1,"_EN_",1)"_" Piece "_6)
KILL FDA,MSG
+40 QUIT
End DoDot:3
+41 QUIT
End DoDot:2
+42 ; fields: 52,53,55
+43 FOR PC=3,4,5
SET (VALUE,TMP)=$PIECE($GET(^MAG(2006.1,EN,"NET")),U,PC)
Begin DoDot:2
+44 SET VALUE=$$FRP(VALUE,.LIST)
IF VALUE
Begin DoDot:3
+45 SET FDA(2006.1,EN_",",FLDAR(2006.1,"NET",PC))=VALUE
+46 DO FILE^DIE("I","FDA","MSG")
+47 IF $DATA(MSG("DIERR"))
Begin DoDot:4
+48 DO PMSG("Site Parameter Filing Error for IEN: "_EN_" "_MSG("DIERR",1,"TEXT",1))
KILL FDA,MSG
+49 QUIT
End DoDot:4
QUIT
+50 SET OLD=$PIECE(^MAG(2005.2,TMP,0),"^")
SET NEW=$PIECE(^MAG(2005.2,VALUE,0),"^")
+51 DO PMSG("Field #"_FLDAR(2006.1,"NET",PC)_" Value: "_OLD_" Changed to New Value: "_NEW)
+52 DO PMSG("^MAG(2006.1,"_EN_",NET)"_" Piece "_PC)
KILL FDA,MSG
+53 QUIT
End DoDot:3
+54 QUIT
End DoDot:2
+55 QUIT
End DoDot:1
+56 QUIT
SFRP(LIST) ; DESTINATION field (#1) of the SEND QUEUE File (#2006.035).
+1 NEW EN,VALUE,TMP,FDA,MSG,TEXT,TMP,OLD
+2 SET EN=0
FOR
SET EN=$ORDER(^MAGQUEUE(2006.035,EN))
if 'EN
QUIT
Begin DoDot:1
+3 IF $PIECE($PIECE($GET(^MAGQUEUE(2006.035,EN,0)),U,2),";",2)="MAG(2005.2,"
Begin DoDot:2
+4 SET (VALUE,TMP)=$PIECE($PIECE($GET(^MAGQUEUE(2006.035,EN,0)),U,2),";",1)
+5 SET VALUE=$$FRP(VALUE,.LIST)
IF VALUE
Begin DoDot:3
+6 SET TMP=$PIECE($GET(^MAGQUEUE(2006.035,EN,0)),U,2)
SET OLD=$PIECE(TMP,";")
SET $PIECE(TMP,";")=VALUE
+7 SET $PIECE(^MAGQUEUE(2006.035,EN,0),U,2)=TMP
SET OLD=$PIECE(^MAG(2005.2,OLD,0),U)
SET NEW=$PIECE(^MAG(2005.2,VALUE,0),U)
+8 SET TEXT=("DESTINATION (#1) value: "_OLD_" changed to: "_NEW)
+9 SET ^XTMP("MAGP39","IMAGEFILE",2006.035,EN,1)=TEXT
+10 QUIT
End DoDot:3
+11 QUIT
End DoDot:2
+12 QUIT
End DoDot:1
+13 QUIT
RSREF(LIST,IEN) ; Consolidate references
+1 NEW GL,IEN,IENS,NODE,PIECE,FNUM,VALUE,SIEN,SPIECE,SNODE,FLD,SUB,MSG,FDA,TMP,TEXT
+2 SET GL=""
SET IEN=$SELECT(+$GET(IEN):IEN,1:0)
+3 FOR
DO SCAN^MAGQBPG1(.IEN,"F",.GL)
Begin DoDot:1
+4 if 'IEN
QUIT
+5 SET FNUM=$SELECT(GL[2005.1:2005.1,GL[2005:2005,1:"")
+6 SET NODE=$GET(^MAG(FNUM,IEN,0))
+7 FOR PIECE=3,4,5
SET (VALUE,TMP)=$PIECE(NODE,U,PIECE)
if VALUE
Begin DoDot:2
+8 SET VALUE=$$FRP(VALUE,.LIST)
IF VALUE
Begin DoDot:3
+9 SET FDA(FNUM,IEN_",",FLDAR(FNUM,0,PIECE))=VALUE
+10 DO FILE^DIE("I","FDA","MSG")
+11 IF $DATA(MSG("DIERR"))
Begin DoDot:4
+12 DO PMSG($SELECT(FNUM=2005:"Image File",1:"Image Archive")_" Filing Error for entry: "_IEN_MSG("DIERR",1,"TEXT",1))
KILL FDA,MSG
+13 QUIT
End DoDot:4
QUIT
+14 SET TEXT="FIELD #"_FLDAR(FNUM,0,PIECE)_" value: "_TMP_" changed to: "_VALUE
+15 SET ^XTMP("MAGP39","IMAGEFILE",FNUM,IEN,$GET(FLDAR(FNUM,0,PIECE)))=TEXT
+16 QUIT
End DoDot:3
+17 QUIT
End DoDot:2
+18 SET NODE=$GET(^MAG(FNUM,IEN,"FBIG"))
+19 FOR PIECE=1,2
SET VALUE=$PIECE(NODE,U,PIECE)
if VALUE
Begin DoDot:2
+20 SET (VALUE,TMP)=$$FRP(VALUE,.LIST)
IF VALUE
Begin DoDot:3
+21 SET FDA(FNUM,IEN_",",FLDAR(FNUM,"FBIG",PIECE))=VALUE
+22 DO FILE^DIE("I","FDA","MSG")
+23 IF $DATA(MSG("DIERR"))
Begin DoDot:4
+24 DO PMSG($SELECT(FNUM=2005:"Image File",1:"Image Archive")_" Filing Error for IEN: "_IEN_MSG("DIERR",1,"TEXT",1))
KILL FDA,MSG
+25 QUIT
End DoDot:4
QUIT
+26 SET TEXT="FIELD #"_FLDAR(FNUM,"FBIG",PIECE)_" Value: "_TMP_" changed to: "_VALUE
+27 SET ^XTMP("MAGP39","IMAGEFILE",FNUM,IEN,$GET(FLDAR(FNUM,"FBIG",PIECE)))=TEXT
+28 QUIT
End DoDot:3
+29 QUIT
End DoDot:2
+30 ;ROUTING TIMESTAMP, EXPORT LOCATION, ROUTING LOG
FOR SNODE=4,5,6
IF $DATA(^MAG(FNUM,IEN,SNODE))
Begin DoDot:2
+31 SET SIEN=0
SET SPIECE=$SELECT(SNODE=4:2,SNODE=5:1,SNODE=6:2)
FOR
SET SIEN=$ORDER(^MAG(FNUM,IEN,SNODE,SIEN))
if 'SIEN
QUIT
Begin DoDot:3
+32 SET (VALUE,TMP)=$PIECE($GET(^MAG(FNUM,IEN,SNODE,SIEN,0)),U,SPIECE)
+33 SET VALUE=$$FRP(VALUE,.LIST)
IF VALUE
Begin DoDot:4
+34 IF SNODE=4
IF FNUM=2005
SET SUB=2005.0106
+35 IF SNODE=4
IF FNUM=2005.1
SET SUB=2005.1106
+36 IF SNODE=5
IF FNUM=2005
SET SUB=2005.01
+37 IF SNODE=5
IF FNUM=2005.1
SET SUB=2005.11
+38 IF SNODE=6
IF FNUM=2005
SET SUB=2005.0111
+39 IF SNODE=6
IF FNUM=2005.1
SET SUB=2005.1111
+40 SET IENS=SIEN_","_IEN_","
+41 SET FDA(SUB,IENS,FLDAR(SUB,0,SPIECE))=VALUE
+42 DO FILE^DIE("I","FDA","MSG")
+43 IF $DATA(MSG("DIERR"))
Begin DoDot:5
+44 DO PMSG($SELECT(FNUM=2005:"Image File",1:"Image Archive")_" Filing Error for IEN: "_IEN_MSG("DIERR",1,"TEXT",1))
KILL FDA,MSG
+45 QUIT
End DoDot:5
QUIT
+46 SET TEXT=SUB_" FIELD #"_FLDAR(SUB,0,SPIECE)_" value: "_TMP_" changed to: "_VALUE
+47 SET ^XTMP("MAGP39","IMAGEFILE",FNUM,IEN,SUB_$GET(FLDAR(SUB,0,SPIECE)))=TEXT
+48 QUIT
End DoDot:4
+49 QUIT
End DoDot:3
+50 QUIT
End DoDot:2
+51 SET ^XTMP("MAGP39","DUPSHARE","LAST")=IEN
+52 QUIT
End DoDot:1
if 'IEN
QUIT
+53 QUIT
FRP(IEN,LIST) ;Find entry number in list and return the primary
+1 NEW EN,PN,PC
+2 SET EN=""
SET PN=0
FOR
SET EN=$ORDER(LIST(EN))
if EN=""
QUIT
Begin DoDot:1
+3 IF (U_$PIECE(LIST(EN),U,2,99)_U)[(U_IEN_U)
SET PN=$PIECE(LIST(EN),U)
+4 QUIT
End DoDot:1
if PN
QUIT
+5 QUIT PN
PMSG(TXT) ; Display to Screen and Build E-MAIL content
+1 DO DFNIQ^MAGQBPG1("",TXT,0,PLACE,"Consolidate Shares")
+2 QUIT
FAR(FLDAR) ; Setup File/Node/Piece Table for FieldNumbers
+1 SET FLDAR(2006.1,0,3)=.03
+2 SET FLDAR(2006.1,0,7)=.07
+3 SET FLDAR(2006.1,0,8)=.08
+4 SET FLDAR(2006.1,1,6)=2.01
+5 SET FLDAR(2006.1,"PACS",2)=1.02
+6 SET FLDAR(2006.1,"PACS",3)=1.03
+7 SET FLDAR(2006.1,"NET",3)=52
+8 SET FLDAR(2006.1,"NET",4)=53
+9 SET FLDAR(2006.1,"NET",5)=55
+10 SET FLDAR(2005,0,3)=2
+11 SET FLDAR(2005,0,4)=2.1
+12 SET FLDAR(2005,0,5)=2.2
+13 SET FLDAR(2005,"FBIG",1)=102
+14 SET FLDAR(2005,"FBIG",2)=103
+15 SET FLDAR(2005.1,0,3)=2
+16 SET FLDAR(2005.1,0,4)=2.1
+17 SET FLDAR(2005.1,0,5)=2.2
+18 SET FLDAR(2005.1,"FBIG",1)=102
+19 SET FLDAR(2005.1,"FBIG",2)=103
+20 SET FLDAR(2005.0106,0,2)=2
+21 SET FLDAR(2005.1106,0,2)=2
+22 SET FLDAR(2005.01,0,1)=.01
+23 SET FLDAR(2005.11,0,1)=.01
+24 SET FLDAR(2005.0111,0,2)=2
+25 SET FLDAR(2005.1111,0,2)=2
+26 QUIT
RTRS ;Check to see if any network locations are routers & send an email
+1 NEW EN,IEN,IENS,NLIST,PRIME,RTR,SITE
+2 DO GETRL^MAGQBU6A(.NLIST)
SET PLACE=$ORDER(^MAG(2006.1,"B",$$KSP^XUPARAM("INST"),""))
+3 ;No duplicate network locations.
SET EN=$ORDER(NLIST(""))
IF EN=""
QUIT
+4 SET (RTR,EN)=""
FOR
SET EN=$ORDER(NLIST(EN))
if EN=""
QUIT
FOR PC=2:1:$LENGTH(NLIST(EN),U)
Begin DoDot:1
+5 IF $PIECE(^MAG(2005.2,+$PIECE(NLIST(EN),U,PC),0),U,9)
SET RTR(EN)=$GET(NLIST(EN))
QUIT
+6 QUIT
End DoDot:1
+7 ;No duplicate router network locations.
SET EN=$ORDER(RTR(""))
IF EN=""
QUIT
+8 DO RMSG
SET EN=""
FOR
SET EN=$ORDER(RTR(EN))
if EN=""
QUIT
Begin DoDot:1
+9 SET IEN=$PIECE(RTR(EN),U)
SET PRIME=$PIECE(^MAG(2005.2,+IEN,0),U)
SET SITE=$PIECE(^MAG(2005.2,+IEN,0),U,10)
+10 DO PMSG("Prime entry is IEN:"_IEN_" Name: "_PRIME_" "_$PIECE(^MAG(2005.2,+IEN,0),U,2)_" SITE: "_$PIECE(^MAG(2006.1,+SITE,0),U))
+11 DO PMSG(" Duplicate entries that are marked for deletion: ")
FOR PC=2:1:$LENGTH(RTR(EN),U)
Begin DoDot:2
+12 DO PMSG(" IEN: "_+$PIECE(RTR(EN),U,PC)_" Name: "_$PIECE(^MAG(2005.2,+$PIECE(RTR(EN),"^",PC),0),U))
+13 QUIT
End DoDot:2
+14 QUIT
End DoDot:1
+15 if $GET(PRIME)]""
DO DFNIQ^MAGQBPG1("","Installation: Possible Duplicate Router Shares",1,PLACE,"Consolidate Shares")
+16 QUIT
RMSG ;
+1 DO PMSG("The following entries may be defined as 'ROUTERS'.")
+2 DO PMSG("Review the ROUTE.DIC file on each Routing DICOM Gateway")
+3 DO PMSG("and replace any duplicate entries with prime entries.")
+4 DO PMSG("======================================================================")
+5 QUIT
