Routine: AUM1011E

AUM1011E ;IHS/OIT/NKD - SCB UPDATE FOR JAN 2013 12/07/2012 ;

 ;;13.0;TABLE MAINTENANCE;**1**;AUG 30,2012;Build 1

 ;AUM* 12.7.2009 IHS/OIT/FCJ MODIFIED INTRO TEXT AND VERSION CHECKS

 I '$G(DUZ) W !,"DUZ UNDEFINED OR 0." D SORRY(2) Q

 I '$L($G(DUZ(0))) W !,"DUZ(0) UNDEFINED OR NULL." D SORRY(2) Q

 S X=$P(^VA(200,DUZ,0),U)

 W !!,$$CJ^XLFSTR("Hello, "_$P(X,",",2)_" "_$P(X,","),IOM)

 W !!,$$CJ^XLFSTR("Checking Environment for "_$P($T(+2),";",4)_" V "_$P($T(+2),";",3)_$S($L($P($T(+2),";",5))>4:" Patch "_$P($T(+2),";",5),1:"")_".",IOM),!

 I $$VCHK("XU","8.0",2)

 I $$VCHK("DI","22.0",2)

 ;IHS/OIT/NKD AUM*13.0*1 - CHANGED PATCH CHECK

 ;I $$VCHK2("AUM","12.0.4",2)

 I $$PCHK("AUM*12.0*4",2)

 NEW DA,DIC

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

 D IX^DIC

 I Y<0,$D(^DIC(9.4,"C","AUM")) D

 . W !!,*7,*7,$$CJ^XLFSTR("You Have More Than One Entry In The",IOM),!,$$CJ^XLFSTR("PACKAGE File with an ""AUM"" prefix.",IOM)

 . W !,$$CJ^XLFSTR("One entry needs to be deleted.",IOM)

 . D SORRY(2)

.Q

 I $G(XPDQUIT) W !,$$CJ^XLFSTR("FIX IT! Before Proceeding.",IOM),!!,*7,*7,*7 Q

 W !!,$$CJ^XLFSTR("ENVIRONMENT OK.",IOM)

 D HELP^XBHELP("INTROE","AZHBENV")

 I $G(XPDENV)=1 D

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

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

 . S (XPDDIQ("XPZ1"),XPDDIQ("XPZ2"))=0

 . D HELP^XBHELP("INTROI","AZHBENV")

.Q

 I '$$DIR^XBDIR("E","","","","","",1) D SORRY(2)

SORRY(X) ;

 KILL DIFQ

 S XPDQUIT=X

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

VCHK(AUMPRE,AUMVER,AUMQUIT) ; Check versions needed.

 NEW AUMV

 S AUMV=$$VERSION^XPDUTL(AUMPRE)

 W !,$$CJ^XLFSTR("Need at least "_AUMPRE_" v "_AUMVER_"....."_AUMPRE_" v "_AUMV_" Present",IOM)

 I AUMV<AUMVER KILL DIFQ S XPDQUIT=AUMQUIT D SORRY(AUMQUIT) Q 0

Q 1

VCHK2(AUMPRE,AUMVER,AUMQUIT) ; Check patch level for AUM

 NEW AUMV

 S AUMV=$$VERSION^XPDUTL(AUMPRE)

 S PTCH=+$$LAST(AUMPRE,AUMV) S:PTCH=-1 DPTCH="" S:PTCH'=-1 DPTCH="."_PTCH

 W !,$$CJ^XLFSTR("Need at least "_AUMPRE_" v "_AUMVER_"....."_AUMPRE_" v "_AUMV_DPTCH_" Present",IOM)

 I (AUMV<($P(AUMVER,".",1,2))) KILL DIFQ S XPDQUIT=AUMQUIT D SORRY(AUMQUIT) Q 0

 I (AUMV=$P(AUMVER,".",1,2))&(PTCH<$P(AUMVER,".",3)) KILL DIFQ S XPDQUIT=AUMQUIT D SORRY(AUMQUIT) Q 0

Q 1

 ;IHS/OIT/NKD AUM*13.0*1 - CHANGED PATCH CHECK - LOOKS FOR SPECIFIC PATCH

PCHK(AUMPAT,AUMQUIT) ; Check patch level for AUM

 N AUMP

 S AUMP=$$PATCH^XPDUTL(AUMPAT)

 W !,$$CJ^XLFSTR("Patch "_AUMPAT_" is "_$S(AUMP<1:"*NOT* ",1:"")_"installed.",IOM)

 I 'AUMP KILL DIFQ S XPDQUIT=AUMQUIT D SORRY(AUMQUIT) Q 0

Q 1

LAST(PKG,VER) ;EP - returns last patch applied for a Package, PATCH^DATE

 ;        Patch includes Seq # if Released

 N PKGIEN,VERIEN,LATEST,PATCH,SUBIEN

 I $G(VER)="" S VER=$$VERSION^XPDUTL(PKG) Q:'VER -1

 S PKGIEN=$O(^DIC(9.4,"C",PKG,"")) Q:'PKGIEN -1

 S VERIEN=$O(^DIC(9.4,PKGIEN,22,"B",VER,"")) Q:'VERIEN -1

 S LATEST=-1,PATCH=-1,SUBIEN=0

 F  S SUBIEN=$O(^DIC(9.4,PKGIEN,22,VERIEN,"PAH",SUBIEN)) Q:SUBIEN'>0  D

 . I $P(^DIC(9.4,PKGIEN,22,VERIEN,"PAH",SUBIEN,0),U,2)>LATEST S LATEST=$P(^(0),U,2),PATCH=$P(^(0),U)

 . I $P(^DIC(9.4,PKGIEN,22,VERIEN,"PAH",SUBIEN,0),U,2)=LATEST,$P(^(0),U)>PATCH S PATCH=$P(^(0),U)

 Q PATCH_U_LATEST

PRE ; EP FR KIDS

 ;CLEAN UP CONTROL CHAR AND REMOVE DATA FROM AUMDATA

 D START^AUMPRE

 ;IHS/OIT/NKD AUM*13.0*1 - ROUTINE EXCISE

 N CNT,TEXT,DISP

 D BMES^XPDUTL("Excising the following AUM routines for ICD-10 implementation...")

 S DISP=""

 F CNT=1:1 S TEXT=$P($T(RLIST+CNT),";;",2) Q:TEXT="END"  D

 . N X

 . S X=TEXT X ^%ZOSF("DEL")

 . S DISP=DISP_TEXT_$J("",12-$L(TEXT))

 . I $L(DISP)>70 D MES^XPDUTL(DISP) S DISP=""

 I $L(DISP)>0 D MES^XPDUTL(DISP)

RLIST ;; LIST OF ROUTINES TO EXCISE

 ;;AUM101

 ;;AUM111

 ;;AUM111R2

 ;;AUM111R3

 ;;AUM111RL

 ;;AUM31

 ;;AUM41

 ;;AUM41E

 ;;AUM41P3

 ;;AUM51

 ;;AUM516PT

 ;;AUM61

 ;;AUM71

 ;;AUM71P2

 ;;AUM81

 ;;AUM81DRG

 ;;AUM91

 ;;AUMDO1A

 ;;AUMDO1B

 ;;AUMICD1

 ;;END

 ;IHS/OIT/NKD AUM*13.0*1 - COMMENTED OUT AUM*12.0*4 PRE-INSTALL

 ; CHECK FOR DUPLICATE PHQT MEASUREMENT TYPE

 ;D MES^XPDUTL("Checking for duplicate PHQT Measurement Type...")

 ;N AUMRES,AUMCNT,AUMCNT2,AUML1,AUML2,AUMTMP

 ;D FIND^DIC(9999999.07,"","@;.01;.02","PX","PHQT",,,,,"AUMRES")

 ;S AUMCNT=$P($G(AUMRES("DILIST",0)),U,1)

 ;I AUMCNT<2 D MES^XPDUTL("  No duplicates found!") Q

 ;D MES^XPDUTL("  "_(AUMCNT-1)_" duplicate(s) found!")

 ;S (AUML1,AUML2)=""

 ; PUT LOWERCASE DESCRIPTIONS INTO LIST 1 (FROM), UPPERCASE INTO LIST 2 (TO)

 ;F AUMCNT2=1:1:AUMCNT S AUMTMP=$G(AUMRES("DILIST",AUMCNT2,0)) D

 ;. S:$P(AUMTMP,"^",3)'=$$UP^XLFSTR($P(AUMTMP,"^",3)) AUML1=AUML1_AUMCNT2_"^"

 ;. S:$P(AUMTMP,"^",3)=$$UP^XLFSTR($P(AUMTMP,"^",3)) AUML2=AUML2_AUMCNT2_"^"

 ; MOVE ADDITIONAL UPPERCASES INTO LIST 1 (FROM)

 ;S AUML1=AUML1_$P(AUML2,"^",2,100),AUML2=$P(AUML2,"^",1)

 ; IF ONLY LOWERCASES, MOVE LOWEST IEN INTO LIST 2 (TO)

 ;S:AUML2']"" AUML2=$P(AUML1,"^",1),AUML1=$P(AUML1,"^",2,100)

 ; MERGE ALL LIST 1 (FROM) ENTRIES INTO LIST 2 (TO) ENTRY

 ;F AUMCNT2=1:1:$L(AUML1,"^") S AUMTMP=$P(AUML1,"^",AUMCNT2) Q:'AUMTMP  D

 ;. D MMERG($P($G(AUMRES("DILIST",AUMTMP,0)),"^",1),$P($G(AUMRES("DILIST",AUML2,0)),"^",1))

;Q

 ;MMERG(FROM,TO) ; MEASUREMENT TYPE COMPARE/MERGE

 ;N DILN,DITM,L

 ;;D MES^XPDUTL("MERGING ENTRY '"_FROM_"' INTO '"_TO_"'")

 ;S DILN=21

 ;S DITM=0

 ;S DITM("DDEF")=2

 ;S DITM("DDIF")=1

 ;S DITM("DELETE")=""

 ;S DITM("DFF")=9999999.07

 ;S DITM("DIC")="^AUTTMSR("

 ;S DITM("DIMERGE")=1

 ;S DITM("DIT(1)")=FROM

 ;S DITM("DIT(2)")=TO

 ;S DITM("NON-INTERACTIVE")=""

 ;S DITM("REPOINT")=""

 ;S L=1

 ;D ^DITM2,END^DITM

;Q

INTROE ; Intro text during KIDS Environment check.

 ;;This is the update to the standard code book tables.  There are modifications

 ;;and additions to the following files:  Community, Location, Tribe,

 ;;Reservation and Service Unit.

;;

 ;;The install message will report updates and failed updates to those files.

;;

 ;;###

INTROI ; Intro text during KIDS Install.

 ;;If you run interactively, results will be displayed on your screen,

 ;;and recorded in the entry in the INSTALL file.

 ;;If you queue to TaskMan, remember not to Q to the HOME device.

 ;;###

AUM1011E  ;IHS/OIT/NKD - SCB UPDATE FOR JAN 2013 12/07/2012 ;

 +1       ;;13.0;TABLE MAINTENANCE;**1**;AUG 30,2012;Build 1

 +2       ;AUM* 12.7.2009 IHS/OIT/FCJ MODIFIED INTRO TEXT AND VERSION CHECKS

 +3       ;

 +4        IF '$GET(DUZ)

               WRITE !,"DUZ UNDEFINED OR 0."

               DO SORRY(2)

               QUIT

 +5       ;

 +6        IF '$LENGTH($GET(DUZ(0)))

               WRITE !,"DUZ(0) UNDEFINED OR NULL."

               DO SORRY(2)

               QUIT

 +7       ;

 +8        SET X=$PIECE(^VA(200,DUZ,0),U)

 +9        WRITE !!,$$CJ^XLFSTR("Hello, "_$PIECE(X,",",2)_" "_$PIECE(X,","),IOM)

 +10       WRITE !!,$$CJ^XLFSTR("Checking Environment for "_$PIECE($TEXT(+2),";",4)_" V "_$PIECE($TEXT(+2),";",3)_$SELECT($LENGTH($PIECE($TEXT(+2),";",5))>4:" Patch "_$PIECE($TEXT(+2),";",5),1:"")_".",IOM),!

 +11      ;

 +12       IF $$VCHK("XU","8.0",2)

 +13       IF $$VCHK("DI","22.0",2)

 +14      ;IHS/OIT/NKD AUM*13.0*1 - CHANGED PATCH CHECK

 +15      ;I $$VCHK2("AUM","12.0.4",2)

 +16       IF $$PCHK("AUM*12.0*4",2)

 +17      ;

 +18       NEW DA,DIC

 +19       SET X="AUM"

           SET DIC="^DIC(9.4,"

           SET DIC(0)=""

           SET D="C"

 +20       DO IX^DIC

 +21       IF Y<0

               IF $DATA(^DIC(9.4,"C","AUM"))

                   Begin DoDot:1

 +22                   WRITE !!,*7,*7,$$CJ^XLFSTR("You Have More Than One Entry In The",IOM),!,$$CJ^XLFSTR("PACKAGE File with an ""AUM"" prefix.",IOM)

 +23                   WRITE !,$$CJ^XLFSTR("One entry needs to be deleted.",IOM)

 +24                   DO SORRY(2)

 +25                   QUIT

                   End DoDot:1

 +26      ;

 +27       IF $GET(XPDQUIT)

               WRITE !,$$CJ^XLFSTR("FIX IT! Before Proceeding.",IOM),!!,*7,*7,*7

               QUIT

 +28      ;

 +29       WRITE !!,$$CJ^XLFSTR("ENVIRONMENT OK.",IOM)

 +30       DO HELP^XBHELP("INTROE","AZHBENV")

 +31      ;

 +32       IF $GET(XPDENV)=1

               Begin DoDot:1

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

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

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

 +36               DO HELP^XBHELP("INTROI","AZHBENV")

 +37               QUIT

               End DoDot:1

 +38      ;

 +39       IF '$$DIR^XBDIR("E","","","","","",1)

               DO SORRY(2)

 +40       QUIT

 +41      ;

SORRY(X)  ;

 +1        KILL DIFQ

 +2        SET XPDQUIT=X

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

 +4        QUIT

 +5       ;

VCHK(AUMPRE,AUMVER,AUMQUIT) ; Check versions needed.

 +1       ;

 +2        NEW AUMV

 +3        SET AUMV=$$VERSION^XPDUTL(AUMPRE)

 +4        WRITE !,$$CJ^XLFSTR("Need at least "_AUMPRE_" v "_AUMVER_"....."_AUMPRE_" v "_AUMV_" Present",IOM)

 +5        IF AUMV<AUMVER

               KILL DIFQ

               SET XPDQUIT=AUMQUIT

               DO SORRY(AUMQUIT)

               QUIT 0

 +6        QUIT 1

VCHK2(AUMPRE,AUMVER,AUMQUIT) ; Check patch level for AUM

 +1        NEW AUMV

 +2        SET AUMV=$$VERSION^XPDUTL(AUMPRE)

 +3        SET PTCH=+$$LAST(AUMPRE,AUMV)

           IF PTCH=-1

               SET DPTCH=""

           IF PTCH'=-1

               SET DPTCH="."_PTCH

 +4        WRITE !,$$CJ^XLFSTR("Need at least "_AUMPRE_" v "_AUMVER_"....."_AUMPRE_" v "_AUMV_DPTCH_" Present",IOM)

 +5        IF (AUMV<($PIECE(AUMVER,".",1,2)))

               KILL DIFQ

               SET XPDQUIT=AUMQUIT

               DO SORRY(AUMQUIT)

               QUIT 0

 +6        IF (AUMV=$PIECE(AUMVER,".",1,2))&(PTCH<$PIECE(AUMVER,".",3))

               KILL DIFQ

               SET XPDQUIT=AUMQUIT

               DO SORRY(AUMQUIT)

               QUIT 0

 +7        QUIT 1

 +8       ;IHS/OIT/NKD AUM*13.0*1 - CHANGED PATCH CHECK - LOOKS FOR SPECIFIC PATCH

PCHK(AUMPAT,AUMQUIT) ; Check patch level for AUM

 +1        NEW AUMP

 +2        SET AUMP=$$PATCH^XPDUTL(AUMPAT)

 +3        WRITE !,$$CJ^XLFSTR("Patch "_AUMPAT_" is "_$SELECT(AUMP<1:"*NOT* ",1:"")_"installed.",IOM)

 +4        IF 'AUMP

               KILL DIFQ

               SET XPDQUIT=AUMQUIT

               DO SORRY(AUMQUIT)

               QUIT 0

 +5        QUIT 1

LAST(PKG,VER) ;EP - returns last patch applied for a Package, PATCH^DATE

 +1       ;        Patch includes Seq # if Released

 +2        NEW PKGIEN,VERIEN,LATEST,PATCH,SUBIEN

 +3        IF $GET(VER)=""

               SET VER=$$VERSION^XPDUTL(PKG)

               IF 'VER

                   QUIT -1

 +4        SET PKGIEN=$ORDER(^DIC(9.4,"C",PKG,""))

           IF 'PKGIEN

               QUIT -1

 +5        SET VERIEN=$ORDER(^DIC(9.4,PKGIEN,22,"B",VER,""))

           IF 'VERIEN

               QUIT -1

 +6        SET LATEST=-1

           SET PATCH=-1

           SET SUBIEN=0

 +7        FOR

               SET SUBIEN=$ORDER(^DIC(9.4,PKGIEN,22,VERIEN,"PAH",SUBIEN))

               IF SUBIEN'>0

                   QUIT

               Begin DoDot:1

 +8                IF $PIECE(^DIC(9.4,PKGIEN,22,VERIEN,"PAH",SUBIEN,0),U,2)>LATEST

                       SET LATEST=$PIECE(^(0),U,2)

                       SET PATCH=$PIECE(^(0),U)

 +9                IF $PIECE(^DIC(9.4,PKGIEN,22,VERIEN,"PAH",SUBIEN,0),U,2)=LATEST

                       IF $PIECE(^(0),U)>PATCH

                           SET PATCH=$PIECE(^(0),U)

               End DoDot:1

 +10       QUIT PATCH_U_LATEST

 +11      ;

PRE       ; EP FR KIDS

 +1       ;CLEAN UP CONTROL CHAR AND REMOVE DATA FROM AUMDATA

 +2        DO START^AUMPRE

 +3       ;IHS/OIT/NKD AUM*13.0*1 - ROUTINE EXCISE

 +4        NEW CNT,TEXT,DISP

 +5        DO BMES^XPDUTL("Excising the following AUM routines for ICD-10 implementation...")

 +6        SET DISP=""

 +7        FOR CNT=1:1

               SET TEXT=$PIECE($TEXT(RLIST+CNT),";;",2)

               IF TEXT="END"

                   QUIT

               Begin DoDot:1

 +8                NEW X

 +9                SET X=TEXT

                   XECUTE ^%ZOSF("DEL")

 +10               SET DISP=DISP_TEXT_$JUSTIFY("",12-$LENGTH(TEXT))

 +11               IF $LENGTH(DISP)>70

                       DO MES^XPDUTL(DISP)

                       SET DISP=""

               End DoDot:1

 +12       IF $LENGTH(DISP)>0

               DO MES^XPDUTL(DISP)

 +13       QUIT

RLIST     ;; LIST OF ROUTINES TO EXCISE

 +1       ;;AUM101

 +2       ;;AUM111

 +3       ;;AUM111R2

 +4       ;;AUM111R3

 +5       ;;AUM111RL

 +6       ;;AUM31

 +7       ;;AUM41

 +8       ;;AUM41E

 +9       ;;AUM41P3

 +10      ;;AUM51

 +11      ;;AUM516PT

 +12      ;;AUM61

 +13      ;;AUM71

 +14      ;;AUM71P2

 +15      ;;AUM81

 +16      ;;AUM81DRG

 +17      ;;AUM91

 +18      ;;AUMDO1A

 +19      ;;AUMDO1B

 +20      ;;AUMICD1

 +21      ;;END

 +22      ;

 +23      ;IHS/OIT/NKD AUM*13.0*1 - COMMENTED OUT AUM*12.0*4 PRE-INSTALL

 +24      ; CHECK FOR DUPLICATE PHQT MEASUREMENT TYPE

 +25      ;D MES^XPDUTL("Checking for duplicate PHQT Measurement Type...")

 +26      ;N AUMRES,AUMCNT,AUMCNT2,AUML1,AUML2,AUMTMP

 +27      ;D FIND^DIC(9999999.07,"","@;.01;.02","PX","PHQT",,,,,"AUMRES")

 +28      ;S AUMCNT=$P($G(AUMRES("DILIST",0)),U,1)

 +29      ;I AUMCNT<2 D MES^XPDUTL("  No duplicates found!") Q

 +30      ;D MES^XPDUTL("  "_(AUMCNT-1)_" duplicate(s) found!")

 +31      ;S (AUML1,AUML2)=""

 +32      ; PUT LOWERCASE DESCRIPTIONS INTO LIST 1 (FROM), UPPERCASE INTO LIST 2 (TO)

 +33      ;F AUMCNT2=1:1:AUMCNT S AUMTMP=$G(AUMRES("DILIST",AUMCNT2,0)) D

 +34      ;. S:$P(AUMTMP,"^",3)'=$$UP^XLFSTR($P(AUMTMP,"^",3)) AUML1=AUML1_AUMCNT2_"^"

 +35      ;. S:$P(AUMTMP,"^",3)=$$UP^XLFSTR($P(AUMTMP,"^",3)) AUML2=AUML2_AUMCNT2_"^"

 +36      ; MOVE ADDITIONAL UPPERCASES INTO LIST 1 (FROM)

 +37      ;S AUML1=AUML1_$P(AUML2,"^",2,100),AUML2=$P(AUML2,"^",1)

 +38      ; IF ONLY LOWERCASES, MOVE LOWEST IEN INTO LIST 2 (TO)

 +39      ;S:AUML2']"" AUML2=$P(AUML1,"^",1),AUML1=$P(AUML1,"^",2,100)

 +40      ; MERGE ALL LIST 1 (FROM) ENTRIES INTO LIST 2 (TO) ENTRY

 +41      ;F AUMCNT2=1:1:$L(AUML1,"^") S AUMTMP=$P(AUML1,"^",AUMCNT2) Q:'AUMTMP  D

 +42      ;. D MMERG($P($G(AUMRES("DILIST",AUMTMP,0)),"^",1),$P($G(AUMRES("DILIST",AUML2,0)),"^",1))

 +43      ;Q

 +44      ;MMERG(FROM,TO) ; MEASUREMENT TYPE COMPARE/MERGE

 +45      ;N DILN,DITM,L

 +46      ;;D MES^XPDUTL("MERGING ENTRY '"_FROM_"' INTO '"_TO_"'")

 +47      ;S DILN=21

 +48      ;S DITM=0

 +49      ;S DITM("DDEF")=2

 +50      ;S DITM("DDIF")=1

 +51      ;S DITM("DELETE")=""

 +52      ;S DITM("DFF")=9999999.07

 +53      ;S DITM("DIC")="^AUTTMSR("

 +54      ;S DITM("DIMERGE")=1

 +55      ;S DITM("DIT(1)")=FROM

 +56      ;S DITM("DIT(2)")=TO

 +57      ;S DITM("NON-INTERACTIVE")=""

 +58      ;S DITM("REPOINT")=""

 +59      ;S L=1

 +60      ;D ^DITM2,END^DITM

 +61      ;Q

 +62      ;

INTROE    ; Intro text during KIDS Environment check.

 +1       ;;This is the update to the standard code book tables.  There are modifications

 +2       ;;and additions to the following files:  Community, Location, Tribe,

 +3       ;;Reservation and Service Unit.

 +4       ;;

 +5       ;;The install message will report updates and failed updates to those files.

 +6       ;;

 +7       ;;###

 +8       ;

INTROI    ; Intro text during KIDS Install.

 +1       ;;If you run interactively, results will be displayed on your screen,

 +2       ;;and recorded in the entry in the INSTALL file.

 +3       ;;If you queue to TaskMan, remember not to Q to the HOME device.

 +4       ;;###

 +5       ;

AUM1011E.m