source: WorldVistAEHR/trunk/r/IMAGING-MAG-ZMAG/MAGENV77.m@ 1073

Last change on this file since 1073 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 4.1 KB
Line 
1MAGENV77 ;WOIFO/MJK; P77 (Reports) Environment Check ; 06 Jun 2006 7:50 AM
2 ;;3.0;IMAGING;**77**;07-December-2006;;Build 982
3 ;; Per VHA Directive 2004-038, this routine should not be modified.
4 ;; +---------------------------------------------------------------+
5 ;; | Property of the US Government. |
6 ;; | No permission to copy or redistribute this software is given. |
7 ;; | Use of unreleased versions of this software requires the user |
8 ;; | to execute a written test agreement with the VistA Imaging |
9 ;; | Development Office of the Department of Veterans Affairs, |
10 ;; | telephone (301) 734-0100. |
11 ;; | The Food and Drug Administration classifies this software as |
12 ;; | a medical device. As such, it may not be changed in any way. |
13 ;; | Modifications to this software may result in an adulterated |
14 ;; | medical device under 21CFR820, the use of which is considered |
15 ;; | to be a violation of US Federal Statutes. |
16 ;; +---------------------------------------------------------------+
17 ;;
18 ; Check for the existence of an 'AD' cross reference in the 2005 or 2005.1 file.
19 ; If one exists and it was not created by the VistA Imaging Team, alert the installer
20 ; and terminate the install.
21 ;
22 ; Also check for any cross reference on Field 7 - Date/Time Image Saved. There should be
23 ; no cross references except the 'AD' cross reference created by this Patch.
24 ;
25 NEW %,%X,%Y,CTR,D,D0,D1,D2,DA,DG,DIC,DICR,DIK,DIW,IMGFILE,MAILMSG,MESSAGE,SS4,SS5,SS6
26 NEW X,XMDUZ,XMERR,XMSUBJ,XMTO,XMZ,Y
27 ;
28 S CTR=0
29 ;
30 F IMGFILE=2005,2005.1 U IO(0) W !! D 1,2,3,4
31 I $G(XPDQUIT) D XPDQUIT
32 Q
331 ; I started out with the Traditional Type cross reference for the 'AD' xref. Skip Ormsby suggested that I use 'AD' as the
34 ; xref but use the New Index type. This code removes the Traditional xref from the DD at those alpha sites that installed
35 ; the earlier p77 't' versions.
36 ;
37 S SS4=0
38 F S SS4=$O(^DD(IMGFILE,7,1,SS4)) Q:'SS4 D
39 . I $P(^DD(IMGFILE,7,1,SS4,0),U,2)="AD",($G(^DD(IMGFILE,7,1,SS4,"%D",1,0))["VistA Imaging Team") D
40 . . S DA=SS4,DA(1)=7,DA(2)=IMGFILE,DIK="^DD("_DA(2)_","_DA(1)_",1," D ^DIK
41 . . K ^MAG(IMGFILE,"AD")
42 . . Q
43 . Q
44 Q
452 ; If an 'AD' xref is not defined, there should not be an 'AD' node.
46 ;
47 I '$D(^DD(IMGFILE,0,"IX","AD"))&('$D(^DD("IX","BB",IMGFILE,"AD"))) D
48 . I '$D(^MAG(IMGFILE,"AD")) Q
49 . S MESSAGE="File: "_$P(^DIC(IMGFILE,0),U)_" (#"_IMGFILE_") dictionary does not have an 'AD' cross reference defined for any field yet an 'AD' global node exists in global ^MAG("_IMGFILE_","
50 . D ABORT(MESSAGE)
51 . Q
52 Q
533 ; There should not be a Traditional 'AD' xref.
54 ;
55 I $D(^DD(IMGFILE,0,"IX","AD")) D
56 . S SS5=""
57 . F S SS5=$O(^DD(IMGFILE,0,"IX","AD",SS5)) Q:'SS5 S SS6="" D
58 . . F S SS6=$O(^DD(IMGFILE,0,"IX","AD",SS5,SS6)) Q:'SS6 D
59 . . . S MESSAGE="File: "_$P(^DIC(IMGFILE,0),U)_" (#"_IMGFILE_") Field: "_$P(^DD(IMGFILE,SS6,0),U)_" (#"_SS6_") - has an illegal 'AD' cross reference"
60 . . . D ABORT(MESSAGE)
61 . . . Q
62 . . Q
63 . Q
64 Q
654 ; Check for 'AD' New Type Index Cross Reference.
66 ; It must have been created by P77 for field 7 (Date/Time Image Saved.)
67 ;
68 I $D(^DD("IX","BB",IMGFILE,"AD")) D
69 . S SS5=""
70 . F S SS5=$O(^DD("IX","BB",IMGFILE,"AD",SS5)) Q:SS5="" D
71 . . I $P(^DD("IX",SS5,0),U,3)["Created by Patch 77" Q
72 . . S MESSAGE="File: "_$P(^DIC(IMGFILE,0),U)_" - has an illegal 'AD' 'New Index' type cross reference"
73 . . D ABORT(MESSAGE)
74 . . Q
75 . Q
76 Q
77ABORT(MESSAGE) ; Build a mail message. Set 'Do not install' flag.
78 ;
79 S XPDQUIT=2
80 I CTR=0 D
81 . D GETENV^%ZOSV
82 . S CTR=CTR+1,MAILMSG(CTR)=$P(Y,U,3)_" "_$P(Y,U)
83 . S CTR=CTR+1,MAILMSG(CTR)=""
84 . Q
85 S CTR=CTR+1
86 S MAILMSG(CTR)=MESSAGE
87 D BMES^XPDUTL(MESSAGE)
88 Q
89XPDQUIT ;
90 ;
91 U IO(0) W !!!
92 S MESSAGE="Please resolve these issues before installing Patch 77"
93 D ABORT(MESSAGE)
94 U IO(0) W !!!
95 S XMDUZ=$G(DUZ) S:'XMDUZ XMDUZ=.5
96 S XMSUBJ="Patch 77 Cross Reference Issues"
97 S XMTO("G.MAG SERVER")=""
98 D SENDMSG^XMXAPI(XMDUZ,XMSUBJ,"MAILMSG",.XMTO,,.XMZ,)
99 I $G(XMERR) M XMERR=^TMP("XMERR",$J) S $EC=",U13-Cannot send MailMan message,"
100 Q
101 ;
Note: See TracBrowser for help on using the repository browser.