Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: AMH40P2

AMH40P2.m

Go to the documentation of this file. 
  1. 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
  1.  ;
  1. ENV ;EP 
  1.  F X="XPO1","XPZ1","XPZ2","XPI1" S XPDDIQ(X)=0
  1.  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
  1.  E  D MES^XPDUTL($$CJ^XLFSTR("Requires Kernel Version 8.0....Present.",80))
  1.  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
  1.  E  D MES^XPDUTL($$CJ^XLFSTR("Requires Fileman v22....Present.",80))
  1.  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
  1.  E  D MES^XPDUTL($$CJ^XLFSTR("Requires AMH v4.0....Present.",80))
  1.  I '$$INSTALLD("AMH*4.0*1") D SORRY(2)
  1.  Q
  1.  ;
  1. PRE ;
  1.  S DA=0 F  S DA=$O(^AMHSORT(DA)) Q:DA'=+DA  S DIK="^AMHSORT(" D ^DIK
  1.  S DA=0 F  S DA=$O(^AMHTPCAD(DA)) Q:DA'=+DA  S DIK="^AMHTPCAD(" D ^DIK
  1.  K DA,DIK
  1.  Q
  1.  ;
  1. POST ;EP
  1.  ;add three new codes
  1.  D NEW
  1.  D EDITDSM
  1.  D ICDUP
  1.  D BMXPO
  1.  Q
  1. BMXPO ;-- update the RPC file
  1.  N AMHRPC
  1.  S AMHRPC=$O(^DIC(19,"B","AMHGRPC",0))
  1.  Q:'AMHRPC
  1.  D CLEAN(AMHRPC)
  1.  D GUIEP^BMXPO(.RETVAL,AMHRPC_"|AMH")
  1.  Q
  1. ICDUP ;
  1.  ;INACTIVATE 2 CODES
  1.  S DA=$O(^AMHPROB("B","310.8",0))
  1.  I DA S DIE="^AMHPROB(",DR=".13///1;.14////3111001" D ^DIE K DIE,DA,DR
  1.  S DA=$O(^AMHPROB("B","V40.3",0))
  1.  I DA S DIE="^AMHPROB(",DR=".13///1;.14////3111001" D ^DIE K DIE,DA,DR
  1.  S AMHX=0 F  S AMHX=$O(^AMHPROB("B","290.0",AMHX)) Q:AMHX'=+AMHX  D
  1.  .I $P(^AMHPROB(AMHX,0),U,2)'="DEMENTIA OF THE ALZHEIMER'S TYPE W/LATE ONSET, UNCOMPLICATED" Q
  1.  .Q:$P(^AMHPROB(AMHX,0),U,14)]""
  1.  .S DA=AMHX,DIE="^AMHPROB(",DR=".13////1;.14////3111001" D ^DIE K DA,DIE,DR
  1.  S AMHX=0 F  S AMHX=$O(^AMHPROB("B","294.1",AMHX)) Q:AMHX'=+AMHX  D
  1.  .I $P(^AMHPROB(AMHX,0),U,2)'="DEMENTIA DUE TO..(INDICATE MEDICAL CONDITION)" Q
  1.  .Q:$P(^AMHPROB(AMHX,0),U,14)]""
  1.  .S DA=AMHX,DIE="^AMHPROB(",DR=".13////1;.14////3111001" D ^DIE K DA,DIE,DR
  1.  S AMHX=0 F  S AMHX=$O(^AMHPROB("B","780.93",AMHX)) Q:AMHX'=+AMHX  D
  1.  .I $P(^AMHPROB(AMHX,0),U,2)'="AGE-RELATED COGNITIVE DECLINE" Q
  1.  .Q:$P(^AMHPROB(AMHX,0),U,14)]""
  1.  .S DA=AMHX,DIE="^AMHPROB(",DR=".13////1;.14////3111001" D ^DIE K DA,DIE,DR
  1.  S AMHX=0 F  S AMHX=$O(^AMHPROB("B","V18.4",AMHX)) Q:AMHX'=+AMHX  D
  1.  .I $P(^AMHPROB(AMHX,0),U,2)'="FAMILY HISTORY OF MENTAL RETARDATION" Q
  1.  .Q:$P(^AMHPROB(AMHX,0),U,14)]""
  1.  .S DA=AMHX,DIE="^AMHPROB(",DR=".13////1;.14////3111001" D ^DIE K DA,DIE,DR
  1.  S AMHX=0 F  S AMHX=$O(^AMHPROB("B","V79.2",AMHX)) Q:AMHX'=+AMHX  D
  1.  .I $P(^AMHPROB(AMHX,0),U,2)'="SPECIAL SCREENING FOR MENTAL RETARDATION" Q
  1.  .Q:$P(^AMHPROB(AMHX,0),U,14)]""
  1.  .S DA=AMHX,DIE="^AMHPROB(",DR=".13////1;.14////3111001" D ^DIE K DA,DIE,DR
  1.  ;
  1.  ;ADD NEW CODES
  1.  D NEWICD
  1.  Q
  1.  ;
  1. EDITDSM ;
  1.  S DA=$O(^AMHPROB("B","V71.09",0))
  1.  I DA S DIE="^AMHPROB(",DR=".02///NO DIAGNOSIS ON AXIS I OR NO DIAGNOSIS ON AXIS II" D ^DIE K DIE,DA,DR
  1.  S G=0,DA="" F  S G=$O(^AMHPROB("B","304.10",G)) Q:G'=+G  D
  1.  .I $P(^AMHPROB(G,0),U,2)="SEDATIVE, HYPNOTIC, OR ANXIOLYTIC DEPENDENCE, UNSPECIFIED" D
  1.  ..S DA=G,DIE="^AMHPROB(",DR=".02///SEDATIVE, HYPNOTIC OR ANXIOLYTIC DEPENDENCE, UNSPECIFIED" D ^DIE
  1.  S G=0,DA="" F  S G=$O(^AMHPROB("B","304.11",G)) Q:G'=+G  D
  1.  .I $P(^AMHPROB(G,0),U,2)="SEDATIVE, HYPNOTIC, OR ANXIOLYTIC DEPENDENCE, CONTINUOUS" D
  1.  ..S DA=G,DIE="^AMHPROB(",DR=".02///SEDATIVE, HYPNOTIC OR ANXIOLYTIC DEPENDENCE, CONTINUOUS" D ^DIE
  1.  S G=0,DA="" F  S G=$O(^AMHPROB("B","304.12",G)) Q:G'=+G  D
  1.  .I $P(^AMHPROB(G,0),U,2)="SEDATIVE, HYPNOTIC, OR ANXIOLYTIC DEPENDENCE, EPISODIC" D
  1.  ..S DA=G,DIE="^AMHPROB(",DR=".02///SEDATIVE, HYPNOTIC OR ANXIOLYTIC DEPENDENCE, EPISODIC" D ^DIE
  1.  S G=0,DA="" F  S G=$O(^AMHPROB("B","304.13",G)) Q:G'=+G  D
  1.  .I $P(^AMHPROB(G,0),U,2)="SEDATIVE, HYPNOTIC, OR ANXIOLYTIC DEPENDENCE, IN REMISSION" D
  1.  ..S DA=G,DIE="^AMHPROB(",DR=".02///SEDATIVE, HYPNOTIC OR ANXIOLYTIC DEPENDENCE, IN REMISSION" D ^DIE
  1.  S G=0,DA="" F  S G=$O(^AMHPROB("B","304.50",G)) Q:G'=+G  D
  1.  .I $P(^AMHPROB(G,0),U,2)="HALLUCINOGEN DEPENDENCE. UNSPECIFIED" D
  1.  ..S DA=G,DIE="^AMHPROB(",DR=".02///HALLUCINOGEN DEPENDENCE, UNSPECIFIED" D ^DIE
  1.  S G=0,DA="" F  S G=$O(^AMHPROB("B","304.61",G)) Q:G'=+G  D
  1.  .I $P(^AMHPROB(G,0),U,15)=1 D
  1.  ..S DA=G,DIE="^AMHPROB(",DR=".15///@" D ^DIE
  1.  S G=0,DA="" F  S G=$O(^AMHPROB("B","304.62",G)) Q:G'=+G  D
  1.  .I $P(^AMHPROB(G,0),U,15)=1 D
  1.  ..S DA=G,DIE="^AMHPROB(",DR=".15///@" D ^DIE
  1.  S G=0,DA="" F  S G=$O(^AMHPROB("B","304.63",G)) Q:G'=+G  D
  1.  .I $P(^AMHPROB(G,0),U,15)=1 D
  1.  ..S DA=G,DIE="^AMHPROB(",DR=".15///@" D ^DIE
  1.  S G=0,DA="" F  S G=$O(^AMHPROB("B","304.80",G)) Q:G'=+G  D
  1.  .I $P(^AMHPROB(G,0),U,2)="POLYSUBSTANCE DEPENDENCE, UNSPECIFIED" D
  1.  ..S DA=G,DIE="^AMHPROB(",DR=".13///1;.14///"_DT_";.15///@" D ^DIE
  1.  S G=0,DA="" F  S G=$O(^AMHPROB("B","291.5",G)) Q:G'=+G  D
  1.  .I $P(^AMHPROB(G,0),U,2)="ALCOHOL-INDUCED PSYCHOTIC DISORDER, W/DELUSIONS" D
  1.  ..S DA=G,DIE="^AMHPROB(",DR=".02///ALCOHOL-INDUCED PSYCHOTIC DISORDER, WITH DELUSIONS" D ^DIE
  1.  S G=0,DA="" F  S G=$O(^AMHPROB("B","291.3",G)) Q:G'=+G  D
  1.  .I $P(^AMHPROB(G,0),U,2)="ALCOHOL-INDUCED PSYCHOTIC DISORDER, W/HALLUCINATIONS" D
  1.  ..S DA=G,DIE="^AMHPROB(",DR=".02///ALCOHOL-INDUCED PSYCHOTIC DISORDER, WITH HALLUCINATIONS" D ^DIE
  1.  S G=0,DA="" F  S G=$O(^AMHPROB("B","305.02",G)) Q:G'=+G  D
  1.  .I $P(^AMHPROB(G,0),U,2)="ALCOHOL ABUSE, EPISODIC," D
  1.  ..S DA=G,DIE="^AMHPROB(",DR=".02///ALCOHOL ABUSE, EPISODIC" D ^DIE
  1.  S G=0,DA="" F  S G=$O(^AMHPROB("B","304.60",G)) Q:G'=+G  D
  1.  .I $P(^AMHPROB(G,0),U,15)=1 D
  1.  ..S DA=G,DIE="^AMHPROB(",DR=".15///@" D ^DIE
  1.  K DA,DIE,DR
  1.  S AMHX=0 F  S AMHX=$O(^AMHTPCAD(AMHX)) Q:AMHX'=+AMHX  D
  1.  .S AMH0=^AMHTPCAD(AMHX,0)
  1.  .S AMHCODE=$P(AMH0,U,1)
  1.  .S AMHNARR=$P(AMH0,U,2)
  1.  .S AMHPCODE=$P(AMH0,U,3) S AMHPCODE=$O(^AMHPROBC("B",AMHPCODE,0))
  1.  .S AMHICD=$P(AMH0,U,5)
  1.  .S AMHAXIS=$P(AMH0,U,6)
  1.  .S AMHINA=$P(AMH0,U,13)
  1.  .S AMHEHR=$P(AMH0,U,15)
  1.  .;lookup up code, if exist do edit, if not, do add
  1.  .S G=0,AMHDSM="" F  S G=$O(^AMHPROB("B",AMHCODE,G)) Q:G'=+G!(AMHDSM)  D
  1.  ..I $P(^AMHPROB(G,0),U,2)=AMHNARR S AMHDSM=G
  1.  .I AMHDSM D EDIT Q
  1.  .;add code and edit
  1.  .K D0,DO
  1.  .S DIC="^AMHPROB(",DIADD=1,DLAYGO=9002012.2,DIC(0)="L",X=AMHCODE D FILE^DICN
  1.  .I Y=-1 D MES^XPDUTL("Failure to add code "_AMHCODE_" "_AMHNARR) Q
  1.  .K DIADD,DLAYGO,DIC
  1.  .S AMHDSM=+Y
  1.  .D EDIT
  1.  Q
  1. EDIT ;
  1.  S DA=AMHDSM,DIE="^AMHPROB("
  1.  S DR=".02///"_AMHNARR_";.03////"_AMHPCODE_";.05///"_AMHICD_";.06///I;.15///"_AMHEHR
  1.  D ^DIE
  1.  I $D(Y) D MES^XPDUTL("Failure to update code "_AMHCODE_" "_AMHNARR)
  1.  K DA,DIE,DR
  1.  Q
  1. INSTALLD(AMHSTAL) ;EP - Determine if patch AMHSTAL was installed, where
  1.  ; APCLSTAL is the name of the INSTALL.  E.g "AG*6.0*11".
  1.  ;
  1.  NEW AMHY,DIC,X,Y
  1.  S X=$P(AMHSTAL,"*",1)
  1.  S DIC="^DIC(9.4,",DIC(0)="FM",D="C"
  1.  D IX^DIC
  1.  I Y<1 D IMES Q 0
  1.  S DIC=DIC_+Y_",22,",X=$P(AMHSTAL,"*",2)
  1.  D ^DIC
  1.  I Y<1 D IMES Q 0
  1.  S DIC=DIC_+Y_",""PAH"",",X=$P(AMHSTAL,"*",3)
  1.  D ^DIC
  1.  S AMHY=Y
  1.  D IMES
  1.  Q $S(AMHY<1:0,1:1)
  1. IMES ;
  1.  D MES^XPDUTL($$CJ^XLFSTR("Patch """_AMHSTAL_""" is"_$S(Y<1:" *NOT*",1:"")_" Present.",IOM))
  1.  Q
  1. SORRY(X) ;
  1.  KILL DIFQ
  1.  I X=3 S XPDQUIT=2 Q
  1.  S XPDQUIT=X
  1.  W *7,!,$$CJ^XLFSTR("Sorry....FIX IT!",IOM)
  1.  Q
  1.  ;
  1. MM3 ;BULLETIN;
  1.  I '$G(DUZ) W !,"DUZ UNDEFINED OR ZERO.",! Q
  1.  D HOME^%ZIS,DT^DICRW
  1.  ;
  1.  NEW XMSUB,XMDUZ,XMTEXT,XMY,DIFROM
  1.  KILL ^TMP($J,"AMHBUL")
  1.  D WRITEMS3,GETREC3
  1.  ;Change following lines as desired
  1. SUBJECT3 S XMSUB="* * * IMPORTANT RPMS INFORMATION * * *"
  1. SENDER3 S XMDUZ="IHS Behavioral Health"
  1.  S XMTEXT="^TMP($J,""AMHBUL"",",XMY(1)="",XMY(DUZ)=""
  1.  I $E(IOST)="C" W !,"Sending Mailman message to holders of the"_" "_AMHKEY_" "_"security key."
  1.  D ^XMD
  1.  KILL ^TMP($J,"AMHBUL"),AMHKEY
  1.  Q
  1.  ;
  1. WRITEMS3 ;
  1.  S AMHIEN=$O(^AMHPATCH("AA",4,99,0))
  1.  I AMHIEN="" Q
  1.  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)
  1.  S AMHC=AMHC+1,^TMP($J,"AMHBUL",AMHC)=" "
  1.  S AMHC=AMHC+1,^TMP($J,"AMHBUL",AMHC)="The following users had their PCC link type changed"
  1.  S AMHC=AMHC+1,^TMP($J,"AMHBUL",AMHC)="from Link type 3 to Link type 5.  This is under the"
  1.  S AMHC=AMHC+1,^TMP($J,"AMHBUL",AMHC)="list of users who have a PCC Link exception entered"
  1.  S AMHC=AMHC+1,^TMP($J,"AMHBUL",AMHC)="in the Site Parameter file."
  1.  S AMHC=AMHC+1,^TMP($J,"AMHBUL",AMHC)=AMHNMM
  1.  Q
  1. GETREC3 ;
  1.  ;* * * Define key below to identify recipients * * *
  1.  ;
  1.  S CTR=0,AMHKEY="AMHZMGR"
  1.  F  S CTR=$O(^XUSEC(AMHKEY,CTR)) Q:'CTR  S Y=CTR S XMY(Y)=""
  1.  Q
  1.  ;
  1. CLEAN(APP) ;-- clean out the RPC multiple first
  1.  S DA(1)=APP
  1.  S DIK="^DIC(19,"_DA(1)_","_"""RPC"""_","
  1.  N AMHDA
  1.  S AMHDA=0 F  S AMHDA=$O(^DIC(19,APP,"RPC",AMHDA)) Q:'AMHDA  D
  1.  . S DA=AMHDA
  1.  . D ^DIK
  1.  K ^DIC(19,APP,"RPC","B")
  1.  Q
  1.  ;
  1. NEW ;add new codes
  1.  ;
  1.  ;add new codes if they don't exist
  1.  S AMH1II="",AMH1I=""
  1.  S AMH1X=0 F  S AMH1X=$O(^AMHPROB("B","V71.09",AMH1X)) Q:AMH1X'=+AMH1X  D
  1.  .I $P(^AMHPROB(AMH1X,0),U,2)="NO DIAGNOSIS ON AXIS II" S AMH1II=1
  1.  .I $P(^AMHPROB(AMH1X,0),U,2)="NO DIAGNOSIS ON AXIS I" S AMH1I=1
  1.  I 'AMH1II D
  1.  .S X="V71.09",DIC("DR")=".02///NO DIAGNOSIS ON AXIS II;.03///38;.05///V71.09"
  1.  .S DIC="^AMHPROB(",DLAYGO=9001012.2,DIADD=1
  1.  .S DIC(0)="L"
  1.  .K DD,D0,DO D FILE^DICN K DIADD,DLAYGO,DD,DIC,D0,DO
  1.  .I Y=-1 D MES^XPDUTL("Code "_AMHCODE_" could not be added.") Q
  1.  .Q
  1.  I 'AMH1I D
  1.  .S X="V71.09",DIC("DR")=".02///NO DIAGNOSIS ON AXIS I;.03///38;.05///V71.09"
  1.  .S DIC="^AMHPROB(",DLAYGO=9001012.2,DIADD=1
  1.  .S DIC(0)="L"
  1.  .K DD,D0,DO D FILE^DICN K DIADD,DLAYGO,DD,DIC,D0,DO
  1.  .I Y=-1 D MES^XPDUTL("Code "_AMHCODE_" could not be added.") Q
  1.  .Q
  1.  S AMH1X=0 F  S AMH1X=$O(^AMHPROB("B","V71.09",AMH1X)) Q:AMH1X'=+AMH1X  D
  1.  .Q:$P(^AMHPROB(AMH1X,0),U,2)'="OBSERVATION OF OTHER SUSPECTED MENTAL CONDITION"
  1.  .S DA=AMH1X,DIE="^AMHPROB(",DR=".15///1" D ^DIE K DA,DR,DIE
  1.  Q
  1. NEWICD ;add new codes
  1.  ;
  1.  ;add new codes if they don't exist
  1.  S AMHTEXT="ICDNEW" F AMHY=1:1 S AMHTX=$P($T(@AMHTEXT+AMHY),";;",2,4) Q:AMHTX=""  D
  1.  .S (X,AMHCODE)=$P(AMHTX,";;",1),C=$P(AMHTX,";;",2)
  1.  .S AMHPC=$O(^AMHPROBC("B",C,0))
  1.  .I AMHPC="" D MES^XPDUTL("Problem code: "_$P(AMHTX,";;",2)_" does not exist")
  1.  .S AMHINA=$P(AMHTX,";;",3)
  1.  .S (G,AMHX)=0 F  S AMHX=$O(^AMHPROB("B",AMHCODE,AMHX)) Q:AMHX'=+AMHX  D
  1.  ..;CHECK NARRATIVE
  1.  ..I $P(^AMHPROB(AMHX,0),U,2)=AMHINA S G=1
  1.  ..Q
  1.  .Q:G  ;already have this code
  1.  .S DIC="^AMHPROB(",DLAYGO=9001012.2,DIADD=1,DIC="^AMHPROB("
  1.  .S DIC(0)="L"
  1.  .K DD,D0,DO D FILE^DICN K DIADD,DLAYGO,DD,DIC,D0,DO
  1.  .I Y=-1 D MES^XPDUTL("Code "_AMHCODE_" could not be added.") Q
  1.  .S DA=+Y
  1. NEWE .;
  1.  .S DIE="^AMHPROB("
  1.  .S DR=".02////"_AMHINA_";.03////"_AMHPC_";.05////"_AMHCODE_";.16////3111001"
  1.  .D ^DIE K DIE,DA,DR
  1.  .I $D(Y) D MES^XPDUTL("Error updating code "_AMHCODE_".") Q
  1.  Q
  1. ICDNEW ;;
  1.  ;;290.0;;9.2;;SENILE DEMENTIA UNCOMP;;290.0
  1.  ;;294.20;;12;;DEMEN NOS W/O BEHV DSTRB;;294.20
  1.  ;;294.21;;12;;DEMEN NOS W BEHAV DISTRB;;294.21
  1.  ;;310.2;;12;;POSTCONCUSSION SYNDROME;;310.2
  1.  ;;310.81;;12;;PSEUDOBULBAR AFFECT;;310.81
  1.  ;;310.89;;12;;NONPSYCH MNTL DISORD NEC;;310.89
  1.  ;;780.93;;9;;MEMORY LOSS;;780.93
  1.  ;;V18.4;;35;;FM FX-INTELLECT DISBLTY;;V18.4
  1.  ;;V40.39;;38;;OTH SPC BEHAVIOR PROBLEM;;V40.39
  1.  ;;V79.2;;35;;SCRN INTELLECT DISABILTY;;V79.2
  1.  ;;
  1.  ;;