ATXSTX ; IHS/OHPRD/TMJ - SEND TAXONOMY WITH PACKAGE ; 29 Apr 2014 8:34 AM
;;5.1;TAXONOMY;**11**;FEB 04, 1997;Build 48
;
;
START ;
D MAIN
D EOJ
Q
;
MAIN ;
D INIT
Q:ATXQ
F D GENRTN Q:ATXQ
Q:'ATXTSF ; quit if no taxonomy sent
;D POSTINIT ; update post-init in package file
Q
;
GENRTN ; GENERATE ROUTINE TO INSTALL TAXONOMY
K ^TMP($J),^TMP("ATX",$J)
D TAXONOMY ; get taxonomy to export
Q:ATXQ
D PGMNAME ; get program name
Q:ATXQ
D TXCHECK ; check taxonomy
Q:ATXQ
S ATXTSF=1 ; set flag that taxonomy sent
D TXSTORE ; store taxonomy
D BUILD ; build and save routines
D DRIVER ; build and save main driver
Q
;
INIT ;
D ^XBKVAR
S ATXQ=1
S ATXTSF=0 ; taxonomy sent flag
W !!,"This routine will build a post-init routine for the specified package."
W !,"The post-init routine will add the selected entry to the TAXONOMY file"
W !,"on the target machine.",!!
D PACKAGE ; get package
Q:ATXQ
S ATXQ=1
; get agency/site/programmer
W !
S DIR(0)="F^7:15",DIR("A")="Enter agency/site/programmer for routine first line",DIR("?")="E.g., IHS/OHPRD/EDE" K DA D ^DIR K DIR
Q:$D(DIRUT)
S ATXASP=X
W !!,"The name of the primary routine to be generated will be the package prefix"
W !,"followed by TX. For each taxonomy being sent there will be one routine with"
W !,"the same name followed by a letter A-Z. For large taxonomies there will be"
W !,"additional routines with the same letter A-Z followed by a letter A-Z.",!
S ATXQ=0
Q
;
PACKAGE ; GET PACKAGE
S ATXQ=1
S DIC="^DIC(9.4,",DIC(0)="AEMQ"
D ^DIC
K D,DD,D0,D1,DA,DI,DIADD,DIC,DICR,DIE,DIPGM,DLAYGO,DO,DQ,DR,DINUM
Q:Y<0
S ATXPK=+Y
S ATXPRFX=$P(^DIC(9.4,ATXPK,0),U,2)
S ATXQ=0
Q
;
PGMNAME ; GET PROGRAM NAME
S ATXQ=1
K DIR
S DIR(0)="F^1:6",DIR("A")="Name of Routine Set to Create (routine stub)" KILL DA D ^DIR KILL DIR
I $D(DIRUT) Q
S ATXPGMZ=Y
;S ATXPGM=ATXPRFX_"TX",ATXDRVR=ATXPGM
S ATXPGM=ATXPGMZ,ATXDRVR=ATXPGM
F ATXI=1:1:27 S X=ATXPGM_$C(64+ATXI) X ^%ZOSF("TEST") Q:'$T
I ATXI=27 W !,ATXPGM_"A-Z already exist. Cannot continue.",!! Q
S (ATXPGM,ATXPGMR)=X
W !!,"Generating new routine ^"_ATXPGM
S X=ATXDRVR X ^%ZOSF("TEST")
I $T W !,"Updating existing routine ^"_ATXDRVR,! I 1
E W !,"Generating new routine ^"_ATXDRVR,!
S ATXQ=0
Q
;
TAXONOMY ; GET TAXONOMY
S ATXQ=1
S DIC="^ATXAX(",DIC(0)="AEMQZ"
D ^DIC
K D,DD,D0,D1,DA,DI,DIADD,DIC,DICR,DIE,DIPGM,DLAYGO,DO,DQ,DR,DINUM
Q:Y<0
S ATXTX=+Y
S ATXTXNM=Y(0,0)
S ATXQ=0
Q
;
TXCHECK ; CHECK TAXONOMY
W !,"Checking taxonomy "
S ATXQ=0
D TXIENCHK ; see if values or iens
I ATXQ W !!,"Cannot send a taxonomy of IENs.",! Q
S ATXY=0
F ATX21C=0:1 S ATXY=$O(^ATXAX(ATXTX,21,ATXY)) Q:'ATXY D
. S X=$P(^ATXAX(ATXTX,21,ATXY,0),U)
. S:$E(X,$L(X))'=" " X=X_" "
. I $D(^TMP("ATX",$J,21,X)) W !!,"Duplicate code entry for code="_X,! S ATXQ=1 Q
. S ^TMP("ATX",$J,21,X)=ATXY
. Q
Q:ATXQ
S ATXQ=1
S ATXAAC=0
S ATXX=""
F ATXAAC=0:1 S ATXX=$O(^ATXAX(ATXTX,21,"AA",ATXX)) Q:ATXX=""
S ATXX=""
F ATXBC=0:1 S ATXX=$O(^ATXAX(ATXTX,21,"B",ATXX)) Q:ATXX=""
I 'ATX21C W !!,"No codes in taxonomy",! Q
I ATXBC'=ATX21C W !!,"B xref is not correct. B count=",ATXBC," Entry count=",ATX21C,! Q
I ATXAAC,ATXAAC'=ATX21C W !!,"AA xref is not correct. AA count=",ATXAAC," Entry count=",ATX21C,! Q
S ATXQ=0
Q
;
TXIENCHK ; CHECK TAXONOMY FOR IENS OR VALUES
S ATXFILE=$P(^ATXAX(ATXTX,0),U,15)
Q:'ATXFILE
S ATXFGBL=^DIC(ATXFILE,0,"GL")
S ATXY=0,ATXNIEN=0
F S ATXY=$O(^ATXAX(ATXTX,21,ATXY)) Q:'ATXY D Q:ATXNIEN
. S X=$P(^ATXAX(ATXTX,21,ATXY,0),U)
. I X'=+X S ATXNIEN=1 Q
. I '$D(@(ATXFGBL_"X,0)")) S ATXNIEN=1 Q
. Q
I 'ATXNIEN S ATXQ=1
Q
;
TXSTORE ; STORE TAXONOMY IN ^TMP
W !,"Storing taxonomy "
K ^TMP("DIERR",$J)
F ATXF=.01,.02,.04,.06,.08,.09,.11,.12,.13,.14,.15,.16,.17,3101 D
. S ATXX=$$VALI^XBDIQ1(9002226,ATXTX,ATXF)
. S:ATXX="" ATXX="@" ; if field null make null on target
. S ^TMP("ATX",$J,9002226,ATXTX,ATXF)=ATXX
. Q
S ATXCODE=""
F S ATXCODE=$O(^TMP("ATX",$J,21,ATXCODE)) Q:ATXCODE="" D
. S ATXY=^TMP("ATX",$J,21,ATXCODE)
. S ATXIENS=ATXTX_","_ATXY
. S ATXSBSC=ATXTX_","_ATXCODE
. W "."
. F ATXF=.01,.02,.03 D
.. S ATXX=$$VALI^XBDIQ1(9002226.02101,ATXIENS,ATXF)
.. Q:ATXX=""
.. S ^TMP("ATX",$J,9002226.02101,ATXSBSC,ATXF)=ATXX
.. Q
. Q
;store 5101 multiple
S ATXCODE=0 F S ATXCODE=$O(^ATXAX(ATXTX,51,ATXCODE)) Q:ATXCODE'=+ATXCODE D
. S ATXY=^ATXAX(ATXTX,51,ATXCODE,0)
. W ":"
. S ATXSBSC=ATXTX_","_ATXCODE
. S ^TMP("ATX",$J,9002226.05101,ATXSBSC,.01)=ATXY
. Q
;store 1101 multiple
S ATXCODE=0 F S ATXCODE=$O(^ATXAX(ATXTX,11,ATXCODE)) Q:ATXCODE'=+ATXCODE D
. S ATXY=^ATXAX(ATXTX,11,ATXCODE,0)
. W ":"
. S ATXSBSC=ATXTX_","_ATXCODE
. S ^TMP("ATX",$J,9002226.01101,ATXSBSC,.01)=ATXY
. Q
;store 4101 multiple
S ATXCODE=0 F S ATXCODE=$O(^ATXAX(ATXTX,41,ATXCODE)) Q:ATXCODE'=+ATXCODE D
. S ATXY=$P(^ATXAX(ATXTX,41,ATXCODE,0),U,1),ATXY=$P(^DIC(9.4,ATXY,0),U,2)
. W ":"
. S ATXSBSC=ATXTX_","_ATXCODE
. S ^TMP("ATX",$J,9002226.04101,ATXSBSC,.01)=ATXY
. Q
S ATXBULL=$$VALI^XBDIQ1(9002226,ATXTX,.07)
D:ATXBULL BULSTORE
; should the bulletin on the target machine be deleted if there
; is no bulletin on the sending machine? If yes, uncomment the
; following line:
;S:'ATXBULL ^TMP("ATX",$J,9002226,ATXTX,.07)="@"
Q
;
BULSTORE ; STORE BULLETIN
W !,"Storing bulletin "
F ATXF=.01,2 D
. S ATXX=$$VALI^XBDIQ1(3.6,ATXBULL,ATXF)
. Q:ATXX=""
. S ^TMP("ATX",$J,3.6,ATXBULL,ATXF)=ATXX
. Q
S ATXY=0
F S ATXY=$O(^XMB(3.6,ATXBULL,4,ATXY)) Q:'ATXY D
. S ATXIENS=ATXBULL_","_ATXY
. W "."
. S ATXX=$$VALI^XBDIQ1(3.64,ATXIENS,.01)
. Q:ATXX=""
. S ^TMP("ATX",$J,3.64,ATXIENS,.01)=ATXX
. Q:'$O(^XMB(3.6,ATXBULL,4,ATXY,1,0))
. S ^TMP("ATX",$J,3.64,ATXIENS,1,0)=^XMB(3.6,ATXBULL,4,ATXY,1,0)
. S ATXZ=0
. F S ATXZ=$O(^XMB(3.6,ATXBULL,4,ATXY,1,ATXZ)) Q:'ATXZ S ^TMP("ATX",$J,3.64,ATXIENS,1,ATXZ,0)=^(ATXZ,0)
. Q
I $O(^XMB(3.6,ATXBULL,3,0)) D
. S ^TMP("ATX",$J,3.63,ATXBULL,3,0)=^XMB(3.6,ATXBULL,3,0)
. S ATXY=0
. F S ATXY=$O(^XMB(3.6,ATXBULL,3,ATXY)) Q:'ATXY S ^TMP("ATX",$J,3.63,ATXBULL,3,ATXY,0)=^(ATXY,0)
. Q
I $O(^XMB(3.6,ATXBULL,1,0)) D
. S ^TMP("ATX",$J,3.63,ATXBULL,1,0)=^XMB(3.6,ATXBULL,1,0)
. S ATXY=0
. F S ATXY=$O(^XMB(3.6,ATXBULL,1,ATXY)) Q:'ATXY S ^TMP("ATX",$J,3.63,ATXBULL,1,ATXY,0)=^(ATXY,0)
. Q
Q
;
BUILD ;
W !,"Generating routines",!!
S Y=DT
D DD^%DT
S ATXVER=$S($D(^DIC(9.4,ATXPK,"VERSION")):^("VERSION"),1:"")_";"_$P(^DIC(9.4,ATXPK,0),U,1)_";;"_Y
K ^TMP("ATXPGM",$J)
S ATXPGMC=1
K ATXPGMS
D PGMBEG ; build main routine
S ATXZR=0
F S ATXZR=$O(^TMP("ATX",ATXZR)) Q:ATXZR=$J
S ATXZR="^TMP(""ATX"","_ATXZR_")"
D PGMTMP ; build TMP for $T
S X=" ;" D SETTMP
S X="OTHER ; OTHER ROUTINES" D SETTMP
S ATXX=""
F S ATXX=$O(ATXPGMS(ATXX)) Q:ATXX="" S X=" D ^"_ATXX D SETTMP
S X=" Q" D SETTMP
D PGMSAVE ; save generated program
Q
;
PGMBEG ; BUILD BEGINNING OF PROGRAM
K ^TMP("ATXPGM",$J,ATXPGM)
S (ATXL,ATXLNTH)=0
S X=ATXPGM_" ;"_ATXASP_"-CREATED BY ^ATXSTX ON "_Y_";" D SETTMP
S X=" ;;"_ATXVER D SETTMP
I ATXPGMC=1 D
. S X=" ;;"_ATXTXNM D SETTMP
. S X=" ;" D SETTMP
. S X=" ; This routine loads Taxonomy "_ATXTXNM D SETTMP
. Q
F ATXI=1:1:5 S X=$P($T(CODE+ATXI),";;",2,99) Q:X="" D SETTMP
I ATXPGMC=1 F ATXI=6:1:10 S X=$P($T(CODE+ATXI),";;",2,99) Q:X="" D SETTMP
I ATXPGMC>1 S X=" Q" D SETTMP
Q
;
PGMTMP ; BUILD TMP DATA FOR $T ***(CALLED RECURSIVELY)***
S ATXTMPQ=0
S X=" ;" D SETTMP
S X="TMP ;;TAXONOMY (WITH BULLETIN)" D SETTMP
F S ATXZR=$Q(@ATXZR) Q:$P(ATXZR,",")'="^TMP(""ATX""" D PGMTMP2 Q:ATXTMPQ
Q
;
PGMTMP2 ;
S X=" ;;"_$P(ATXZR,$J_",",2,99) D SETTMP
S X=" ;;"_@ATXZR D SETTMP
I ATXLNTH>13000 D RECURSE S ATXTMPQ=1 Q
Q
;
PGMSAVE ; SAVE GENERATED PROGRAM
S XCN=0,DIE="^TMP(""ATXPGM"","_$J_","""_ATXPGM_""",",X=ATXPGM
X ^%ZOSF("SAVE")
K DIE,XCM,XCN
S X=ATXPGM
X ^%ZOSF("TEST")
I $T W "Routine ^",ATXPGM," has been filed.",! I 1
E W "Saving of routine ^",ATXPGM," failed.",!
K ^TMP("ATXPGM",$J,ATXPGM)
Q
;
SETTMP ; SET ^TMP GLOBAL
S ATXL=ATXL+1
S ^TMP("ATXPGM",$J,ATXPGM,ATXL,0)=X
S ATXLNTH=ATXLNTH+(4+$L(X))
Q
;
RECURSE ; CALLED FROM PGMTMP TO BUILD OTHER ROUTINES IF TOO LARGE
NEW ATXL,ATXLNTH,ATXPGM,ATXTMPQ
S ATXPGMC=ATXPGMC+1
S ATXPGM=ATXPGMR_ATXPGMC
D PGMBEG
D PGMTMP
D PGMSAVE
S ATXPGMS(ATXPGM)=""
Q
;
DRIVER ; BUILD MAIN DRIVER ROUTINE
S ATXPGM=ATXDRVR
K ^TMP("ATXPGM",$J,ATXPGM)
S (ATXL,ATXLNTH)=0
S X=ATXPGM_" ;"_ATXASP_"-CREATED BY ^ATXSTX ON "_Y_";" D SETTMP
S X=" ;;"_ATXVER D SETTMP
S X=" ;" D SETTMP
S X=" ; See referenced routines to see taxonomies being loaded." D SETTMP
S X=" ;" D SETTMP
S X="START ;" D SETTMP
F ATXI=1:1:26 S X=ATXPGM_$C(64+ATXI) X ^%ZOSF("TEST") Q:'$T D
. X "ZL @X S Z=$T(@X+2),Z=$P(Z,"";;"",2)"
. S Y="",$P(Y," ",(10-$L(X)))=" ",Y=" ;"_Y_Z
. S X=" D ^"_X_Y D SETTMP
. Q
S X=" Q" D SETTMP
D PGMSAVE
Q
;
POSTINIT ; UPDATE POST INIT ENTRY IN PACKAGE FILE
S ATXX=$$VALI^XBDIQ1(9.4,ATXPK,914)
I ATXX'="",ATXX'=ATXDRVR D Q:ATXQ
. S ATXQ=1
. W !!,"Package file already has post-init routine=^",ATXX
. S DIR(0)="Y",DIR("A")="Do you want me to replace it",DIR("B")="NO" K DA D ^DIR K DIR
. Q:'Y
. S ATXQ=0
. Q
S DIE="^DIC(9.4,",DA=ATXPK,DR="914////"_ATXDRVR
D ^DIE
W !,"Package post-init routine has been set to ^",ATXDRVR,!
Q
;
EOJ ;
K ^TMP("ATX",$J),^TMP("ATXPGM",$J)
D EN^XBVK("ATX")
Q
;
;-------------------
INSTALL ; This is to test the code for the post init routine
K ^TMP("ATX",$J)
;F ATXI=1:1 S X=$P($T(TMP+ATXI),";;",2,99) Q:X="" S ATXI=ATXI+1,Y=$P($T(TMP+ATXI),";;",2,99) S @X=Y
F ATXI=4:1 S X=$P($G(^TMP("ATXPGM",$J,ATXI,0)),";;",2) Q:X="" S ATXI=ATXI+1,Y=$P(^TMP("ATXPGM",$J,ATXI,0),";;",2) S @X=Y
I $O(^TMP("ATX",$J,3.6,0)) D BULL^ATXSTX2
I $O(^TMP("ATX",$J,9002226,0)) D TAX^ATXSTX2
D KILL^ATXSTX2
Q
;--------------------
;
CODE ;; If you modify this code change all F ATXI=n1:n2:n3 as appropriate
1 ;; ;
2 ;;START ;
3 ;; K:'$G(ATXPGMC) ^TMP("ATX",$J)
4 ;; S ATXPGMC=$G(ATXPGMC)+1
5 ;; F ATXI=1:1 S X=$P($T(TMP+ATXI),";;",2,99) Q:X="" S X="^TMP(""ATX"",$J,"_X,ATXI=ATXI+1,Y=$P($T(TMP+ATXI),";;",2,99) S @X=Y
6 ;; D OTHER
7 ;; I $O(^TMP("ATX",$J,3.6,0)) D BULL^ATXSTX2
8 ;; I $O(^TMP("ATX",$J,9002226,0)) D TAX^ATXSTX2
9 ;; D KILL^ATXSTX2
10 ;; Q
ATXSTX ; IHS/OHPRD/TMJ - SEND TAXONOMY WITH PACKAGE ; 29 Apr 2014 8:34 AM
+1 ;;5.1;TAXONOMY;**11**;FEB 04, 1997;Build 48
+2 ;
+3 ;
START ;
+1 DO MAIN
+2 DO EOJ
+3 QUIT
+4 ;
MAIN ;
+1 DO INIT
+2 IF ATXQ
QUIT
+3 FOR
DO GENRTN
IF ATXQ
QUIT
+4 ; quit if no taxonomy sent
IF 'ATXTSF
QUIT
+5 ;D POSTINIT ; update post-init in package file
+6 QUIT
+7 ;
GENRTN ; GENERATE ROUTINE TO INSTALL TAXONOMY
+1 KILL ^TMP($JOB),^TMP("ATX",$JOB)
+2 ; get taxonomy to export
DO TAXONOMY
+3 IF ATXQ
QUIT
+4 ; get program name
DO PGMNAME
+5 IF ATXQ
QUIT
+6 ; check taxonomy
DO TXCHECK
+7 IF ATXQ
QUIT
+8 ; set flag that taxonomy sent
SET ATXTSF=1
+9 ; store taxonomy
DO TXSTORE
+10 ; build and save routines
DO BUILD
+11 ; build and save main driver
DO DRIVER
+12 QUIT
+13 ;
INIT ;
+1 DO ^XBKVAR
+2 SET ATXQ=1
+3 ; taxonomy sent flag
SET ATXTSF=0
+4 WRITE !!,"This routine will build a post-init routine for the specified package."
+5 WRITE !,"The post-init routine will add the selected entry to the TAXONOMY file"
+6 WRITE !,"on the target machine.",!!
+7 ; get package
DO PACKAGE
+8 IF ATXQ
QUIT
+9 SET ATXQ=1
+10 ; get agency/site/programmer
+11 WRITE !
+12 SET DIR(0)="F^7:15"
SET DIR("A")="Enter agency/site/programmer for routine first line"
SET DIR("?")="E.g., IHS/OHPRD/EDE"
KILL DA
DO ^DIR
KILL DIR
+13 IF $DATA(DIRUT)
QUIT
+14 SET ATXASP=X
+15 WRITE !!,"The name of the primary routine to be generated will be the package prefix"
+16 WRITE !,"followed by TX. For each taxonomy being sent there will be one routine with"
+17 WRITE !,"the same name followed by a letter A-Z. For large taxonomies there will be"
+18 WRITE !,"additional routines with the same letter A-Z followed by a letter A-Z.",!
+19 SET ATXQ=0
+20 QUIT
+21 ;
PACKAGE ; GET PACKAGE
+1 SET ATXQ=1
+2 SET DIC="^DIC(9.4,"
SET DIC(0)="AEMQ"
+3 DO ^DIC
+4 KILL D,DD,D0,D1,DA,DI,DIADD,DIC,DICR,DIE,DIPGM,DLAYGO,DO,DQ,DR,DINUM
+5 IF Y<0
QUIT
+6 SET ATXPK=+Y
+7 SET ATXPRFX=$PIECE(^DIC(9.4,ATXPK,0),U,2)
+8 SET ATXQ=0
+9 QUIT
+10 ;
PGMNAME ; GET PROGRAM NAME
+1 SET ATXQ=1
+2 KILL DIR
+3 SET DIR(0)="F^1:6"
SET DIR("A")="Name of Routine Set to Create (routine stub)"
KILL DA
DO ^DIR
KILL DIR
+4 IF $DATA(DIRUT)
QUIT
+5 SET ATXPGMZ=Y
+6 ;S ATXPGM=ATXPRFX_"TX",ATXDRVR=ATXPGM
+7 SET ATXPGM=ATXPGMZ
SET ATXDRVR=ATXPGM
+8 FOR ATXI=1:1:27
SET X=ATXPGM_$CHAR(64+ATXI)
XECUTE ^%ZOSF("TEST")
IF '$TEST
QUIT
+9 IF ATXI=27
WRITE !,ATXPGM_"A-Z already exist. Cannot continue.",!!
QUIT
+10 SET (ATXPGM,ATXPGMR)=X
+11 WRITE !!,"Generating new routine ^"_ATXPGM
+12 SET X=ATXDRVR
XECUTE ^%ZOSF("TEST")
+13 IF $TEST
WRITE !,"Updating existing routine ^"_ATXDRVR,!
IF 1
+14 IF '$TEST
WRITE !,"Generating new routine ^"_ATXDRVR,!
+15 SET ATXQ=0
+16 QUIT
+17 ;
TAXONOMY ; GET TAXONOMY
+1 SET ATXQ=1
+2 SET DIC="^ATXAX("
SET DIC(0)="AEMQZ"
+3 DO ^DIC
+4 KILL D,DD,D0,D1,DA,DI,DIADD,DIC,DICR,DIE,DIPGM,DLAYGO,DO,DQ,DR,DINUM
+5 IF Y<0
QUIT
+6 SET ATXTX=+Y
+7 SET ATXTXNM=Y(0,0)
+8 SET ATXQ=0
+9 QUIT
+10 ;
TXCHECK ; CHECK TAXONOMY
+1 WRITE !,"Checking taxonomy "
+2 SET ATXQ=0
+3 ; see if values or iens
DO TXIENCHK
+4 IF ATXQ
WRITE !!,"Cannot send a taxonomy of IENs.",!
QUIT
+5 SET ATXY=0
+6 FOR ATX21C=0:1
SET ATXY=$ORDER(^ATXAX(ATXTX,21,ATXY))
IF 'ATXY
QUIT
Begin DoDot:1
+7 SET X=$PIECE(^ATXAX(ATXTX,21,ATXY,0),U)
+8 IF $EXTRACT(X,$LENGTH(X))'=" "
SET X=X_" "
+9 IF $DATA(^TMP("ATX",$JOB,21,X))
WRITE !!,"Duplicate code entry for code="_X,!
SET ATXQ=1
QUIT
+10 SET ^TMP("ATX",$JOB,21,X)=ATXY
+11 QUIT
End DoDot:1
+12 IF ATXQ
QUIT
+13 SET ATXQ=1
+14 SET ATXAAC=0
+15 SET ATXX=""
+16 FOR ATXAAC=0:1
SET ATXX=$ORDER(^ATXAX(ATXTX,21,"AA",ATXX))
IF ATXX=""
QUIT
+17 SET ATXX=""
+18 FOR ATXBC=0:1
SET ATXX=$ORDER(^ATXAX(ATXTX,21,"B",ATXX))
IF ATXX=""
QUIT
+19 IF 'ATX21C
WRITE !!,"No codes in taxonomy",!
QUIT
+20 IF ATXBC'=ATX21C
WRITE !!,"B xref is not correct. B count=",ATXBC," Entry count=",ATX21C,!
QUIT
+21 IF ATXAAC
IF ATXAAC'=ATX21C
WRITE !!,"AA xref is not correct. AA count=",ATXAAC," Entry count=",ATX21C,!
QUIT
+22 SET ATXQ=0
+23 QUIT
+24 ;
TXIENCHK ; CHECK TAXONOMY FOR IENS OR VALUES
+1 SET ATXFILE=$PIECE(^ATXAX(ATXTX,0),U,15)
+2 IF 'ATXFILE
QUIT
+3 SET ATXFGBL=^DIC(ATXFILE,0,"GL")
+4 SET ATXY=0
SET ATXNIEN=0
+5 FOR
SET ATXY=$ORDER(^ATXAX(ATXTX,21,ATXY))
IF 'ATXY
QUIT
Begin DoDot:1
+6 SET X=$PIECE(^ATXAX(ATXTX,21,ATXY,0),U)
+7 IF X'=+X
SET ATXNIEN=1
QUIT
+8 IF '$DATA(@(ATXFGBL_"X,0)"))
SET ATXNIEN=1
QUIT
+9 QUIT
End DoDot:1
IF ATXNIEN
QUIT
+10 IF 'ATXNIEN
SET ATXQ=1
+11 QUIT
+12 ;
TXSTORE ; STORE TAXONOMY IN ^TMP
+1 WRITE !,"Storing taxonomy "
+2 KILL ^TMP("DIERR",$JOB)
+3 FOR ATXF=.01,.02,.04,.06,.08,.09,.11,.12,.13,.14,.15,.16,.17,3101
Begin DoDot:1
+4 SET ATXX=$$VALI^XBDIQ1(9002226,ATXTX,ATXF)
+5 ; if field null make null on target
IF ATXX=""
SET ATXX="@"
+6 SET ^TMP("ATX",$JOB,9002226,ATXTX,ATXF)=ATXX
+7 QUIT
End DoDot:1
+8 SET ATXCODE=""
+9 FOR
SET ATXCODE=$ORDER(^TMP("ATX",$JOB,21,ATXCODE))
IF ATXCODE=""
QUIT
Begin DoDot:1
+10 SET ATXY=^TMP("ATX",$JOB,21,ATXCODE)
+11 SET ATXIENS=ATXTX_","_ATXY
+12 SET ATXSBSC=ATXTX_","_ATXCODE
+13 WRITE "."
+14 FOR ATXF=.01,.02,.03
Begin DoDot:2
+15 SET ATXX=$$VALI^XBDIQ1(9002226.02101,ATXIENS,ATXF)
+16 IF ATXX=""
QUIT
+17 SET ^TMP("ATX",$JOB,9002226.02101,ATXSBSC,ATXF)=ATXX
+18 QUIT
End DoDot:2
+19 QUIT
End DoDot:1
+20 ;store 5101 multiple
+21 SET ATXCODE=0
FOR
SET ATXCODE=$ORDER(^ATXAX(ATXTX,51,ATXCODE))
IF ATXCODE'=+ATXCODE
QUIT
Begin DoDot:1
+22 SET ATXY=^ATXAX(ATXTX,51,ATXCODE,0)
+23 WRITE ":"
+24 SET ATXSBSC=ATXTX_","_ATXCODE
+25 SET ^TMP("ATX",$JOB,9002226.05101,ATXSBSC,.01)=ATXY
+26 QUIT
End DoDot:1
+27 ;store 1101 multiple
+28 SET ATXCODE=0
FOR
SET ATXCODE=$ORDER(^ATXAX(ATXTX,11,ATXCODE))
IF ATXCODE'=+ATXCODE
QUIT
Begin DoDot:1
+29 SET ATXY=^ATXAX(ATXTX,11,ATXCODE,0)
+30 WRITE ":"
+31 SET ATXSBSC=ATXTX_","_ATXCODE
+32 SET ^TMP("ATX",$JOB,9002226.01101,ATXSBSC,.01)=ATXY
+33 QUIT
End DoDot:1
+34 ;store 4101 multiple
+35 SET ATXCODE=0
FOR
SET ATXCODE=$ORDER(^ATXAX(ATXTX,41,ATXCODE))
IF ATXCODE'=+ATXCODE
QUIT
Begin DoDot:1
+36 SET ATXY=$PIECE(^ATXAX(ATXTX,41,ATXCODE,0),U,1)
SET ATXY=$PIECE(^DIC(9.4,ATXY,0),U,2)
+37 WRITE ":"
+38 SET ATXSBSC=ATXTX_","_ATXCODE
+39 SET ^TMP("ATX",$JOB,9002226.04101,ATXSBSC,.01)=ATXY
+40 QUIT
End DoDot:1
+41 SET ATXBULL=$$VALI^XBDIQ1(9002226,ATXTX,.07)
+42 IF ATXBULL
DO BULSTORE
+43 ; should the bulletin on the target machine be deleted if there
+44 ; is no bulletin on the sending machine? If yes, uncomment the
+45 ; following line:
+46 ;S:'ATXBULL ^TMP("ATX",$J,9002226,ATXTX,.07)="@"
+47 QUIT
+48 ;
BULSTORE ; STORE BULLETIN
+1 WRITE !,"Storing bulletin "
+2 FOR ATXF=.01,2
Begin DoDot:1
+3 SET ATXX=$$VALI^XBDIQ1(3.6,ATXBULL,ATXF)
+4 IF ATXX=""
QUIT
+5 SET ^TMP("ATX",$JOB,3.6,ATXBULL,ATXF)=ATXX
+6 QUIT
End DoDot:1
+7 SET ATXY=0
+8 FOR
SET ATXY=$ORDER(^XMB(3.6,ATXBULL,4,ATXY))
IF 'ATXY
QUIT
Begin DoDot:1
+9 SET ATXIENS=ATXBULL_","_ATXY
+10 WRITE "."
+11 SET ATXX=$$VALI^XBDIQ1(3.64,ATXIENS,.01)
+12 IF ATXX=""
QUIT
+13 SET ^TMP("ATX",$JOB,3.64,ATXIENS,.01)=ATXX
+14 IF '$ORDER(^XMB(3.6,ATXBULL,4,ATXY,1,0))
QUIT
+15 SET ^TMP("ATX",$JOB,3.64,ATXIENS,1,0)=^XMB(3.6,ATXBULL,4,ATXY,1,0)
+16 SET ATXZ=0
+17 FOR
SET ATXZ=$ORDER(^XMB(3.6,ATXBULL,4,ATXY,1,ATXZ))
IF 'ATXZ
QUIT
SET ^TMP("ATX",$JOB,3.64,ATXIENS,1,ATXZ,0)=^(ATXZ,0)
+18 QUIT
End DoDot:1
+19 IF $ORDER(^XMB(3.6,ATXBULL,3,0))
Begin DoDot:1
+20 SET ^TMP("ATX",$JOB,3.63,ATXBULL,3,0)=^XMB(3.6,ATXBULL,3,0)
+21 SET ATXY=0
+22 FOR
SET ATXY=$ORDER(^XMB(3.6,ATXBULL,3,ATXY))
IF 'ATXY
QUIT
SET ^TMP("ATX",$JOB,3.63,ATXBULL,3,ATXY,0)=^(ATXY,0)
+23 QUIT
End DoDot:1
+24 IF $ORDER(^XMB(3.6,ATXBULL,1,0))
Begin DoDot:1
+25 SET ^TMP("ATX",$JOB,3.63,ATXBULL,1,0)=^XMB(3.6,ATXBULL,1,0)
+26 SET ATXY=0
+27 FOR
SET ATXY=$ORDER(^XMB(3.6,ATXBULL,1,ATXY))
IF 'ATXY
QUIT
SET ^TMP("ATX",$JOB,3.63,ATXBULL,1,ATXY,0)=^(ATXY,0)
+28 QUIT
End DoDot:1
+29 QUIT
+30 ;
BUILD ;
+1 WRITE !,"Generating routines",!!
+2 SET Y=DT
+3 DO DD^%DT
+4 SET ATXVER=$SELECT($DATA(^DIC(9.4,ATXPK,"VERSION")):^("VERSION"),1:"")_";"_$PIECE(^DIC(9.4,ATXPK,0),U,1)_";;"_Y
+5 KILL ^TMP("ATXPGM",$JOB)
+6 SET ATXPGMC=1
+7 KILL ATXPGMS
+8 ; build main routine
DO PGMBEG
+9 SET ATXZR=0
+10 FOR
SET ATXZR=$ORDER(^TMP("ATX",ATXZR))
IF ATXZR=$JOB
QUIT
+11 SET ATXZR="^TMP(""ATX"","_ATXZR_")"
+12 ; build TMP for $T
DO PGMTMP
+13 SET X=" ;"
DO SETTMP
+14 SET X="OTHER ; OTHER ROUTINES"
DO SETTMP
+15 SET ATXX=""
+16 FOR
SET ATXX=$ORDER(ATXPGMS(ATXX))
IF ATXX=""
QUIT
SET X=" D ^"_ATXX
DO SETTMP
+17 SET X=" Q"
DO SETTMP
+18 ; save generated program
DO PGMSAVE
+19 QUIT
+20 ;
PGMBEG ; BUILD BEGINNING OF PROGRAM
+1 KILL ^TMP("ATXPGM",$JOB,ATXPGM)
+2 SET (ATXL,ATXLNTH)=0
+3 SET X=ATXPGM_" ;"_ATXASP_"-CREATED BY ^ATXSTX ON "_Y_";"
DO SETTMP
+4 SET X=" ;;"_ATXVER
DO SETTMP
+5 IF ATXPGMC=1
Begin DoDot:1
+6 SET X=" ;;"_ATXTXNM
DO SETTMP
+7 SET X=" ;"
DO SETTMP
+8 SET X=" ; This routine loads Taxonomy "_ATXTXNM
DO SETTMP
+9 QUIT
End DoDot:1
+10 FOR ATXI=1:1:5
SET X=$PIECE($TEXT(CODE+ATXI),";;",2,99)
IF X=""
QUIT
DO SETTMP
+11 IF ATXPGMC=1
FOR ATXI=6:1:10
SET X=$PIECE($TEXT(CODE+ATXI),";;",2,99)
IF X=""
QUIT
DO SETTMP
+12 IF ATXPGMC>1
SET X=" Q"
DO SETTMP
+13 QUIT
+14 ;
PGMTMP ; BUILD TMP DATA FOR $T ***(CALLED RECURSIVELY)***
+1 SET ATXTMPQ=0
+2 SET X=" ;"
DO SETTMP
+3 SET X="TMP ;;TAXONOMY (WITH BULLETIN)"
DO SETTMP
+4 FOR
SET ATXZR=$QUERY(@ATXZR)
IF $PIECE(ATXZR,",")'="^TMP(""ATX"""
QUIT
DO PGMTMP2
IF ATXTMPQ
QUIT
+5 QUIT
+6 ;
PGMTMP2 ;
+1 SET X=" ;;"_$PIECE(ATXZR,$JOB_",",2,99)
DO SETTMP
+2 SET X=" ;;"_@ATXZR
DO SETTMP
+3 IF ATXLNTH>13000
DO RECURSE
SET ATXTMPQ=1
QUIT
+4 QUIT
+5 ;
PGMSAVE ; SAVE GENERATED PROGRAM
+1 SET XCN=0
SET DIE="^TMP(""ATXPGM"","_$JOB_","""_ATXPGM_""","
SET X=ATXPGM
+2 XECUTE ^%ZOSF("SAVE")
+3 KILL DIE,XCM,XCN
+4 SET X=ATXPGM
+5 XECUTE ^%ZOSF("TEST")
+6 IF $TEST
WRITE "Routine ^",ATXPGM," has been filed.",!
IF 1
+7 IF '$TEST
WRITE "Saving of routine ^",ATXPGM," failed.",!
+8 KILL ^TMP("ATXPGM",$JOB,ATXPGM)
+9 QUIT
+10 ;
SETTMP ; SET ^TMP GLOBAL
+1 SET ATXL=ATXL+1
+2 SET ^TMP("ATXPGM",$JOB,ATXPGM,ATXL,0)=X
+3 SET ATXLNTH=ATXLNTH+(4+$LENGTH(X))
+4 QUIT
+5 ;
RECURSE ; CALLED FROM PGMTMP TO BUILD OTHER ROUTINES IF TOO LARGE
+1 NEW ATXL,ATXLNTH,ATXPGM,ATXTMPQ
+2 SET ATXPGMC=ATXPGMC+1
+3 SET ATXPGM=ATXPGMR_ATXPGMC
+4 DO PGMBEG
+5 DO PGMTMP
+6 DO PGMSAVE
+7 SET ATXPGMS(ATXPGM)=""
+8 QUIT
+9 ;
DRIVER ; BUILD MAIN DRIVER ROUTINE
+1 SET ATXPGM=ATXDRVR
+2 KILL ^TMP("ATXPGM",$JOB,ATXPGM)
+3 SET (ATXL,ATXLNTH)=0
+4 SET X=ATXPGM_" ;"_ATXASP_"-CREATED BY ^ATXSTX ON "_Y_";"
DO SETTMP
+5 SET X=" ;;"_ATXVER
DO SETTMP
+6 SET X=" ;"
DO SETTMP
+7 SET X=" ; See referenced routines to see taxonomies being loaded."
DO SETTMP
+8 SET X=" ;"
DO SETTMP
+9 SET X="START ;"
DO SETTMP
+10 FOR ATXI=1:1:26
SET X=ATXPGM_$CHAR(64+ATXI)
XECUTE ^%ZOSF("TEST")
IF '$TEST
QUIT
Begin DoDot:1
+11 XECUTE "ZL @X S Z=$T(@X+2),Z=$P(Z,"";;"",2)"
+12 SET Y=""
SET $PIECE(Y," ",(10-$LENGTH(X)))=" "
SET Y=" ;"_Y_Z
+13 SET X=" D ^"_X_Y
DO SETTMP
+14 QUIT
End DoDot:1
+15 SET X=" Q"
DO SETTMP
+16 DO PGMSAVE
+17 QUIT
+18 ;
POSTINIT ; UPDATE POST INIT ENTRY IN PACKAGE FILE
+1 SET ATXX=$$VALI^XBDIQ1(9.4,ATXPK,914)
+2 IF ATXX'=""
IF ATXX'=ATXDRVR
Begin DoDot:1
+3 SET ATXQ=1
+4 WRITE !!,"Package file already has post-init routine=^",ATXX
+5 SET DIR(0)="Y"
SET DIR("A")="Do you want me to replace it"
SET DIR("B")="NO"
KILL DA
DO ^DIR
KILL DIR
+6 IF 'Y
QUIT
+7 SET ATXQ=0
+8 QUIT
End DoDot:1
IF ATXQ
QUIT
+9 SET DIE="^DIC(9.4,"
SET DA=ATXPK
SET DR="914////"_ATXDRVR
+10 DO ^DIE
+11 WRITE !,"Package post-init routine has been set to ^",ATXDRVR,!
+12 QUIT
+13 ;
EOJ ;
+1 KILL ^TMP("ATX",$JOB),^TMP("ATXPGM",$JOB)
+2 DO EN^XBVK("ATX")
+3 QUIT
+4 ;
+5 ;-------------------
INSTALL ; This is to test the code for the post init routine
+1 KILL ^TMP("ATX",$JOB)
+2 ;F ATXI=1:1 S X=$P($T(TMP+ATXI),";;",2,99) Q:X="" S ATXI=ATXI+1,Y=$P($T(TMP+ATXI),";;",2,99) S @X=Y
+3 FOR ATXI=4:1
SET X=$PIECE($GET(^TMP("ATXPGM",$JOB,ATXI,0)),";;",2)
IF X=""
QUIT
SET ATXI=ATXI+1
SET Y=$PIECE(^TMP("ATXPGM",$JOB,ATXI,0),";;",2)
SET @X=Y
+4 IF $ORDER(^TMP("ATX",$JOB,3.6,0))
DO BULL^ATXSTX2
+5 IF $ORDER(^TMP("ATX",$JOB,9002226,0))
DO TAX^ATXSTX2
+6 DO KILL^ATXSTX2
+7 QUIT
+8 ;--------------------
+9 ;
CODE ;; If you modify this code change all F ATXI=n1:n2:n3 as appropriate
1 ;; ;
2 ;;START ;
3 ;; K:'$G(ATXPGMC) ^TMP("ATX",$J)
4 ;; S ATXPGMC=$G(ATXPGMC)+1
5 ;; F ATXI=1:1 S X=$P($T(TMP+ATXI),";;",2,99) Q:X="" S X="^TMP(""ATX"",$J,"_X,ATXI=ATXI+1,Y=$P($T(TMP+ATXI),";;",2,99) S @X=Y
6 ;; D OTHER
7 ;; I $O(^TMP("ATX",$J,3.6,0)) D BULL^ATXSTX2
8 ;; I $O(^TMP("ATX",$J,9002226,0)) D TAX^ATXSTX2
9 ;; D KILL^ATXSTX2
10 ;; Q
