Routine: AMH40P7

AMH40P7 ; IHS/CMI/LAB - POST INIT BH 4.0 P7

 ;;4.0;IHS BEHAVIORAL HEALTH;**7**;JUN 02, 2010;Build 15

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*6") D SORRY(2)

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

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

PRE ;

 NEW AMHX,DIK,DA

 S AMHX=0 F  S AMHX=$O(^AMHPCIN(AMHX)) Q:AMHX'=+AMHX  S DA=AMHX,DIK="^AMHPCIN(" D ^DIK K DIK,DA

 S AMHX=0 F  S AMHX=$O(^AMHTPCAD(AMHX)) Q:AMHX'=+AMHX  S DA=AMHX,DIK="^AMHTPCAD(" D ^DIK K DIK,DA

POST ;EP

 D INACTPC

 D ADDDSMV

ADDDSMV ;add all new dsm v codes

 D MES^XPDUTL($$CJ^XLFSTR("Adding codes.",IOM))

 S AMHX=0 F  S AMHX=$O(^AMHTPCAD(AMHX)) Q:AMHX'=+AMHX  D

DSM10 .;ADD DSM5 ICD10 CODES

 .S AMHCODE=$P(^AMHTPCAD(AMHX,0),U,1)

 .Q:AMHCODE=""

 .S AMHNARR=$P(^AMHTPCAD(AMHX,0),U,2)

 .S AMHPC=$P(^AMHTPCAD(AMHX,0),U,3)

 .S AMHPCC=$O(^AMHPROBC("B",AMHPC,0))

 .I 'AMHPCC D MES^XPDUTL("PROBLEM CODE MISSING: "_AMHPC_" CODE "_AMHCODE_" NOT UPLOADED") Q

 .S AMHICD=$P(^AMHTPCAD(AMHX,0),U,17)

 .S AMHEHR=$P(^AMHTPCAD(AMHX,0),U,15)

 .S AMHNOBH=$P(^AMHTPCAD(AMHX,0),U,18)

 .S AMHCS=$P(^AMHTPCAD(AMHX,0),U,10)

 .;FIND EXISTING AND OVERLAY

 .K DIE,DA,DR

 .S DA=""

 .S AMHY=0 F  S AMHY=$O(^AMHPROB("B",AMHCODE,AMHY)) Q:AMHY'=+AMHY!(DA)  D

 ..Q:$P(^AMHPROB(AMHY,0),U,10)'=5  ;ONLY DSMV

 ..Q:$$UP^XLFSTR($P(^AMHPROB(AMHY,0),U,2))'=$$UP^XLFSTR(AMHNARR)

 ..S DA=AMHY

 .I DA D EDITC Q

 .;ADD THEN EDIT

 .K DIC,DLAYGO,DIADD,DD,D0

 .S DITC=1

 .S X=AMHCODE,DIC="^AMHPROB(",DLAYGO=9002012.2,DIADD=1,DIC(0)="EMQ"

 .S DIC("DR")=".02///"_AMHNARR_";.03////"_AMHPCC_";.17///"_AMHICD_";.1///"_AMHCS_";.15///"_AMHEHR_";.18///"_AMHNOBH

 .D FILE^DICN

 .I Y=-1 W !,"ERROR ON ",AMHX," ",AMHCODE," ",DIC("DR") K DA,DIC,DIADD,DLAYGO,DR,DD,D0,DO,DITC Q

 .K DA,DIC,DIADD,DLAYGO,DR,DD,D0,DO,DITC

 .D MES^XPDUTL("."_$P(^AMHPROB(+Y,0),U,1))

.Q

EDITC ;

 S DIE="^AMHPROB(",DR=".02///"_AMHNARR_";.03////"_AMHPCC_";.17///"_AMHICD_";.1///"_AMHCS_";.15///"_AMHEHR_";.18///"_AMHNOBH

 D ^DIE

 I $D(Y) D MES^XPDUTL("DSM CODE FAILED UPDATING: "_AMHCODE) K DIE,DA,DR Q

 D MES^XPDUTL("."_$P(^AMHPROB(DA,0),U,1))

 K DIE,DA,DR

INACTPC ;

 D MES^XPDUTL($$CJ^XLFSTR("Inactivating codes.",IOM))

 S AMHX=0 F  S AMHX=$O(^AMHPCIN(AMHX)) Q:AMHX'=+AMHX  D

 .Q:$P(^AMHPCIN(AMHX,0),U,3)'=1

 .S AMHC=$P(^AMHPCIN(AMHX,0),U,1)

 .;loop through "B" on AMHPROB and flag all that are not already flagged

 .S AMHY=0 F  S AMHY=$O(^AMHPROB("B",AMHC,AMHY)) Q:AMHY'=+AMHY  D

 ..I '$D(^AMHPROB(AMHY,0)) Q

 ..;I $P(^AMHPROB(AMHY,0),U,13),$P(^AMHPROB(AMHY,0),U,14)]"" Q  ;already flagged

 ..S DA=AMHY,DIE="^AMHPROB(",DR=".13///1;.14////"_$P(^AMHPCIN(AMHX,0),U,5) D ^DIE K DA,DIE,DR

 ..D MES^XPDUTL("."_$P(^AMHPROB(AMHY,0),U,1))

..Q

.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))

SORRY(X) ;

 KILL DIFQ

 I X=3 S XPDQUIT=2 Q

 S XPDQUIT=X

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

AMH40P7   ; IHS/CMI/LAB - POST INIT BH 4.0 P7

 +1       ;;4.0;IHS BEHAVIORAL HEALTH;**7**;JUN 02, 2010;Build 15

 +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*6")

               DO SORRY(2)

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

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

               DO SORRY(2)

               IF 1

 +10      IF '$TEST

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

 +11       QUIT

 +12      ;

PRE       ;

 +1        NEW AMHX,DIK,DA

 +2        SET AMHX=0

FOR

               SET AMHX=$ORDER(^AMHPCIN(AMHX))

               IF AMHX'=+AMHX

                   QUIT

               SET DA=AMHX

               SET DIK="^AMHPCIN("

               DO ^DIK

               KILL DIK,DA

 +3        SET AMHX=0

FOR

               SET AMHX=$ORDER(^AMHTPCAD(AMHX))

               IF AMHX'=+AMHX

                   QUIT

               SET DA=AMHX

               SET DIK="^AMHTPCAD("

               DO ^DIK

               KILL DIK,DA

 +4        QUIT

 +5       ;

POST      ;EP

 +1        DO INACTPC

 +2        DO ADDDSMV

 +3        QUIT

 +4       ;

ADDDSMV   ;add all new dsm v codes

 +1        DO MES^XPDUTL($$CJ^XLFSTR("Adding codes.",IOM))

 +2        SET AMHX=0

FOR

               SET AMHX=$ORDER(^AMHTPCAD(AMHX))

               IF AMHX'=+AMHX

                   QUIT

               Begin DoDot:1

DSM10     ;ADD DSM5 ICD10 CODES

 +1                SET AMHCODE=$PIECE(^AMHTPCAD(AMHX,0),U,1)

 +2                IF AMHCODE=""

                       QUIT

 +3                SET AMHNARR=$PIECE(^AMHTPCAD(AMHX,0),U,2)

 +4                SET AMHPC=$PIECE(^AMHTPCAD(AMHX,0),U,3)

 +5                SET AMHPCC=$ORDER(^AMHPROBC("B",AMHPC,0))

 +6                IF 'AMHPCC

                       DO MES^XPDUTL("PROBLEM CODE MISSING: "_AMHPC_" CODE "_AMHCODE_" NOT UPLOADED")

                       QUIT

 +7                SET AMHICD=$PIECE(^AMHTPCAD(AMHX,0),U,17)

 +8                SET AMHEHR=$PIECE(^AMHTPCAD(AMHX,0),U,15)

 +9                SET AMHNOBH=$PIECE(^AMHTPCAD(AMHX,0),U,18)

 +10               SET AMHCS=$PIECE(^AMHTPCAD(AMHX,0),U,10)

 +11      ;FIND EXISTING AND OVERLAY

 +12               KILL DIE,DA,DR

 +13               SET DA=""

 +14               SET AMHY=0

FOR

                       SET AMHY=$ORDER(^AMHPROB("B",AMHCODE,AMHY))

                       IF AMHY'=+AMHY!(DA)

                           QUIT

                       Begin DoDot:2

 +15      ;ONLY DSMV

                           IF $PIECE(^AMHPROB(AMHY,0),U,10)'=5

                               QUIT

 +16                       IF $$UP^XLFSTR($PIECE(^AMHPROB(AMHY,0),U,2))'=$$UP^XLFSTR(AMHNARR)

                               QUIT

 +17                       SET DA=AMHY

                       End DoDot:2

 +18               IF DA

                       DO EDITC

                       QUIT

 +19      ;ADD THEN EDIT

 +20               KILL DIC,DLAYGO,DIADD,DD,D0

 +21               SET DITC=1

 +22               SET X=AMHCODE

                   SET DIC="^AMHPROB("

                   SET DLAYGO=9002012.2

                   SET DIADD=1

                   SET DIC(0)="EMQ"

 +23               SET DIC("DR")=".02///"_AMHNARR_";.03////"_AMHPCC_";.17///"_AMHICD_";.1///"_AMHCS_";.15///"_AMHEHR_";.18///"_AMHNOBH

 +24               DO FILE^DICN

 +25               IF Y=-1

                       WRITE !,"ERROR ON ",AMHX," ",AMHCODE," ",DIC("DR")

                       KILL DA,DIC,DIADD,DLAYGO,DR,DD,D0,DO,DITC

                       QUIT

 +26               KILL DA,DIC,DIADD,DLAYGO,DR,DD,D0,DO,DITC

 +27               DO MES^XPDUTL("."_$PIECE(^AMHPROB(+Y,0),U,1))

 +28               QUIT

               End DoDot:1

 +29       QUIT

EDITC     ;

 +1        SET DIE="^AMHPROB("

           SET DR=".02///"_AMHNARR_";.03////"_AMHPCC_";.17///"_AMHICD_";.1///"_AMHCS_";.15///"_AMHEHR_";.18///"_AMHNOBH

 +2        DO ^DIE

 +3        IF $DATA(Y)

               DO MES^XPDUTL("DSM CODE FAILED UPDATING: "_AMHCODE)

               KILL DIE,DA,DR

               QUIT

 +4        DO MES^XPDUTL("."_$PIECE(^AMHPROB(DA,0),U,1))

 +5        KILL DIE,DA,DR

 +6        QUIT

INACTPC   ;

 +1        DO MES^XPDUTL($$CJ^XLFSTR("Inactivating codes.",IOM))

 +2        SET AMHX=0

FOR

               SET AMHX=$ORDER(^AMHPCIN(AMHX))

               IF AMHX'=+AMHX

                   QUIT

               Begin DoDot:1

 +3                IF $PIECE(^AMHPCIN(AMHX,0),U,3)'=1

                       QUIT

 +4                SET AMHC=$PIECE(^AMHPCIN(AMHX,0),U,1)

 +5       ;loop through "B" on AMHPROB and flag all that are not already flagged

 +6                SET AMHY=0

FOR

                       SET AMHY=$ORDER(^AMHPROB("B",AMHC,AMHY))

                       IF AMHY'=+AMHY

                           QUIT

                       Begin DoDot:2

 +7                        IF '$DATA(^AMHPROB(AMHY,0))

                               QUIT

 +8       ;I $P(^AMHPROB(AMHY,0),U,13),$P(^AMHPROB(AMHY,0),U,14)]"" Q  ;already flagged

 +9                        SET DA=AMHY

                           SET DIE="^AMHPROB("

                           SET DR=".13///1;.14////"_$PIECE(^AMHPCIN(AMHX,0),U,5)

                           DO ^DIE

                           KILL DA,DIE,DR

 +10                       DO MES^XPDUTL("."_$PIECE(^AMHPROB(AMHY,0),U,1))

 +11                       QUIT

                       End DoDot:2

 +12               QUIT

               End DoDot:1

 +13       QUIT

 +14      ;

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

AMH40P7.m