XU8P1018 ;IHS/OIT/FBD - XU V8.0 PATCH 1018 ;
;;8.0;KERNEL;**1018**;JUNE 4, 2015;Build 8
;
;
ENV ;ENVIROMENT CHECK
I '$G(IOM) D HOME^%ZIS
;
I '$G(DUZ) D MES^XPDUTL("No valid user identification found; aborting.") D SORRY(2) Q
;
I '$L($G(DUZ(0))) D MES^XPDUTL("No valid user location found; aborting.") D SORRY(2) Q
;
S X=$P(^VA(200,DUZ,0),U)
W !!,$$CJ^XLFSTR("Hello, "_$P(X,",",2)_" "_$P(X,","),IOM)
W !!,$$CJ^XLFSTR("Checking Environment for "_$P($T(+2),";",4)_" V "_$P($T(+2),";",3)_" Patch "_$P($T(+2),";",5)_".",IOM)
;
NEW IORVON,IORVOFF
S X="IORVON;IORVOFF"
D ENDR^%ZISS
;
I $$VCHK("DI","22.0",2)
I $$VCHK("XT","7.3",2)
I $$VCHK("XM","8.0",2)
I $$VCHK("XU","8.0",2)
;
I '$$INSTALLD("DI*22.0*170") D SORRY(2)
I '$$INSTALLD("XT*7.3*137") D SORRY(2)
I '$$INSTALLD("XM*8.0*45") D SORRY(2)
I '$$INSTALLD("XU*8.0*638") D SORRY(2)
;
NEW DA,DIC
S X="AUPN",DIC="^DIC(9.4,",DIC(0)="",D="C"
D IX^DIC
I Y<0,$D(^DIC(9.4,"C","AUPN")) D Q
. W !!,*7,*7,$$CJ^XLFSTR("You Have More Than One Entry In The",IOM),!,$$CJ^XLFSTR("PACKAGE File with an ""AUPN"" prefix.",IOM)
. W !,$$CJ^XLFSTR(IORVON_"One entry needs to be deleted."_IORVOFF,IOM)
. D SORRY(2)
.Q
;
I $G(XPDQUIT) W !,$$CJ^XLFSTR(IORVON_"FIX IT! Before Proceeding."_IORVOFF,IOM),!!,*7,*7,*7 Q
;
I $G(XPDENV)=1 S (XPDDIQ("XPZ1"),XPDDIQ("XPZ2"),XPDDIQ("XPO1"),XPDDIQ("XPI1"))=0
;
W !!,$$CJ^XLFSTR("ENVIRONMENT OK.",IOM)
;
I '$$DIR^XBDIR("E","","","","","",1) D SORRY(3)
Q ;ENVIRONMENT CHECK EXIT
;
SORRY(X) ;
KILL DIFQ
I X=3 S XPDQUIT=2 Q
S XPDQUIT=X
W *7,!,$$CJ^XLFSTR("Sorry....FIX IT!",IOM)
Q
;
;
VCHK(AUPNPRE,AUPNVER,AUPNQUIT) ; Check versions needed.
;
NEW AUPNV
S AUPNV=$$VERSION^XPDUTL(AUPNPRE)
W !,$$CJ^XLFSTR("Need at least "_AUPNPRE_" v "_AUPNVER_"....."_AUPNPRE_" v "_AUPNV_" Present",IOM)
I AUPNV<AUPNVER D SORRY(AUPNQUIT) Q 0
Q 1
;
;
POST ;EP - XU V8.0 PATCH 1018 POST-INIT
;
D BMES^XPDUTL($$CJ^XLFSTR("Beginning XU v8.0 patch 1018 post-init process.",80))
;
D BMES^XPDUTL($$CJ^XLFSTR("Running ^ZTMGRSET to verify deployment of IHS-modified %-routines...",80))
D ^ZTMGRSET
;
D MES^XPDUTL($$CJ^XLFSTR("Changing Kernel temp file settings to Cache-appropriate default...",80))
K DA,DIE,DR
S DIE="^XTV(8989.3,",DA=1,DR=".07///1"
D ^DIE
;
D MES^XPDUTL($$CJ^XLFSTR("Cleaning up mail group/member cross-references...",80))
K ^XMB(3.8,"AB") ;FLUSH MAIL GROUP FILE'S OLD 'AB' XREF (MEMBER/MAIL GROUP)
S XUMG=0 ;INITIAL SEED VALUE TO LOOP THROUGH ALL MAIL GROUPS
F S XUMG=$O(^XMB(3.8,XUMG)) Q:XUMG'=+XUMG D ;RUN THROUGH ALL MAIL GROUPS
. K DIK,DA
. S DIK="^XMB(3.8,"_XUMG_",1," ;MEMBER SUBFILE GLOBAL ROOT FOR THIS MAIL GROUP
. S DIK(1)=".01^AB" ;EXECUTE 'SET' LOGIC ON MEMBER FIELD'S AB XREF ONLY
. S DA(1)=XUMG
. D ENALL^DIK
K DIK,DA
;
D MES^XPDUTL($$CJ^XLFSTR("Purging obsolete user edit templates...",80))
F XUZTEMP="XUEDIT CHARACTERISTICS","XUEXISTING USER","XUNEW USER" D ;SCAN FOR FILE 3/FILE 200-CONFLICTING USER EDIT TEMPLATES
. S XUZDA=""
. F S XUZDA=$O(^DIE("B",XUZTEMP,XUZDA)) Q:'+XUZDA D ;SCAN FOR MULTIPLE ENTRIES OF SPECIFIED TEMPLATE
. . I $P($G(^DIE(XUZDA,0)),U,4)=3 D ;KILL IF SPECIFIED ENTRY IS ASSOCIATED WITH FILE 3 (USER) - ONLY FILE 200 (NEW USER) ASSOCIATED TEMPLATES SHOULD REMAIN
. . . K DA,DIE,DR
. . . S DIE="^DIE(",DA=XUZDA,DR=".01///@"
. . . D ^DIE
K XUZTEMP,XUZDA
;
D MES^XPDUTL($$CJ^XLFSTR("After purge, verifying Kernel reference of valid user edit template...",80))
S XUZTEMP=$P(^XTV(8989.3,1,3),U,2) ;CURRENT 'USER CHARACTERISTICS TEMPLATE' FIELD REFERENCE
I $D(^DIE(XUZTEMP,0)) D ;LEAVE ALONE IF EXISTING TEMPLATE REFERENCE IS VALID
. D MES^XPDUTL($$CJ^XLFSTR("- Valid template reference exists.",80))
. I 1
E D ;ELSE FIX IF REFERENCED TEMPLATE NO LONGER EXISTS AFTER PURGE
. D MES^XPDUTL($$CJ^XLFSTR("- Valid template reference does NOT exist; correcting...",80))
. S XUZTEMP="XUEDIT CHARACTERISTICS" ;KERNEL'S DEFAULT USER EDIT TEMPLATE
. S XUZDA=$O(^DIE("B",XUZTEMP,"")) ;LOCATE DEFAULT TEMPLATE
. K DA,DIE,DR
. S DIE="^XTV(8989.3,",DA=1
. S DR="12///"_$S(+XUZDA:"`"_XUZDA,1:"@") ;USE DEFAULT TEMPLATE IEN IF LOCATED, ELSE FLUSH 'USER CHARACTERISTICS TEMPLATE' FIELD OF BAD POINTER
. D ^DIE
K XUZTEMP,XUZDA
;
D MES^XPDUTL($$CJ^XLFSTR("Re-verifying/cleaning up ""PT"" file pointer indication nodes...",80))
D ^XBFIXPT
;
;
D BMES^XPDUTL("Delivering XU*8.0*1018 install message to select users...")
NEW DIFROM,XMSUB,XMDUZ,XMTEXT,XMY
KILL ^TMP("XU8P1018",$J)
S ^TMP("XU8P1018",$J,1)=" --- XU v 8.0, Patch 1018, has been installed into this uci ---"
S %=0
F S %=$O(^XTMP("XPDI",XPDA,"BLD",XPDBLD,1,%)) Q:'% S ^TMP("XU8P1018",$J,(%+1))=" "_^(%,0)
S XMSUB=$P($P($T(+1),";",2)," ",3,99),XMDUZ=$S($G(DUZ):DUZ,1:.5),XMTEXT="^TMP(""XU8P1018"",$J,",XMY(1)="",XMY(DUZ)=""
F %="XUMGR","XUPROG","XUPROGMODE" D SINGLE(%)
D ^XMD
KILL ^TMP("XU8P1018",$J)
Q
;
SINGLE(K) ; Get holders of a single key K.
NEW Y
S Y=0
Q:'$D(^XUSEC(K))
F S Y=$O(^XUSEC(K,Y)) Q:'Y S XMY(Y)=""
Q
;
INSTALLD(AUPNSTAL) ;EP - Determine if patch AUPNSTAL was installed, where
; AUPNSTAL is the name of the INSTALL. E.g "AG*6.0*11".
;
NEW AUPNY,DIC,X,Y
S X=$P(AUPNSTAL,"*",1)
S DIC="^DIC(9.4,",DIC(0)="FM",D="C"
D IX^DIC
I Y<1 D IMES Q 0
S DIC=DIC_+Y_",22,",X=$P(AUPNSTAL,"*",2)
D ^DIC
I Y<1 D IMES Q 0
S DIC=DIC_+Y_",""PAH"",",X=$P(AUPNSTAL,"*",3)
D ^DIC
S AUPNY=Y
D IMES
Q $S(AUPNY<1:0,1:1)
IMES ;
D MES^XPDUTL($$CJ^XLFSTR("Patch """_AUPNSTAL_""" is"_$S(Y<1:" *NOT*",1:"")_" installed.",IOM))
Q
;
XU8P1018 ;IHS/OIT/FBD - XU V8.0 PATCH 1018 ;
+1 ;;8.0;KERNEL;**1018**;JUNE 4, 2015;Build 8
+2 ;
+3 ;
ENV ;ENVIROMENT CHECK
+1 IF '$GET(IOM)
DO HOME^%ZIS
+2 ;
+3 IF '$GET(DUZ)
DO MES^XPDUTL("No valid user identification found; aborting.")
DO SORRY(2)
QUIT
+4 ;
+5 IF '$LENGTH($GET(DUZ(0)))
DO MES^XPDUTL("No valid user location found; aborting.")
DO SORRY(2)
QUIT
+6 ;
+7 SET X=$PIECE(^VA(200,DUZ,0),U)
+8 WRITE !!,$$CJ^XLFSTR("Hello, "_$PIECE(X,",",2)_" "_$PIECE(X,","),IOM)
+9 WRITE !!,$$CJ^XLFSTR("Checking Environment for "_$PIECE($TEXT(+2),";",4)_" V "_$PIECE($TEXT(+2),";",3)_" Patch "_$PIECE($TEXT(+2),";",5)_".",IOM)
+10 ;
+11 NEW IORVON,IORVOFF
+12 SET X="IORVON;IORVOFF"
+13 DO ENDR^%ZISS
+14 ;
+15 IF $$VCHK("DI","22.0",2)
+16 IF $$VCHK("XT","7.3",2)
+17 IF $$VCHK("XM","8.0",2)
+18 IF $$VCHK("XU","8.0",2)
+19 ;
+20 IF '$$INSTALLD("DI*22.0*170")
DO SORRY(2)
+21 IF '$$INSTALLD("XT*7.3*137")
DO SORRY(2)
+22 IF '$$INSTALLD("XM*8.0*45")
DO SORRY(2)
+23 IF '$$INSTALLD("XU*8.0*638")
DO SORRY(2)
+24 ;
+25 NEW DA,DIC
+26 SET X="AUPN"
SET DIC="^DIC(9.4,"
SET DIC(0)=""
SET D="C"
+27 DO IX^DIC
+28 IF Y<0
IF $DATA(^DIC(9.4,"C","AUPN"))
Begin DoDot:1
+29 WRITE !!,*7,*7,$$CJ^XLFSTR("You Have More Than One Entry In The",IOM),!,$$CJ^XLFSTR("PACKAGE File with an ""AUPN"" prefix.",IOM)
+30 WRITE !,$$CJ^XLFSTR(IORVON_"One entry needs to be deleted."_IORVOFF,IOM)
+31 DO SORRY(2)
+32 QUIT
End DoDot:1
QUIT
+33 ;
+34 IF $GET(XPDQUIT)
WRITE !,$$CJ^XLFSTR(IORVON_"FIX IT! Before Proceeding."_IORVOFF,IOM),!!,*7,*7,*7
QUIT
+35 ;
+36 IF $GET(XPDENV)=1
SET (XPDDIQ("XPZ1"),XPDDIQ("XPZ2"),XPDDIQ("XPO1"),XPDDIQ("XPI1"))=0
+37 ;
+38 WRITE !!,$$CJ^XLFSTR("ENVIRONMENT OK.",IOM)
+39 ;
+40 IF '$$DIR^XBDIR("E","","","","","",1)
DO SORRY(3)
+41 ;ENVIRONMENT CHECK EXIT
QUIT
+42 ;
SORRY(X) ;
+1 KILL DIFQ
+2 IF X=3
SET XPDQUIT=2
QUIT
+3 SET XPDQUIT=X
+4 WRITE *7,!,$$CJ^XLFSTR("Sorry....FIX IT!",IOM)
+5 QUIT
+6 ;
+7 ;
VCHK(AUPNPRE,AUPNVER,AUPNQUIT) ; Check versions needed.
+1 ;
+2 NEW AUPNV
+3 SET AUPNV=$$VERSION^XPDUTL(AUPNPRE)
+4 WRITE !,$$CJ^XLFSTR("Need at least "_AUPNPRE_" v "_AUPNVER_"....."_AUPNPRE_" v "_AUPNV_" Present",IOM)
+5 IF AUPNV<AUPNVER
DO SORRY(AUPNQUIT)
QUIT 0
+6 QUIT 1
+7 ;
+8 ;
POST ;EP - XU V8.0 PATCH 1018 POST-INIT
+1 ;
+2 DO BMES^XPDUTL($$CJ^XLFSTR("Beginning XU v8.0 patch 1018 post-init process.",80))
+3 ;
+4 DO BMES^XPDUTL($$CJ^XLFSTR("Running ^ZTMGRSET to verify deployment of IHS-modified %-routines...",80))
+5 DO ^ZTMGRSET
+6 ;
+7 DO MES^XPDUTL($$CJ^XLFSTR("Changing Kernel temp file settings to Cache-appropriate default...",80))
+8 KILL DA,DIE,DR
+9 SET DIE="^XTV(8989.3,"
SET DA=1
SET DR=".07///1"
+10 DO ^DIE
+11 ;
+12 DO MES^XPDUTL($$CJ^XLFSTR("Cleaning up mail group/member cross-references...",80))
+13 ;FLUSH MAIL GROUP FILE'S OLD 'AB' XREF (MEMBER/MAIL GROUP)
KILL ^XMB(3.8,"AB")
+14 ;INITIAL SEED VALUE TO LOOP THROUGH ALL MAIL GROUPS
SET XUMG=0
+15 ;RUN THROUGH ALL MAIL GROUPS
FOR
SET XUMG=$ORDER(^XMB(3.8,XUMG))
IF XUMG'=+XUMG
QUIT
Begin DoDot:1
+16 KILL DIK,DA
+17 ;MEMBER SUBFILE GLOBAL ROOT FOR THIS MAIL GROUP
SET DIK="^XMB(3.8,"_XUMG_",1,"
+18 ;EXECUTE 'SET' LOGIC ON MEMBER FIELD'S AB XREF ONLY
SET DIK(1)=".01^AB"
+19 SET DA(1)=XUMG
+20 DO ENALL^DIK
End DoDot:1
+21 KILL DIK,DA
+22 ;
+23 DO MES^XPDUTL($$CJ^XLFSTR("Purging obsolete user edit templates...",80))
+24 ;SCAN FOR FILE 3/FILE 200-CONFLICTING USER EDIT TEMPLATES
FOR XUZTEMP="XUEDIT CHARACTERISTICS","XUEXISTING USER","XUNEW USER"
Begin DoDot:1
+25 SET XUZDA=""
+26 ;SCAN FOR MULTIPLE ENTRIES OF SPECIFIED TEMPLATE
FOR
SET XUZDA=$ORDER(^DIE("B",XUZTEMP,XUZDA))
IF '+XUZDA
QUIT
Begin DoDot:2
+27 ;KILL IF SPECIFIED ENTRY IS ASSOCIATED WITH FILE 3 (USER) - ONLY FILE 200 (NEW USER) ASSOCIATED TEMPLATES SHOULD REMAIN
IF $PIECE($GET(^DIE(XUZDA,0)),U,4)=3
Begin DoDot:3
+28 KILL DA,DIE,DR
+29 SET DIE="^DIE("
SET DA=XUZDA
SET DR=".01///@"
+30 DO ^DIE
End DoDot:3
End DoDot:2
End DoDot:1
+31 KILL XUZTEMP,XUZDA
+32 ;
+33 DO MES^XPDUTL($$CJ^XLFSTR("After purge, verifying Kernel reference of valid user edit template...",80))
+34 ;CURRENT 'USER CHARACTERISTICS TEMPLATE' FIELD REFERENCE
SET XUZTEMP=$PIECE(^XTV(8989.3,1,3),U,2)
+35 ;LEAVE ALONE IF EXISTING TEMPLATE REFERENCE IS VALID
IF $DATA(^DIE(XUZTEMP,0))
Begin DoDot:1
+36 DO MES^XPDUTL($$CJ^XLFSTR("- Valid template reference exists.",80))
+37 IF 1
End DoDot:1
+38 ;ELSE FIX IF REFERENCED TEMPLATE NO LONGER EXISTS AFTER PURGE
IF '$TEST
Begin DoDot:1
+39 DO MES^XPDUTL($$CJ^XLFSTR("- Valid template reference does NOT exist; correcting...",80))
+40 ;KERNEL'S DEFAULT USER EDIT TEMPLATE
SET XUZTEMP="XUEDIT CHARACTERISTICS"
+41 ;LOCATE DEFAULT TEMPLATE
SET XUZDA=$ORDER(^DIE("B",XUZTEMP,""))
+42 KILL DA,DIE,DR
+43 SET DIE="^XTV(8989.3,"
SET DA=1
+44 ;USE DEFAULT TEMPLATE IEN IF LOCATED, ELSE FLUSH 'USER CHARACTERISTICS TEMPLATE' FIELD OF BAD POINTER
SET DR="12///"_$SELECT(+XUZDA:"`"_XUZDA,1:"@")
+45 DO ^DIE
End DoDot:1
+46 KILL XUZTEMP,XUZDA
+47 ;
+48 DO MES^XPDUTL($$CJ^XLFSTR("Re-verifying/cleaning up ""PT"" file pointer indication nodes...",80))
+49 DO ^XBFIXPT
+50 ;
+51 ;
+52 DO BMES^XPDUTL("Delivering XU*8.0*1018 install message to select users...")
+53 NEW DIFROM,XMSUB,XMDUZ,XMTEXT,XMY
+54 KILL ^TMP("XU8P1018",$JOB)
+55 SET ^TMP("XU8P1018",$JOB,1)=" --- XU v 8.0, Patch 1018, has been installed into this uci ---"
+56 SET %=0
+57 FOR
SET %=$ORDER(^XTMP("XPDI",XPDA,"BLD",XPDBLD,1,%))
IF '%
QUIT
SET ^TMP("XU8P1018",$JOB,(%+1))=" "_^(%,0)
+58 SET XMSUB=$PIECE($PIECE($TEXT(+1),";",2)," ",3,99)
SET XMDUZ=$SELECT($GET(DUZ):DUZ,1:.5)
SET XMTEXT="^TMP(""XU8P1018"",$J,"
SET XMY(1)=""
SET XMY(DUZ)=""
+59 FOR %="XUMGR","XUPROG","XUPROGMODE"
DO SINGLE(%)
+60 DO ^XMD
+61 KILL ^TMP("XU8P1018",$JOB)
+62 QUIT
+63 ;
SINGLE(K) ; Get holders of a single key K.
+1 NEW Y
+2 SET Y=0
+3 IF '$DATA(^XUSEC(K))
QUIT
+4 FOR
SET Y=$ORDER(^XUSEC(K,Y))
IF 'Y
QUIT
SET XMY(Y)=""
+5 QUIT
+6 ;
INSTALLD(AUPNSTAL) ;EP - Determine if patch AUPNSTAL was installed, where
+1 ; AUPNSTAL is the name of the INSTALL. E.g "AG*6.0*11".
+2 ;
+3 NEW AUPNY,DIC,X,Y
+4 SET X=$PIECE(AUPNSTAL,"*",1)
+5 SET DIC="^DIC(9.4,"
SET DIC(0)="FM"
SET D="C"
+6 DO IX^DIC
+7 IF Y<1
DO IMES
QUIT 0
+8 SET DIC=DIC_+Y_",22,"
SET X=$PIECE(AUPNSTAL,"*",2)
+9 DO ^DIC
+10 IF Y<1
DO IMES
QUIT 0
+11 SET DIC=DIC_+Y_",""PAH"","
SET X=$PIECE(AUPNSTAL,"*",3)
+12 DO ^DIC
+13 SET AUPNY=Y
+14 DO IMES
+15 QUIT $SELECT(AUPNY<1:0,1:1)
IMES ;
+1 DO MES^XPDUTL($$CJ^XLFSTR("Patch """_AUPNSTAL_""" is"_$SELECT(Y<1:" *NOT*",1:"")_" installed.",IOM))
+2 QUIT
+3 ;
