MAGIP202 ;WOIFO/JSL,DAC - MAG INDEX TERMS UPDATE Utilities for Imaging 3.0; 06/06/2018 9:01AM
;;3.0;IMAGING;**202**;Mar 19, 2002;Build 12
;; 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 ;PRECHECK
D GETENV^%ZOSV,KILL^XM ;Clean up
N DIR,SUB,TKID,X,Y,ENTER
U IO(0) S DIR("A")="Update Imaging Index Terms with the latest Distribution (Y/N)",DIR("B")="Y",DIR(0)="Y"
D ^DIR I '$G(Y) S XPDABORT=1 Q ;quit if the user selected not to update
S SUB="MAG INDEX TERMS UPDATE" K ^TMP(SUB,$J)
S X="ERR^MAGIP202",@^%ZOSF("TRAP")
S TKID=$H*86400+$P($H,",",2) D MAKEBKUP(TKID) ;backup before loading M global
D BMES^XPDUTL("Restore Code: "_TKID)
S ^TMP(SUB,$J,"TKID")=TKID
D BMES^XPDUTL("Record restore code and hit <enter>: ")
R ENTER:300
Q
MAKEBKUP(TKID) ;make last MAG INDEX backup before install
N IN,SUBJ,X,X0,X1
S SUBJ="MAG INDEX TERMS BACKUP" U IO(0) W !,"backup"
F IN=2005.82,2005.83,2005.84,2005.85 M ^XTMP(SUBJ,TKID,IN)=^MAG(IN) U IO(0) W "*"
S X0=$$NOW^XLFDT()\1,X=$$FMADD^XLFDT(X0,180),^XTMP(SUBJ,0)=X_U_X0_U_SUBJ ;keep 180 days
U IO(0) W ! M ^TMP(SUB,$J,0)=^XTMP(SUBJ,TKID)
Q
;
;;
POST ;POSTINSTALL
POS ;
N CT,CNT,COM,D,D0,D1,D2,DG,DIC,DICR,DIR,DIW,IN,MAGMSG,ST,SUB,TKID,XMID,XMY,XMZ,XMSUB,XMERR,Y
S SUB="MAG INDEX TERMS UPDATE" D CHKSTA ;Status active
S TKID=$G(^TMP(SUB,$J,"TKID"))
I $$ISIHS^MAGSPID() D ;IHS has different terms active
. F IN=105,106,107,110 S:$D(^MAG(2005.83,IN,0)) $P(^(0),"^",3)="A"
. S IN=98 S:$D(^MAG(2005.84,IN,0)) $P(^(0),"^",4)="A" ;IHS SPECIALTY
. S DIC=2005,D=45,D0=$G(^DD(DIC,D,0)) I $P(D0,U,2)="S" D ;IHS Origin
.. S:$P(D0,U,3)'["T:TRIBAL;" $P(^DD(DIC,D,0),U,3)=$P(^(0),U,3)_"T:TRIBAL;"
.. S:$P(D0,U,3)'["U:URBAN;" $P(^DD(DIC,D,0),U,3)=$P(^(0),U,3)_"U:URBAN;"
.. Q
. ;IHS active MARRIAGE LICENSE, BIRTH CERTIFICATE, CERTIFICATE OF INDIAN BLOOD, CCD-SUMMARY
. F IN=7,46,47,48,49,51,53,57,70,86,87,88,95,98,102,104,108 S:$D(^MAG(2005.83,IN,0)) $P(^(0),"^",3)="I"
. S ^MAG(2005.85,3,1,0)="^2005.852P^6^6",^MAG(2005.85,3,1,1,0)=2 ;EKG has more specialty
. S ^MAG(2005.85,3,1,2,0)=39,^MAG(2005.85,3,1,3,0)=1
. S ^MAG(2005.85,3,1,4,0)=87,^MAG(2005.85,3,1,5,0)=42
. S ^MAG(2005.85,3,1,6,0)=52,^MAG(2005.85,3,1,"B",1,3)=""
. S ^MAG(2005.85,3,1,"B",2,1)="",^MAG(2005.85,3,1,"B",39,2)=""
. S ^MAG(2005.85,3,1,"B",42,5)="",^MAG(2005.85,3,1,"B",52,6)=""
. S ^MAG(2005.85,3,1,"B",87,4)=""
. S ^MAG(2005.85,210,0)="STATE AUTHORIZED PORTABLE ORDERS^7^I" ;IHS has inactive SAPO
. Q
I '$$ISIHS^MAGSPID() D ;VA
. S IN=98 S:$D(^MAG(2005.84,IN,0)) $P(^(0),"^",4)="I" ;Physical Therapy, active for IHS only
. S DIC=2005,D=45,D0=$G(^DD(DIC,D,0)) I $P(D0,U,2)="S" S D2=$P(D0,U,3) D
.. S:D2["U:URBAN;" D2=$P(D2,"U:URBAN;",1) ;remove IHS term from VA
.. S:D2["T:TRIBAL;" D2=$P(D2,"T:TRIBAL;",1)
.. S $P(^DD(DIC,D,0),U,3)=D2
.. Q
. Q
;--- Send the notification e-mail
D BMES^XPDUTL("Post Install Mail Message: "_$$FMTE^XLFDT($$NOW^XLFDT))
D INS^MAGQBUT4(XPDNM,DUZ,$$NOW^XLFDT,XPDA)
;--- Send the restore code notification
D BMES^XPDUTL("Restore Code Mail Message: "_$$FMTE^XLFDT($$NOW^XLFDT))
D INS(XPDNM,DUZ,$$NOW^XLFDT,XPDA)
;--- Send restore code e-mail
Q
;
ERR ;error handler
Q:'$G(DUZ)
I $G(TKID) I $D(^XTMP("MAG INDEX TERMS BACKUP",TKID)) D RECOVER
S XPDABORT=1
D @^%ZOSF("ERRTN")
Q
;
CHKSTA ;verify current site status w/ National
N IN,IEN,STA,STO S IEN=0 ;only 2 terms can inactive by local site
S IN=2005.84 F S IEN=$O(^TMP(SUB,$J,0,IN,IEN)) Q:'IEN D
. S STO=$P(^TMP(SUB,$J,0,IN,IEN,0),U,4),STA=$P($G(^MAG(IN,IEN,0)),U,4)
. I STA="I" Q ;Apply inactive by VA national
. I STO="I" S $P(^MAG(IN,IEN,0),U,4)=STO Q ;keep site Option
. Q
S IN=2005.85 F S IEN=$O(^TMP(SUB,$J,0,IN,IEN)) Q:'IEN D
. S STO=$P(^TMP(SUB,$J,0,IN,IEN,0),U,3),STA=$P($G(^MAG(IN,IEN,0)),U,3)
. I STA="I" Q ;Apply inactive by VA national
. I STO="I" S $P(^MAG(IN,IEN,0),U,3)=STO Q ;keep site Option
. Q
Q
;
RECOVER ;Call restore old value, in case of error
Q:$G(TKID)=""
N IN
F IN=2005.82,2005.83,2005.84,2005.85 D U IO(0) W ^MAG(IN,0),!
. I $D(^MAG(IN))&$D(^XTMP("MAG INDEX TERMS BACKUP",TKID,IN)) D
. . K ^MAG(IN) M ^MAG(IN)=^XTMP("MAG INDEX TERMS BACKUP",TKID,IN) ;recovered
. Q
Q
;
INS(XP,DUZ,DATE,IDA) ;
N COM,D,D0,D1,D2,DG,DIC,DICR,DIW,MAGMSG,XMID,XMY,PLACE,XMSUB,XMZ
S PLACE=$O(^MAG(2006.1,"B",$$KSP^XUPARAM("INST"),""))
D GETENV^%ZOSV
S MAGMSG(1)="RESTORE CODE: "_$O(^XTMP("MAG INDEX TERMS BACKUP",""),-1)
S MAGMSG(2)=""
S MAGMSG(3)="SITE: "_$$KSP^XUPARAM("WHERE")
S MAGMSG(5)="PACKAGE: "_XP
S MAGMSG(7)="Install time: "_$$FMTE^XLFDT($$NOW^XLFDT)
S XMSUB=XP_" RESTORE CODE"
S XMID=$G(DUZ) S:'XMID XMID=.5
S XMY(XMID)=""
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) K XMERR
K MAGMSG
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMAGIP202 5860 printed Nov 22, 2024@17:14:56 Page 2
MAGIP202 ;WOIFO/JSL,DAC - MAG INDEX TERMS UPDATE Utilities for Imaging 3.0; 06/06/2018 9:01AM
+1 ;;3.0;IMAGING;**202**;Mar 19, 2002;Build 12
+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 ;PRECHECK
+1 ;Clean up
DO GETENV^%ZOSV
DO KILL^XM
+2 NEW DIR,SUB,TKID,X,Y,ENTER
+3 USE IO(0)
SET DIR("A")="Update Imaging Index Terms with the latest Distribution (Y/N)"
SET DIR("B")="Y"
SET DIR(0)="Y"
+4 ;quit if the user selected not to update
DO ^DIR
IF '$GET(Y)
SET XPDABORT=1
QUIT
+5 SET SUB="MAG INDEX TERMS UPDATE"
KILL ^TMP(SUB,$JOB)
+6 SET X="ERR^MAGIP202"
SET @^%ZOSF("TRAP")
+7 ;backup before loading M global
SET TKID=$HOROLOG*86400+$PIECE($HOROLOG,",",2)
DO MAKEBKUP(TKID)
+8 DO BMES^XPDUTL("Restore Code: "_TKID)
+9 SET ^TMP(SUB,$JOB,"TKID")=TKID
+10 DO BMES^XPDUTL("Record restore code and hit <enter>: ")
+11 READ ENTER:300
+12 QUIT
MAKEBKUP(TKID) ;make last MAG INDEX backup before install
+1 NEW IN,SUBJ,X,X0,X1
+2 SET SUBJ="MAG INDEX TERMS BACKUP"
USE IO(0)
WRITE !,"backup"
+3 FOR IN=2005.82,2005.83,2005.84,2005.85
MERGE ^XTMP(SUBJ,TKID,IN)=^MAG(IN)
USE IO(0)
WRITE "*"
+4 ;keep 180 days
SET X0=$$NOW^XLFDT()\1
SET X=$$FMADD^XLFDT(X0,180)
SET ^XTMP(SUBJ,0)=X_U_X0_U_SUBJ
+5 USE IO(0)
WRITE !
MERGE ^TMP(SUB,$JOB,0)=^XTMP(SUBJ,TKID)
+6 QUIT
+7 ;
+8 ;;
POST ;POSTINSTALL
POS ;
+1 NEW CT,CNT,COM,D,D0,D1,D2,DG,DIC,DICR,DIR,DIW,IN,MAGMSG,ST,SUB,TKID,XMID,XMY,XMZ,XMSUB,XMERR,Y
+2 ;Status active
SET SUB="MAG INDEX TERMS UPDATE"
DO CHKSTA
+3 SET TKID=$GET(^TMP(SUB,$JOB,"TKID"))
+4 ;IHS has different terms active
IF $$ISIHS^MAGSPID()
Begin DoDot:1
+5 FOR IN=105,106,107,110
if $DATA(^MAG(2005.83,IN,0))
SET $PIECE(^(0),"^",3)="A"
+6 ;IHS SPECIALTY
SET IN=98
if $DATA(^MAG(2005.84,IN,0))
SET $PIECE(^(0),"^",4)="A"
+7 ;IHS Origin
SET DIC=2005
SET D=45
SET D0=$GET(^DD(DIC,D,0))
IF $PIECE(D0,U,2)="S"
Begin DoDot:2
+8 if $PIECE(D0,U,3)'["T
SET $PIECE(^DD(DIC,D,0),U,3)=$PIECE(^(0),U,3)_"T:TRIBAL;"
+9 if $PIECE(D0,U,3)'["U
SET $PIECE(^DD(DIC,D,0),U,3)=$PIECE(^(0),U,3)_"U:URBAN;"
+10 QUIT
End DoDot:2
+11 ;IHS active MARRIAGE LICENSE, BIRTH CERTIFICATE, CERTIFICATE OF INDIAN BLOOD, CCD-SUMMARY
+12 FOR IN=7,46,47,48,49,51,53,57,70,86,87,88,95,98,102,104,108
if $DATA(^MAG(2005.83,IN,0))
SET $PIECE(^(0),"^",3)="I"
+13 ;EKG has more specialty
SET ^MAG(2005.85,3,1,0)="^2005.852P^6^6"
SET ^MAG(2005.85,3,1,1,0)=2
+14 SET ^MAG(2005.85,3,1,2,0)=39
SET ^MAG(2005.85,3,1,3,0)=1
+15 SET ^MAG(2005.85,3,1,4,0)=87
SET ^MAG(2005.85,3,1,5,0)=42
+16 SET ^MAG(2005.85,3,1,6,0)=52
SET ^MAG(2005.85,3,1,"B",1,3)=""
+17 SET ^MAG(2005.85,3,1,"B",2,1)=""
SET ^MAG(2005.85,3,1,"B",39,2)=""
+18 SET ^MAG(2005.85,3,1,"B",42,5)=""
SET ^MAG(2005.85,3,1,"B",52,6)=""
+19 SET ^MAG(2005.85,3,1,"B",87,4)=""
+20 ;IHS has inactive SAPO
SET ^MAG(2005.85,210,0)="STATE AUTHORIZED PORTABLE ORDERS^7^I"
+21 QUIT
End DoDot:1
+22 ;VA
IF '$$ISIHS^MAGSPID()
Begin DoDot:1
+23 ;Physical Therapy, active for IHS only
SET IN=98
if $DATA(^MAG(2005.84,IN,0))
SET $PIECE(^(0),"^",4)="I"
+24 SET DIC=2005
SET D=45
SET D0=$GET(^DD(DIC,D,0))
IF $PIECE(D0,U,2)="S"
SET D2=$PIECE(D0,U,3)
Begin DoDot:2
+25 ;remove IHS term from VA
if D2["U
SET D2=$PIECE(D2,"U:URBAN;",1)
+26 if D2["T
SET D2=$PIECE(D2,"T:TRIBAL;",1)
+27 SET $PIECE(^DD(DIC,D,0),U,3)=D2
+28 QUIT
End DoDot:2
+29 QUIT
End DoDot:1
+30 ;--- Send the notification e-mail
+31 DO BMES^XPDUTL("Post Install Mail Message: "_$$FMTE^XLFDT($$NOW^XLFDT))
+32 DO INS^MAGQBUT4(XPDNM,DUZ,$$NOW^XLFDT,XPDA)
+33 ;--- Send the restore code notification
+34 DO BMES^XPDUTL("Restore Code Mail Message: "_$$FMTE^XLFDT($$NOW^XLFDT))
+35 DO INS(XPDNM,DUZ,$$NOW^XLFDT,XPDA)
+36 ;--- Send restore code e-mail
+37 QUIT
+38 ;
ERR ;error handler
+1 if '$GET(DUZ)
QUIT
+2 IF $GET(TKID)
IF $DATA(^XTMP("MAG INDEX TERMS BACKUP",TKID))
DO RECOVER
+3 SET XPDABORT=1
+4 DO @^%ZOSF("ERRTN")
+5 QUIT
+6 ;
CHKSTA ;verify current site status w/ National
+1 ;only 2 terms can inactive by local site
NEW IN,IEN,STA,STO
SET IEN=0
+2 SET IN=2005.84
FOR
SET IEN=$ORDER(^TMP(SUB,$JOB,0,IN,IEN))
if 'IEN
QUIT
Begin DoDot:1
+3 SET STO=$PIECE(^TMP(SUB,$JOB,0,IN,IEN,0),U,4)
SET STA=$PIECE($GET(^MAG(IN,IEN,0)),U,4)
+4 ;Apply inactive by VA national
IF STA="I"
QUIT
+5 ;keep site Option
IF STO="I"
SET $PIECE(^MAG(IN,IEN,0),U,4)=STO
QUIT
+6 QUIT
End DoDot:1
+7 SET IN=2005.85
FOR
SET IEN=$ORDER(^TMP(SUB,$JOB,0,IN,IEN))
if 'IEN
QUIT
Begin DoDot:1
+8 SET STO=$PIECE(^TMP(SUB,$JOB,0,IN,IEN,0),U,3)
SET STA=$PIECE($GET(^MAG(IN,IEN,0)),U,3)
+9 ;Apply inactive by VA national
IF STA="I"
QUIT
+10 ;keep site Option
IF STO="I"
SET $PIECE(^MAG(IN,IEN,0),U,3)=STO
QUIT
+11 QUIT
End DoDot:1
+12 QUIT
+13 ;
RECOVER ;Call restore old value, in case of error
+1 if $GET(TKID)=""
QUIT
+2 NEW IN
+3 FOR IN=2005.82,2005.83,2005.84,2005.85
Begin DoDot:1
+4 IF $DATA(^MAG(IN))&$DATA(^XTMP("MAG INDEX TERMS BACKUP",TKID,IN))
Begin DoDot:2
+5 ;recovered
KILL ^MAG(IN)
MERGE ^MAG(IN)=^XTMP("MAG INDEX TERMS BACKUP",TKID,IN)
End DoDot:2
+6 QUIT
End DoDot:1
USE IO(0)
WRITE ^MAG(IN,0),!
+7 QUIT
+8 ;
INS(XP,DUZ,DATE,IDA) ;
+1 NEW COM,D,D0,D1,D2,DG,DIC,DICR,DIW,MAGMSG,XMID,XMY,PLACE,XMSUB,XMZ
+2 SET PLACE=$ORDER(^MAG(2006.1,"B",$$KSP^XUPARAM("INST"),""))
+3 DO GETENV^%ZOSV
+4 SET MAGMSG(1)="RESTORE CODE: "_$ORDER(^XTMP("MAG INDEX TERMS BACKUP",""),-1)
+5 SET MAGMSG(2)=""
+6 SET MAGMSG(3)="SITE: "_$$KSP^XUPARAM("WHERE")
+7 SET MAGMSG(5)="PACKAGE: "_XP
+8 SET MAGMSG(7)="Install time: "_$$FMTE^XLFDT($$NOW^XLFDT)
+9 SET XMSUB=XP_" RESTORE CODE"
+10 SET XMID=$GET(DUZ)
if 'XMID
SET XMID=.5
+11 SET XMY(XMID)=""
+12 if $GET(MAGDUZ)
SET XMY(MAGDUZ)=""
+13 SET XMSUB=$EXTRACT(XMSUB,1,63)
+14 DO SENDMSG^XMXAPI(XMID,XMSUB,"MAGMSG",.XMY,,.XMZ,)
+15 IF $GET(XMERR)
MERGE XMERR=^TMP("XMERR",$JOB)
KILL XMERR
+16 KILL MAGMSG
+17 QUIT
