Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: MAGIP163

MAGIP163.m

Go to the documentation of this file. 
  1. 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
  1.  ;; Per VHA Directive 2004-038, this routine should not be modified.
  1.  ;; +---------------------------------------------------------------+
  1.  ;; | Property of the US Government.                                |
  1.  ;; | No permission to copy or redistribute this software is given. |
  1.  ;; | Use of unreleased versions of this software requires the user |
  1.  ;; | to execute a written test agreement with the VistA Imaging    |
  1.  ;; | Development Office of the Department of Veterans Affairs,     |
  1.  ;; | telephone (301) 734-0100.                                     |
  1.  ;; | The Food and Drug Administration classifies this software as  |
  1.  ;; | a medical device.  As such, it may not be changed in any way. |
  1.  ;; | Modifications to this software may result in an adulterated   |
  1.  ;; | medical device under 21CFR820, the use of which is considered |
  1.  ;; | to be a violation of US Federal Statutes.                     |
  1.  ;; +---------------------------------------------------------------+
  1.  ;;
  1.  Q
  1.  ;
  1. PRE ;PRECHECK
  1.  D GETENV^%ZOSV,KILL^XM ;Clean up
  1.  N DIR,SUB,TKID,X,Y
  1.  U IO(0) S DIR("A")="Update Imaging Index Terms with the latest Distribution (Y/N)",DIR("B")="Y",DIR(0)="Y"
  1.  D ^DIR I '$G(Y) S XPDABORT=1 Q  ;quit if the user selected not to update
  1.  S SUB="MAG INDEX TERMS UPDATE" K ^TMP(SUB,$J)
  1.  S X="ERR^MAGIP163",@^%ZOSF("TRAP")
  1.  S TKID=$H*86400+$P($H,",",2) D MAKEBKUP(TKID)  ;backup before loading M global
  1.  U IO(0) W !,"Restore Code: "_TKID,!
  1.  S ^TMP(SUB,$J,"TKID")=TKID
  1.  Q
  1. MAKEBKUP(TKID) ;make last MAG INDEX backup before install
  1.  N IN,SUBJ,X,X0,X1
  1.  S SUBJ="MAG INDEX TERMS BACKUP" U IO(0) W !,"backup"
  1.  F IN=2005.82,2005.83,2005.84,2005.85 M ^XTMP(SUBJ,TKID,IN)=^MAG(IN) U IO(0) W "*"
  1.  S X0=$$NOW^XLFDT()\1,X=$$FMADD^XLFDT(X0,180),^XTMP(SUBJ,0)=X_U_X0_U_SUBJ  ;keep 180 days
  1.  U IO(0) W ! M ^TMP(SUB,$J,0)=^XTMP(SUBJ,TKID)
  1.  Q
  1.  ;
  1.  ;;
  1. POST ;POSTINSTALL
  1. POS ;
  1.  N CT,CNT,COM,D,D0,D1,D2,DG,DIC,DICR,DIR,DIW,IN,MAGMSG,ST,SUB,TKID,XMID,XMY,XMZ,XMSUB,XMERR,Y
  1.  S SUB="MAG INDEX TERMS UPDATE" D CHKSTA ;Status active
  1.  S TKID=$G(^TMP(SUB,$J,"TKID"))
  1.  I $$ISIHS^MAGSPID() D  ;IHS has different terms active
  1.  . F IN=105,106,107,110 S:$D(^MAG(2005.83,IN,0)) $P(^(0),"^",3)="A"
  1.  . S IN=98 S:$D(^MAG(2005.84,IN,0)) $P(^(0),"^",4)="A"  ;IHS SPECIALTY
  1.  . S DIC=2005,D=45,D0=$G(^DD(DIC,D,0)) I $P(D0,U,2)="S" D  ;IHS Origin
  1.  .. S:$P(D0,U,3)'["T:TRIBAL;" $P(^DD(DIC,D,0),U,3)=$P(^(0),U,3)_"T:TRIBAL;"
  1.  .. S:$P(D0,U,3)'["U:URBAN;" $P(^DD(DIC,D,0),U,3)=$P(^(0),U,3)_"U:URBAN;"
  1.  .. Q
  1.  . ;IHS active  MARRIAGE LICENSE, BIRTH CERTIFICATE, CERTIFICATE OF INDIAN BLOOD, CCD-SUMMARY
  1.  . 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"
  1.  . S ^MAG(2005.85,3,1,0)="^2005.852P^6^6",^MAG(2005.85,3,1,1,0)=2  ;EKG has more specialty
  1.  . S ^MAG(2005.85,3,1,2,0)=39,^MAG(2005.85,3,1,3,0)=1
  1.  . S ^MAG(2005.85,3,1,4,0)=87,^MAG(2005.85,3,1,5,0)=42
  1.  . S ^MAG(2005.85,3,1,6,0)=52,^MAG(2005.85,3,1,"B",1,3)=""
  1.  . S ^MAG(2005.85,3,1,"B",2,1)="",^MAG(2005.85,3,1,"B",39,2)=""
  1.  . S ^MAG(2005.85,3,1,"B",42,5)="",^MAG(2005.85,3,1,"B",52,6)=""
  1.  . S ^MAG(2005.85,3,1,"B",87,4)=""
  1.  . S ^MAG(2005.85,210,0)="STATE AUTHORIZED PORTABLE ORDERS^7^I"  ;IHS has inactive SAPO
  1.  . Q
  1.  I '$$ISIHS^MAGSPID() D  ;VA
  1.  . S IN=98 S:$D(^MAG(2005.84,IN,0)) $P(^(0),"^",4)="I" ;Physical Therapy, active for IHS only
  1.  . S DIC=2005,D=45,D0=$G(^DD(DIC,D,0)) I $P(D0,U,2)="S" S D2=$P(D0,U,3) D 
  1.  .. S:D2["U:URBAN;" D2=$P(D2,"U:URBAN;",1)  ;remove IHS term from VA
  1.  .. S:D2["T:TRIBAL;" D2=$P(D2,"T:TRIBAL;",1)
  1.  .. S $P(^DD(DIC,D,0),U,3)=D2
  1.  .. Q
  1.  . Q
  1.  ;--- Send the notification e-mail
  1.  D BMES^XPDUTL("Post Install Mail Message: "_$$FMTE^XLFDT($$NOW^XLFDT))
  1.  D INS^MAGQBUT4(XPDNM,DUZ,$$NOW^XLFDT,XPDA)
  1.  Q
  1.  ;
  1. ERR ;error handler
  1.  Q:'$G(DUZ)
  1.  I $G(TKID) I $D(^XTMP("MAG INDEX TERMS BACKUP",TKID)) D RECOVER
  1.  S XPDABORT=1
  1.  D @^%ZOSF("ERRTN")
  1.  Q
  1.  ;
  1. CHKSTA ;verify current site status w/ National
  1.  N IN,IEN,STA,STO S IEN=0  ;only 2 terms can inactive by local site
  1.  S IN=2005.84 F  S IEN=$O(^TMP(SUB,$J,0,IN,IEN)) Q:'IEN  D
  1.  . S STO=$P(^TMP(SUB,$J,0,IN,IEN,0),U,4),STA=$P($G(^MAG(IN,IEN,0)),U,4)
  1.  . I STA="I" Q  ;Apply inactive by VA national
  1.  . I STO="I" S $P(^MAG(IN,IEN,0),U,4)=STO Q  ;keep site Option
  1.  . Q
  1.  S IN=2005.85 F  S IEN=$O(^TMP(SUB,$J,0,IN,IEN)) Q:'IEN  D
  1.  . S STO=$P(^TMP(SUB,$J,0,IN,IEN,0),U,3),STA=$P($G(^MAG(IN,IEN,0)),U,3)
  1.  . I STA="I" Q  ;Apply inactive by VA national
  1.  . I STO="I" S $P(^MAG(IN,IEN,0),U,3)=STO Q  ;keep site Option
  1.  . Q
  1.  Q
  1.  ;
  1. RECOVER ;Call restore old value, in case of error
  1.  Q:$G(TKID)=""
  1.  N IN
  1.  F IN=2005.82,2005.83,2005.84,2005.85 D  U IO(0) W ^MAG(IN,0),!
  1.  . I $D(^MAG(IN))&$D(^XTMP("MAG INDEX TERMS BACKUP",TKID,IN)) D
  1.  . . K ^MAG(IN) M ^MAG(IN)=^XTMP("MAG INDEX TERMS BACKUP",TKID,IN) ;recoverd
  1.  . Q
  1.  Q
  1.  ;