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

AMH40P10.m

Go to the documentation of this file.
AMH40P10 ; IHS/CMI/LAB - POST INIT BH 4.0 P10 ; 19 Sep 2018  4:15 PM
 ;;4.0;IHS BEHAVIORAL HEALTH;**10**;JUN 02, 2010;Build 15
 ;
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*9") D SORRY(2)
 I +$$VERSION^XPDUTL("AUM")<19 D MES^XPDUTL($$CJ^XLFSTR("Version 19.0 of AUM (ICD UPDATE) is required.  Not installed",80)) D SORRY(2) I 1
 E  D MES^XPDUTL($$CJ^XLFSTR("Requires AUM Version 19.0....Present.",80))
 Q
 ;
PRE ;
 NEW AMHX,DIK,DA
 S AMHX=0 F  S AMHX=$O(^AMHPCIN(AMHX)) Q:AMHX'=+AMHX  S DA=AMHX,DIK="^AMHPCIN(" D ^DIK K DIK,DA
 S AMHX=0 F  S AMHX=$O(^AMHTPCAD(AMHX)) Q:AMHX'=+AMHX  S DA=AMHX,DIK="^AMHTPCAD(" D ^DIK K DIK,DA
 Q
 ;
POST ;EP
 D INACTPC
 D ADDDSMV
 Q
 ;
ADDDSMV ;add all new dsm v codes
 D MES^XPDUTL($$CJ^XLFSTR("Adding codes.",IOM))
 S AMHX=0 F  S AMHX=$O(^AMHTPCAD(AMHX)) Q:AMHX'=+AMHX  D
DSM10 .;ADD DSM5 ICD10 CODES
 .S AMHCODE=$P(^AMHTPCAD(AMHX,0),U,1)
 .Q:AMHCODE=""
 .;do check for others
 .D
 ..S X=0 F  S X=$O(^AMHPROB("B",AMHCODE,X)) Q:X'=+X  I $D(^AMHPROB(X,0)),$P(^AMHPROB(X,0),U,15),$P(^AMHPROB(X,0),U,10)=5 S $P(^AMHPROB(X,0),U,15)=""
 .S AMHNARR=$P(^AMHTPCAD(AMHX,0),U,2)
 .S AMHPC=$P(^AMHTPCAD(AMHX,0),U,3)
 .S AMHPCC=$O(^AMHPROBC("B",AMHPC,0))
 .I 'AMHPCC D MES^XPDUTL("PROBLEM CODE MISSING: "_AMHPC_" CODE "_AMHCODE_" NOT UPLOADED") Q
 .S AMHICD=$P(^AMHTPCAD(AMHX,0),U,17)
 .S AMHEHR=$P(^AMHTPCAD(AMHX,0),U,15)
 .S AMHNOBH=$P(^AMHTPCAD(AMHX,0),U,18)
 .S AMHCS=$P(^AMHTPCAD(AMHX,0),U,10)
 .;FIND EXISTING AND OVERLAY
 .K DIE,DA,DR
 .S DA=""
 .S AMHY=0 F  S AMHY=$O(^AMHPROB("B",AMHCODE,AMHY)) Q:AMHY'=+AMHY!(DA)  D
 ..;Q:$P(^AMHPROB(AMHY,0),U,10)'=5  ;ONLY DSMV
 ..Q:$$UP^XLFSTR($P(^AMHPROB(AMHY,0),U,2))'=$$UP^XLFSTR(AMHNARR)
 ..S DA=AMHY
 .I DA D EDITC Q
 .;ADD THEN EDIT
 .K DIC,DLAYGO,DIADD,DD,D0
 .S DITC=1
 .S X=AMHCODE,DIC="^AMHPROB(",DLAYGO=9002012.2,DIADD=1,DIC(0)="EMQ"
 .S DIC("DR")=".02///"_AMHNARR_";.03////"_AMHPCC_";.17///"_AMHICD_";.1///"_AMHCS_";.15///"_AMHEHR_";.18///"_AMHNOBH_";.16////"_$P($G(^AMHTPCAD(AMHX,11)),U,1)
 .D FILE^DICN
 .I Y=-1 W !,"ERROR ON ",AMHX," ",AMHCODE," ",DIC("DR") K DA,DIC,DIADD,DLAYGO,DR,DD,D0,DO,DITC Q
 .K DA,DIC,DIADD,DLAYGO,DR,DD,D0,DO,DITC
 .D MES^XPDUTL("."_$P(^AMHPROB(+Y,0),U,1))
 .Q
 Q
EDITC ;
 S DIE="^AMHPROB(",DR=".02///"_AMHNARR_";.03////"_AMHPCC_";.17///"_AMHICD_";.1///"_AMHCS_";.15///"_AMHEHR_";.18///"_AMHNOBH ;_";.16////3181001"
 D ^DIE
 I $D(Y) D MES^XPDUTL("DSM CODE FAILED UPDATING: "_AMHCODE) K DIE,DA,DR Q
 D MES^XPDUTL("."_$P(^AMHPROB(DA,0),U,1))
 K DIE,DA,DR
 Q
INACTPC ;
 D MES^XPDUTL($$CJ^XLFSTR("Inactivating codes.",IOM))
 S AMHX=0 F  S AMHX=$O(^AMHPCIN(AMHX)) Q:AMHX'=+AMHX  D
 .Q:$P(^AMHPCIN(AMHX,0),U,3)'=1
 .S AMHC=$P(^AMHPCIN(AMHX,0),U,1)
 .;loop through "B" on AMHPROB and flag all that are not already flagged
 .S AMHY=0 F  S AMHY=$O(^AMHPROB("B",AMHC,AMHY)) Q:AMHY'=+AMHY  D
 ..I '$D(^AMHPROB(AMHY,0)) Q
 ..I $P(^AMHPCIN(AMHX,0),U,4)'=$P(^AMHPROB(AMHY,0),U,2) Q  ;narratives must match
 ..S DA=AMHY,DIE="^AMHPROB(",DR=".13///1;.14////"_$P(^AMHPCIN(AMHX,0),U,5) D ^DIE K DA,DIE,DR
 ..D MES^XPDUTL("."_$P(^AMHPROB(AMHY,0),U,1)_" "_$P(^AMHPROB(AMHY,0),U,4))
 ..Q
 .Q
 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