ATXSTX2 ; IHS/OHPRD/TMJ - SEND TAXONOMY WITH PACKAGE ;
;;5.1;TAXONOMY;**11**;FEB 04, 1997;Build 48
;
;
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
K ^ATXAX(ATXTIEN,21) ; kill multiple in case of bad data
; 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
. S Y=$G(^TMP("ATX",$J,9002226.02101,ATXTIENS,.03))
. S:Y'="" DIC("DR")=DIC("DR")_";.03////"_Y
. D DIC
. Q
;1101 - file extended description if it exists
K ^ATXAX(ATXTIEN,11) ;clean out old WP field
K ATXWP ;clean out WP array
S ATXERR=""
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)
D WP^DIE(9002226,ATXTIEN_",",1101,"","ATXWP","ATXERR")
;4101
S ATXTIENS=""
F S ATXTIENS=$O(^TMP("ATX",$J,9002226.04101,ATXTIENS)) Q:ATXTIENS="" S X=^(ATXTIENS,.01) D
. S Y=$O(^DIC(9.4,"C",X,0))
. Q:'Y ;no package entry
. I $D(^ATXAX(ATXTIEN,41,"B",Y)) ;already has this package
. S X="`"_Y
. S DIC="^ATXAX("_ATXTIEN_",41,",DIC(0)="L",DIC("P")="9002226.04101A",DA(1)=ATXTIEN
. D DIC
. Q
;5101
S ATXTIENS=""
F S ATXTIENS=$O(^TMP("ATX",$J,9002226.05101,ATXTIENS)) Q:ATXTIENS="" S X=^(ATXTIENS,.01) D
. I $D(^ATXAX(ATXTIEN,51,"B",Y)) ;already has this term
. S DIC="^ATXAX("_ATXTIEN_",51,",DIC(0)="L",DIC("P")="9002226.05101A",DA(1)=ATXTIEN
. 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^XBVK("ATX")
K ^TMP("ATX",$J)
Q
ATXSTX2 ; IHS/OHPRD/TMJ - SEND TAXONOMY WITH PACKAGE ;
+1 ;;5.1;TAXONOMY;**11**;FEB 04, 1997;Build 48
+2 ;
+3 ;
BULL ;EP GENERATE OR UPDATE BULLETIN
+1 SET ATXBSBR=$ORDER(^TMP("ATX",$JOB,3.6,0))
+2 SET ATXBULL=^TMP("ATX",$JOB,3.6,ATXBSBR,.01)
+3 SET ATXBIEN=$ORDER(^XMB(3.6,"B",ATXBULL,0))
+4 WRITE !,$SELECT(ATXBIEN:"Updating [",1:"Creating [")_ATXBULL_"] bulletin... "
+5 IF 'ATXBIEN
Begin DoDot:1
+6 SET X=ATXBULL
SET DIC="^XMB(3.6,"
SET DIC(0)="L"
SET DIC("DR")=""
SET DIADD=1
SET DLAYGO=3.6
+7 DO DIC
+8 IF Y<0
WRITE !!,"Adding bulletin failed. Notify developer.",!
QUIT
+9 SET ATXBIEN=+Y
+10 QUIT
End DoDot:1
+11 IF 'ATXBIEN
QUIT
+12 SET DR="2////"_$GET(^TMP("ATX",$JOB,3.6,ATXBSBR,2))
+13 DO BULLDIE
+14 ; kill message (field 10, subscript 1)
KILL ^XMB(3.6,ATXBIEN,1)
+15 IF $DATA(^TMP("ATX",$JOB,3.63,ATXBSBR,1,0))
SET X=^(0)
Begin DoDot:1
+16 SET ^XMB(3.6,ATXBIEN,1,0)=X
+17 SET ATXBMIEN=0
+18 FOR
SET ATXBMIEN=$ORDER(^TMP("ATX",$JOB,3.63,ATXBSBR,1,ATXBMIEN))
IF 'ATXBMIEN
QUIT
SET X=^(ATXBMIEN,0)
SET ^XMB(3.6,ATXBIEN,1,ATXBMIEN,0)=X
+19 QUIT
End DoDot:1
+20 ; kill message (field 6, subscript 3)
KILL ^XMB(3.6,ATXBIEN,3)
+21 ; add new message
+22 IF $DATA(^TMP("ATX",$JOB,3.63,ATXBSBR,3,0))
SET X=^(0)
Begin DoDot:1
+23 SET ^XMB(3.6,ATXBIEN,3,0)=X
+24 SET ATXBMIEN=0
+25 FOR
SET ATXBMIEN=$ORDER(^TMP("ATX",$JOB,3.63,ATXBSBR,3,ATXBMIEN))
IF 'ATXBMIEN
QUIT
SET X=^(ATXBMIEN,0)
SET ^XMB(3.6,ATXBIEN,3,ATXBMIEN,0)=X
+26 QUIT
End DoDot:1
+27 ; delete current parameter list
+28 SET ATXBMIEN=0
+29 FOR
SET ATXBMIEN=$ORDER(^XMB(3.6,ATXBIEN,4,ATXBMIEN))
IF 'ATXBMIEN
QUIT
Begin DoDot:1
+30 SET DIK="^XMB(3.6,"_ATXBIEN_",4,"
SET DA(1)=ATXBIEN
SET DA=ATXBMIEN
+31 DO ^DIK
+32 QUIT
End DoDot:1
+33 ; add new parameter list
+34 SET ATXBIENS=""
+35 FOR
SET ATXBIENS=$ORDER(^TMP("ATX",$JOB,3.64,ATXBIENS))
IF ATXBIENS=""
QUIT
SET X=^(ATXBIENS,.01)
Begin DoDot:1
+36 SET DIC="^XMB(3.6,"_ATXBIEN_",4,"
SET DIC(0)="L"
SET DIC("P")="3.64A"
SET DA(1)=ATXBIEN
+37 DO DIC
+38 IF Y<0
QUIT
+39 SET ATXBMIEN=+Y
+40 ; add wp description under parameter multiple
+41 IF $DATA(^TMP("ATX",$JOB,3.64,ATXBIENS,1,0))
SET X=^(0)
Begin DoDot:2
+42 SET ^XMB(3.6,ATXBIEN,4,ATXBMIEN,1,0)=X
+43 SET ATXY=0
+44 FOR
SET ATXY=$ORDER(^TMP("ATX",$JOB,3.64,ATXBIENS,1,ATXY))
IF 'ATXY
QUIT
SET X=^(ATXY,0)
SET ^XMB(3.6,ATXBIEN,4,ATXBMIEN,1,ATXY,0)=X
+45 QUIT
End DoDot:2
+46 QUIT
End DoDot:1
+47 QUIT
+48 ;
BULLDIE ; ^DIE CALLS FOR BULLETIN
+1 IF DR=""
QUIT
+2 SET DIE="^XMB(3.6,"
SET DA=ATXBIEN
+3 DO DIE
+4 QUIT
+5 ;
TAX ;EP GENERATE OR UPDATE TAXONOMY
+1 SET ATXTSBR=$ORDER(^TMP("ATX",$JOB,9002226,0))
+2 SET ATXTNAM=^TMP("ATX",$JOB,9002226,ATXTSBR,.01)
+3 SET ATXTIEN=$ORDER(^ATXAX("B",ATXTNAM,0))
+4 WRITE !,$SELECT(ATXTIEN:"Updating [",1:"Creating [")_ATXTNAM_"] taxonomy... "
+5 IF 'ATXTIEN
Begin DoDot:1
+6 SET X=ATXTNAM
SET DIC="^ATXAX("
SET DIC(0)="L"
SET DIC("DR")=""
SET DIADD=1
SET DLAYGO=9002226
+7 NEW ATXFLG
SET ATXFLG=1
+8 DO DIC
+9 IF Y<0
WRITE !!,"Adding taxonomy failed. Notify developer.",!
QUIT
+10 SET ATXTIEN=+Y
+11 QUIT
End DoDot:1
+12 IF 'ATXTIEN
QUIT
+13 SET DR=".05////.5"
IF $GET(ATXBIEN)
SET DR=DR_";.07////"_ATXBIEN
+14 SET ATXFIELD=""
+15 FOR
SET ATXFIELD=$ORDER(^TMP("ATX",$JOB,9002226,ATXTSBR,ATXFIELD))
IF ATXFIELD=""
QUIT
SET X=^(ATXFIELD)
SET DR=DR_";"_ATXFIELD_"////"_X
+16 DO TAXDIE
+17 ; delete current code list
+18 SET ATXTMIEN=0
+19 FOR
SET ATXTMIEN=$ORDER(^ATXAX(ATXTIEN,21,ATXTMIEN))
IF 'ATXTMIEN
QUIT
Begin DoDot:1
+20 SET DIK="^ATXAX("_ATXTIEN_",21,"
SET DA(1)=ATXTIEN
SET DA=ATXTMIEN
+21 DO ^DIK
+22 QUIT
End DoDot:1
+23 ; kill multiple in case of bad data
KILL ^ATXAX(ATXTIEN,21)
+24 ; add new code list
+25 SET ATXTIENS=""
+26 FOR
SET ATXTIENS=$ORDER(^TMP("ATX",$JOB,9002226.02101,ATXTIENS))
IF ATXTIENS=""
QUIT
SET X=^(ATXTIENS,.01)
Begin DoDot:1
+27 SET DIC="^ATXAX("_ATXTIEN_",21,"
SET DIC(0)="L"
SET DIC("P")="9002226.02101A"
SET DA(1)=ATXTIEN
+28 SET Y=$GET(^TMP("ATX",$JOB,9002226.02101,ATXTIENS,.02))
+29 IF Y'=""
SET DIC("DR")=".02////"_Y
+30 SET Y=$GET(^TMP("ATX",$JOB,9002226.02101,ATXTIENS,.03))
+31 IF Y'=""
SET DIC("DR")=DIC("DR")_";.03////"_Y
+32 DO DIC
+33 QUIT
End DoDot:1
+34 ;1101 - file extended description if it exists
+35 ;clean out old WP field
KILL ^ATXAX(ATXTIEN,11)
+36 ;clean out WP array
KILL ATXWP
+37 SET ATXERR=""
+38 SET ATXTSBR=""
SET X=""
SET C=0
FOR
SET ATXTSBR=$ORDER(^TMP("ATX",$JOB,9002226.01101,ATXTSBR))
IF ATXTSBR=""
QUIT
SET C=C+1
SET ATXWP(C)=^TMP("ATX",$JOB,9002226.01101,ATXTSBR,.01)
+39 DO WP^DIE(9002226,ATXTIEN_",",1101,"","ATXWP","ATXERR")
+40 ;4101
+41 SET ATXTIENS=""
+42 FOR
SET ATXTIENS=$ORDER(^TMP("ATX",$JOB,9002226.04101,ATXTIENS))
IF ATXTIENS=""
QUIT
SET X=^(ATXTIENS,.01)
Begin DoDot:1
+43 SET Y=$ORDER(^DIC(9.4,"C",X,0))
+44 ;no package entry
IF 'Y
QUIT
+45 ;already has this package
IF $DATA(^ATXAX(ATXTIEN,41,"B",Y))
+46 SET X="`"_Y
+47 SET DIC="^ATXAX("_ATXTIEN_",41,"
SET DIC(0)="L"
SET DIC("P")="9002226.04101A"
SET DA(1)=ATXTIEN
+48 DO DIC
+49 QUIT
End DoDot:1
+50 ;5101
+51 SET ATXTIENS=""
+52 FOR
SET ATXTIENS=$ORDER(^TMP("ATX",$JOB,9002226.05101,ATXTIENS))
IF ATXTIENS=""
QUIT
SET X=^(ATXTIENS,.01)
Begin DoDot:1
+53 ;already has this term
IF $DATA(^ATXAX(ATXTIEN,51,"B",Y))
+54 SET DIC="^ATXAX("_ATXTIEN_",51,"
SET DIC(0)="L"
SET DIC("P")="9002226.05101A"
SET DA(1)=ATXTIEN
+55 DO DIC
+56 QUIT
End DoDot:1
+57 QUIT
+58 ;
TAXDIE ; ^DIE CALL FOR TAX
+1 IF DR=""
QUIT
+2 SET DIE="^ATXAX("
SET DA=ATXTIEN
+3 DO DIE
+4 QUIT
+5 ;
DIC ; CALL ^DIC
+1 DO ^DIC
+2 KILL D,DD,D0,D1,DA,DI,DIADD,DIC,DICR,DIE,DIPGM,DLAYGO,DO,DQ,DR,DINUM
+3 QUIT
+4 ;
DIE ; CALL ^DIE
+1 DO ^DIE
+2 KILL D,D0,D1,DI,DIADD,DIC,DICR,DIE,DLAYGO,DQ,DR,DINUM
+3 QUIT
+4 ;
KILL ;EP KILL VARIABLES AND ^TMP GLOBAL ENTRIES
+1 DO EN^XBVK("ATX")
+2 KILL ^TMP("ATX",$JOB)
+3 QUIT
