AMH40P2 ; 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;**2**;JUN 18, 2010;Build 23
;
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*1") D SORRY(2)
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(^AMHTPCAD(DA)) Q:DA'=+DA S DIK="^AMHTPCAD(" D ^DIK
K DA,DIK
Q
;
POST ;EP
;add three new codes
D NEW
D EDITDSM
D ICDUP
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
ICDUP ;
;INACTIVATE 2 CODES
S DA=$O(^AMHPROB("B","310.8",0))
I DA S DIE="^AMHPROB(",DR=".13///1;.14////3111001" D ^DIE K DIE,DA,DR
S DA=$O(^AMHPROB("B","V40.3",0))
I DA S DIE="^AMHPROB(",DR=".13///1;.14////3111001" D ^DIE K DIE,DA,DR
S AMHX=0 F S AMHX=$O(^AMHPROB("B","290.0",AMHX)) Q:AMHX'=+AMHX D
.I $P(^AMHPROB(AMHX,0),U,2)'="DEMENTIA OF THE ALZHEIMER'S TYPE W/LATE ONSET, UNCOMPLICATED" Q
.Q:$P(^AMHPROB(AMHX,0),U,14)]""
.S DA=AMHX,DIE="^AMHPROB(",DR=".13////1;.14////3111001" D ^DIE K DA,DIE,DR
S AMHX=0 F S AMHX=$O(^AMHPROB("B","294.1",AMHX)) Q:AMHX'=+AMHX D
.I $P(^AMHPROB(AMHX,0),U,2)'="DEMENTIA DUE TO..(INDICATE MEDICAL CONDITION)" Q
.Q:$P(^AMHPROB(AMHX,0),U,14)]""
.S DA=AMHX,DIE="^AMHPROB(",DR=".13////1;.14////3111001" D ^DIE K DA,DIE,DR
S AMHX=0 F S AMHX=$O(^AMHPROB("B","780.93",AMHX)) Q:AMHX'=+AMHX D
.I $P(^AMHPROB(AMHX,0),U,2)'="AGE-RELATED COGNITIVE DECLINE" Q
.Q:$P(^AMHPROB(AMHX,0),U,14)]""
.S DA=AMHX,DIE="^AMHPROB(",DR=".13////1;.14////3111001" D ^DIE K DA,DIE,DR
S AMHX=0 F S AMHX=$O(^AMHPROB("B","V18.4",AMHX)) Q:AMHX'=+AMHX D
.I $P(^AMHPROB(AMHX,0),U,2)'="FAMILY HISTORY OF MENTAL RETARDATION" Q
.Q:$P(^AMHPROB(AMHX,0),U,14)]""
.S DA=AMHX,DIE="^AMHPROB(",DR=".13////1;.14////3111001" D ^DIE K DA,DIE,DR
S AMHX=0 F S AMHX=$O(^AMHPROB("B","V79.2",AMHX)) Q:AMHX'=+AMHX D
.I $P(^AMHPROB(AMHX,0),U,2)'="SPECIAL SCREENING FOR MENTAL RETARDATION" Q
.Q:$P(^AMHPROB(AMHX,0),U,14)]""
.S DA=AMHX,DIE="^AMHPROB(",DR=".13////1;.14////3111001" D ^DIE K DA,DIE,DR
;
;ADD NEW CODES
D NEWICD
Q
;
EDITDSM ;
S DA=$O(^AMHPROB("B","V71.09",0))
I DA S DIE="^AMHPROB(",DR=".02///NO DIAGNOSIS ON AXIS I OR NO DIAGNOSIS ON AXIS II" D ^DIE K DIE,DA,DR
S G=0,DA="" F S G=$O(^AMHPROB("B","304.10",G)) Q:G'=+G D
.I $P(^AMHPROB(G,0),U,2)="SEDATIVE, HYPNOTIC, OR ANXIOLYTIC DEPENDENCE, UNSPECIFIED" D
..S DA=G,DIE="^AMHPROB(",DR=".02///SEDATIVE, HYPNOTIC OR ANXIOLYTIC DEPENDENCE, UNSPECIFIED" D ^DIE
S G=0,DA="" F S G=$O(^AMHPROB("B","304.11",G)) Q:G'=+G D
.I $P(^AMHPROB(G,0),U,2)="SEDATIVE, HYPNOTIC, OR ANXIOLYTIC DEPENDENCE, CONTINUOUS" D
..S DA=G,DIE="^AMHPROB(",DR=".02///SEDATIVE, HYPNOTIC OR ANXIOLYTIC DEPENDENCE, CONTINUOUS" D ^DIE
S G=0,DA="" F S G=$O(^AMHPROB("B","304.12",G)) Q:G'=+G D
.I $P(^AMHPROB(G,0),U,2)="SEDATIVE, HYPNOTIC, OR ANXIOLYTIC DEPENDENCE, EPISODIC" D
..S DA=G,DIE="^AMHPROB(",DR=".02///SEDATIVE, HYPNOTIC OR ANXIOLYTIC DEPENDENCE, EPISODIC" D ^DIE
S G=0,DA="" F S G=$O(^AMHPROB("B","304.13",G)) Q:G'=+G D
.I $P(^AMHPROB(G,0),U,2)="SEDATIVE, HYPNOTIC, OR ANXIOLYTIC DEPENDENCE, IN REMISSION" D
..S DA=G,DIE="^AMHPROB(",DR=".02///SEDATIVE, HYPNOTIC OR ANXIOLYTIC DEPENDENCE, IN REMISSION" D ^DIE
S G=0,DA="" F S G=$O(^AMHPROB("B","304.50",G)) Q:G'=+G D
.I $P(^AMHPROB(G,0),U,2)="HALLUCINOGEN DEPENDENCE. UNSPECIFIED" D
..S DA=G,DIE="^AMHPROB(",DR=".02///HALLUCINOGEN DEPENDENCE, UNSPECIFIED" D ^DIE
S G=0,DA="" F S G=$O(^AMHPROB("B","304.61",G)) Q:G'=+G D
.I $P(^AMHPROB(G,0),U,15)=1 D
..S DA=G,DIE="^AMHPROB(",DR=".15///@" D ^DIE
S G=0,DA="" F S G=$O(^AMHPROB("B","304.62",G)) Q:G'=+G D
.I $P(^AMHPROB(G,0),U,15)=1 D
..S DA=G,DIE="^AMHPROB(",DR=".15///@" D ^DIE
S G=0,DA="" F S G=$O(^AMHPROB("B","304.63",G)) Q:G'=+G D
.I $P(^AMHPROB(G,0),U,15)=1 D
..S DA=G,DIE="^AMHPROB(",DR=".15///@" D ^DIE
S G=0,DA="" F S G=$O(^AMHPROB("B","304.80",G)) Q:G'=+G D
.I $P(^AMHPROB(G,0),U,2)="POLYSUBSTANCE DEPENDENCE, UNSPECIFIED" D
..S DA=G,DIE="^AMHPROB(",DR=".13///1;.14///"_DT_";.15///@" D ^DIE
S G=0,DA="" F S G=$O(^AMHPROB("B","291.5",G)) Q:G'=+G D
.I $P(^AMHPROB(G,0),U,2)="ALCOHOL-INDUCED PSYCHOTIC DISORDER, W/DELUSIONS" D
..S DA=G,DIE="^AMHPROB(",DR=".02///ALCOHOL-INDUCED PSYCHOTIC DISORDER, WITH DELUSIONS" D ^DIE
S G=0,DA="" F S G=$O(^AMHPROB("B","291.3",G)) Q:G'=+G D
.I $P(^AMHPROB(G,0),U,2)="ALCOHOL-INDUCED PSYCHOTIC DISORDER, W/HALLUCINATIONS" D
..S DA=G,DIE="^AMHPROB(",DR=".02///ALCOHOL-INDUCED PSYCHOTIC DISORDER, WITH HALLUCINATIONS" D ^DIE
S G=0,DA="" F S G=$O(^AMHPROB("B","305.02",G)) Q:G'=+G D
.I $P(^AMHPROB(G,0),U,2)="ALCOHOL ABUSE, EPISODIC," D
..S DA=G,DIE="^AMHPROB(",DR=".02///ALCOHOL ABUSE, EPISODIC" D ^DIE
S G=0,DA="" F S G=$O(^AMHPROB("B","304.60",G)) Q:G'=+G D
.I $P(^AMHPROB(G,0),U,15)=1 D
..S DA=G,DIE="^AMHPROB(",DR=".15///@" D ^DIE
K DA,DIE,DR
S AMHX=0 F S AMHX=$O(^AMHTPCAD(AMHX)) Q:AMHX'=+AMHX D
.S AMH0=^AMHTPCAD(AMHX,0)
.S AMHCODE=$P(AMH0,U,1)
.S AMHNARR=$P(AMH0,U,2)
.S AMHPCODE=$P(AMH0,U,3) S AMHPCODE=$O(^AMHPROBC("B",AMHPCODE,0))
.S AMHICD=$P(AMH0,U,5)
.S AMHAXIS=$P(AMH0,U,6)
.S AMHINA=$P(AMH0,U,13)
.S AMHEHR=$P(AMH0,U,15)
.;lookup up code, if exist do edit, if not, do add
.S G=0,AMHDSM="" F S G=$O(^AMHPROB("B",AMHCODE,G)) Q:G'=+G!(AMHDSM) D
..I $P(^AMHPROB(G,0),U,2)=AMHNARR S AMHDSM=G
.I AMHDSM D EDIT Q
.;add code and edit
.K D0,DO
.S DIC="^AMHPROB(",DIADD=1,DLAYGO=9002012.2,DIC(0)="L",X=AMHCODE D FILE^DICN
.I Y=-1 D MES^XPDUTL("Failure to add code "_AMHCODE_" "_AMHNARR) Q
.K DIADD,DLAYGO,DIC
.S AMHDSM=+Y
.D EDIT
Q
EDIT ;
S DA=AMHDSM,DIE="^AMHPROB("
S DR=".02///"_AMHNARR_";.03////"_AMHPCODE_";.05///"_AMHICD_";.06///I;.15///"_AMHEHR
D ^DIE
I $D(Y) D MES^XPDUTL("Failure to update code "_AMHCODE_" "_AMHNARR)
K DA,DIE,DR
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
;
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
;
NEW ;add new codes
;
;add new codes if they don't exist
S AMH1II="",AMH1I=""
S AMH1X=0 F S AMH1X=$O(^AMHPROB("B","V71.09",AMH1X)) Q:AMH1X'=+AMH1X D
.I $P(^AMHPROB(AMH1X,0),U,2)="NO DIAGNOSIS ON AXIS II" S AMH1II=1
.I $P(^AMHPROB(AMH1X,0),U,2)="NO DIAGNOSIS ON AXIS I" S AMH1I=1
I 'AMH1II D
.S X="V71.09",DIC("DR")=".02///NO DIAGNOSIS ON AXIS II;.03///38;.05///V71.09"
.S DIC="^AMHPROB(",DLAYGO=9001012.2,DIADD=1
.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
.Q
I 'AMH1I D
.S X="V71.09",DIC("DR")=".02///NO DIAGNOSIS ON AXIS I;.03///38;.05///V71.09"
.S DIC="^AMHPROB(",DLAYGO=9001012.2,DIADD=1
.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
.Q
S AMH1X=0 F S AMH1X=$O(^AMHPROB("B","V71.09",AMH1X)) Q:AMH1X'=+AMH1X D
.Q:$P(^AMHPROB(AMH1X,0),U,2)'="OBSERVATION OF OTHER SUSPECTED MENTAL CONDITION"
.S DA=AMH1X,DIE="^AMHPROB(",DR=".15///1" D ^DIE K DA,DR,DIE
Q
NEWICD ;add new codes
;
;add new codes if they don't exist
S AMHTEXT="ICDNEW" F AMHY=1:1 S AMHTX=$P($T(@AMHTEXT+AMHY),";;",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 (G,AMHX)=0 F S AMHX=$O(^AMHPROB("B",AMHCODE,AMHX)) Q:AMHX'=+AMHX D
..;CHECK NARRATIVE
..I $P(^AMHPROB(AMHX,0),U,2)=AMHINA S G=1
..Q
.Q:G ;already have this code
.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_";.16////3111001"
.D ^DIE K DIE,DA,DR
.I $D(Y) D MES^XPDUTL("Error updating code "_AMHCODE_".") Q
Q
ICDNEW ;;
;;290.0;;9.2;;SENILE DEMENTIA UNCOMP;;290.0
;;294.20;;12;;DEMEN NOS W/O BEHV DSTRB;;294.20
;;294.21;;12;;DEMEN NOS W BEHAV DISTRB;;294.21
;;310.2;;12;;POSTCONCUSSION SYNDROME;;310.2
;;310.81;;12;;PSEUDOBULBAR AFFECT;;310.81
;;310.89;;12;;NONPSYCH MNTL DISORD NEC;;310.89
;;780.93;;9;;MEMORY LOSS;;780.93
;;V18.4;;35;;FM FX-INTELLECT DISBLTY;;V18.4
;;V40.39;;38;;OTH SPC BEHAVIOR PROBLEM;;V40.39
;;V79.2;;35;;SCRN INTELLECT DISABILTY;;V79.2
;;
;;
AMH40P2 ; 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;**2**;JUN 18, 2010;Build 23
+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*1")
DO SORRY(2)
+9 QUIT
+10 ;
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(^AMHTPCAD(DA))
IF DA'=+DA
QUIT
SET DIK="^AMHTPCAD("
DO ^DIK
+3 KILL DA,DIK
+4 QUIT
+5 ;
POST ;EP
+1 ;add three new codes
+2 DO NEW
+3 DO EDITDSM
+4 DO ICDUP
+5 DO 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
ICDUP ;
+1 ;INACTIVATE 2 CODES
+2 SET DA=$ORDER(^AMHPROB("B","310.8",0))
+3 IF DA
SET DIE="^AMHPROB("
SET DR=".13///1;.14////3111001"
DO ^DIE
KILL DIE,DA,DR
+4 SET DA=$ORDER(^AMHPROB("B","V40.3",0))
+5 IF DA
SET DIE="^AMHPROB("
SET DR=".13///1;.14////3111001"
DO ^DIE
KILL DIE,DA,DR
+6 SET AMHX=0
FOR
SET AMHX=$ORDER(^AMHPROB("B","290.0",AMHX))
IF AMHX'=+AMHX
QUIT
Begin DoDot:1
+7 IF $PIECE(^AMHPROB(AMHX,0),U,2)'="DEMENTIA OF THE ALZHEIMER'S TYPE W/LATE ONSET, UNCOMPLICATED"
QUIT
+8 IF $PIECE(^AMHPROB(AMHX,0),U,14)]""
QUIT
+9 SET DA=AMHX
SET DIE="^AMHPROB("
SET DR=".13////1;.14////3111001"
DO ^DIE
KILL DA,DIE,DR
End DoDot:1
+10 SET AMHX=0
FOR
SET AMHX=$ORDER(^AMHPROB("B","294.1",AMHX))
IF AMHX'=+AMHX
QUIT
Begin DoDot:1
+11 IF $PIECE(^AMHPROB(AMHX,0),U,2)'="DEMENTIA DUE TO..(INDICATE MEDICAL CONDITION)"
QUIT
+12 IF $PIECE(^AMHPROB(AMHX,0),U,14)]""
QUIT
+13 SET DA=AMHX
SET DIE="^AMHPROB("
SET DR=".13////1;.14////3111001"
DO ^DIE
KILL DA,DIE,DR
End DoDot:1
+14 SET AMHX=0
FOR
SET AMHX=$ORDER(^AMHPROB("B","780.93",AMHX))
IF AMHX'=+AMHX
QUIT
Begin DoDot:1
+15 IF $PIECE(^AMHPROB(AMHX,0),U,2)'="AGE-RELATED COGNITIVE DECLINE"
QUIT
+16 IF $PIECE(^AMHPROB(AMHX,0),U,14)]""
QUIT
+17 SET DA=AMHX
SET DIE="^AMHPROB("
SET DR=".13////1;.14////3111001"
DO ^DIE
KILL DA,DIE,DR
End DoDot:1
+18 SET AMHX=0
FOR
SET AMHX=$ORDER(^AMHPROB("B","V18.4",AMHX))
IF AMHX'=+AMHX
QUIT
Begin DoDot:1
+19 IF $PIECE(^AMHPROB(AMHX,0),U,2)'="FAMILY HISTORY OF MENTAL RETARDATION"
QUIT
+20 IF $PIECE(^AMHPROB(AMHX,0),U,14)]""
QUIT
+21 SET DA=AMHX
SET DIE="^AMHPROB("
SET DR=".13////1;.14////3111001"
DO ^DIE
KILL DA,DIE,DR
End DoDot:1
+22 SET AMHX=0
FOR
SET AMHX=$ORDER(^AMHPROB("B","V79.2",AMHX))
IF AMHX'=+AMHX
QUIT
Begin DoDot:1
+23 IF $PIECE(^AMHPROB(AMHX,0),U,2)'="SPECIAL SCREENING FOR MENTAL RETARDATION"
QUIT
+24 IF $PIECE(^AMHPROB(AMHX,0),U,14)]""
QUIT
+25 SET DA=AMHX
SET DIE="^AMHPROB("
SET DR=".13////1;.14////3111001"
DO ^DIE
KILL DA,DIE,DR
End DoDot:1
+26 ;
+27 ;ADD NEW CODES
+28 DO NEWICD
+29 QUIT
+30 ;
EDITDSM ;
+1 SET DA=$ORDER(^AMHPROB("B","V71.09",0))
+2 IF DA
SET DIE="^AMHPROB("
SET DR=".02///NO DIAGNOSIS ON AXIS I OR NO DIAGNOSIS ON AXIS II"
DO ^DIE
KILL DIE,DA,DR
+3 SET G=0
SET DA=""
FOR
SET G=$ORDER(^AMHPROB("B","304.10",G))
IF G'=+G
QUIT
Begin DoDot:1
+4 IF $PIECE(^AMHPROB(G,0),U,2)="SEDATIVE, HYPNOTIC, OR ANXIOLYTIC DEPENDENCE, UNSPECIFIED"
Begin DoDot:2
+5 SET DA=G
SET DIE="^AMHPROB("
SET DR=".02///SEDATIVE, HYPNOTIC OR ANXIOLYTIC DEPENDENCE, UNSPECIFIED"
DO ^DIE
End DoDot:2
End DoDot:1
+6 SET G=0
SET DA=""
FOR
SET G=$ORDER(^AMHPROB("B","304.11",G))
IF G'=+G
QUIT
Begin DoDot:1
+7 IF $PIECE(^AMHPROB(G,0),U,2)="SEDATIVE, HYPNOTIC, OR ANXIOLYTIC DEPENDENCE, CONTINUOUS"
Begin DoDot:2
+8 SET DA=G
SET DIE="^AMHPROB("
SET DR=".02///SEDATIVE, HYPNOTIC OR ANXIOLYTIC DEPENDENCE, CONTINUOUS"
DO ^DIE
End DoDot:2
End DoDot:1
+9 SET G=0
SET DA=""
FOR
SET G=$ORDER(^AMHPROB("B","304.12",G))
IF G'=+G
QUIT
Begin DoDot:1
+10 IF $PIECE(^AMHPROB(G,0),U,2)="SEDATIVE, HYPNOTIC, OR ANXIOLYTIC DEPENDENCE, EPISODIC"
Begin DoDot:2
+11 SET DA=G
SET DIE="^AMHPROB("
SET DR=".02///SEDATIVE, HYPNOTIC OR ANXIOLYTIC DEPENDENCE, EPISODIC"
DO ^DIE
End DoDot:2
End DoDot:1
+12 SET G=0
SET DA=""
FOR
SET G=$ORDER(^AMHPROB("B","304.13",G))
IF G'=+G
QUIT
Begin DoDot:1
+13 IF $PIECE(^AMHPROB(G,0),U,2)="SEDATIVE, HYPNOTIC, OR ANXIOLYTIC DEPENDENCE, IN REMISSION"
Begin DoDot:2
+14 SET DA=G
SET DIE="^AMHPROB("
SET DR=".02///SEDATIVE, HYPNOTIC OR ANXIOLYTIC DEPENDENCE, IN REMISSION"
DO ^DIE
End DoDot:2
End DoDot:1
+15 SET G=0
SET DA=""
FOR
SET G=$ORDER(^AMHPROB("B","304.50",G))
IF G'=+G
QUIT
Begin DoDot:1
+16 IF $PIECE(^AMHPROB(G,0),U,2)="HALLUCINOGEN DEPENDENCE. UNSPECIFIED"
Begin DoDot:2
+17 SET DA=G
SET DIE="^AMHPROB("
SET DR=".02///HALLUCINOGEN DEPENDENCE, UNSPECIFIED"
DO ^DIE
End DoDot:2
End DoDot:1
+18 SET G=0
SET DA=""
FOR
SET G=$ORDER(^AMHPROB("B","304.61",G))
IF G'=+G
QUIT
Begin DoDot:1
+19 IF $PIECE(^AMHPROB(G,0),U,15)=1
Begin DoDot:2
+20 SET DA=G
SET DIE="^AMHPROB("
SET DR=".15///@"
DO ^DIE
End DoDot:2
End DoDot:1
+21 SET G=0
SET DA=""
FOR
SET G=$ORDER(^AMHPROB("B","304.62",G))
IF G'=+G
QUIT
Begin DoDot:1
+22 IF $PIECE(^AMHPROB(G,0),U,15)=1
Begin DoDot:2
+23 SET DA=G
SET DIE="^AMHPROB("
SET DR=".15///@"
DO ^DIE
End DoDot:2
End DoDot:1
+24 SET G=0
SET DA=""
FOR
SET G=$ORDER(^AMHPROB("B","304.63",G))
IF G'=+G
QUIT
Begin DoDot:1
+25 IF $PIECE(^AMHPROB(G,0),U,15)=1
Begin DoDot:2
+26 SET DA=G
SET DIE="^AMHPROB("
SET DR=".15///@"
DO ^DIE
End DoDot:2
End DoDot:1
+27 SET G=0
SET DA=""
FOR
SET G=$ORDER(^AMHPROB("B","304.80",G))
IF G'=+G
QUIT
Begin DoDot:1
+28 IF $PIECE(^AMHPROB(G,0),U,2)="POLYSUBSTANCE DEPENDENCE, UNSPECIFIED"
Begin DoDot:2
+29 SET DA=G
SET DIE="^AMHPROB("
SET DR=".13///1;.14///"_DT_";.15///@"
DO ^DIE
End DoDot:2
End DoDot:1
+30 SET G=0
SET DA=""
FOR
SET G=$ORDER(^AMHPROB("B","291.5",G))
IF G'=+G
QUIT
Begin DoDot:1
+31 IF $PIECE(^AMHPROB(G,0),U,2)="ALCOHOL-INDUCED PSYCHOTIC DISORDER, W/DELUSIONS"
Begin DoDot:2
+32 SET DA=G
SET DIE="^AMHPROB("
SET DR=".02///ALCOHOL-INDUCED PSYCHOTIC DISORDER, WITH DELUSIONS"
DO ^DIE
End DoDot:2
End DoDot:1
+33 SET G=0
SET DA=""
FOR
SET G=$ORDER(^AMHPROB("B","291.3",G))
IF G'=+G
QUIT
Begin DoDot:1
+34 IF $PIECE(^AMHPROB(G,0),U,2)="ALCOHOL-INDUCED PSYCHOTIC DISORDER, W/HALLUCINATIONS"
Begin DoDot:2
+35 SET DA=G
SET DIE="^AMHPROB("
SET DR=".02///ALCOHOL-INDUCED PSYCHOTIC DISORDER, WITH HALLUCINATIONS"
DO ^DIE
End DoDot:2
End DoDot:1
+36 SET G=0
SET DA=""
FOR
SET G=$ORDER(^AMHPROB("B","305.02",G))
IF G'=+G
QUIT
Begin DoDot:1
+37 IF $PIECE(^AMHPROB(G,0),U,2)="ALCOHOL ABUSE, EPISODIC,"
Begin DoDot:2
+38 SET DA=G
SET DIE="^AMHPROB("
SET DR=".02///ALCOHOL ABUSE, EPISODIC"
DO ^DIE
End DoDot:2
End DoDot:1
+39 SET G=0
SET DA=""
FOR
SET G=$ORDER(^AMHPROB("B","304.60",G))
IF G'=+G
QUIT
Begin DoDot:1
+40 IF $PIECE(^AMHPROB(G,0),U,15)=1
Begin DoDot:2
+41 SET DA=G
SET DIE="^AMHPROB("
SET DR=".15///@"
DO ^DIE
End DoDot:2
End DoDot:1
+42 KILL DA,DIE,DR
+43 SET AMHX=0
FOR
SET AMHX=$ORDER(^AMHTPCAD(AMHX))
IF AMHX'=+AMHX
QUIT
Begin DoDot:1
+44 SET AMH0=^AMHTPCAD(AMHX,0)
+45 SET AMHCODE=$PIECE(AMH0,U,1)
+46 SET AMHNARR=$PIECE(AMH0,U,2)
+47 SET AMHPCODE=$PIECE(AMH0,U,3)
SET AMHPCODE=$ORDER(^AMHPROBC("B",AMHPCODE,0))
+48 SET AMHICD=$PIECE(AMH0,U,5)
+49 SET AMHAXIS=$PIECE(AMH0,U,6)
+50 SET AMHINA=$PIECE(AMH0,U,13)
+51 SET AMHEHR=$PIECE(AMH0,U,15)
+52 ;lookup up code, if exist do edit, if not, do add
+53 SET G=0
SET AMHDSM=""
FOR
SET G=$ORDER(^AMHPROB("B",AMHCODE,G))
IF G'=+G!(AMHDSM)
QUIT
Begin DoDot:2
+54 IF $PIECE(^AMHPROB(G,0),U,2)=AMHNARR
SET AMHDSM=G
End DoDot:2
+55 IF AMHDSM
DO EDIT
QUIT
+56 ;add code and edit
+57 KILL D0,DO
+58 SET DIC="^AMHPROB("
SET DIADD=1
SET DLAYGO=9002012.2
SET DIC(0)="L"
SET X=AMHCODE
DO FILE^DICN
+59 IF Y=-1
DO MES^XPDUTL("Failure to add code "_AMHCODE_" "_AMHNARR)
QUIT
+60 KILL DIADD,DLAYGO,DIC
+61 SET AMHDSM=+Y
+62 DO EDIT
End DoDot:1
+63 QUIT
EDIT ;
+1 SET DA=AMHDSM
SET DIE="^AMHPROB("
+2 SET DR=".02///"_AMHNARR_";.03////"_AMHPCODE_";.05///"_AMHICD_";.06///I;.15///"_AMHEHR
+3 DO ^DIE
+4 IF $DATA(Y)
DO MES^XPDUTL("Failure to update code "_AMHCODE_" "_AMHNARR)
+5 KILL DA,DIE,DR
+6 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
+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
+6 ;
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
+9 ;
NEW ;add new codes
+1 ;
+2 ;add new codes if they don't exist
+3 SET AMH1II=""
SET AMH1I=""
+4 SET AMH1X=0
FOR
SET AMH1X=$ORDER(^AMHPROB("B","V71.09",AMH1X))
IF AMH1X'=+AMH1X
QUIT
Begin DoDot:1
+5 IF $PIECE(^AMHPROB(AMH1X,0),U,2)="NO DIAGNOSIS ON AXIS II"
SET AMH1II=1
+6 IF $PIECE(^AMHPROB(AMH1X,0),U,2)="NO DIAGNOSIS ON AXIS I"
SET AMH1I=1
End DoDot:1
+7 IF 'AMH1II
Begin DoDot:1
+8 SET X="V71.09"
SET DIC("DR")=".02///NO DIAGNOSIS ON AXIS II;.03///38;.05///V71.09"
+9 SET DIC="^AMHPROB("
SET DLAYGO=9001012.2
SET DIADD=1
+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 QUIT
End DoDot:1
+14 IF 'AMH1I
Begin DoDot:1
+15 SET X="V71.09"
SET DIC("DR")=".02///NO DIAGNOSIS ON AXIS I;.03///38;.05///V71.09"
+16 SET DIC="^AMHPROB("
SET DLAYGO=9001012.2
SET DIADD=1
+17 SET DIC(0)="L"
+18 KILL DD,D0,DO
DO FILE^DICN
KILL DIADD,DLAYGO,DD,DIC,D0,DO
+19 IF Y=-1
DO MES^XPDUTL("Code "_AMHCODE_" could not be added.")
QUIT
+20 QUIT
End DoDot:1
+21 SET AMH1X=0
FOR
SET AMH1X=$ORDER(^AMHPROB("B","V71.09",AMH1X))
IF AMH1X'=+AMH1X
QUIT
Begin DoDot:1
+22 IF $PIECE(^AMHPROB(AMH1X,0),U,2)'="OBSERVATION OF OTHER SUSPECTED MENTAL CONDITION"
QUIT
+23 SET DA=AMH1X
SET DIE="^AMHPROB("
SET DR=".15///1"
DO ^DIE
KILL DA,DR,DIE
End DoDot:1
+24 QUIT
NEWICD ;add new codes
+1 ;
+2 ;add new codes if they don't exist
+3 SET AMHTEXT="ICDNEW"
FOR AMHY=1:1
SET AMHTX=$PIECE($TEXT(@AMHTEXT+AMHY),";;",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 (G,AMHX)=0
FOR
SET AMHX=$ORDER(^AMHPROB("B",AMHCODE,AMHX))
IF AMHX'=+AMHX
QUIT
Begin DoDot:2
+9 ;CHECK NARRATIVE
+10 IF $PIECE(^AMHPROB(AMHX,0),U,2)=AMHINA
SET G=1
+11 QUIT
End DoDot:2
+12 ;already have this code
IF G
QUIT
+13 SET DIC="^AMHPROB("
SET DLAYGO=9001012.2
SET DIADD=1
SET DIC="^AMHPROB("
+14 SET DIC(0)="L"
+15 KILL DD,D0,DO
DO FILE^DICN
KILL DIADD,DLAYGO,DD,DIC,D0,DO
+16 IF Y=-1
DO MES^XPDUTL("Code "_AMHCODE_" could not be added.")
QUIT
+17 SET DA=+Y
NEWE ;
+1 SET DIE="^AMHPROB("
+2 SET DR=".02////"_AMHINA_";.03////"_AMHPC_";.05////"_AMHCODE_";.16////3111001"
+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 ;;290.0;;9.2;;SENILE DEMENTIA UNCOMP;;290.0
+2 ;;294.20;;12;;DEMEN NOS W/O BEHV DSTRB;;294.20
+3 ;;294.21;;12;;DEMEN NOS W BEHAV DISTRB;;294.21
+4 ;;310.2;;12;;POSTCONCUSSION SYNDROME;;310.2
+5 ;;310.81;;12;;PSEUDOBULBAR AFFECT;;310.81
+6 ;;310.89;;12;;NONPSYCH MNTL DISORD NEC;;310.89
+7 ;;780.93;;9;;MEMORY LOSS;;780.93
+8 ;;V18.4;;35;;FM FX-INTELLECT DISBLTY;;V18.4
+9 ;;V40.39;;38;;OTH SPC BEHAVIOR PROBLEM;;V40.39
+10 ;;V79.2;;35;;SCRN INTELLECT DISABILTY;;V79.2
+11 ;;
+12 ;;
