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))
Q
;
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
Q
;
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
Q
BMXPO ;-- update the RPC file
D GUIEP^BMXPO(.RETVAL,"AMHGRPC|AMH")
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
;
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
Q
;
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
Q
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)=""
Q
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
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 ;;
