Routine: AMH40P1

AMH40P1 ; IHS/CMI/LAB - POST INIT BH 16 Apr 2009 7:37 AM 01 Aug 2009 5:37 AM ; 13 Apr 2010  3:54 PM

 ;;4.0;IHS BEHAVIORAL HEALTH;**1**;JUN 18, 2010;Build 8

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

PRE ;

 S DA=0 F  S DA=$O(^AMHSORT(DA)) Q:DA'=+DA  S DIK="^AMHSORT(" D ^DIK

 S DA=0 F  S DA=$O(^AMHBHPC(DA)) Q:DA'=+DA  S DIK="^AMHBHPC(" D ^DIK

 K DIK,DA

 S DA=$O(^AMHTSET("B","TELE-MENTAL HEALTH",0))

 I DA S DIE="^AMHTSET(",DR=".01///TELE-BEHAVIORAL HEALTH;.04///TBH" D ^DIE K DIE,DA,DR

POST ;EP

 ;add three new codes

 D NEW

 S DIK="^AMHPSUIC(",DIK(1)=".06^AB" D ENALL^DIK

 K DIK

 S AMHX=0,AMHNMM="" F  S AMHX=$O(^AMHSITE(AMHX)) Q:AMHX'=+AMHX  D

 .S AMHY=0 F  S AMHY=$O(^AMHSITE(AMHX,11,AMHY)) Q:AMHY'=+AMHY  D

 ..Q:$P(^AMHSITE(AMHX,11,AMHY,0),U,2)'=3

 ..S $P(^AMHSITE(AMHX,11,AMHY,0),U,2)=5,AMHNMM=AMHNMM_$S(AMHNMM]"":"; ",1:"")_$P($G(^DIC(4,AMHX,0)),U)

 I AMHNMM]"" D MM3

 D BMXPO

BMXPO ;-- update the RPC file

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

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)

MM3 ;BULLETIN;

 I '$G(DUZ) W !,"DUZ UNDEFINED OR ZERO.",! Q

 D HOME^%ZIS,DT^DICRW

 NEW XMSUB,XMDUZ,XMTEXT,XMY,DIFROM

 KILL ^TMP($J,"AMHBUL")

 D WRITEMS3,GETREC3

 ;Change following lines as desired

SUBJECT3 S XMSUB="* * * IMPORTANT RPMS INFORMATION * * *"

SENDER3 S XMDUZ="IHS Behavioral Health"

 S XMTEXT="^TMP($J,""AMHBUL"",",XMY(1)="",XMY(DUZ)=""

 I $E(IOST)="C" W !,"Sending Mailman message to holders of the"_" "_AMHKEY_" "_"security key."

 D ^XMD

 KILL ^TMP($J,"AMHBUL"),AMHKEY

WRITEMS3 ;

 S AMHIEN=$O(^AMHPATCH("AA",4,99,0))

 I AMHIEN="" Q

 S AMHX=0,AMHC=0 F  S AMHX=$O(^AMHPATCH(AMHIEN,11,AMHX)) Q:AMHX'=+AMHX  S AMHC=AMHC+1,^TMP($J,"AMHBUL",AMHC)=^AMHPATCH(AMHIEN,11,AMHX,0)

 S AMHC=AMHC+1,^TMP($J,"AMHBUL",AMHC)=" "

 S AMHC=AMHC+1,^TMP($J,"AMHBUL",AMHC)="The following users had their PCC link type changed"

 S AMHC=AMHC+1,^TMP($J,"AMHBUL",AMHC)="from Link type 3 to Link type 5.  This is under the"

 S AMHC=AMHC+1,^TMP($J,"AMHBUL",AMHC)="list of users who have a PCC Link exception entered"

 S AMHC=AMHC+1,^TMP($J,"AMHBUL",AMHC)="in the Site Parameter file."

 S AMHC=AMHC+1,^TMP($J,"AMHBUL",AMHC)=AMHNMM

GETREC3 ;

 ;* * * Define key below to identify recipients * * *

 S CTR=0,AMHKEY="AMHZMGR"

 F  S CTR=$O(^XUSEC(AMHKEY,CTR)) Q:'CTR  S Y=CTR S XMY(Y)=""

NEW ;add new codes

 ;add new codes if they don't exist

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

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

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

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

 .S AMHINA=$P(AMHTX,";;",3)

 .S DA=$O(^AMHPROB("B",X,0)) I DA Q

 .S DIC="^AMHPROB(",DLAYGO=9001012.2,DIADD=1,DIC="^AMHPROB("

 .S DIC(0)="L"

 .K DD,D0,DO D FILE^DICN K DIADD,DLAYGO,DD,DIC,D0,DO

 .I Y=-1 D MES^XPDUTL("Code "_AMHCODE_" could not be added.") Q

 .S DA=+Y

NEWE .;

 .S DIE="^AMHPROB("

 .S DR=".02////"_AMHINA_";.03////"_AMHPC_";.05////"_AMHCODE

 .D ^DIE K DIE,DA,DR

 .I $D(Y) D MES^XPDUTL("Error updating code "_AMHCODE_".") Q

ICDNEW ;;

 ;;315.35;;31;;CHILDHOOD ONSET FLUENCY DISORDER

 ;;V11.4;;38;;PERSONAL HISTORY OF COMBAT AND OPERATIONAL STRESS REACTION

 ;;V62.85;;38;;HOMICIDAL IDEATION

;;

AMH40P1   ; IHS/CMI/LAB - POST INIT BH 16 Apr 2009 7:37 AM 01 Aug 2009 5:37 AM ; 13 Apr 2010  3:54 PM

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

 +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        QUIT

 +9       ;

PRE       ;

 +1        SET DA=0

FOR

               SET DA=$ORDER(^AMHSORT(DA))

               IF DA'=+DA

                   QUIT

               SET DIK="^AMHSORT("

               DO ^DIK

 +2        SET DA=0

FOR

               SET DA=$ORDER(^AMHBHPC(DA))

               IF DA'=+DA

                   QUIT

               SET DIK="^AMHBHPC("

               DO ^DIK

 +3        KILL DIK,DA

 +4        SET DA=$ORDER(^AMHTSET("B","TELE-MENTAL HEALTH",0))

 +5        IF DA

               SET DIE="^AMHTSET("

               SET DR=".01///TELE-BEHAVIORAL HEALTH;.04///TBH"

               DO ^DIE

               KILL DIE,DA,DR

 +6        QUIT

 +7       ;

POST      ;EP

 +1       ;add three new codes

 +2        DO NEW

 +3        SET DIK="^AMHPSUIC("

           SET DIK(1)=".06^AB"

           DO ENALL^DIK

 +4        KILL DIK

 +5        SET AMHX=0

           SET AMHNMM=""

FOR

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

               IF AMHX'=+AMHX

                   QUIT

               Begin DoDot:1

 +6                SET AMHY=0

FOR

                       SET AMHY=$ORDER(^AMHSITE(AMHX,11,AMHY))

                       IF AMHY'=+AMHY

                           QUIT

                       Begin DoDot:2

 +7                        IF $PIECE(^AMHSITE(AMHX,11,AMHY,0),U,2)'=3

                               QUIT

 +8                        SET $PIECE(^AMHSITE(AMHX,11,AMHY,0),U,2)=5

                           SET AMHNMM=AMHNMM_$SELECT(AMHNMM]"":"; ",1:"")_$PIECE($GET(^DIC(4,AMHX,0)),U)

                       End DoDot:2

               End DoDot:1

 +9        IF AMHNMM]""

               DO MM3

 +10       DO BMXPO

 +11       QUIT

BMXPO     ;-- update the RPC file

 +1        DO GUIEP^BMXPO(.RETVAL,"AMHGRPC|AMH")

 +2        QUIT

 +3       ;

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

 +6       ;

MM3       ;BULLETIN;

 +1        IF '$GET(DUZ)

               WRITE !,"DUZ UNDEFINED OR ZERO.",!

               QUIT

 +2        DO HOME^%ZIS

           DO DT^DICRW

 +3       ;

 +4        NEW XMSUB,XMDUZ,XMTEXT,XMY,DIFROM

 +5        KILL ^TMP($JOB,"AMHBUL")

 +6        DO WRITEMS3

           DO GETREC3

 +7       ;Change following lines as desired

SUBJECT3   SET XMSUB="* * * IMPORTANT RPMS INFORMATION * * *"

SENDER3    SET XMDUZ="IHS Behavioral Health"

 +1        SET XMTEXT="^TMP($J,""AMHBUL"","

           SET XMY(1)=""

           SET XMY(DUZ)=""

 +2        IF $EXTRACT(IOST)="C"

               WRITE !,"Sending Mailman message to holders of the"_" "_AMHKEY_" "_"security key."

 +3        DO ^XMD

 +4        KILL ^TMP($JOB,"AMHBUL"),AMHKEY

 +5        QUIT

 +6       ;

WRITEMS3  ;

 +1        SET AMHIEN=$ORDER(^AMHPATCH("AA",4,99,0))

 +2        IF AMHIEN=""

               QUIT

 +3        SET AMHX=0

           SET AMHC=0

FOR

               SET AMHX=$ORDER(^AMHPATCH(AMHIEN,11,AMHX))

               IF AMHX'=+AMHX

                   QUIT

               SET AMHC=AMHC+1

               SET ^TMP($JOB,"AMHBUL",AMHC)=^AMHPATCH(AMHIEN,11,AMHX,0)

 +4        SET AMHC=AMHC+1

           SET ^TMP($JOB,"AMHBUL",AMHC)=" "

 +5        SET AMHC=AMHC+1

           SET ^TMP($JOB,"AMHBUL",AMHC)="The following users had their PCC link type changed"

 +6        SET AMHC=AMHC+1

           SET ^TMP($JOB,"AMHBUL",AMHC)="from Link type 3 to Link type 5.  This is under the"

 +7        SET AMHC=AMHC+1

           SET ^TMP($JOB,"AMHBUL",AMHC)="list of users who have a PCC Link exception entered"

 +8        SET AMHC=AMHC+1

           SET ^TMP($JOB,"AMHBUL",AMHC)="in the Site Parameter file."

 +9        SET AMHC=AMHC+1

           SET ^TMP($JOB,"AMHBUL",AMHC)=AMHNMM

 +10       QUIT

GETREC3   ;

 +1       ;* * * Define key below to identify recipients * * *

 +2       ;

 +3        SET CTR=0

           SET AMHKEY="AMHZMGR"

 +4        FOR

               SET CTR=$ORDER(^XUSEC(AMHKEY,CTR))

               IF 'CTR

                   QUIT

               SET Y=CTR

               SET XMY(Y)=""

 +5        QUIT

NEW       ;add new codes

 +1       ;

 +2       ;add new codes if they don't exist

 +3        SET AMHTEXT="ICDNEW"

           FOR AMHX=1:1

               SET AMHTX=$PIECE($TEXT(@AMHTEXT+AMHX),";;",2,4)

               IF AMHTX=""

                   QUIT

               Begin DoDot:1

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

                   SET C=$PIECE(AMHTX,";;",2)

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

 +6                IF AMHPC=""

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

 +7                SET AMHINA=$PIECE(AMHTX,";;",3)

 +8                SET DA=$ORDER(^AMHPROB("B",X,0))

                   IF DA

                       QUIT

 +9                SET DIC="^AMHPROB("

                   SET DLAYGO=9001012.2

                   SET DIADD=1

                   SET DIC="^AMHPROB("

 +10               SET DIC(0)="L"

 +11               KILL DD,D0,DO

                   DO FILE^DICN

                   KILL DIADD,DLAYGO,DD,DIC,D0,DO

 +12               IF Y=-1

                       DO MES^XPDUTL("Code "_AMHCODE_" could not be added.")

                       QUIT

 +13               SET DA=+Y

NEWE      ;

 +1                SET DIE="^AMHPROB("

 +2                SET DR=".02////"_AMHINA_";.03////"_AMHPC_";.05////"_AMHCODE

 +3                DO ^DIE

                   KILL DIE,DA,DR

 +4                IF $DATA(Y)

                       DO MES^XPDUTL("Error updating code "_AMHCODE_".")

                       QUIT

               End DoDot:1

 +5        QUIT

ICDNEW    ;;

 +1       ;;315.35;;31;;CHILDHOOD ONSET FLUENCY DISORDER

 +2       ;;V11.4;;38;;PERSONAL HISTORY OF COMBAT AND OPERATIONAL STRESS REACTION

 +3       ;;V62.85;;38;;HOMICIDAL IDEATION

 +4       ;;

AMH40P1.m