Routine: AMH40P5

AMH40P5 ; IHS/CMI/LAB - POST INIT BH 16 Apr 2009 7:37 AM 01 Aug 2009 5:37 AM ; 18 Sep 2014  11:23 AM

 ;;4.0;IHS BEHAVIORAL HEALTH;**5**;JUN 02, 2010;Build 18

ENV ;EP

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

 I +$$VERSION^XPDUTL("XU")<8 D MES^XPDUTL($$CJ^XLFSTR("Version 8.0 of KERNEL is required.  Not installed",80)) D SORRY(2) I 1

 E  D MES^XPDUTL($$CJ^XLFSTR("Requires Kernel Version 8.0....Present.",80))

 I +$$VERSION^XPDUTL("DI")<22 D MES^XPDUTL($$CJ^XLFSTR("Version 22.0 of FILEMAN is required.  Not installed.",80)) D SORRY(2) I 1

 E  D MES^XPDUTL($$CJ^XLFSTR("Requires Fileman v22....Present.",80))

 I $E($$VERSION^XPDUTL("AMH"),1,3)'="4.0" D MES^XPDUTL($$CJ^XLFSTR("Version 4.0 of AMH is required.  Not installed.",80)) D SORRY(2) I 1

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

 I '$$INSTALLD("AMH*4.0*4") D SORRY(2)

PRE ;

POST ;EP

 S X=$$DELETE^XPDMENU("AMH M PRINT TABLES","AMH P TABLES MHSS PROB CODES")

 D ICD10

 ;INACTIVATE 8.4

 S DA=$O(^AMHPROB("B","8.4",0)) I DA S DIE="^AMHPROB(",DR=".13///1;.14////"_DT D ^DIE K DIE,DA,DR

 ;D BMXPO

BMXPO ;-- update the RPC file

 N AMHRPC

 S AMHRPC=$O(^DIC(19,"B","AMHGRPC",0))

 Q:'AMHRPC

 D CLEAN(AMHRPC)

 D GUIEP^BMXPO(.RETVAL,AMHRPC_"|AMH")

CLEAN(APP) ;-- clean out the RPC multiple first

 S DA(1)=APP

 S DIK="^DIC(19,"_DA(1)_","_"""RPC"""_","

 N AMHDA

 S AMHDA=0 F  S AMHDA=$O(^DIC(19,APP,"RPC",AMHDA)) Q:'AMHDA  D

 . S DA=AMHDA

 . D ^DIK

 K ^DIC(19,APP,"RPC","B")

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

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

 NEW AMHY,DIC,X,Y

 S X=$P(AMHSTAL,"*",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(AMHSTAL,"*",2)

 D ^DIC

 I Y<1 D IMES Q 0

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

 D ^DIC

 S AMHY=Y

 D IMES

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

IMES ;

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

SORRY(X) ;

 KILL DIFQ

 I X=3 S XPDQUIT=2 Q

 S XPDQUIT=X

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

ICD10 ;

 NEW AMHTEXT,AMHY,AMHTX,X,AMHCODE,AMHPC,AMH10

 S AMHTEXT="ICDNEW" F AMHY=1:1 S AMHTX=$P($T(@AMHTEXT+AMHY),";;",2,3) Q:AMHTX=""  D

 .S (X,AMHCODE)=$P(AMHTX,";;",1)

 .S AMHPC=$O(^AMHPROB("B",AMHCODE,0))

 .I AMHPC="" D MES^XPDUTL("Problem code: "_$P(AMHTX,";;",1)_" does not exist") Q

 .S AMH10=$P(AMHTX,";;",2)

 .S DA=AMHPC,DIE="^AMHPROB(",DR=".13///@;.14///@;.17///"_AMH10 D ^DIE K DA,DIE,DR

 .I $D(Y) W !,AMHPC," DID NOT UPDATE"

.Q

ICDNEW ;

 ;;1;;Z74.2

 ;;1.1;;Z71.89

 ;;2;;Z60.3

 ;;3;;F69.

 ;;4;;Z51.89

 ;;5;;Z92.89

 ;;6.1;;Z92.89

 ;;6.2;;Z92.89

 ;;7;;Z91.19

 ;;8;;Z91.19

 ;;8.1;;

 ;;8.11;;Z91.19

 ;;8.2;;

 ;;8.21;;

 ;;8.3;;

 ;;8.4;;Z76.5

 ;;38.2;;Z76.0

 ;;39;;R45.851

 ;;40;;F48.9

 ;;41;;R99.

 ;;54.1;;

 ;;70;;Z59.8

 ;;71;;Z59.8

 ;;72;;Z62.21

 ;;72.1;;Z71.89

 ;;73;;Z51.89

 ;;74;;Z51.89

 ;;75;;Z51.89

 ;;76;;Z51.89

 ;;77;;Z59.3

 ;;78;;Z02.89

 ;;79;;Z59.5

 ;;79.1;;Z59.5

 ;;79.2;;Z75.4

 ;;81;;Z71.3

 ;;83;;Z59.9

 ;;85;;Z59.9

 ;;86;;Z65.3

 ;;87;;Z65.3

 ;;88;;Z65.3

 ;;89;;Z55.9

 ;;89.1;;

 ;;90;;Z55.9

 ;;91;;Z55.9

 ;;92;;Z51.89

 ;;93;;Z60.9

 ;;94;;Z60.0

 ;;94.1;;Z65.8

 ;;94.2;;R41.83

 ;;95;;

 ;;96;;

 ;;97;;

 ;;98;;

 ;;99;;

AMH40P5   ; IHS/CMI/LAB - POST INIT BH 16 Apr 2009 7:37 AM 01 Aug 2009 5:37 AM ; 18 Sep 2014  11:23 AM

 +1       ;;4.0;IHS BEHAVIORAL HEALTH;**5**;JUN 02, 2010;Build 18

 +2       ;

ENV       ;EP

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

               SET XPDDIQ(X)=0

 +2        IF +$$VERSION^XPDUTL("XU")<8

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

               DO SORRY(2)

               IF 1

 +3       IF '$TEST

               DO MES^XPDUTL($$CJ^XLFSTR("Requires Kernel Version 8.0....Present.",80))

 +4        IF +$$VERSION^XPDUTL("DI")<22

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

               DO SORRY(2)

               IF 1

 +5       IF '$TEST

               DO MES^XPDUTL($$CJ^XLFSTR("Requires Fileman v22....Present.",80))

 +6        IF $EXTRACT($$VERSION^XPDUTL("AMH"),1,3)'="4.0"

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

               DO SORRY(2)

               IF 1

 +7       IF '$TEST

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

 +8        IF '$$INSTALLD("AMH*4.0*4")

               DO SORRY(2)

 +9        QUIT

 +10      ;

PRE       ;

 +1        QUIT

 +2       ;

POST      ;EP

 +1        SET X=$$DELETE^XPDMENU("AMH M PRINT TABLES","AMH P TABLES MHSS PROB CODES")

 +2        DO ICD10

 +3       ;INACTIVATE 8.4

 +4        SET DA=$ORDER(^AMHPROB("B","8.4",0))

           IF DA

               SET DIE="^AMHPROB("

               SET DR=".13///1;.14////"_DT

               DO ^DIE

               KILL DIE,DA,DR

 +5       ;D BMXPO

 +6        QUIT

BMXPO     ;-- update the RPC file

 +1        NEW AMHRPC

 +2        SET AMHRPC=$ORDER(^DIC(19,"B","AMHGRPC",0))

 +3        IF 'AMHRPC

               QUIT

 +4        DO CLEAN(AMHRPC)

 +5        DO GUIEP^BMXPO(.RETVAL,AMHRPC_"|AMH")

 +6        QUIT

 +7       ;

CLEAN(APP) ;-- clean out the RPC multiple first

 +1        SET DA(1)=APP

 +2        SET DIK="^DIC(19,"_DA(1)_","_"""RPC"""_","

 +3        NEW AMHDA

 +4        SET AMHDA=0

FOR

               SET AMHDA=$ORDER(^DIC(19,APP,"RPC",AMHDA))

               IF 'AMHDA

                   QUIT

               Begin DoDot:1

 +5                SET DA=AMHDA

 +6                DO ^DIK

               End DoDot:1

 +7        KILL ^DIC(19,APP,"RPC","B")

 +8        QUIT

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

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

 +2       ;

 +3        NEW AMHY,DIC,X,Y

 +4        SET X=$PIECE(AMHSTAL,"*",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(AMHSTAL,"*",2)

 +9        DO ^DIC

 +10       IF Y<1

               DO IMES

               QUIT 0

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

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

 +12       DO ^DIC

 +13       SET AMHY=Y

 +14       DO IMES

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

IMES      ;

 +1        DO MES^XPDUTL($$CJ^XLFSTR("Patch """_AMHSTAL_""" is"_$SELECT(Y<1:" *NOT*",1:"")_" Present.",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

ICD10     ;

 +1        NEW AMHTEXT,AMHY,AMHTX,X,AMHCODE,AMHPC,AMH10

 +2        SET AMHTEXT="ICDNEW"

           FOR AMHY=1:1

               SET AMHTX=$PIECE($TEXT(@AMHTEXT+AMHY),";;",2,3)

               IF AMHTX=""

                   QUIT

               Begin DoDot:1

 +3                SET (X,AMHCODE)=$PIECE(AMHTX,";;",1)

 +4                SET AMHPC=$ORDER(^AMHPROB("B",AMHCODE,0))

 +5                IF AMHPC=""

                       DO MES^XPDUTL("Problem code: "_$PIECE(AMHTX,";;",1)_" does not exist")

                       QUIT

 +6                SET AMH10=$PIECE(AMHTX,";;",2)

 +7                SET DA=AMHPC

                   SET DIE="^AMHPROB("

                   SET DR=".13///@;.14///@;.17///"_AMH10

                   DO ^DIE

                   KILL DA,DIE,DR

 +8                IF $DATA(Y)

                       WRITE !,AMHPC," DID NOT UPDATE"

 +9                QUIT

               End DoDot:1

 +10       QUIT

ICDNEW    ;

 +1       ;;1;;Z74.2

 +2       ;;1.1;;Z71.89

 +3       ;;2;;Z60.3

 +4       ;;3;;F69.

 +5       ;;4;;Z51.89

 +6       ;;5;;Z92.89

 +7       ;;6.1;;Z92.89

 +8       ;;6.2;;Z92.89

 +9       ;;7;;Z91.19

 +10      ;;8;;Z91.19

 +11      ;;8.1;;

 +12      ;;8.11;;Z91.19

 +13      ;;8.2;;

 +14      ;;8.21;;

 +15      ;;8.3;;

 +16      ;;8.4;;Z76.5

 +17      ;;38.2;;Z76.0

 +18      ;;39;;R45.851

 +19      ;;40;;F48.9

 +20      ;;41;;R99.

 +21      ;;54.1;;

 +22      ;;70;;Z59.8

 +23      ;;71;;Z59.8

 +24      ;;72;;Z62.21

 +25      ;;72.1;;Z71.89

 +26      ;;73;;Z51.89

 +27      ;;74;;Z51.89

 +28      ;;75;;Z51.89

 +29      ;;76;;Z51.89

 +30      ;;77;;Z59.3

 +31      ;;78;;Z02.89

 +32      ;;79;;Z59.5

 +33      ;;79.1;;Z59.5

 +34      ;;79.2;;Z75.4

 +35      ;;81;;Z71.3

 +36      ;;83;;Z59.9

 +37      ;;85;;Z59.9

 +38      ;;86;;Z65.3

 +39      ;;87;;Z65.3

 +40      ;;88;;Z65.3

 +41      ;;89;;Z55.9

 +42      ;;89.1;;

 +43      ;;90;;Z55.9

 +44      ;;91;;Z55.9

 +45      ;;92;;Z51.89

 +46      ;;93;;Z60.9

 +47      ;;94;;Z60.0

 +48      ;;94.1;;Z65.8

 +49      ;;94.2;;R41.83

 +50      ;;95;;

 +51      ;;96;;

 +52      ;;97;;

 +53      ;;98;;

 +54      ;;99;;

AMH40P5.m