MAGIPS54 ;Post init routine to queue site activity at install. ; 09/11/2008 02:17 pm
;;3.0;IMAGING;**54**;03-July-2009;;Build 1424
;; 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
;
PRE ;
N DIU
; Remove obsolete DD definitions
F DIU=2006.589 D
. S DIU(0)="" D EN^DIU2
. Q
K ^MAGDICOM(2006.589)
Q
;
POST N CVT,OPT
; 1. Add RPCs to Secondary menu(s)
; 2. Convert tables
; 3. Run INIT^MAGDRUID (create UID root)
; 4. Remove any dangling cross references from #2006.575
;
F OPT="MAG DICOM GATEWAY FULL","MAG DICOM GATEWAY VIEW" D
. ; Don't ADDRPC("MAG DICOM CHECK MACHINE ID",OPT) ; removed at site
. D ADDRPC("MAG DICOM GET MACHINE ID",OPT)
. D ADDRPC("MAG DICOM GET UID ROOT",OPT)
. ; Don't ADDRPC("MAG DICOM UPDATE MACHINE ID",OPT) ; removed at site
. D ADDRPC("MAG GET SOP CLASS METHOD",OPT)
. Q
;
D ; Convert Tables:
. ; 2006.5641 (Gateway Registry)
. ; 2006.5715 (Last Image UID)
. ;
. ; NOTE: The code below is such that if this routine
. ; is run multiple times, the 2nd and later times
. ; are no-ops.
. ;
. N D0,ID,HN,HOST,L,LO,LOC,N,NA,UID,UP,X
. S LO="abcdefghijklmnopqrstuvwxyz"
. S UP="ABCDEFGHIJKLMNOPQRSTUVWXYZ"
. S D0=0 F S D0=$O(^MAGDICOM(2006.5641,D0)) Q:'D0 D
. . S X=$G(^MAGDICOM(2006.5641,D0,0)),ID=$P(X,"^",1),NA=$P(X,"^",2)
. . Q:ID ; Entry is already converted
. . S HN=$TR(NA,LO,UP)
. . D:ID'=""
. . . K ^MAGDICOM(2006.5641,"B",ID,D0)
. . . S ^MAGDICOM(2006.5641,"B",D0,D0)=""
. . . S $P(^MAGDICOM(2006.5641,D0,0),"^",1,2)=D0_"^"_HN
. . . S HOST(ID)=HN
. . . Q
. . D:NA'=""
. . . K ^MAGDICOM(2006.5641,"C",NA,D0)
. . . S ^MAGDICOM(2006.5641,"C",HN,D0)=""
. . . Q
. . Q
. S (N,L,D0)=0 F S D0=$O(^MAGD(2006.5715,D0)) Q:'D0 D
. . S X=$G(^MAGD(2006.5715,D0,0)),UID=$P(X,"^",2),X=$P(X,"^",1)
. . Q:X'?1U ; Entry is empty or already converted
. . I X'="" K ^MAGD(2006.5715,"B",X,D0) S X=$G(HOST(X))
. . I X="" K ^MAGD(2006.5715,D0) Q
. . S N=N+1,L=D0,^MAGD(2006.5715,D0,0)=X_"^"_UID
. . S ^MAGD(2006.5715,"B",X,D0)=""
. . Q
. S ^MAGD(2006.5715,0)="CURRENT IMAGE^2006.5715^"_L_"^"_N
. Q
;
D INIT^MAGDRUID
D UPDATE
;
D ; Add shortcuts to DICOM Correct
. N FDA,IEN,LBL,MSG,SUB
. S SUB(1)="MAGD FIX DICOM FILE",LBL(1)="RAD"
. S SUB(2)="MAGD FIX CLINSPEC DICOM FILE",LBL(2)="CLN"
. D FIND^DIC(19,"",".001","","MAGD DICOM MENU","","B","","","LST","MSG")
. S LST="" F S LST=$O(LST("DILIST",2,LST)) Q:LST="" D
. . F SUB=1,2 D
. . . K FDA,IEN,MSG
. . . S FDA(19.01,"?1,"_LST("DILIST",2,LST)_",",.01)=SUB(SUB)
. . . S FDA(19.01,"?1,"_LST("DILIST",2,LST)_",",2)=LBL(SUB)
. . . D UPDATE^DIE("E","FDA","IEN","MSG")
. . . Q
. . Q
. Q
;
D ; Confirmation message
. N CT,CNT,D,D0,D1,D2,DDATE,DG,DIC,DICR,DIW,MAGMSG,ST,XMID,XMY
. ;
. D GETENV^%ZOSV
. S CNT=0
. S CNT=CNT+1,MAGMSG(CNT)="PACKAGE INSTALL"
. S CNT=CNT+1,MAGMSG(CNT)="SITE: "_$$KSP^XUPARAM("WHERE")
. S CNT=CNT+1,MAGMSG(CNT)="PACKAGE: "_XPDNM
. S CNT=CNT+1,MAGMSG(CNT)="Version: "_$$VER^XPDUTL(XPDNM)
. S ST=$$GET1^DIQ(9.7,XPDA,11,"I")
. S CNT=CNT+1,MAGMSG(CNT)="Start time: "_$$FMTE^XLFDT(ST)
. S CT=$$GET1^DIQ(9.7,XPDA,17,"I") S:+CT'=CT CT=$$NOW^XLFDT()
. S CNT=CNT+1,MAGMSG(CNT)="Completion time: "_$$FMTE^XLFDT(CT)
. S CNT=CNT+1,MAGMSG(CNT)="Run time: "_$$FMDIFF^XLFDT(CT,ST,3)
. S CNT=CNT+1,MAGMSG(CNT)="Environment: "_Y
. S CNT=CNT+1,MAGMSG(CNT)="FILE COMMENT: "_$$GET1^DIQ(9.7,XPDA,6,"I")
. S CNT=CNT+1,MAGMSG(CNT)="DATE: "_$$NOW^XLFDT()
. S CNT=CNT+1,MAGMSG(CNT)="Installed by: "_$$GET1^DIQ(9.7,XPDA,9,"E")
. S CNT=CNT+1,MAGMSG(CNT)="Install Name: "_$$GET1^DIQ(9.7,XPDA,.01,"E")
. S DDATE=$$GET1^DIQ(9.7,XPDA,51,"I")
. S CNT=CNT+1,MAGMSG(CNT)="Distribution Date: "_$$FMTE^XLFDT(DDATE)
. S:$G(CVT)'="" CNT=CNT+1,MAGMSG(CNT)="Conversion time: "_CVT
. S XMSUB=XPDNM_" INSTALLATION"
. S XMID=$G(DUZ) S:'XMID XMID=.5
. S XMY(XMID)=""
. S XMY("G.MAG SERVER")=""
. S:$G(MAGDUZ) XMY(MAGDUZ)=""
. S XMSUB=$E(XMSUB,1,63)
. D SENDMSG^XMXAPI(XMID,XMSUB,"MAGMSG",.XMY,,.XMZ,)
. I $G(XMERR) M XMERR=^TMP("XMERR",$J) S $EC=",U13-Cannot send MailMan message,"
. Q
K ^MAGD(2006.575) S ^MAGD(2006.575,0)="DICOM FAILED IMAGES^2006.575" ; remove any vestigal nodes
Q
;
ADDRPC(RPCNAME,OPTNAME) N DA,DIC
S DIC="^DIC(19,",DIC(0)="",X=OPTNAME D ^DIC
I Y<0 D Q
. W !,"Cannot add """_RPCNAME_""" to """_OPTNAME_"""."
. W !,"Cannot find """_OPTNAME_"""."
. Q
S DA(1)=+Y
S DIC=DIC_DA(1)_",""RPC"","
S DIC(0)="L" ; LAYGO should be allowed here
S X=RPCNAME
D ^DIC
I Y<0 D Q
. W !,"Cannot add """_RPCNAME_""" to """_OPTNAME_"""."
. W !,"Cannot find """_RPCNAME_"""."
. Q
Q
;
UP(X) ; special UPPER CASE function -- removes redundant blanks as well
F Q:X'[" " S $E(X,$F(X," ")-1)="" ; remove redundant blank
I $E(X)=" " S $E(X)="" ; remove leading blank
I $E(X,$L(X))=" " S $E(X,$L(X))="" ; remove trailing blank
Q $TR(X,"abcdefghijklmnopqrstuvwxyz^|","ABCDEFGHIJKLMNOPQRSTUVWXYZ~~")
;
UPDATE ;Update description for menu option
N IEN
S IEN=$$FIND1^DIC(19,"","X","MAGD DICOM MENU","","","")
I 'IEN D BMES^XPDUTL("Menu option MAGD DICOM MENU is undefined in the Option file!") Q
S ^TMP($J,"WP",1)="Menu to allow correcting of DICOM Image file references that failed"
S ^TMP($J,"WP",2)="the matching process during the initial DICOM image acquistion."
D WP^DIE(19,IEN_",",3.5,"","^TMP($J,""WP"")","MAGMSG")
I $D(MAGMSG) D BMES^XPDUTL("Error setting the description field for MAGD DICOM MENU")
K ^TMP($J,"WP")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMAGIPS54 6526 printed Sep 23, 2025@19:42:36 Page 2
MAGIPS54 ;Post init routine to queue site activity at install. ; 09/11/2008 02:17 pm
+1 ;;3.0;IMAGING;**54**;03-July-2009;;Build 1424
+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
+18 ;
PRE ;
+1 NEW DIU
+2 ; Remove obsolete DD definitions
+3 FOR DIU=2006.589
Begin DoDot:1
+4 SET DIU(0)=""
DO EN^DIU2
+5 QUIT
End DoDot:1
+6 KILL ^MAGDICOM(2006.589)
+7 QUIT
+8 ;
POST NEW CVT,OPT
+1 ; 1. Add RPCs to Secondary menu(s)
+2 ; 2. Convert tables
+3 ; 3. Run INIT^MAGDRUID (create UID root)
+4 ; 4. Remove any dangling cross references from #2006.575
+5 ;
+6 FOR OPT="MAG DICOM GATEWAY FULL","MAG DICOM GATEWAY VIEW"
Begin DoDot:1
+7 ; Don't ADDRPC("MAG DICOM CHECK MACHINE ID",OPT) ; removed at site
+8 DO ADDRPC("MAG DICOM GET MACHINE ID",OPT)
+9 DO ADDRPC("MAG DICOM GET UID ROOT",OPT)
+10 ; Don't ADDRPC("MAG DICOM UPDATE MACHINE ID",OPT) ; removed at site
+11 DO ADDRPC("MAG GET SOP CLASS METHOD",OPT)
+12 QUIT
End DoDot:1
+13 ;
+14 ; Convert Tables:
Begin DoDot:1
+15 ; 2006.5641 (Gateway Registry)
+16 ; 2006.5715 (Last Image UID)
+17 ;
+18 ; NOTE: The code below is such that if this routine
+19 ; is run multiple times, the 2nd and later times
+20 ; are no-ops.
+21 ;
+22 NEW D0,ID,HN,HOST,L,LO,LOC,N,NA,UID,UP,X
+23 SET LO="abcdefghijklmnopqrstuvwxyz"
+24 SET UP="ABCDEFGHIJKLMNOPQRSTUVWXYZ"
+25 SET D0=0
FOR
SET D0=$ORDER(^MAGDICOM(2006.5641,D0))
if 'D0
QUIT
Begin DoDot:2
+26 SET X=$GET(^MAGDICOM(2006.5641,D0,0))
SET ID=$PIECE(X,"^",1)
SET NA=$PIECE(X,"^",2)
+27 ; Entry is already converted
if ID
QUIT
+28 SET HN=$TRANSLATE(NA,LO,UP)
+29 if ID'=""
Begin DoDot:3
+30 KILL ^MAGDICOM(2006.5641,"B",ID,D0)
+31 SET ^MAGDICOM(2006.5641,"B",D0,D0)=""
+32 SET $PIECE(^MAGDICOM(2006.5641,D0,0),"^",1,2)=D0_"^"_HN
+33 SET HOST(ID)=HN
+34 QUIT
End DoDot:3
+35 if NA'=""
Begin DoDot:3
+36 KILL ^MAGDICOM(2006.5641,"C",NA,D0)
+37 SET ^MAGDICOM(2006.5641,"C",HN,D0)=""
+38 QUIT
End DoDot:3
+39 QUIT
End DoDot:2
+40 SET (N,L,D0)=0
FOR
SET D0=$ORDER(^MAGD(2006.5715,D0))
if 'D0
QUIT
Begin DoDot:2
+41 SET X=$GET(^MAGD(2006.5715,D0,0))
SET UID=$PIECE(X,"^",2)
SET X=$PIECE(X,"^",1)
+42 ; Entry is empty or already converted
if X'?1U
QUIT
+43 IF X'=""
KILL ^MAGD(2006.5715,"B",X,D0)
SET X=$GET(HOST(X))
+44 IF X=""
KILL ^MAGD(2006.5715,D0)
QUIT
+45 SET N=N+1
SET L=D0
SET ^MAGD(2006.5715,D0,0)=X_"^"_UID
+46 SET ^MAGD(2006.5715,"B",X,D0)=""
+47 QUIT
End DoDot:2
+48 SET ^MAGD(2006.5715,0)="CURRENT IMAGE^2006.5715^"_L_"^"_N
+49 QUIT
End DoDot:1
+50 ;
+51 DO INIT^MAGDRUID
+52 DO UPDATE
+53 ;
+54 ; Add shortcuts to DICOM Correct
Begin DoDot:1
+55 NEW FDA,IEN,LBL,MSG,SUB
+56 SET SUB(1)="MAGD FIX DICOM FILE"
SET LBL(1)="RAD"
+57 SET SUB(2)="MAGD FIX CLINSPEC DICOM FILE"
SET LBL(2)="CLN"
+58 DO FIND^DIC(19,"",".001","","MAGD DICOM MENU","","B","","","LST","MSG")
+59 SET LST=""
FOR
SET LST=$ORDER(LST("DILIST",2,LST))
if LST=""
QUIT
Begin DoDot:2
+60 FOR SUB=1,2
Begin DoDot:3
+61 KILL FDA,IEN,MSG
+62 SET FDA(19.01,"?1,"_LST("DILIST",2,LST)_",",.01)=SUB(SUB)
+63 SET FDA(19.01,"?1,"_LST("DILIST",2,LST)_",",2)=LBL(SUB)
+64 DO UPDATE^DIE("E","FDA","IEN","MSG")
+65 QUIT
End DoDot:3
+66 QUIT
End DoDot:2
+67 QUIT
End DoDot:1
+68 ;
+69 ; Confirmation message
Begin DoDot:1
+70 NEW CT,CNT,D,D0,D1,D2,DDATE,DG,DIC,DICR,DIW,MAGMSG,ST,XMID,XMY
+71 ;
+72 DO GETENV^%ZOSV
+73 SET CNT=0
+74 SET CNT=CNT+1
SET MAGMSG(CNT)="PACKAGE INSTALL"
+75 SET CNT=CNT+1
SET MAGMSG(CNT)="SITE: "_$$KSP^XUPARAM("WHERE")
+76 SET CNT=CNT+1
SET MAGMSG(CNT)="PACKAGE: "_XPDNM
+77 SET CNT=CNT+1
SET MAGMSG(CNT)="Version: "_$$VER^XPDUTL(XPDNM)
+78 SET ST=$$GET1^DIQ(9.7,XPDA,11,"I")
+79 SET CNT=CNT+1
SET MAGMSG(CNT)="Start time: "_$$FMTE^XLFDT(ST)
+80 SET CT=$$GET1^DIQ(9.7,XPDA,17,"I")
if +CT'=CT
SET CT=$$NOW^XLFDT()
+81 SET CNT=CNT+1
SET MAGMSG(CNT)="Completion time: "_$$FMTE^XLFDT(CT)
+82 SET CNT=CNT+1
SET MAGMSG(CNT)="Run time: "_$$FMDIFF^XLFDT(CT,ST,3)
+83 SET CNT=CNT+1
SET MAGMSG(CNT)="Environment: "_Y
+84 SET CNT=CNT+1
SET MAGMSG(CNT)="FILE COMMENT: "_$$GET1^DIQ(9.7,XPDA,6,"I")
+85 SET CNT=CNT+1
SET MAGMSG(CNT)="DATE: "_$$NOW^XLFDT()
+86 SET CNT=CNT+1
SET MAGMSG(CNT)="Installed by: "_$$GET1^DIQ(9.7,XPDA,9,"E")
+87 SET CNT=CNT+1
SET MAGMSG(CNT)="Install Name: "_$$GET1^DIQ(9.7,XPDA,.01,"E")
+88 SET DDATE=$$GET1^DIQ(9.7,XPDA,51,"I")
+89 SET CNT=CNT+1
SET MAGMSG(CNT)="Distribution Date: "_$$FMTE^XLFDT(DDATE)
+90 if $GET(CVT)'=""
SET CNT=CNT+1
SET MAGMSG(CNT)="Conversion time: "_CVT
+91 SET XMSUB=XPDNM_" INSTALLATION"
+92 SET XMID=$GET(DUZ)
if 'XMID
SET XMID=.5
+93 SET XMY(XMID)=""
+94 SET XMY("G.MAG SERVER")=""
+95 if $GET(MAGDUZ)
SET XMY(MAGDUZ)=""
+96 SET XMSUB=$EXTRACT(XMSUB,1,63)
+97 DO SENDMSG^XMXAPI(XMID,XMSUB,"MAGMSG",.XMY,,.XMZ,)
+98 IF $GET(XMERR)
MERGE XMERR=^TMP("XMERR",$JOB)
SET $ECODE=",U13-Cannot send MailMan message,"
+99 QUIT
End DoDot:1
+100 ; remove any vestigal nodes
KILL ^MAGD(2006.575)
SET ^MAGD(2006.575,0)="DICOM FAILED IMAGES^2006.575"
+101 QUIT
+102 ;
ADDRPC(RPCNAME,OPTNAME) NEW DA,DIC
+1 SET DIC="^DIC(19,"
SET DIC(0)=""
SET X=OPTNAME
DO ^DIC
+2 IF Y<0
Begin DoDot:1
+3 WRITE !,"Cannot add """_RPCNAME_""" to """_OPTNAME_"""."
+4 WRITE !,"Cannot find """_OPTNAME_"""."
+5 QUIT
End DoDot:1
QUIT
+6 SET DA(1)=+Y
+7 SET DIC=DIC_DA(1)_",""RPC"","
+8 ; LAYGO should be allowed here
SET DIC(0)="L"
+9 SET X=RPCNAME
+10 DO ^DIC
+11 IF Y<0
Begin DoDot:1
+12 WRITE !,"Cannot add """_RPCNAME_""" to """_OPTNAME_"""."
+13 WRITE !,"Cannot find """_RPCNAME_"""."
+14 QUIT
End DoDot:1
QUIT
+15 QUIT
+16 ;
UP(X) ; special UPPER CASE function -- removes redundant blanks as well
+1 ; remove redundant blank
FOR
if X'[" "
QUIT
SET $EXTRACT(X,$FIND(X," ")-1)=""
+2 ; remove leading blank
IF $EXTRACT(X)=" "
SET $EXTRACT(X)=""
+3 ; remove trailing blank
IF $EXTRACT(X,$LENGTH(X))=" "
SET $EXTRACT(X,$LENGTH(X))=""
+4 QUIT $TRANSLATE(X,"abcdefghijklmnopqrstuvwxyz^|","ABCDEFGHIJKLMNOPQRSTUVWXYZ~~")
+5 ;
UPDATE ;Update description for menu option
+1 NEW IEN
+2 SET IEN=$$FIND1^DIC(19,"","X","MAGD DICOM MENU","","","")
+3 IF 'IEN
DO BMES^XPDUTL("Menu option MAGD DICOM MENU is undefined in the Option file!")
QUIT
+4 SET ^TMP($JOB,"WP",1)="Menu to allow correcting of DICOM Image file references that failed"
+5 SET ^TMP($JOB,"WP",2)="the matching process during the initial DICOM image acquistion."
+6 DO WP^DIE(19,IEN_",",3.5,"","^TMP($J,""WP"")","MAGMSG")
+7 IF $DATA(MAGMSG)
DO BMES^XPDUTL("Error setting the description field for MAGD DICOM MENU")
+8 KILL ^TMP($JOB,"WP")
+9 QUIT
+10
***** ERRORS & WARNINGS IN MAGIPS54 *****
UPDATE+10 W - Null line (no commands or comment).
POST+51 F - Reference to routine '^MAGDRUID'. That isn't in this UCI.
