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

APCLPOS2.m

Go to the documentation of this file. 
  1. APCLPOS2 ; IHS/OHPRD/TMJ -CREATED BY ^XBERERTN ON APR 04, 1996 ;
  1.  ;;3.0;IHS PCC REPORTS;;FEB 05, 1997
  1.  ; This routine loads Routine ^ATXSTX2
  1.  ;
  1. START ;
  1.  S XBERPGM="ATXSTX2"
  1.  F I=1:1 S Y=$P($T(RTN+I),";;",2,99) Q:Y=""  S X="^TMP(""XBERPGM"",$J,"_I_",0)" S @X=Y
  1.  S XCN=0,DIE="^TMP(""XBERPGM"","_$J_",",X=XBERPGM
  1.  X ^%ZOSF("SAVE")
  1.  K DIE,XCM,XCN
  1.  S X=XBERPGM
  1.  X ^%ZOSF("TEST")
  1.  W !
  1.  I $T W "Routine ^",XBERPGM," has been filed.",! I 1
  1.  E  W "Saving of routine ^",XBERPGM," failed.",!
  1.  K ^TMP("XBERPGM",$J)
  1.  K XBERPGM,I,X,Y
  1.  Q
  1.  ;
  1. RTN ; The routine to be loaded follows:
  1.  ;;ATXSTX2 ; IHS/OHPRD/EDE - SEND TAXONOMY WITH PACKAGE ; [ 01/04/96  3:59 PM ]
  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.  ;; ; 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.  ;; . 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^ZIBVK("ATX")
  1.  ;; K ^TMP("ATX",$J)
  1.  ;; Q