AMH40P8 ; IHS/CMI/LAB - POST INIT BH 4.0 P8
;;4.0;IHS BEHAVIORAL HEALTH;**8**;JUN 02, 2010;Build 7
;
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*7") D SORRY(2)
;I +$$VERSION^XPDUTL("AUM")<17 D MES^XPDUTL($$CJ^XLFSTR("Version 17.0 of AUM (ICD UPDATE) is required. Not installed",80)) D SORRY(2) I 1
;E D MES^XPDUTL($$CJ^XLFSTR("Requires AUM Version 17.0....Present.",80))
Q
;
PRE ;
NEW AMHX,DIK,DA
S AMHX=0 F S AMHX=$O(^AMHSORT(AMHX)) Q:AMHX'=+AMHX S DA=AMHX,DIK="^AMHSORT(" 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
FIXF1420 ;
S AMHX=0 F S AMHX=$O(^AMHTPCAD("B","F14.20",AMHX)) Q:AMHX'=+AMHX D
.S AMHT=$P(^AMHTPCAD(AMHX,0),U,2)
.S AMHIEN=0 F S AMHIEN=$O(^AMHPROB("C",AMHT,AMHIEN)) Q:AMHIEN'=+AMHIEN D
..Q:'$D(^AMHPROB(AMHIEN,0))
..Q:$P(^AMHPROB(AMHIEN,0),U,1)'="F14.10"
..S DA=AMHIEN,DIE="^AMHPROB(",DR=".01///F14.20" D ^DIE K DA,DIE,DR
..Q
.Q
Q
;
POST ;EP
D ADDZ86
D FIXF1420
D ADDDSMV
S X=$$ADD^XPDMENU("AMH MENU SCREENING REPORTS","AMH M SUICIDE RISK REPORTS","SRA",35)
I 'X W !,"Attempt to add SUICIDE SCREENING REPORTS option failed.." H 3
S X=$$ADD^XPDMENU("AMH MENU SCREENING REPORTS","AMH GAD ONE PATIENT","GAD",50)
I 'X W !,"Attempt to add AMH GAD ONE PATIENT option failed.." H 3
S X=$$ADD^XPDMENU("AMH DE MENU MORE","AMH GAD ONE PATIENT","GAD",68)
I 'X W !,"Attempt to add AMH GAD ONE PATIENT option failed.." H 3
S X=$$ADD^XPDMENU("AMH MENU SCREENING REPORTS","AMH GAD MULTIPLE PTS","GADS",52)
I 'X W !,"Attempt to add AMH GAD MULTIPLE PATIENTS option failed.." H 3
S X=$$ADD^XPDMENU("AMH DE MENU MORE","AMH GAD MULTIPLE PTS","GADS",69)
I 'X W !,"Attempt to add AMH GAD MULTIPLE PATIENTS option failed.." H 3
S X=$$ADD^XPDMENU("AMH M PATIENT LISTINGS","AMHR SBIRT","SB")
I 'X W !,"Attempt to add SBIRT REPORT option failed.." H 3
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=""
.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
.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
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(^AMHPROB(AMHY,0),U,13),$P(^AMHPROB(AMHY,0),U,14)]"" Q ;already flagged
..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))
..Q
.Q
Q
ADDZ86 ;
I $O(^AMHPROB("B","Z86.59",0)) G ADDZ86E
;ADD THEN EDIT
K DIC,DLAYGO,DIADD,DD,D0
S DITC=1
S X="Z86.59",DIC="^AMHPROB(",DLAYGO=9002012.2,DIADD=1,DIC(0)="EMQ"
S DIC("DR")=".02///PERSONAL HISTORY OF OTHER MENTAL AND BEHAVIORAL DISORDERS;.03///99.9;.1///0;.17///Z86.59"
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("ADDED "_$P(^AMHPROB(+Y,0),U,1))
Q
ADDZ86E ;
S DA=$O(^AMHPROB("B","Z86.59",0))
S DIE="^AMHPROB(",DR=".02///PERSONAL HISTORY OF OTHER MENTAL AND BEHAVIORAL DISORDERS;.03///99.9;.1///0;.17///Z86.59" D ^DIE K DIE,DA,DR
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
AMH40P8 ; IHS/CMI/LAB - POST INIT BH 4.0 P8
+1 ;;4.0;IHS BEHAVIORAL HEALTH;**8**;JUN 02, 2010;Build 7
+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*7")
DO SORRY(2)
+9 ;I +$$VERSION^XPDUTL("AUM")<17 D MES^XPDUTL($$CJ^XLFSTR("Version 17.0 of AUM (ICD UPDATE) is required. Not installed",80)) D SORRY(2) I 1
+10 ;E D MES^XPDUTL($$CJ^XLFSTR("Requires AUM Version 17.0....Present.",80))
+11 QUIT
+12 ;
PRE ;
+1 NEW AMHX,DIK,DA
+2 SET AMHX=0
FOR
SET AMHX=$ORDER(^AMHSORT(AMHX))
IF AMHX'=+AMHX
QUIT
SET DA=AMHX
SET DIK="^AMHSORT("
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
FIXF1420 ;
+1 SET AMHX=0
FOR
SET AMHX=$ORDER(^AMHTPCAD("B","F14.20",AMHX))
IF AMHX'=+AMHX
QUIT
Begin DoDot:1
+2 SET AMHT=$PIECE(^AMHTPCAD(AMHX,0),U,2)
+3 SET AMHIEN=0
FOR
SET AMHIEN=$ORDER(^AMHPROB("C",AMHT,AMHIEN))
IF AMHIEN'=+AMHIEN
QUIT
Begin DoDot:2
+4 IF '$DATA(^AMHPROB(AMHIEN,0))
QUIT
+5 IF $PIECE(^AMHPROB(AMHIEN,0),U,1)'="F14.10"
QUIT
+6 SET DA=AMHIEN
SET DIE="^AMHPROB("
SET DR=".01///F14.20"
DO ^DIE
KILL DA,DIE,DR
+7 QUIT
End DoDot:2
+8 QUIT
End DoDot:1
+9 QUIT
+10 ;
POST ;EP
+1 DO ADDZ86
+2 DO FIXF1420
+3 DO ADDDSMV
+4 SET X=$$ADD^XPDMENU("AMH MENU SCREENING REPORTS","AMH M SUICIDE RISK REPORTS","SRA",35)
+5 IF 'X
WRITE !,"Attempt to add SUICIDE SCREENING REPORTS option failed.."
HANG 3
+6 SET X=$$ADD^XPDMENU("AMH MENU SCREENING REPORTS","AMH GAD ONE PATIENT","GAD",50)
+7 IF 'X
WRITE !,"Attempt to add AMH GAD ONE PATIENT option failed.."
HANG 3
+8 SET X=$$ADD^XPDMENU("AMH DE MENU MORE","AMH GAD ONE PATIENT","GAD",68)
+9 IF 'X
WRITE !,"Attempt to add AMH GAD ONE PATIENT option failed.."
HANG 3
+10 SET X=$$ADD^XPDMENU("AMH MENU SCREENING REPORTS","AMH GAD MULTIPLE PTS","GADS",52)
+11 IF 'X
WRITE !,"Attempt to add AMH GAD MULTIPLE PATIENTS option failed.."
HANG 3
+12 SET X=$$ADD^XPDMENU("AMH DE MENU MORE","AMH GAD MULTIPLE PTS","GADS",69)
+13 IF 'X
WRITE !,"Attempt to add AMH GAD MULTIPLE PATIENTS option failed.."
HANG 3
+14 SET X=$$ADD^XPDMENU("AMH M PATIENT LISTINGS","AMHR SBIRT","SB")
+15 IF 'X
WRITE !,"Attempt to add SBIRT REPORT option failed.."
HANG 3
+16 QUIT
+17 ;
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 SET AMHNARR=$PIECE(^AMHTPCAD(AMHX,0),U,2)
+4 SET AMHPC=$PIECE(^AMHTPCAD(AMHX,0),U,3)
+5 SET AMHPCC=$ORDER(^AMHPROBC("B",AMHPC,0))
+6 IF 'AMHPCC
DO MES^XPDUTL("PROBLEM CODE MISSING: "_AMHPC_" CODE "_AMHCODE_" NOT UPLOADED")
QUIT
+7 SET AMHICD=$PIECE(^AMHTPCAD(AMHX,0),U,17)
+8 SET AMHEHR=$PIECE(^AMHTPCAD(AMHX,0),U,15)
+9 SET AMHNOBH=$PIECE(^AMHTPCAD(AMHX,0),U,18)
+10 SET AMHCS=$PIECE(^AMHTPCAD(AMHX,0),U,10)
+11 ;FIND EXISTING AND OVERLAY
+12 KILL DIE,DA,DR
+13 SET DA=""
+14 SET AMHY=0
FOR
SET AMHY=$ORDER(^AMHPROB("B",AMHCODE,AMHY))
IF AMHY'=+AMHY!(DA)
QUIT
Begin DoDot:2
+15 ;ONLY DSMV
IF $PIECE(^AMHPROB(AMHY,0),U,10)'=5
QUIT
+16 IF $$UP^XLFSTR($PIECE(^AMHPROB(AMHY,0),U,2))'=$$UP^XLFSTR(AMHNARR)
QUIT
+17 SET DA=AMHY
End DoDot:2
+18 IF DA
DO EDITC
QUIT
+19 ;ADD THEN EDIT
+20 KILL DIC,DLAYGO,DIADD,DD,D0
+21 SET DITC=1
+22 SET X=AMHCODE
SET DIC="^AMHPROB("
SET DLAYGO=9002012.2
SET DIADD=1
SET DIC(0)="EMQ"
+23 SET DIC("DR")=".02///"_AMHNARR_";.03////"_AMHPCC_";.17///"_AMHICD_";.1///"_AMHCS_";.15///"_AMHEHR_";.18///"_AMHNOBH
+24 DO FILE^DICN
+25 IF Y=-1
WRITE !,"ERROR ON ",AMHX," ",AMHCODE," ",DIC("DR")
KILL DA,DIC,DIADD,DLAYGO,DR,DD,D0,DO,DITC
QUIT
+26 KILL DA,DIC,DIADD,DLAYGO,DR,DD,D0,DO,DITC
+27 DO MES^XPDUTL("."_$PIECE(^AMHPROB(+Y,0),U,1))
+28 QUIT
End DoDot:1
+29 QUIT
EDITC ;
+1 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 ;I $P(^AMHPROB(AMHY,0),U,13),$P(^AMHPROB(AMHY,0),U,14)]"" Q ;already flagged
+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))
+11 QUIT
End DoDot:2
+12 QUIT
End DoDot:1
+13 QUIT
ADDZ86 ;
+1 IF $ORDER(^AMHPROB("B","Z86.59",0))
GOTO ADDZ86E
+2 ;ADD THEN EDIT
+3 KILL DIC,DLAYGO,DIADD,DD,D0
+4 SET DITC=1
+5 SET X="Z86.59"
SET DIC="^AMHPROB("
SET DLAYGO=9002012.2
SET DIADD=1
SET DIC(0)="EMQ"
+6 SET DIC("DR")=".02///PERSONAL HISTORY OF OTHER MENTAL AND BEHAVIORAL DISORDERS;.03///99.9;.1///0;.17///Z86.59"
+7 DO FILE^DICN
+8 IF Y=-1
WRITE !,"ERROR ON ",AMHX," ",AMHCODE," ",DIC("DR")
KILL DA,DIC,DIADD,DLAYGO,DR,DD,D0,DO,DITC
QUIT
+9 KILL DA,DIC,DIADD,DLAYGO,DR,DD,D0,DO,DITC
+10 DO MES^XPDUTL("ADDED "_$PIECE(^AMHPROB(+Y,0),U,1))
+11 QUIT
ADDZ86E ;
+1 SET DA=$ORDER(^AMHPROB("B","Z86.59",0))
+2 SET DIE="^AMHPROB("
SET DR=".02///PERSONAL HISTORY OF OTHER MENTAL AND BEHAVIORAL DISORDERS;.03///99.9;.1///0;.17///Z86.59"
DO ^DIE
KILL DIE,DA,DR
+3 QUIT
+4 ;
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
