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

ATXSTX.m

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