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)
Q
;
PRE ;
Q
;
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
Q
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")
Q
;
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")
Q
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))
Q
SORRY(X) ;
KILL DIFQ
I X=3 S XPDQUIT=2 Q
S XPDQUIT=X
W *7,!,$$CJ^XLFSTR("Sorry....FIX IT!",IOM)
Q
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
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;;
