MAGIP163 ;WOIFO/JSL - MAG INDEX TERMS UPDATE Utilities for Imaging 3.0; 10/07/2015 12:15
;;3.0;IMAGING;**163**;;Build 21;;OCT 07, 2015
;; 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
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^MAGIP163",@^%ZOSF("TRAP")
S TKID=$H*86400+$P($H,",",2) D MAKEBKUP(TKID) ;backup before loading M global
U IO(0) W !,"Restore Code: "_TKID,!
S ^TMP(SUB,$J,"TKID")=TKID
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)
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) ;recoverd
. Q
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMAGIP163 4961 printed Dec 13, 2024@02:04:23 Page 2
MAGIP163 ;WOIFO/JSL - MAG INDEX TERMS UPDATE Utilities for Imaging 3.0; 10/07/2015 12:15
+1 ;;3.0;IMAGING;**163**;;Build 21;;OCT 07, 2015
+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
+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^MAGIP163"
SET @^%ZOSF("TRAP")
+7 ;backup before loading M global
SET TKID=$HOROLOG*86400+$PIECE($HOROLOG,",",2)
DO MAKEBKUP(TKID)
+8 USE IO(0)
WRITE !,"Restore Code: "_TKID,!
+9 SET ^TMP(SUB,$JOB,"TKID")=TKID
+10 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 QUIT
+34 ;
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 ;recoverd
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 ;
