Routine: ATX51P26

ATX51P26 ; IHS/CMI/LAB - PCC Suite v5.1 patch 26 environment check ;

 ;;5.1;TAXONOMY;**26**;FEB 04, 1997;Build 48

 ; The following line prevents the "Disable Options..." and "Move

 ; Routines..." questions from being asked during the install.

 I $G(XPDENV)=1 S (XPDDIQ("XPZ1"),XPDDIQ("XPZ2"))=0

 F X="XPO1","XPZ1","XPZ2","XPI1" S XPDDIQ(X)=0

 I '$$INSTALLD("ATX*5.1*25") D SORRY(2)

 I +$$VERSION^XPDUTL("AUM")<19 D MES^XPDUTL($$CJ^XLFSTR("Version 19.0 of AUM is required.  Not installed",80)) D SORRY(2) I 1

 E  D MES^XPDUTL($$CJ^XLFSTR("Requires AUM V19.0....Present.",80))

PRE ;

POST ;

 D ^ATXFE

 D BUILDAC

 ;D SETTAXRN^ATX6ENV

BUILDAC ;

 D MES^XPDUTL("Re-Indexing AC on taxonomies..")

 S ATXDA=0

 F  S ATXDA=$O(^ATXAX(ATXDA)) Q:ATXDA'=+ATXDA  D

 .Q:'$D(^ATXAX(ATXDA,0))

 .K DA

 .Q:'$$ICDTX^ATXXREF(ATXDA)  ;NOT AN ICD TAX

 .S DA=ATXDA D BUILDAC^ATXXREF

 .W "."

 K DA,ATXDA

SETTAXRN ;EP

 ;set read only and no delete for selected taxonomies

 S ATXTFI="" F  S ATXTFI=$O(^ATXAX("B",ATXTFI)) Q:ATXTFI=""  D

 .S ATXTDA=$O(^ATXAX("B",ATXTFI,0))

 .Q:'ATXTDA  ;did not find taxonomy

 .Q:'$$NS(ATXTFI)

 .I $P(^ATXAX(ATXTDA,0),U,4)'="n" S $P(^ATXAX(ATXTDA,0),U,4)="n" D MES^XPDUTL(".") ;set no delete

 .Q:$P(^ATXAX(ATXTDA,0),U,22)=1  ;ALREADY SET

 .S F=$P(^ATXAX(ATXTDA,0),U,15)

 .I $$RO(F,ATXTFI) S $P(^ATXAX(ATXTDA,0),U,22)=1 D MES^XPDUTL($P(^ATXAX(ATXTDA,0),U,1))  ;SET READ ONLY

.Q

RO(T,S) ;

 I T=81 Q 1   ;CPT

 I T=80 Q 1   ;ICD DX

 I T=80.1 Q 1  ;ICD OP

 I T=9999999.31 Q 1  ;

 I T=9999999.64 Q 1  ;HEALTH FACTORS

 I T=9999999.14 Q 1  ;cvx codes

 I T=95.3 Q 1  ;LAB LOINC

 I S[" NDC" Q 1  ;NDC taxonomies  -  not perfect logic by no tax had " NDC " but NDC taxonomies

Q 0

NS(T,L) ;

 ;I T["DIABETES REG" Q 0

 I $E(T,1,4)="APCD" Q 1

 I $E(T,1,3)="BGP" Q 1

 ;I $E(T,1,7)="SURVEIL" Q 1

 I $E(T,1,4)="APCH" Q 1

 I $E(T,1,4)="APCL" Q 1

 I $E(T,1,3)="ATX" Q 1

 ;I $E(T,1,3)="BAT" Q 1

 ;I $E(T,1,3)="BDR" Q 1

 ;I $E(T,1,3)="BI " Q 1

 I $E(T,1,4)="BJPC" Q 1

 ;I $E(T,1,3)="BUD" Q 1

 ;I $E(T,1,8)="DM AUDIT" Q 1

Q 0

INSTALLD(ATXSTAL) ;EP - Determine if patch ATXSTAL was installed, where

 ; ATXSTAL is the name of the INSTALL.  E.g "AG*6.0*11".

 NEW ATXY,DIC,X,Y

 S X=$P(ATXSTAL,"*",1)

 S DIC="^DIC(9.4,",DIC(0)="FM",D="C"

 D IX^DIC

 I Y<1 D IMES Q 0

 S DIC=DIC_+Y_",22,",X=$P(ATXSTAL,"*",2)

 D ^DIC

 I Y<1 D IMES Q 0

 S DIC=DIC_+Y_",""PAH"",",X=$P(ATXSTAL,"*",3)

 D ^DIC

 S ATXY=Y

 D IMES

 Q $S(ATXY<1:0,1:1)

IMES ;

 D MES^XPDUTL($$CJ^XLFSTR("Patch """_ATXSTAL_""" is"_$S(Y<1:" *NOT*",1:"")_" installed.",IOM))

SORRY(X) ;

 KILL DIFQ

 I X=3 S XPDQUIT=2 Q

 S XPDQUIT=X

 W *7,!,$$CJ^XLFSTR("Sorry....FIX IT!",IOM)

ATX51P26  ; IHS/CMI/LAB - PCC Suite v5.1 patch 26 environment check ;

 +1       ;;5.1;TAXONOMY;**26**;FEB 04, 1997;Build 48

 +2       ;

 +3       ;

 +4       ; The following line prevents the "Disable Options..." and "Move

 +5       ; Routines..." questions from being asked during the install.

 +6        IF $GET(XPDENV)=1

               SET (XPDDIQ("XPZ1"),XPDDIQ("XPZ2"))=0

 +7        FOR X="XPO1","XPZ1","XPZ2","XPI1"

               SET XPDDIQ(X)=0

 +8        IF '$$INSTALLD("ATX*5.1*25")

               DO SORRY(2)

 +9        IF +$$VERSION^XPDUTL("AUM")<19

               DO MES^XPDUTL($$CJ^XLFSTR("Version 19.0 of AUM is required.  Not installed",80))

               DO SORRY(2)

               IF 1

 +10      IF '$TEST

               DO MES^XPDUTL($$CJ^XLFSTR("Requires AUM V19.0....Present.",80))

 +11      ;

 +12       QUIT

 +13      ;

PRE       ;

 +1        QUIT

POST      ;

 +1        DO ^ATXFE

 +2        DO BUILDAC

 +3       ;D SETTAXRN^ATX6ENV

 +4        QUIT

BUILDAC   ;

 +1        DO MES^XPDUTL("Re-Indexing AC on taxonomies..")

 +2        SET ATXDA=0

 +3        FOR

               SET ATXDA=$ORDER(^ATXAX(ATXDA))

               IF ATXDA'=+ATXDA

                   QUIT

               Begin DoDot:1

 +4                IF '$DATA(^ATXAX(ATXDA,0))

                       QUIT

 +5                KILL DA

 +6       ;NOT AN ICD TAX

                   IF '$$ICDTX^ATXXREF(ATXDA)

                       QUIT

 +7                SET DA=ATXDA

                   DO BUILDAC^ATXXREF

 +8                WRITE "."

               End DoDot:1

 +9        KILL DA,ATXDA

 +10       QUIT

SETTAXRN  ;EP

 +1       ;set read only and no delete for selected taxonomies

 +2        SET ATXTFI=""

FOR

               SET ATXTFI=$ORDER(^ATXAX("B",ATXTFI))

               IF ATXTFI=""

                   QUIT

               Begin DoDot:1

 +3                SET ATXTDA=$ORDER(^ATXAX("B",ATXTFI,0))

 +4       ;did not find taxonomy

                   IF 'ATXTDA

                       QUIT

 +5                IF '$$NS(ATXTFI)

                       QUIT

 +6       ;set no delete

                   IF $PIECE(^ATXAX(ATXTDA,0),U,4)'="n"

                       SET $PIECE(^ATXAX(ATXTDA,0),U,4)="n"

                       DO MES^XPDUTL(".")

 +7       ;ALREADY SET

                   IF $PIECE(^ATXAX(ATXTDA,0),U,22)=1

                       QUIT

 +8                SET F=$PIECE(^ATXAX(ATXTDA,0),U,15)

 +9       ;SET READ ONLY

                   IF $$RO(F,ATXTFI)

                       SET $PIECE(^ATXAX(ATXTDA,0),U,22)=1

                       DO MES^XPDUTL($PIECE(^ATXAX(ATXTDA,0),U,1))

 +10               QUIT

               End DoDot:1

 +11       QUIT

RO(T,S)   ;

 +1       ;CPT

           IF T=81

               QUIT 1

 +2       ;ICD DX

           IF T=80

               QUIT 1

 +3       ;ICD OP

           IF T=80.1

               QUIT 1

 +4       ;

           IF T=9999999.31

               QUIT 1

 +5       ;HEALTH FACTORS

           IF T=9999999.64

               QUIT 1

 +6       ;cvx codes

           IF T=9999999.14

               QUIT 1

 +7       ;LAB LOINC

           IF T=95.3

               QUIT 1

 +8       ;NDC taxonomies  -  not perfect logic by no tax had " NDC " but NDC taxonomies

           IF S[" NDC"

               QUIT 1

 +9        QUIT 0

NS(T,L)   ;

 +1       ;I T["DIABETES REG" Q 0

 +2        IF $EXTRACT(T,1,4)="APCD"

               QUIT 1

 +3        IF $EXTRACT(T,1,3)="BGP"

               QUIT 1

 +4       ;I $E(T,1,7)="SURVEIL" Q 1

 +5        IF $EXTRACT(T,1,4)="APCH"

               QUIT 1

 +6        IF $EXTRACT(T,1,4)="APCL"

               QUIT 1

 +7        IF $EXTRACT(T,1,3)="ATX"

               QUIT 1

 +8       ;I $E(T,1,3)="BAT" Q 1

 +9       ;I $E(T,1,3)="BDR" Q 1

 +10      ;I $E(T,1,3)="BI " Q 1

 +11       IF $EXTRACT(T,1,4)="BJPC"

               QUIT 1

 +12      ;I $E(T,1,3)="BUD" Q 1

 +13      ;I $E(T,1,8)="DM AUDIT" Q 1

 +14       QUIT 0

INSTALLD(ATXSTAL) ;EP - Determine if patch ATXSTAL was installed, where

 +1       ; ATXSTAL is the name of the INSTALL.  E.g "AG*6.0*11".

 +2       ;

 +3        NEW ATXY,DIC,X,Y

 +4        SET X=$PIECE(ATXSTAL,"*",1)

 +5        SET DIC="^DIC(9.4,"

           SET DIC(0)="FM"

           SET D="C"

 +6        DO IX^DIC

 +7        IF Y<1

               DO IMES

               QUIT 0

 +8        SET DIC=DIC_+Y_",22,"

           SET X=$PIECE(ATXSTAL,"*",2)

 +9        DO ^DIC

 +10       IF Y<1

               DO IMES

               QUIT 0

 +11       SET DIC=DIC_+Y_",""PAH"","

           SET X=$PIECE(ATXSTAL,"*",3)

 +12       DO ^DIC

 +13       SET ATXY=Y

 +14       DO IMES

 +15       QUIT $SELECT(ATXY<1:0,1:1)

IMES      ;

 +1        DO MES^XPDUTL($$CJ^XLFSTR("Patch """_ATXSTAL_""" is"_$SELECT(Y<1:" *NOT*",1:"")_" installed.",IOM))

 +2        QUIT

SORRY(X)  ;

 +1        KILL DIFQ

 +2        IF X=3

               SET XPDQUIT=2

               QUIT

 +3        SET XPDQUIT=X

 +4        WRITE *7,!,$$CJ^XLFSTR("Sorry....FIX IT!",IOM)

 +5        QUIT

ATX51P26.m