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