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

ATXSTX2.m

Go to the documentation of this file. 
  1. ATXSTX2 ; IHS/OHPRD/TMJ - SEND TAXONOMY WITH PACKAGE ; 
  1.  ;;5.1;TAXONOMY;**11**;FEB 04, 1997;Build 48
  1.  ;
  1.  ;
  1. BULL ;EP GENERATE OR UPDATE BULLETIN
  1.  S ATXBSBR=$O(^TMP("ATX",$J,3.6,0))
  1.  S ATXBULL=^TMP("ATX",$J,3.6,ATXBSBR,.01)
  1.  S ATXBIEN=$O(^XMB(3.6,"B",ATXBULL,0))
  1.  W !,$S(ATXBIEN:"Updating [",1:"Creating [")_ATXBULL_"] bulletin... "
  1.  I 'ATXBIEN D
  1.  . S X=ATXBULL,DIC="^XMB(3.6,",DIC(0)="L",DIC("DR")="",DIADD=1,DLAYGO=3.6
  1.  . D DIC
  1.  . I Y<0 W !!,"Adding bulletin failed.  Notify developer.",! Q
  1.  . S ATXBIEN=+Y
  1.  . Q
  1.  Q:'ATXBIEN
  1.  S DR="2////"_$G(^TMP("ATX",$J,3.6,ATXBSBR,2))
  1.  D BULLDIE
  1.  K ^XMB(3.6,ATXBIEN,1) ; kill message (field 10, subscript 1)
  1.  I $D(^TMP("ATX",$J,3.63,ATXBSBR,1,0)) S X=^(0) D
  1.  . S ^XMB(3.6,ATXBIEN,1,0)=X
  1.  . S ATXBMIEN=0
  1.  . F  S ATXBMIEN=$O(^TMP("ATX",$J,3.63,ATXBSBR,1,ATXBMIEN)) Q:'ATXBMIEN  S X=^(ATXBMIEN,0),^XMB(3.6,ATXBIEN,1,ATXBMIEN,0)=X
  1.  . Q
  1.  K ^XMB(3.6,ATXBIEN,3) ; kill message (field 6, subscript 3)
  1.  ; add new message
  1.  I $D(^TMP("ATX",$J,3.63,ATXBSBR,3,0)) S X=^(0) D
  1.  . S ^XMB(3.6,ATXBIEN,3,0)=X
  1.  . S ATXBMIEN=0
  1.  . F  S ATXBMIEN=$O(^TMP("ATX",$J,3.63,ATXBSBR,3,ATXBMIEN)) Q:'ATXBMIEN  S X=^(ATXBMIEN,0),^XMB(3.6,ATXBIEN,3,ATXBMIEN,0)=X
  1.  . Q
  1.  ; delete current parameter list
  1.  S ATXBMIEN=0
  1.  F  S ATXBMIEN=$O(^XMB(3.6,ATXBIEN,4,ATXBMIEN)) Q:'ATXBMIEN  D
  1.  . S DIK="^XMB(3.6,"_ATXBIEN_",4,",DA(1)=ATXBIEN,DA=ATXBMIEN
  1.  . D ^DIK
  1.  . Q
  1.  ; add new parameter list
  1.  S ATXBIENS=""
  1.  F  S ATXBIENS=$O(^TMP("ATX",$J,3.64,ATXBIENS)) Q:ATXBIENS=""  S X=^(ATXBIENS,.01) D
  1.  . S DIC="^XMB(3.6,"_ATXBIEN_",4,",DIC(0)="L",DIC("P")="3.64A",DA(1)=ATXBIEN
  1.  . D DIC
  1.  . Q:Y<0
  1.  . S ATXBMIEN=+Y
  1.  .; add wp description under parameter multiple
  1.  . I $D(^TMP("ATX",$J,3.64,ATXBIENS,1,0)) S X=^(0) D
  1.  .. S ^XMB(3.6,ATXBIEN,4,ATXBMIEN,1,0)=X
  1.  .. S ATXY=0
  1.  .. F  S ATXY=$O(^TMP("ATX",$J,3.64,ATXBIENS,1,ATXY)) Q:'ATXY  S X=^(ATXY,0),^XMB(3.6,ATXBIEN,4,ATXBMIEN,1,ATXY,0)=X
  1.  .. Q
  1.  . Q
  1.  Q
  1.  ;
  1. BULLDIE ; ^DIE CALLS FOR BULLETIN
  1.  Q:DR=""
  1.  S DIE="^XMB(3.6,",DA=ATXBIEN
  1.  D DIE
  1.  Q
  1.  ;
  1. TAX ;EP GENERATE OR UPDATE TAXONOMY
  1.  S ATXTSBR=$O(^TMP("ATX",$J,9002226,0))
  1.  S ATXTNAM=^TMP("ATX",$J,9002226,ATXTSBR,.01)
  1.  S ATXTIEN=$O(^ATXAX("B",ATXTNAM,0))
  1.  W !,$S(ATXTIEN:"Updating [",1:"Creating [")_ATXTNAM_"] taxonomy... "
  1.  I 'ATXTIEN D
  1.  . S X=ATXTNAM,DIC="^ATXAX(",DIC(0)="L",DIC("DR")="",DIADD=1,DLAYGO=9002226
  1.  . NEW ATXFLG S ATXFLG=1
  1.  . D DIC
  1.  . I Y<0 W !!,"Adding taxonomy failed.  Notify developer.",! Q
  1.  . S ATXTIEN=+Y
  1.  . Q
  1.  Q:'ATXTIEN
  1.  S DR=".05////.5" S:$G(ATXBIEN) DR=DR_";.07////"_ATXBIEN
  1.  S ATXFIELD=""
  1.  F  S ATXFIELD=$O(^TMP("ATX",$J,9002226,ATXTSBR,ATXFIELD)) Q:ATXFIELD=""  S X=^(ATXFIELD),DR=DR_";"_ATXFIELD_"////"_X
  1.  D TAXDIE
  1.  ; delete current code list
  1.  S ATXTMIEN=0
  1.  F  S ATXTMIEN=$O(^ATXAX(ATXTIEN,21,ATXTMIEN)) Q:'ATXTMIEN  D
  1.  . S DIK="^ATXAX("_ATXTIEN_",21,",DA(1)=ATXTIEN,DA=ATXTMIEN
  1.  . D ^DIK
  1.  . Q
  1.  K ^ATXAX(ATXTIEN,21) ;       kill multiple in case of bad data
  1.  ; add new code list
  1.  S ATXTIENS=""
  1.  F  S ATXTIENS=$O(^TMP("ATX",$J,9002226.02101,ATXTIENS)) Q:ATXTIENS=""  S X=^(ATXTIENS,.01) D
  1.  . S DIC="^ATXAX("_ATXTIEN_",21,",DIC(0)="L",DIC("P")="9002226.02101A",DA(1)=ATXTIEN
  1.  . S Y=$G(^TMP("ATX",$J,9002226.02101,ATXTIENS,.02))
  1.  . S:Y'="" DIC("DR")=".02////"_Y
  1.  . S Y=$G(^TMP("ATX",$J,9002226.02101,ATXTIENS,.03))
  1.  . S:Y'="" DIC("DR")=DIC("DR")_";.03////"_Y
  1.  . D DIC
  1.  . Q
  1.  ;1101 - file extended description if it exists
  1.  K ^ATXAX(ATXTIEN,11)  ;clean out old WP field
  1.  K ATXWP  ;clean out WP array
  1.  S ATXERR=""
  1.  S ATXTSBR="",X="",C=0 F  S ATXTSBR=$O(^TMP("ATX",$J,9002226.01101,ATXTSBR)) Q:ATXTSBR=""  S C=C+1,ATXWP(C)=^TMP("ATX",$J,9002226.01101,ATXTSBR,.01)
  1.  D WP^DIE(9002226,ATXTIEN_",",1101,"","ATXWP","ATXERR")
  1.  ;4101
  1.  S ATXTIENS=""
  1.  F  S ATXTIENS=$O(^TMP("ATX",$J,9002226.04101,ATXTIENS)) Q:ATXTIENS=""  S X=^(ATXTIENS,.01) D
  1.  . S Y=$O(^DIC(9.4,"C",X,0))
  1.  . Q:'Y  ;no package entry
  1.  . I $D(^ATXAX(ATXTIEN,41,"B",Y)) ;already has this package
  1.  . S X="`"_Y
  1.  . S DIC="^ATXAX("_ATXTIEN_",41,",DIC(0)="L",DIC("P")="9002226.04101A",DA(1)=ATXTIEN
  1.  . D DIC
  1.  . Q
  1.  ;5101
  1.  S ATXTIENS=""
  1.  F  S ATXTIENS=$O(^TMP("ATX",$J,9002226.05101,ATXTIENS)) Q:ATXTIENS=""  S X=^(ATXTIENS,.01) D
  1.  . I $D(^ATXAX(ATXTIEN,51,"B",Y)) ;already has this term
  1.  . S DIC="^ATXAX("_ATXTIEN_",51,",DIC(0)="L",DIC("P")="9002226.05101A",DA(1)=ATXTIEN
  1.  . D DIC
  1.  . Q
  1.  Q
  1.  ;
  1. TAXDIE ; ^DIE CALL FOR TAX
  1.  Q:DR=""
  1.  S DIE="^ATXAX(",DA=ATXTIEN
  1.  D DIE
  1.  Q
  1.  ;
  1. DIC ; CALL ^DIC
  1.  D ^DIC
  1.  K D,DD,D0,D1,DA,DI,DIADD,DIC,DICR,DIE,DIPGM,DLAYGO,DO,DQ,DR,DINUM
  1.  Q
  1.  ;
  1. DIE ; CALL ^DIE
  1.  D ^DIE
  1.  K D,D0,D1,DI,DIADD,DIC,DICR,DIE,DLAYGO,DQ,DR,DINUM
  1.  Q
  1.  ;
  1. KILL ;EP KILL VARIABLES AND ^TMP GLOBAL ENTRIES
  1.  D EN^XBVK("ATX")
  1.  K ^TMP("ATX",$J)
  1.  Q