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

AMH40P4.m

Go to the documentation of this file. 
  1. AMH40P4 ; 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;**4**;JUN 18, 2010;Build 28
  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*3") D SORRY(2)
  1.  Q
  1.  ;
  1. PRE ;
  1.  S AMHPAIN=0
  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(^AMHPCIN(DA)) Q:DA'=+DA  S DIK="^AMHPCIN(" D ^DIK
  1.  S DA=0 F  S DA=$O(^AMHRECD(DA)) Q:DA'=+DA  S DIK="^AMHRECD(" 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.  S DA=$O(^AMHPROBC("B",14,0))
  1.  I DA S DIE="^AMHPROBC(",DR=".02///DEPRESSIVE DISORDERS" D ^DIE
  1.  K DIE,DA
  1.  I $$INSTALLD("AMH*4.0*4") S AMHPAIN=1  ;PATCH ALREADY INSTALLED ONCE
  1.  Q
  1. SETDSMD ;
  1.  S AMHX=0 F  S AMHX=$O(^AMHSITE(AMHX)) Q:AMHX'=+AMHX  D
  1.  .Q:$P($G(^AMHSITE(AMHX,18)),U,11)]""
  1.  .S DA=AMHX,DIE="^AMHSITE(",DR="1811////3151001" D ^DIE K DIE,DA,DR
  1.  .Q
  1.  Q
  1.  ;
  1. POST ;EP
  1.  ;STUFF DSM 5 DATE
  1.  D SETDSMD
  1.  S AMHX=$O(^DIC(19.1,"B","AMHZ PCC PROBLEM LIST",0))
  1.  I AMHX D DEL^XPDKEY(AMHX)
  1.  D DELETE^XPDMENU("AMH M PRINT TABLES","AMH P TABLES MH/SS PROBLEM DSM")
  1.  D RENAME^XPDMENU("AMH P FREQ PROBLEMS (DSM)","AMH P FREQ PROBLEMS DX")
  1.  D DELETE^XPDMENU("AMH M PROBLEM SPECIFIC","AMH P FREQ PROBLEMS DX")
  1.  D ADD^XPDMENU("AMH M PROBLEM SPECIFIC","AMH P FREQ PROBLEMS DX","FDX",40)
  1.  D ADD^XPDMENU("AMH M DATA ENTRY MENU","AMH DSM-5 COPYRIGHT","DSM",92)
  1.  D FLAG4
  1.  D INACTPC
  1.  ;D FLAG5
  1.  D FLAGOC
  1.  D FLAGTP
  1.  D BMXPO
  1.  D ADDDSMV
  1.  Q
  1.  ;
  1. ADDDSMV ;add all new dsm v codes
  1.  Q:$$INSTALLD("AMH*4.0*4")
  1.  S AMHX=0 F  S AMHX=$O(^AMHTPCAD(AMHX)) Q:AMHX'=+AMHX  D
  1.  .I $P(^AMHTPCAD(AMHX,0),U,5)="" G DSM10
  1.  .S AMHCODE=$P(^AMHTPCAD(AMHX,0),U,1)
  1.  .Q:AMHCODE=""
  1.  .S AMHNARR=$P(^AMHTPCAD(AMHX,0),U,2)
  1.  .S AMHPC=$P(^AMHTPCAD(AMHX,0),U,3)
  1.  .S AMHPCC=$O(^AMHPROBC("B",AMHPC,0))
  1.  .I 'AMHPCC D MES^XPDUTL("PROBLEM CODE MISSING: "_AMHPC_" CODE "_AMHCODE_" NOT UPLOADED")
  1.  .;I AMHPCC S AMHPCC="`"_AMHPCC
  1.  .S AMHICD=$P(^AMHTPCAD(AMHX,0),U,5)
  1.  .S AMHEHR=$P(^AMHTPCAD(AMHX,0),U,15)
  1.  .S AMHNOBH=$P(^AMHTPCAD(AMHX,0),U,18)
  1.  .S AMHCS=$P(^AMHTPCAD(AMHX,0),U,10)
  1.  .;FIND EXISTING AND OVERLAY
  1.  .;S DA=""
  1.  .;S AMHY=0 F  S AMHY=$O(^AMHPROB("B",AMHCODE,AMHY)) Q:AMHY'=+AMHY!(DA)  D
  1.  .;.Q:$P(^AMHPROB(AMHY,0),U,10)'=5  ;ONLY DSMV
  1.  .;.Q:$$UP^XLFSTR($P(^AMHPROB(AMHY,0),U,2))'=$$UP^XLFST(AMHNARR)
  1.  .;.S DA=AMHY
  1.  .;I DA D EDIT9
  1.  .;ADD THEN EDIT
  1.  .K DIC,DLAYGO,DIADD,DD,D0
  1.  .S DITC=1
  1.  .S X=AMHCODE,DIC="^AMHPROB(",DLAYGO=9002012.2,DIADD=1,DIC(0)="EMQ"
  1.  .S DIC("DR")=".02///"_AMHNARR_";.03////"_AMHPCC_";.05///"_AMHICD_";.1///"_AMHCS_";.15///"_AMHEHR_";.18///"_AMHNOBH
  1.  .D FILE^DICN
  1.  .I Y=-1 W !,"ERROR ON ",AMHX," ",AMHCODE," ",DIC("DR")
  1.  .K DA,DIC,DIADD,DLAYGO,DR,DD,D0,DO,DITC
  1.  .Q
  1. DSM10 .;ADD DSM5 ICD10 CODES
  1.  .S AMHCODE=$P(^AMHTPCAD(AMHX,0),U,1)
  1.  .Q:AMHCODE=""
  1.  .S AMHNARR=$P(^AMHTPCAD(AMHX,0),U,2)
  1.  .S AMHPC=$P(^AMHTPCAD(AMHX,0),U,3)
  1.  .S AMHPCC=$O(^AMHPROBC("B",AMHPC,0))
  1.  .I 'AMHPCC D MES^XPDUTL("PROBLEM CODE MISSING: "_AMHPC_" CODE "_AMHCODE_" NOT UPLOADED")
  1.  .;I AMHPCC S AMHPCC="`"_AMHPCC
  1.  .S AMHICD=$P(^AMHTPCAD(AMHX,0),U,17)
  1.  .S AMHEHR=$P(^AMHTPCAD(AMHX,0),U,15)
  1.  .S AMHNOBH=$P(^AMHTPCAD(AMHX,0),U,18)
  1.  .S AMHCS=$P(^AMHTPCAD(AMHX,0),U,10)
  1.  .;FIND EXISTING AND OVERLAY
  1.  .;S DA=""
  1.  .;S AMHY=0 F  S AMHY=$O(^AMHPROB("B",AMHCODE,AMHY)) Q:AMHY'=+AMHY!(DA)  D
  1.  .;.Q:$P(^AMHPROB(AMHY,0),U,10)'=5  ;ONLY DSMV
  1.  .;.Q:$$UP^XLFSTR($P(^AMHPROB(AMHY,0),U,2))'=$$UP^XLFST(AMHNARR)
  1.  .;.S DA=AMHY
  1.  .;I DA D EDIT9
  1.  .;ADD THEN EDIT
  1.  .K DIC,DLAYGO,DIADD,DD,D0
  1.  .S DITC=1
  1.  .S X=AMHCODE,DIC="^AMHPROB(",DLAYGO=9002012.2,DIADD=1,DIC(0)="EMQ"
  1.  .S DIC("DR")=".02///"_AMHNARR_";.03////"_AMHPCC_";.17///"_AMHICD_";.1///"_AMHCS_";.15///"_AMHEHR_";.18///"_AMHNOBH
  1.  .D FILE^DICN
  1.  .I Y=-1 W !,"ERROR ON ",AMHX," ",AMHCODE," ",DIC("DR")
  1.  .K DA,DIC,DIADD,DLAYGO,DR,DD,D0,DO,DITC
  1.  .Q
  1.  Q
  1. FLAGTP ;
  1.  ;FLAG ALL TP'S with "old format", .22 field = 1
  1.  ;FIRST CHECK TO SEE IF THIS RAN ALREADY, IF IT DID QUIT
  1.  Q:$G(AMHPAIN)
  1.  S AMHX=0 F  S AMHX=$O(^AMHPTXP(AMHX)) Q:AMHX'=+AMHX  D
  1.  .S DA=AMHX,DIE="^AMHPTXP(",DR=".22///1" D ^DIE K DIE,DA,DR
  1.  .Q
  1.  Q
  1. FLAGOC ;FLAG ALL OTHER CODES AS DSV IV OR PC
  1.  ;SKIP IF ALREADY FLAGGED
  1.  S AMHX=0 F  S AMHX=$O(^AMHPROB(AMHX)) Q:AMHX'=+AMHX  D
  1.  .Q:$P(^AMHPROB(AMHX,0),U,10)]""
  1.  .S C=$P(^AMHPROB(AMHX,0),U,1),S="",T=""
  1.  .I $P(C,".")]"",$L($P(C,"."))<3 S S="P"
  1.  .I S="" D
  1.  ..I $T(^ICDEX)]"" S T=$P($$ICDDX^ICDEX(C),U,20) S:T=1 S=9 S:T=30 S=0 Q
  1.  ..S S=9
  1.  .S DA=AMHX,DIE="^AMHPROB(",DR=".1///"_S D ^DIE K DA,DIE,DR
  1.  .W !,C,"  ",S
  1.  Q
  1. INACTPC ;
  1.  S AMHX=0 F  S AMHX=$O(^AMHPCIN(AMHX)) Q:AMHX'=+AMHX  D
  1.  .Q:$P(^AMHPCIN(AMHX,0),U,3)'=1
  1.  .S AMHC=$P(^AMHPCIN(AMHX,0),U,1)
  1.  .;loop through "B" on AMHPROB and flag all that are not already flagged to 4
  1.  .S AMHY=0 F  S AMHY=$O(^AMHPROB("B",AMHC,AMHY)) Q:AMHY'=+AMHY  D
  1.  ..I '$D(^AMHPROB(AMHY,0)) Q
  1.  ..I $P(^AMHPROB(AMHY,0),U,13),$P(^AMHPROB(AMHY,0),U,14)]"" Q  ;already flagged
  1.  ..S DA=AMHY,DIE="^AMHPROB(",DR=".13///1;.14////"_DT D ^DIE K DA,DIE,DR
  1.  ..;W AMHC,"."
  1.  ..Q
  1.  .Q
  1.  Q
  1. FLAG4 ;
  1.  S AMHX=0 F  S AMHX=$O(^AMHPCIN(AMHX)) Q:AMHX'=+AMHX  D
  1.  .Q:$P(^AMHPCIN(AMHX,0),U,2)'=1
  1.  .S AMHC=$P(^AMHPCIN(AMHX,0),U,1)
  1.  .;loop through "B" on AMHPROB and flag all that are not already flagged to 4
  1.  .S AMHY=0 F  S AMHY=$O(^AMHPROB("B",AMHC,AMHY)) Q:AMHY'=+AMHY  D
  1.  ..I '$D(^AMHPROB(AMHY,0)) Q
  1.  ..Q:$P(^AMHPROB(AMHY,0),U,10)]""  ;already flagged
  1.  ..S DA=AMHY,DIE="^AMHPROB(",DR=".1///4" D ^DIE K DA,DIE,DR
  1.  ..;W AMHC,"."
  1.  ..Q
  1.  .Q
  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.  ;
  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. 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