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

AMH30P8.m

Go to the documentation of this file. 
  1. AMH30P8 ; IHS/CMI/LAB - POST INIT BH ;   [ 01/02/05  3:20 PM ]
  1.  ;;3.0;IHS BEHAVIORAL HEALTH;**5,6**;JAN 27, 2003
  1.  ;
  1. ENV ;EP 
  1.  I $G(XPDENV)=1 S (XPDDIQ("XPZ1"),XPDDIQ("XPZ2"))=0
  1.  F X="XPO1","XPZ1","XPZ2","XPI1" S XPDDIQ(X)=0
  1.  I '$$INSTALLD("AMH*3.0*7") D SORRY(2)
  1.  I '$$INSTALLD("AICD*3.51*7") D SORRY(2)
  1.  I '$$INSTALLD("AUPN*99.1*18") D SORRY(2)
  1.  Q
  1.  ;
  1. PRE ;EP
  1.  F DA=1:1:999 S DIK="^AMHSORT(" D ^DIK
  1.  F DA=1:1:50 S DIK="^AMHDTER(" D ^DIK
  1.  F DA=1:1:10 S DIK="^AMHRECD(" D ^DIK
  1.  F DA=1:1:200 S DIK="^AMHBHPC(" D ^DIK
  1.  S DIU="^AMHBHPC(",DIU(0)="D" D EN^DIU2
  1.  D ^XBFMK
  1.  Q
  1. POST ;
  1.  S AMHX=0 F  S AMHX=$O(^AMHREC(AMHX)) Q:AMHX'=+AMHX  D
  1.  .Q:$P($G(^AMHREC(AMHX,11)),U,10)
  1.  .;Q:$P(^AMHREC(AMHX,0),U,16)=""
  1.  .S $P(^AMHREC(AMHX,11),U,11)=1
  1.  .Q
  1. ADDPC ;
  1.  I '$O(^AMHPROBC("B",99.9,0)) D
  1.  .S X=99.9,DIC="^AMHPROBC(",DIC(0)="L",DIC("DR")=".02///OTHER EHR CLINICAL;.03///OTHER PATIENT RELATED" K DD,D0,DO S DIADD=1,DLAYGO=9002012.4 D FILE^DICN K DIADD,DLAYGO,DD,DO,D0,DIC
  1.  .I Y=-1 W "  adding 99.9 failed." Q
  1.  ;NOW UPDATE ALL DSM CODES PER DENISE'S SPREADSHEET
  1.  S AMHX=0,G=0 F  S AMHX=$O(^AMHPROB("B","292.0",AMHX)) Q:AMHX'=+AMHX  D
  1.  .I $P(^AMHPROB(AMHX,0),U,13)]"" S $P(^AMHPROB(AMHX,0),U,15)=1,G=1 Q
  1.  .Q
  1.  I 'G W !!,"code 292.0 was not mapped to EHR"
  1.  ;
  1.  S AMHX=0,G=0 F  S AMHX=$O(^AMHPROB("B",292.89,AMHX)) Q:AMHX'=+AMHX  D
  1.  .I $P(^AMHPROB(AMHX,0),U,13)]"" D ^XBFMK S DA=AMHX,DIE="^AMHPROB(",DR=".02///OTHER SPECIFIED DRUG INDUCED MENTAL DISORDERS;.15///1" D ^DIE,^XBFMK S G=1 Q
  1.  .Q
  1.  I 'G W !!,"code 292.89 was not mapped to EHR"
  1.  ;
  1.  S AMHX=0,G=0 F  S AMHX=$O(^AMHPROB("B",292.81,AMHX)) Q:AMHX'=+AMHX  D
  1.  .I $P(^AMHPROB(AMHX,0),U,13)]"" D ^XBFMK S DA=AMHX,DIE="^AMHPROB(",DR=".02///DRUG INDUCED DELIRIUM;.15///1" D ^DIE,^XBFMK S G=1 Q
  1.  .Q
  1.  I 'G W !!,"code 292.81 was not mapped to EHR"
  1.  ;
  1.  S AMHX=0,G=0 F  S AMHX=$O(^AMHPROB("B",292.82,AMHX)) Q:AMHX'=+AMHX  D
  1.  .I $P(^AMHPROB(AMHX,0),U,13)]"" D ^XBFMK S DA=AMHX,DIE="^AMHPROB(",DR=".02///DRUG INDUCED PERSISTING DEMENTIA;.15///1" D ^DIE,^XBFMK S G=1 Q
  1.  .Q
  1.  I 'G W !!,"code 292.82 was not mapped to EHR"
  1.  ;
  1.  S AMHX=0,G=0 F  S AMHX=$O(^AMHPROB("B",292.83,AMHX)) Q:AMHX'=+AMHX  D
  1.  .I $P(^AMHPROB(AMHX,0),U,13)]"" D ^XBFMK S DA=AMHX,DIE="^AMHPROB(",DR=".02///DRUG INDUCED PERSISTING AMNESTIC DISORDER;.15///1" D ^DIE,^XBFMK S G=1 Q
  1.  .Q
  1.  I 'G W !!,"code 292.83 was not mapped to EHR"
  1.  ;
  1.  S AMHX=0,G=0 F  S AMHX=$O(^AMHPROB("B",292.84,AMHX)) Q:AMHX'=+AMHX  D
  1.  .I $P(^AMHPROB(AMHX,0),U,13)]"" D ^XBFMK S DA=AMHX,DIE="^AMHPROB(",DR=".02///DRUG INDUCED MOOD DISORDER;.15///1" D ^DIE,^XBFMK S G=1 Q
  1.  .Q
  1.  I 'G W !!,"code 292.84 was not mapped to EHR"
  1.  ;
  1.  S AMHX=0,G=0 F  S AMHX=$O(^AMHPROB("B",292.11,AMHX)) Q:AMHX'=+AMHX  D
  1.  .I $P(^AMHPROB(AMHX,0),U,13)]"" D ^XBFMK S DA=AMHX,DIE="^AMHPROB(",DR=".02///DRUG INDUCED PSYCHOTIC DISORDER WITH DELUSIONS;.15///1" D ^DIE,^XBFMK S G=1 Q
  1.  .Q
  1.  I 'G W !!,"code 292.11 was not mapped to EHR"
  1.  ;
  1.  S AMHX=0,G=0 F  S AMHX=$O(^AMHPROB("B",292.12,AMHX)) Q:AMHX'=+AMHX  D
  1.  .I $P(^AMHPROB(AMHX,0),U,13)]"" D ^XBFMK S DA=AMHX,DIE="^AMHPROB(",DR=".02///DRUG INDUCED PSYCHOTIC DISORDER WITH HALLUCINATIONS;.15///1" D ^DIE,^XBFMK S G=1 Q
  1.  .Q
  1.  I 'G W !!,"code 292.12 was not mapped to EHR"
  1.  ;
  1.  S AMHX=0,G=0 F  S AMHX=$O(^AMHPROB("B",292.9,AMHX)) Q:AMHX'=+AMHX  D
  1.  .I $P(^AMHPROB(AMHX,0),U,13)]"" D ^XBFMK S DA=AMHX,DIE="^AMHPROB(",DR=".02///UNSPECIFIED DRUG INDUCED MENTAL DISORDER;.15///1" D ^DIE,^XBFMK S G=1 Q
  1.  .Q
  1.  I 'G W !!,"code 292.9 was not mapped to EHR"
  1.  ;
  1.  S AMHX=0,G=0 F  S AMHX=$O(^AMHPROB("B","305.90",AMHX)) Q:AMHX'=+AMHX  D
  1.  .I $P(^AMHPROB(AMHX,0),U,13)]"" D ^XBFMK S DA=AMHX,DIE="^AMHPROB(",DR=".02///OTHER, MIXED, OR UNSPECIFIED DRUG ABUSE, UNSPECIFIED;.15///1" D ^DIE,^XBFMK S G=1 Q
  1.  .Q
  1.  I 'G W !!,"code 305.90 was not mapped to EHR"
  1.  ;
  1.  S AMHX=0,G=0 F  S AMHX=$O(^AMHPROB("B",305.91,AMHX)) Q:AMHX'=+AMHX  D
  1.  .I $P(^AMHPROB(AMHX,0),U,13)]"" D ^XBFMK S DA=AMHX,DIE="^AMHPROB(",DR=".02///OTHER, MIXED, OR UNSPECIFIED DRUG ABUSE, CONTINUOUS;.15///1" D ^DIE,^XBFMK S G=1 Q
  1.  .Q
  1.  I 'G W !!,"code 305.91 was not mapped to EHR"
  1.  ;
  1.  S AMHX=0,G=0 F  S AMHX=$O(^AMHPROB("B",305.92,AMHX)) Q:AMHX'=+AMHX  D
  1.  .I $P(^AMHPROB(AMHX,0),U,13)]"" D ^XBFMK S DA=AMHX,DIE="^AMHPROB(",DR=".02///OTHER, MIXED, OR UNSPECIFIED DRUG ABUSE, EPISODIC;.15///1" D ^DIE,^XBFMK S G=1 Q
  1.  .Q
  1.  I 'G W !!,"code 305.92 was not mapped to EHR"
  1.  ;
  1.  S AMHX=0,G=0 F  S AMHX=$O(^AMHPROB("B",305.93,AMHX)) Q:AMHX'=+AMHX  D
  1.  .I $P(^AMHPROB(AMHX,0),U,13)]"" D ^XBFMK S DA=AMHX,DIE="^AMHPROB(",DR=".02///OTHER, MIXED, OR UNSPECIFIED DRUG ABUSE, IN REMISSION;.15///1" D ^DIE,^XBFMK S G=1 Q
  1.  .Q
  1.  I 'G W !!,"code 305.93 was not mapped to EHR"
  1. SU ;map suicide code 40 to 300.9
  1.  S DA=$O(^AMHPROB("B",40,0))
  1.  I DA S DIE="^AMHPROB(",DR=".05///300.9" D ^DIE K DIE,DA,DR
  1.  ;
  1.  D BULLETIN
  1.  Q
  1. INSTALLD(AMHSTAL) ;EP - Determine if patch AMHSTAL was installed, where
  1.  ; AMHSTAL 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:"")_" installed.",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. 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 WRITEMSG,GETRECIP
  1.  ;Change following lines as desired
  1. SUBJECT S XMSUB="* * * IMPORTANT RPMS INFORMATION * * *"
  1. SENDER S XMDUZ="Cimarron Medical Informatics"
  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. WRITEMSG ;
  1.  S AMHIEN=$O(^AMHPATCH("AA",3,8,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.  Q
  1. GETRECIP ;
  1.  ;* * * Define key below to identify recipients * * *
  1.  ;
  1.  S CTR=0,AMHKEY="AMHZMENU"
  1.  F  S CTR=$O(^XUSEC(AMHKEY,CTR)) Q:'CTR  S Y=CTR S XMY(Y)=""
  1.  Q