APCLPOS2 ; IHS/OHPRD/TMJ -CREATED BY ^XBERERTN ON APR 04, 1996 ;
;;3.0;IHS PCC REPORTS;;FEB 05, 1997
; This routine loads Routine ^ATXSTX2
;
START ;
S XBERPGM="ATXSTX2"
F I=1:1 S Y=$P($T(RTN+I),";;",2,99) Q:Y="" S X="^TMP(""XBERPGM"",$J,"_I_",0)" S @X=Y
S XCN=0,DIE="^TMP(""XBERPGM"","_$J_",",X=XBERPGM
X ^%ZOSF("SAVE")
K DIE,XCM,XCN
S X=XBERPGM
X ^%ZOSF("TEST")
W !
I $T W "Routine ^",XBERPGM," has been filed.",! I 1
E W "Saving of routine ^",XBERPGM," failed.",!
K ^TMP("XBERPGM",$J)
K XBERPGM,I,X,Y
Q
;
RTN ; The routine to be loaded follows:
;;ATXSTX2 ; IHS/OHPRD/EDE - SEND TAXONOMY WITH PACKAGE ; [ 01/04/96 3:59 PM ]
;; ;
;; ;
;;BULL ;EP GENERATE OR UPDATE BULLETIN
;; S ATXBSBR=$O(^TMP("ATX",$J,3.6,0))
;; S ATXBULL=^TMP("ATX",$J,3.6,ATXBSBR,.01)
;; S ATXBIEN=$O(^XMB(3.6,"B",ATXBULL,0))
;; W !,$S(ATXBIEN:"Updating [",1:"Creating [")_ATXBULL_"] bulletin... "
;; I 'ATXBIEN D
;; . S X=ATXBULL,DIC="^XMB(3.6,",DIC(0)="L",DIC("DR")="",DIADD=1,DLAYGO=3.6
;; . D DIC
;; . I Y<0 W !!,"Adding bulletin failed. Notify developer.",! Q
;; . S ATXBIEN=+Y
;; . Q
;; Q:'ATXBIEN
;; S DR="2////"_$G(^TMP("ATX",$J,3.6,ATXBSBR,2))
;; D BULLDIE
;; K ^XMB(3.6,ATXBIEN,1) ; kill message (field 10, subscript 1)
;; I $D(^TMP("ATX",$J,3.63,ATXBSBR,1,0)) S X=^(0) D
;; . S ^XMB(3.6,ATXBIEN,1,0)=X
;; . S ATXBMIEN=0
;; . 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
;; . Q
;; K ^XMB(3.6,ATXBIEN,3) ; kill message (field 6, subscript 3)
;; ; add new message
;; I $D(^TMP("ATX",$J,3.63,ATXBSBR,3,0)) S X=^(0) D
;; . S ^XMB(3.6,ATXBIEN,3,0)=X
;; . S ATXBMIEN=0
;; . 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
;; . Q
;; ; delete current parameter list
;; S ATXBMIEN=0
;; F S ATXBMIEN=$O(^XMB(3.6,ATXBIEN,4,ATXBMIEN)) Q:'ATXBMIEN D
;; . S DIK="^XMB(3.6,"_ATXBIEN_",4,",DA(1)=ATXBIEN,DA=ATXBMIEN
;; . D ^DIK
;; . Q
;; ; add new parameter list
;; S ATXBIENS=""
;; F S ATXBIENS=$O(^TMP("ATX",$J,3.64,ATXBIENS)) Q:ATXBIENS="" S X=^(ATXBIENS,.01) D
;; . S DIC="^XMB(3.6,"_ATXBIEN_",4,",DIC(0)="L",DIC("P")="3.64A",DA(1)=ATXBIEN
;; . D DIC
;; . Q:Y<0
;; . S ATXBMIEN=+Y
;; .; add wp description under parameter multiple
;; . I $D(^TMP("ATX",$J,3.64,ATXBIENS,1,0)) S X=^(0) D
;; .. S ^XMB(3.6,ATXBIEN,4,ATXBMIEN,1,0)=X
;; .. S ATXY=0
;; .. 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
;; .. Q
;; . Q
;; Q
;; ;
;;BULLDIE ; ^DIE CALLS FOR BULLETIN
;; Q:DR=""
;; S DIE="^XMB(3.6,",DA=ATXBIEN
;; D DIE
;; Q
;; ;
;;TAX ;EP GENERATE OR UPDATE TAXONOMY
;; S ATXTSBR=$O(^TMP("ATX",$J,9002226,0))
;; S ATXTNAM=^TMP("ATX",$J,9002226,ATXTSBR,.01)
;; S ATXTIEN=$O(^ATXAX("B",ATXTNAM,0))
;; W !,$S(ATXTIEN:"Updating [",1:"Creating [")_ATXTNAM_"] taxonomy... "
;; I 'ATXTIEN D
;; . S X=ATXTNAM,DIC="^ATXAX(",DIC(0)="L",DIC("DR")="",DIADD=1,DLAYGO=9002226
;; . NEW ATXFLG S ATXFLG=1
;; . D DIC
;; . I Y<0 W !!,"Adding taxonomy failed. Notify developer.",! Q
;; . S ATXTIEN=+Y
;; . Q
;; Q:'ATXTIEN
;; S DR=".05////.5" S:$G(ATXBIEN) DR=DR_";.07////"_ATXBIEN
;; S ATXFIELD=""
;; F S ATXFIELD=$O(^TMP("ATX",$J,9002226,ATXTSBR,ATXFIELD)) Q:ATXFIELD="" S X=^(ATXFIELD),DR=DR_";"_ATXFIELD_"////"_X
;; D TAXDIE
;; ; delete current code list
;; S ATXTMIEN=0
;; F S ATXTMIEN=$O(^ATXAX(ATXTIEN,21,ATXTMIEN)) Q:'ATXTMIEN D
;; . S DIK="^ATXAX("_ATXTIEN_",21,",DA(1)=ATXTIEN,DA=ATXTMIEN
;; . D ^DIK
;; . Q
;; ; add new code list
;; S ATXTIENS=""
;; F S ATXTIENS=$O(^TMP("ATX",$J,9002226.02101,ATXTIENS)) Q:ATXTIENS="" S X=^(ATXTIENS,.01) D
;; . S DIC="^ATXAX("_ATXTIEN_",21,",DIC(0)="L",DIC("P")="9002226.02101A",DA(1)=ATXTIEN
;; . S Y=$G(^TMP("ATX",$J,9002226.02101,ATXTIENS,.02))
;; . S:Y'="" DIC("DR")=".02////"_Y
;; . D DIC
;; . Q
;; Q
;; ;
;;TAXDIE ; ^DIE CALL FOR TAX
;; Q:DR=""
;; S DIE="^ATXAX(",DA=ATXTIEN
;; D DIE
;; Q
;; ;
;;DIC ; CALL ^DIC
;; D ^DIC
;; K D,DD,D0,D1,DA,DI,DIADD,DIC,DICR,DIE,DIPGM,DLAYGO,DO,DQ,DR,DINUM
;; Q
;; ;
;;DIE ; CALL ^DIE
;; D ^DIE
;; K D,D0,D1,DI,DIADD,DIC,DICR,DIE,DLAYGO,DQ,DR,DINUM
;; Q
;; ;
;;KILL ;EP KILL VARIABLES AND ^TMP GLOBAL ENTRIES
;; D EN^ZIBVK("ATX")
;; K ^TMP("ATX",$J)
;; Q
APCLPOS2 ; IHS/OHPRD/TMJ -CREATED BY ^XBERERTN ON APR 04, 1996 ;
+1 ;;3.0;IHS PCC REPORTS;;FEB 05, 1997
+2 ; This routine loads Routine ^ATXSTX2
+3 ;
START ;
+1 SET XBERPGM="ATXSTX2"
+2 FOR I=1:1
SET Y=$PIECE($TEXT(RTN+I),";;",2,99)
IF Y=""
QUIT
SET X="^TMP(""XBERPGM"",$J,"_I_",0)"
SET @X=Y
+3 SET XCN=0
SET DIE="^TMP(""XBERPGM"","_$JOB_","
SET X=XBERPGM
+4 XECUTE ^%ZOSF("SAVE")
+5 KILL DIE,XCM,XCN
+6 SET X=XBERPGM
+7 XECUTE ^%ZOSF("TEST")
+8 WRITE !
+9 IF $TEST
WRITE "Routine ^",XBERPGM," has been filed.",!
IF 1
+10 IF '$TEST
WRITE "Saving of routine ^",XBERPGM," failed.",!
+11 KILL ^TMP("XBERPGM",$JOB)
+12 KILL XBERPGM,I,X,Y
+13 QUIT
+14 ;
RTN ; The routine to be loaded follows:
+1 ;;ATXSTX2 ; IHS/OHPRD/EDE - SEND TAXONOMY WITH PACKAGE ; [ 01/04/96 3:59 PM ]
+2 ;; ;
+3 ;; ;
+4 ;;BULL ;EP GENERATE OR UPDATE BULLETIN
+5 ;; S ATXBSBR=$O(^TMP("ATX",$J,3.6,0))
+6 ;; S ATXBULL=^TMP("ATX",$J,3.6,ATXBSBR,.01)
+7 ;; S ATXBIEN=$O(^XMB(3.6,"B",ATXBULL,0))
+8 ;; W !,$S(ATXBIEN:"Updating [",1:"Creating [")_ATXBULL_"] bulletin... "
+9 ;; I 'ATXBIEN D
+10 ;; . S X=ATXBULL,DIC="^XMB(3.6,",DIC(0)="L",DIC("DR")="",DIADD=1,DLAYGO=3.6
+11 ;; . D DIC
+12 ;; . I Y<0 W !!,"Adding bulletin failed. Notify developer.",! Q
+13 ;; . S ATXBIEN=+Y
+14 ;; . Q
+15 ;; Q:'ATXBIEN
+16 ;; S DR="2////"_$G(^TMP("ATX",$J,3.6,ATXBSBR,2))
+17 ;; D BULLDIE
+18 ;; K ^XMB(3.6,ATXBIEN,1) ; kill message (field 10, subscript 1)
+19 ;; I $D(^TMP("ATX",$J,3.63,ATXBSBR,1,0)) S X=^(0) D
+20 ;; . S ^XMB(3.6,ATXBIEN,1,0)=X
+21 ;; . S ATXBMIEN=0
+22 ;; . 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
+23 ;; . Q
+24 ;; K ^XMB(3.6,ATXBIEN,3) ; kill message (field 6, subscript 3)
+25 ;; ; add new message
+26 ;; I $D(^TMP("ATX",$J,3.63,ATXBSBR,3,0)) S X=^(0) D
+27 ;; . S ^XMB(3.6,ATXBIEN,3,0)=X
+28 ;; . S ATXBMIEN=0
+29 ;; . 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
+30 ;; . Q
+31 ;; ; delete current parameter list
+32 ;; S ATXBMIEN=0
+33 ;; F S ATXBMIEN=$O(^XMB(3.6,ATXBIEN,4,ATXBMIEN)) Q:'ATXBMIEN D
+34 ;; . S DIK="^XMB(3.6,"_ATXBIEN_",4,",DA(1)=ATXBIEN,DA=ATXBMIEN
+35 ;; . D ^DIK
+36 ;; . Q
+37 ;; ; add new parameter list
+38 ;; S ATXBIENS=""
+39 ;; F S ATXBIENS=$O(^TMP("ATX",$J,3.64,ATXBIENS)) Q:ATXBIENS="" S X=^(ATXBIENS,.01) D
+40 ;; . S DIC="^XMB(3.6,"_ATXBIEN_",4,",DIC(0)="L",DIC("P")="3.64A",DA(1)=ATXBIEN
+41 ;; . D DIC
+42 ;; . Q:Y<0
+43 ;; . S ATXBMIEN=+Y
+44 ;; .; add wp description under parameter multiple
+45 ;; . I $D(^TMP("ATX",$J,3.64,ATXBIENS,1,0)) S X=^(0) D
+46 ;; .. S ^XMB(3.6,ATXBIEN,4,ATXBMIEN,1,0)=X
+47 ;; .. S ATXY=0
+48 ;; .. 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
+49 ;; .. Q
+50 ;; . Q
+51 ;; Q
+52 ;; ;
+53 ;;BULLDIE ; ^DIE CALLS FOR BULLETIN
+54 ;; Q:DR=""
+55 ;; S DIE="^XMB(3.6,",DA=ATXBIEN
+56 ;; D DIE
+57 ;; Q
+58 ;; ;
+59 ;;TAX ;EP GENERATE OR UPDATE TAXONOMY
+60 ;; S ATXTSBR=$O(^TMP("ATX",$J,9002226,0))
+61 ;; S ATXTNAM=^TMP("ATX",$J,9002226,ATXTSBR,.01)
+62 ;; S ATXTIEN=$O(^ATXAX("B",ATXTNAM,0))
+63 ;; W !,$S(ATXTIEN:"Updating [",1:"Creating [")_ATXTNAM_"] taxonomy... "
+64 ;; I 'ATXTIEN D
+65 ;; . S X=ATXTNAM,DIC="^ATXAX(",DIC(0)="L",DIC("DR")="",DIADD=1,DLAYGO=9002226
+66 ;; . NEW ATXFLG S ATXFLG=1
+67 ;; . D DIC
+68 ;; . I Y<0 W !!,"Adding taxonomy failed. Notify developer.",! Q
+69 ;; . S ATXTIEN=+Y
+70 ;; . Q
+71 ;; Q:'ATXTIEN
+72 ;; S DR=".05////.5" S:$G(ATXBIEN) DR=DR_";.07////"_ATXBIEN
+73 ;; S ATXFIELD=""
+74 ;; F S ATXFIELD=$O(^TMP("ATX",$J,9002226,ATXTSBR,ATXFIELD)) Q:ATXFIELD="" S X=^(ATXFIELD),DR=DR_";"_ATXFIELD_"////"_X
+75 ;; D TAXDIE
+76 ;; ; delete current code list
+77 ;; S ATXTMIEN=0
+78 ;; F S ATXTMIEN=$O(^ATXAX(ATXTIEN,21,ATXTMIEN)) Q:'ATXTMIEN D
+79 ;; . S DIK="^ATXAX("_ATXTIEN_",21,",DA(1)=ATXTIEN,DA=ATXTMIEN
+80 ;; . D ^DIK
+81 ;; . Q
+82 ;; ; add new code list
+83 ;; S ATXTIENS=""
+84 ;; F S ATXTIENS=$O(^TMP("ATX",$J,9002226.02101,ATXTIENS)) Q:ATXTIENS="" S X=^(ATXTIENS,.01) D
+85 ;; . S DIC="^ATXAX("_ATXTIEN_",21,",DIC(0)="L",DIC("P")="9002226.02101A",DA(1)=ATXTIEN
+86 ;; . S Y=$G(^TMP("ATX",$J,9002226.02101,ATXTIENS,.02))
+87 ;; . S:Y'="" DIC("DR")=".02////"_Y
+88 ;; . D DIC
+89 ;; . Q
+90 ;; Q
+91 ;; ;
+92 ;;TAXDIE ; ^DIE CALL FOR TAX
+93 ;; Q:DR=""
+94 ;; S DIE="^ATXAX(",DA=ATXTIEN
+95 ;; D DIE
+96 ;; Q
+97 ;; ;
+98 ;;DIC ; CALL ^DIC
+99 ;; D ^DIC
+100 ;; K D,DD,D0,D1,DA,DI,DIADD,DIC,DICR,DIE,DIPGM,DLAYGO,DO,DQ,DR,DINUM
+101 ;; Q
+102 ;; ;
+103 ;;DIE ; CALL ^DIE
+104 ;; D ^DIE
+105 ;; K D,D0,D1,DI,DIADD,DIC,DICR,DIE,DLAYGO,DQ,DR,DINUM
+106 ;; Q
+107 ;; ;
+108 ;;KILL ;EP KILL VARIABLES AND ^TMP GLOBAL ENTRIES
+109 ;; D EN^ZIBVK("ATX")
+110 ;; K ^TMP("ATX",$J)
+111 ;; Q
