AUT98P12 ;IHS/SET/GTH - AUT 98.1 PATCH 12 ; [ 02/12/2003 8:56 AM ]
;;98.1;IHS DICTIONARIES (POINTERS);**12**;MAR 04, 1998;Build 6
;
; IHS/SET/GTH AUT*98.1*12 01/02/2003
;
I '$G(IOM) D HOME^%ZIS
;
I '$G(DUZ) W !,"DUZ UNDEFINED OR 0." D SORRY(2) Q
;
I '$L($G(DUZ(0))) W !,"DUZ(0) UNDEFINED OR NULL." D SORRY(2) Q
;
I '(DUZ(0)["@") W:'$D(ZTQUEUED) !,"DUZ(0) DOES NOT CONTAIN AN '@'." 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
;
S X=$$VERSION^XPDUTL("AUT")
W !!,$$CJ^XLFSTR("Need AUT v 98.1.....AUT v "_X_" Present",IOM)
I X<98.1,+X'=1.1 D SORRY(2)
;
NEW DA,DIC
S X="AUT",DIC="^DIC(9.4,",DIC(0)="",D="C"
D IX^DIC
I Y<0,$D(^DIC(9.4,"C","AUT")) D
. W !!,*7,*7,$$CJ^XLFSTR("You Have More Than One Entry In The",IOM),!,$$CJ^XLFSTR("PACKAGE File with an ""AUT"" 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
;
W !!,$$CJ^XLFSTR("ENVIRONMENT OK.",IOM)
;
D HELP^XBHELP("INTROE","AUT98P12")
I '$$DIR^XBDIR("E","","","","","",1) D SORRY(2) Q
;
I $G(XPDENV)=1 S (XPDDIQ("XPZ1"),XPDDIQ("XPZ2"))=0 D HELP^XBHELP("INTROI","AUT98P12")
;
Q
;
SORRY(X) ;
KILL DIFQ
S XPDQUIT=X
W *7,!,$$CJ^XLFSTR("Sorry....FIX IT!",IOM)
Q
;
VCHK(AUTPRE,AUTVER,AUTQUIT) ; Check versions needed.
;
NEW AUTV
S AUTV=$$VERSION^XPDUTL(AUTPRE)
W !,$$CJ^XLFSTR("Need at least "_AUTPRE_" v "_AUTVER_"....."_AUTPRE_" v "_AUTV_" Present",IOM)
I AUTV<AUTVER D SORRY(AUTQUIT) Q 0
Q 1
;
PRE ;EP - From KIDS.
;
; --- Save, and set dd audit to "y" for effected files.
I $$NEWCP^XPDUTL("PRE1-AUDS^AUT98P12","AUDS^AUT98P12")
;
Q
;
POST ;EP - From KIDS.
;
D UNIQUEL
;
; --- Restore dd audit to pre-install values.
I $$NEWCP^XPDUTL("POS1-AUDR^AUT98P12","AUDR^AUT98P12")
;
; --- Send install mail message.
I $$NEWCP^XPDUTL("POS2-MAIL^AUT98P12","MAIL^AUT98P12")
;
Q
;
MAIL ;
D BMES^XPDUTL("BEGIN Delivering MailMan message to select users...")
NEW DIFROM,XMSUB,XMDUZ,XMTEXT,XMY
KILL ^TMP("AUT98P12",$J)
D RSLT(" --- AUT v 98.1, Patch 12, has been installed into this uci ---")
F %=1:1 D RSLT($P($T(GREET+%),";",3)) Q:$P($T(GREET+%+1),";",3)="###"
S %=0
F S %=$O(^XTMP("XPDI",XPDA,"BLD",XPDBLD,1,%)) Q:'% D RSLT(^(%,0))
S XMSUB=$P($P($T(+1),";",2)," ",3,99),XMDUZ=$S($G(DUZ):DUZ,1:.5),XMTEXT="^TMP(""AUT98P12"",$J,",XMY(1)="",XMY(DUZ)=""
F %="XUMGR","XUPROG","XUPROGMODE" D SINGLE(%)
D ^XMD
KILL ^TMP("AUT98P12",$J)
D MES^XPDUTL("END Delivering MailMan message to select users...")
Q
;
RSLT(%) S ^(0)=$G(^TMP("AUT98P12",$J,0))+1,^(^(0))=%
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
;
INTROE ; Intro text during KIDS Environment check.
;;In this distribution:
;;There are several adds/edits to AUT standard data dictionaries, as
;;well as to the entries within the files. The notes file for this
;;patch can be printed using KIDS option "3 Print Transport Global",
;;and the adds/edits for both the DDs and the entries can be listed
;;using KIDS option "4 Compare Transport Global to Current System".
;;Neither option will effect your system prior to install.
;;###
;
INTROI ; Intro text during KIDS Install.
;;A standard message will be produced by this update.
;;
;;If you run interactively, results will be displayed on your screen,
;;as well as in the mail message and the entry in the INSTALL file.
;;If you queue to TaskMan, please read the mail message for results of
;;this update, and remember not to Q to the HOME device.
;;###
;
GREET ;;To add to mail message.
;;
;;Greetings.
;;
;;You are receiving this message because of the particular RPMS
;;security keys that you hold. This is for your information, only.
;;You need do nothing in response to this message.
;;
;;Questions about this patch, which is a product of the RPMS DBA
;;(George T. Huggins, 520-670-4871), can be directed to the DIR/RPMS
;;Support Center, at 505-248-4371, or via e-mail to
;;"hqwhd@mail.ihs.gov". Please refer to patch "AUT*98.1*12".
;;
;;Requests for modifications or additions to RPMS standard data
;;dictionaries must be directed to the RPMS DBA.
;;
;;###;NOTE: This line indicates the end of text in this message.
;
; -----------------------------------------------------
; The global location for dictionary audit is:
; ^DD(FILE,0,"DDA")
; If the valuey is "Y", dd audit is on. Any other value, or the
; absence of the node, means dd audit is off.
; -----------------------------------------------------
AUDS ; Save current settings, and SET dd auditing 'on'.
D MES^XPDUTL("Saving current DD AUDIT settings for files in this patch")
D MES^XPDUTL("and turning DD AUDIT to 'Y'.")
S ^XTMP("AUT98P12",0)=$$FMADD^XLFDT(DT,10)_"^"_DT_"^"_$P($P($T(+1),";",2)," ",3,99)
NEW AUT
S AUT=0
F S AUT=$O(^XTMP("XPDI",XPDA,"FIA",AUT)) Q:'AUT D
. I '$D(^XTMP("AUT98P12",AUT,"DDA")) S ^XTMP("AUT98P12",AUT,"DDA")=$G(^DD(AUT,0,"DDA"))
. D MES^XPDUTL(" File "_$$RJ^XLFSTR(AUT,12)_" - "_$$LJ^XLFSTR(^XTMP("XPDI",XPDA,"FIA",AUT),30)_"- DD audit was '"_$G(^XTMP("AUT98P12",AUT,"DDA"))_"'"),MES^XPDUTL($$RJ^XLFSTR("Set to 'Y'",69))
. S ^DD(AUT,0,"DDA")="Y"
.Q
D MES^XPDUTL("DD AUDIT settings saved in ^XTMP(.")
Q
; -----------------------------------------------------
AUDR ; Restore the file data audit values to their original values.
D MES^XPDUTL("Restoring DD AUDIT settings for files in this patch")
NEW AUT
S AUT=0
F S AUT=$O(^XTMP("AUT98P12",AUT)) Q:'AUT D
. S ^DD(AUT,0,"DDA")=^XTMP("AUT98P12",AUT,"DDA")
. D MES^XPDUTL(" File "_$$RJ^XLFSTR(AUT,12)_" - "_$$LJ^XLFSTR($$GET1^DID(AUT,"","","NAME"),30)_"- DD AUDIT Set to '"_^DD(AUT,0,"DDA")_"'")
.Q
KILL ^XTMP("AUT98P12")
D MES^XPDUTL("DD AUDIT settings restored.")
Q
; -----------------------------------------------------
;
UNIQUEL ;----- LOOP THRU LOCATION FILE AND POPULATE UNIQUE RPMS DB ID FIELD
;
N DIU,IEN,X,Y
;
D BMES^XPDUTL("Populating UNIQUE RPMS DB ID field in LOCATION file")
;
S IEN=0
F S IEN=$O(^AUTTLOC(IEN)) Q:'IEN D UNIQUE1(IEN)
;
;----- DELETE SCRATCH LOCATION FILE
;
S DIU="^AUTT999(8008699.06,"
S DIU(0)="D"
D EN^DIU2
Q
UNIQUE1(IEN) ;
;----- PROCESS ONE ENTRY
;
N ASUFAC,D0,DATA,IEN2,NAME,UNIQUE,X,Y
;
S NAME=$P($G(^DIC(4,IEN,0)),U)
S D0=IEN
X $P($G(^DD(9999999.06,.0799,0)),U,5,999)
Q:X']""
Q:$L(X)'=6
S ASUFAC=X
S IEN2=0
S IEN2=$O(^AUTT999(8008699.06,"D",ASUFAC,IEN2))
Q:'IEN2
S DATA=$G(^AUTT999(8008699.06,IEN2,0))
Q:DATA']""
;Q:NAME'=$P(DATA,U,2)
Q:ASUFAC'=$P(DATA,U,3)
S UNIQUE=$P(DATA,U,4)
Q:'UNIQUE
Q:$D(^AUTTLOC("F",UNIQUE))
D UNIQUEA(IEN,UNIQUE)
Q
UNIQUEA(IEN,UNIQUE) ;
;----- EDIT ONE ENTRY
;
N DA,DIE,DR,X,Y
;
S DIE="^AUTTLOC("
S DA=IEN
S DR=".32///^S X=UNIQUE"
D ^DIE
Q
AUT98P12 ;IHS/SET/GTH - AUT 98.1 PATCH 12 ; [ 02/12/2003 8:56 AM ]
+1 ;;98.1;IHS DICTIONARIES (POINTERS);**12**;MAR 04, 1998;Build 6
+2 ;
+3 ; IHS/SET/GTH AUT*98.1*12 01/02/2003
+4 ;
+5 IF '$GET(IOM)
DO HOME^%ZIS
+6 ;
+7 IF '$GET(DUZ)
WRITE !,"DUZ UNDEFINED OR 0."
DO SORRY(2)
QUIT
+8 ;
+9 IF '$LENGTH($GET(DUZ(0)))
WRITE !,"DUZ(0) UNDEFINED OR NULL."
DO SORRY(2)
QUIT
+10 ;
+11 IF '(DUZ(0)["@")
IF '$DATA(ZTQUEUED)
WRITE !,"DUZ(0) DOES NOT CONTAIN AN '@'."
DO SORRY(2)
QUIT
+12 ;
+13 SET X=$PIECE(^VA(200,DUZ,0),U)
+14 WRITE !!,$$CJ^XLFSTR("Hello, "_$PIECE(X,",",2)_" "_$PIECE(X,","),IOM)
+15 WRITE !!,$$CJ^XLFSTR("Checking Environment for "_$PIECE($TEXT(+2),";",4)_" V "_$PIECE($TEXT(+2),";",3)_" Patch "_$PIECE($TEXT(+2),";",5)_".",IOM)
+16 ;
+17 NEW IORVON,IORVOFF
+18 SET X="IORVON;IORVOFF"
+19 DO ENDR^%ZISS
+20 ;
+21 SET X=$$VERSION^XPDUTL("AUT")
+22 WRITE !!,$$CJ^XLFSTR("Need AUT v 98.1.....AUT v "_X_" Present",IOM)
+23 IF X<98.1
IF +X'=1.1
DO SORRY(2)
+24 ;
+25 NEW DA,DIC
+26 SET X="AUT"
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","AUT"))
Begin DoDot:1
+29 WRITE !!,*7,*7,$$CJ^XLFSTR("You Have More Than One Entry In The",IOM),!,$$CJ^XLFSTR("PACKAGE File with an ""AUT"" prefix.",IOM)
+30 WRITE !,$$CJ^XLFSTR(IORVON_"One entry needs to be deleted."_IORVOFF,IOM)
+31 DO SORRY(2)
+32 QUIT
End DoDot:1
+33 ;
+34 IF $GET(XPDQUIT)
WRITE !,$$CJ^XLFSTR(IORVON_"FIX IT! Before Proceeding."_IORVOFF,IOM),!!,*7,*7,*7
QUIT
+35 ;
+36 WRITE !!,$$CJ^XLFSTR("ENVIRONMENT OK.",IOM)
+37 ;
+38 DO HELP^XBHELP("INTROE","AUT98P12")
+39 IF '$$DIR^XBDIR("E","","","","","",1)
DO SORRY(2)
QUIT
+40 ;
+41 IF $GET(XPDENV)=1
SET (XPDDIQ("XPZ1"),XPDDIQ("XPZ2"))=0
DO HELP^XBHELP("INTROI","AUT98P12")
+42 ;
+43 QUIT
+44 ;
SORRY(X) ;
+1 KILL DIFQ
+2 SET XPDQUIT=X
+3 WRITE *7,!,$$CJ^XLFSTR("Sorry....FIX IT!",IOM)
+4 QUIT
+5 ;
VCHK(AUTPRE,AUTVER,AUTQUIT) ; Check versions needed.
+1 ;
+2 NEW AUTV
+3 SET AUTV=$$VERSION^XPDUTL(AUTPRE)
+4 WRITE !,$$CJ^XLFSTR("Need at least "_AUTPRE_" v "_AUTVER_"....."_AUTPRE_" v "_AUTV_" Present",IOM)
+5 IF AUTV<AUTVER
DO SORRY(AUTQUIT)
QUIT 0
+6 QUIT 1
+7 ;
PRE ;EP - From KIDS.
+1 ;
+2 ; --- Save, and set dd audit to "y" for effected files.
+3 IF $$NEWCP^XPDUTL("PRE1-AUDS^AUT98P12","AUDS^AUT98P12")
+4 ;
+5 QUIT
+6 ;
POST ;EP - From KIDS.
+1 ;
+2 DO UNIQUEL
+3 ;
+4 ; --- Restore dd audit to pre-install values.
+5 IF $$NEWCP^XPDUTL("POS1-AUDR^AUT98P12","AUDR^AUT98P12")
+6 ;
+7 ; --- Send install mail message.
+8 IF $$NEWCP^XPDUTL("POS2-MAIL^AUT98P12","MAIL^AUT98P12")
+9 ;
+10 QUIT
+11 ;
MAIL ;
+1 DO BMES^XPDUTL("BEGIN Delivering MailMan message to select users...")
+2 NEW DIFROM,XMSUB,XMDUZ,XMTEXT,XMY
+3 KILL ^TMP("AUT98P12",$JOB)
+4 DO RSLT(" --- AUT v 98.1, Patch 12, has been installed into this uci ---")
+5 FOR %=1:1
DO RSLT($PIECE($TEXT(GREET+%),";",3))
IF $PIECE($TEXT(GREET+%+1),";",3)="###"
QUIT
+6 SET %=0
+7 FOR
SET %=$ORDER(^XTMP("XPDI",XPDA,"BLD",XPDBLD,1,%))
IF '%
QUIT
DO RSLT(^(%,0))
+8 SET XMSUB=$PIECE($PIECE($TEXT(+1),";",2)," ",3,99)
SET XMDUZ=$SELECT($GET(DUZ):DUZ,1:.5)
SET XMTEXT="^TMP(""AUT98P12"",$J,"
SET XMY(1)=""
SET XMY(DUZ)=""
+9 FOR %="XUMGR","XUPROG","XUPROGMODE"
DO SINGLE(%)
+10 DO ^XMD
+11 KILL ^TMP("AUT98P12",$JOB)
+12 DO MES^XPDUTL("END Delivering MailMan message to select users...")
+13 QUIT
+14 ;
RSLT(%) SET ^(0)=$GET(^TMP("AUT98P12",$JOB,0))+1
SET ^(^(0))=%
+1 QUIT
+2 ;
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 ;
INTROE ; Intro text during KIDS Environment check.
+1 ;;In this distribution:
+2 ;;There are several adds/edits to AUT standard data dictionaries, as
+3 ;;well as to the entries within the files. The notes file for this
+4 ;;patch can be printed using KIDS option "3 Print Transport Global",
+5 ;;and the adds/edits for both the DDs and the entries can be listed
+6 ;;using KIDS option "4 Compare Transport Global to Current System".
+7 ;;Neither option will effect your system prior to install.
+8 ;;###
+9 ;
INTROI ; Intro text during KIDS Install.
+1 ;;A standard message will be produced by this update.
+2 ;;
+3 ;;If you run interactively, results will be displayed on your screen,
+4 ;;as well as in the mail message and the entry in the INSTALL file.
+5 ;;If you queue to TaskMan, please read the mail message for results of
+6 ;;this update, and remember not to Q to the HOME device.
+7 ;;###
+8 ;
GREET ;;To add to mail message.
+1 ;;
+2 ;;Greetings.
+3 ;;
+4 ;;You are receiving this message because of the particular RPMS
+5 ;;security keys that you hold. This is for your information, only.
+6 ;;You need do nothing in response to this message.
+7 ;;
+8 ;;Questions about this patch, which is a product of the RPMS DBA
+9 ;;(George T. Huggins, 520-670-4871), can be directed to the DIR/RPMS
+10 ;;Support Center, at 505-248-4371, or via e-mail to
+11 ;;"hqwhd@mail.ihs.gov". Please refer to patch "AUT*98.1*12".
+12 ;;
+13 ;;Requests for modifications or additions to RPMS standard data
+14 ;;dictionaries must be directed to the RPMS DBA.
+15 ;;
+16 ;;###;NOTE: This line indicates the end of text in this message.
+17 ;
+18 ; -----------------------------------------------------
+19 ; The global location for dictionary audit is:
+20 ; ^DD(FILE,0,"DDA")
+21 ; If the valuey is "Y", dd audit is on. Any other value, or the
+22 ; absence of the node, means dd audit is off.
+23 ; -----------------------------------------------------
AUDS ; Save current settings, and SET dd auditing 'on'.
+1 DO MES^XPDUTL("Saving current DD AUDIT settings for files in this patch")
+2 DO MES^XPDUTL("and turning DD AUDIT to 'Y'.")
+3 SET ^XTMP("AUT98P12",0)=$$FMADD^XLFDT(DT,10)_"^"_DT_"^"_$PIECE($PIECE($TEXT(+1),";",2)," ",3,99)
+4 NEW AUT
+5 SET AUT=0
+6 FOR
SET AUT=$ORDER(^XTMP("XPDI",XPDA,"FIA",AUT))
IF 'AUT
QUIT
Begin DoDot:1
+7 IF '$DATA(^XTMP("AUT98P12",AUT,"DDA"))
SET ^XTMP("AUT98P12",AUT,"DDA")=$GET(^DD(AUT,0,"DDA"))
+8 DO MES^XPDUTL(" File "_$$RJ^XLFSTR(AUT,12)_" - "_$$LJ^XLFSTR(^XTMP("XPDI",XPDA,"FIA",AUT),30)_"- DD audit was '"_$GET(^XTMP("AUT98P12",AUT,"DDA"))_"'")
DO MES^XPDUTL($$RJ^XLFSTR("Set to 'Y'",69))
+9 SET ^DD(AUT,0,"DDA")="Y"
+10 QUIT
End DoDot:1
+11 DO MES^XPDUTL("DD AUDIT settings saved in ^XTMP(.")
+12 QUIT
+13 ; -----------------------------------------------------
AUDR ; Restore the file data audit values to their original values.
+1 DO MES^XPDUTL("Restoring DD AUDIT settings for files in this patch")
+2 NEW AUT
+3 SET AUT=0
+4 FOR
SET AUT=$ORDER(^XTMP("AUT98P12",AUT))
IF 'AUT
QUIT
Begin DoDot:1
+5 SET ^DD(AUT,0,"DDA")=^XTMP("AUT98P12",AUT,"DDA")
+6 DO MES^XPDUTL(" File "_$$RJ^XLFSTR(AUT,12)_" - "_$$LJ^XLFSTR($$GET1^DID(AUT,"","","NAME"),30)_"- DD AUDIT Set to '"_^DD(AUT,0,"DDA")_"'")
+7 QUIT
End DoDot:1
+8 KILL ^XTMP("AUT98P12")
+9 DO MES^XPDUTL("DD AUDIT settings restored.")
+10 QUIT
+11 ; -----------------------------------------------------
+12 ;
UNIQUEL ;----- LOOP THRU LOCATION FILE AND POPULATE UNIQUE RPMS DB ID FIELD
+1 ;
+2 NEW DIU,IEN,X,Y
+3 ;
+4 DO BMES^XPDUTL("Populating UNIQUE RPMS DB ID field in LOCATION file")
+5 ;
+6 SET IEN=0
+7 FOR
SET IEN=$ORDER(^AUTTLOC(IEN))
IF 'IEN
QUIT
DO UNIQUE1(IEN)
+8 ;
+9 ;----- DELETE SCRATCH LOCATION FILE
+10 ;
+11 SET DIU="^AUTT999(8008699.06,"
+12 SET DIU(0)="D"
+13 DO EN^DIU2
+14 QUIT
UNIQUE1(IEN) ;
+1 ;----- PROCESS ONE ENTRY
+2 ;
+3 NEW ASUFAC,D0,DATA,IEN2,NAME,UNIQUE,X,Y
+4 ;
+5 SET NAME=$PIECE($GET(^DIC(4,IEN,0)),U)
+6 SET D0=IEN
+7 XECUTE $PIECE($GET(^DD(9999999.06,.0799,0)),U,5,999)
+8 IF X']""
QUIT
+9 IF $LENGTH(X)'=6
QUIT
+10 SET ASUFAC=X
+11 SET IEN2=0
+12 SET IEN2=$ORDER(^AUTT999(8008699.06,"D",ASUFAC,IEN2))
+13 IF 'IEN2
QUIT
+14 SET DATA=$GET(^AUTT999(8008699.06,IEN2,0))
+15 IF DATA']""
QUIT
+16 ;Q:NAME'=$P(DATA,U,2)
+17 IF ASUFAC'=$PIECE(DATA,U,3)
QUIT
+18 SET UNIQUE=$PIECE(DATA,U,4)
+19 IF 'UNIQUE
QUIT
+20 IF $DATA(^AUTTLOC("F",UNIQUE))
QUIT
+21 DO UNIQUEA(IEN,UNIQUE)
+22 QUIT
UNIQUEA(IEN,UNIQUE) ;
+1 ;----- EDIT ONE ENTRY
+2 ;
+3 NEW DA,DIE,DR,X,Y
+4 ;
+5 SET DIE="^AUTTLOC("
+6 SET DA=IEN
+7 SET DR=".32///^S X=UNIQUE"
+8 DO ^DIE
+9 QUIT
