AMH30P6 ; IHS/CMI/LAB - POST INIT BH ; [ 01/02/05 3:20 PM ]
;;3.0;IHS BEHAVIORAL HEALTH;**5,6**;JAN 27, 2003
;
;LORI -SEND OUT LISTER ITEMS
ENV ;EP
I $G(XPDENV)=1 S (XPDDIQ("XPZ1"),XPDDIQ("XPZ2"))=0
F X="XPO1","XPZ1","XPZ2","XPI1" S XPDDIQ(X)=0
I '$$INSTALLD("AMH*3.0*5") D SORRY(2)
Q
;
PRE ;
F DA=1:1:200 S DIK="^AMHSORT(" D ^DIK
F DA=1:1:50 S DIK="^AMHDTER(" D ^DIK
F DA=1:1:10 S DIK="^AMHRECD(" D ^DIK
S AMHX=0 F S AMHX=$O(^AMHTSET("C",14,AMHX)) Q:AMHX'=+AMHX I $P(^AMHTSET(AMHX,0),U)="TELE-MENTAL HEALTH" S DA=AMHX,DIK="^AMHTSET(" D ^DIK
D ^XBFMK
Q
POST ;EP
S DA=$O(^AMHPROB("B","305.10",0))
I DA S DIE="^AMHPROB(",DR=".01///305.1;.05///305.1" D ^DIE,^XBFMK
S AMHX=0 F S AMHX=$O(^AMHPROB("B",291.89,AMHX)) Q:AMHX'=+AMHX D
.I $P(^AMHPROB(AMHX,0),U,2)["SLEEP DISORDER" S DA=AMHX,DIE="^AMHPROB(",DR=".05///291.82" D ^DIE,^XBFMK
S AMHX=0 F S AMHX=$O(^AMHPROB("B",292.89,AMHX)) Q:AMHX'=+AMHX D
.I $P(^AMHPROB(AMHX,0),U,2)["SLEEP DISORDER" S DA=AMHX,DIE="^AMHPROB(",DR=".05///292.85" D ^DIE,^XBFMK
S DA=$O(^AMHPROB("B",39,0)) I DA S DIE="^AMHPROB(",DR=".05///V62.84" D ^DIE,^XBFMK
S DA=$O(^AMHPROB("B",40,0)) I DA S DIE="^AMHPROB(",DR=".05///V62.84" D ^DIE,^XBFMK
;W !!,"adding new codes:"
F AMHJ=1:1 S AMHX=$T(ADD+AMHJ) Q:$P(AMHX,";;",2)="" D
.S AMHC=$P(AMHX,";;",2) ;CODE
.S AMHD=$P(AMHX,";;",3) ;DESCRIPTION .02
.S AMHM=$P(AMHX,";;",4) ;MAP TO ICD .05
.S AMHP=$P(AMHX,";;",5) ;MHSS PROBLEM CODE
.S AMHCAT=$P(AMHX,";;",6) ;CATEGORY
.;add to mhss problem codes if appropriate
.W !?5,"adding ",AMHC
.I $L($P(AMHC,"."))<3 D
..D ^XBFMK
..S DA=$O(^AMHPROBC("B",AMHC,0))
..I 'DA D ADDPC
..I 'DA Q
..;now edit the code
..S DIE="^AMHPROBC(",DR=".02///"_AMHD_";.03///"_AMHCAT
..D ^DIE
..I $D(Y) W " editing problem code failed"
.D ^XBFMK
.S DA=$O(^AMHPROB("B",AMHC,0))
.I DA W " Already have code ",AMHC," will edit." G PADDSE
.S X=AMHC,DIC="^AMHPROB(",DIC(0)="L" K DD,D0,DO S DIADD=1,DLAYGO=9002012.2 D FILE^DICN K DIADD,DLAYGO,DD,DO,D0
.I Y=-1 W " adding failed in dsm file" D ^XBFMK Q
.S DA=+Y
PADDSE .;
.S DIE="^AMHPROB(",DR=".02///"_AMHD_";.05///"_AMHM_";.03///"_AMHP
.D ^DIE
.I $D(Y) W " editing ",AMHC," failed dsm file."
.K DA,DR,DIE,DIU,DIV,DIW
.Q
D ^AMHPAR
D ^AMH30P6B
Q
ADDPC ;
S X=AMHC,DIC="^AMHPROBC(",DIC(0)="L" K DD,D0,DO S DIADD=1,DLAYGO=9002012.4 D FILE^DICN K DIADD,DLAYGO,DD,DO,D0
I Y=-1 W " adding failed." Q
S DA=+Y
Q
INSTALLD(AMHSTAL) ;EP - Determine if patch AMHSTAL was installed, where
; AMHSTAL 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:"")_" installed.",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
ADD ;
;;22.2;;INSOMNIA DUE TO MENTAL DISORDER;;327.02;;22;;PSYCHOSOCIAL PROBLEMS
;;22.3;;HYPERSOMNIA DUE TO MENTAL DISORDER;;327.15;;22;;PSYCHOSOCIAL PROBLEMS
;;22.4;;BEHAVIORAL INSOMNIA CHILDHOOD;;V69.50;;22;;PSYCHOSOCIAL PROBLEMS
;;
AMH30P6 ; IHS/CMI/LAB - POST INIT BH ; [ 01/02/05 3:20 PM ]
+1 ;;3.0;IHS BEHAVIORAL HEALTH;**5,6**;JAN 27, 2003
+2 ;
+3 ;LORI -SEND OUT LISTER ITEMS
ENV ;EP
+1 IF $GET(XPDENV)=1
SET (XPDDIQ("XPZ1"),XPDDIQ("XPZ2"))=0
+2 FOR X="XPO1","XPZ1","XPZ2","XPI1"
SET XPDDIQ(X)=0
+3 IF '$$INSTALLD("AMH*3.0*5")
DO SORRY(2)
+4 QUIT
+5 ;
PRE ;
+1 FOR DA=1:1:200
SET DIK="^AMHSORT("
DO ^DIK
+2 FOR DA=1:1:50
SET DIK="^AMHDTER("
DO ^DIK
+3 FOR DA=1:1:10
SET DIK="^AMHRECD("
DO ^DIK
+4 SET AMHX=0
FOR
SET AMHX=$ORDER(^AMHTSET("C",14,AMHX))
IF AMHX'=+AMHX
QUIT
IF $PIECE(^AMHTSET(AMHX,0),U)="TELE-MENTAL HEALTH"
SET DA=AMHX
SET DIK="^AMHTSET("
DO ^DIK
+5 DO ^XBFMK
+6 QUIT
POST ;EP
+1 SET DA=$ORDER(^AMHPROB("B","305.10",0))
+2 IF DA
SET DIE="^AMHPROB("
SET DR=".01///305.1;.05///305.1"
DO ^DIE
DO ^XBFMK
+3 SET AMHX=0
FOR
SET AMHX=$ORDER(^AMHPROB("B",291.89,AMHX))
IF AMHX'=+AMHX
QUIT
Begin DoDot:1
+4 IF $PIECE(^AMHPROB(AMHX,0),U,2)["SLEEP DISORDER"
SET DA=AMHX
SET DIE="^AMHPROB("
SET DR=".05///291.82"
DO ^DIE
DO ^XBFMK
End DoDot:1
+5 SET AMHX=0
FOR
SET AMHX=$ORDER(^AMHPROB("B",292.89,AMHX))
IF AMHX'=+AMHX
QUIT
Begin DoDot:1
+6 IF $PIECE(^AMHPROB(AMHX,0),U,2)["SLEEP DISORDER"
SET DA=AMHX
SET DIE="^AMHPROB("
SET DR=".05///292.85"
DO ^DIE
DO ^XBFMK
End DoDot:1
+7 SET DA=$ORDER(^AMHPROB("B",39,0))
IF DA
SET DIE="^AMHPROB("
SET DR=".05///V62.84"
DO ^DIE
DO ^XBFMK
+8 SET DA=$ORDER(^AMHPROB("B",40,0))
IF DA
SET DIE="^AMHPROB("
SET DR=".05///V62.84"
DO ^DIE
DO ^XBFMK
+9 ;W !!,"adding new codes:"
+10 FOR AMHJ=1:1
SET AMHX=$TEXT(ADD+AMHJ)
IF $PIECE(AMHX,";;",2)=""
QUIT
Begin DoDot:1
+11 ;CODE
SET AMHC=$PIECE(AMHX,";;",2)
+12 ;DESCRIPTION .02
SET AMHD=$PIECE(AMHX,";;",3)
+13 ;MAP TO ICD .05
SET AMHM=$PIECE(AMHX,";;",4)
+14 ;MHSS PROBLEM CODE
SET AMHP=$PIECE(AMHX,";;",5)
+15 ;CATEGORY
SET AMHCAT=$PIECE(AMHX,";;",6)
+16 ;add to mhss problem codes if appropriate
+17 WRITE !?5,"adding ",AMHC
+18 IF $LENGTH($PIECE(AMHC,"."))<3
Begin DoDot:2
+19 DO ^XBFMK
+20 SET DA=$ORDER(^AMHPROBC("B",AMHC,0))
+21 IF 'DA
DO ADDPC
+22 IF 'DA
QUIT
+23 ;now edit the code
+24 SET DIE="^AMHPROBC("
SET DR=".02///"_AMHD_";.03///"_AMHCAT
+25 DO ^DIE
+26 IF $DATA(Y)
WRITE " editing problem code failed"
End DoDot:2
+27 DO ^XBFMK
+28 SET DA=$ORDER(^AMHPROB("B",AMHC,0))
+29 IF DA
WRITE " Already have code ",AMHC," will edit."
GOTO PADDSE
+30 SET X=AMHC
SET DIC="^AMHPROB("
SET DIC(0)="L"
KILL DD,D0,DO
SET DIADD=1
SET DLAYGO=9002012.2
DO FILE^DICN
KILL DIADD,DLAYGO,DD,DO,D0
+31 IF Y=-1
WRITE " adding failed in dsm file"
DO ^XBFMK
QUIT
+32 SET DA=+Y
PADDSE ;
+1 SET DIE="^AMHPROB("
SET DR=".02///"_AMHD_";.05///"_AMHM_";.03///"_AMHP
+2 DO ^DIE
+3 IF $DATA(Y)
WRITE " editing ",AMHC," failed dsm file."
+4 KILL DA,DR,DIE,DIU,DIV,DIW
+5 QUIT
End DoDot:1
+6 DO ^AMHPAR
+7 DO ^AMH30P6B
+8 QUIT
ADDPC ;
+1 SET X=AMHC
SET DIC="^AMHPROBC("
SET DIC(0)="L"
KILL DD,D0,DO
SET DIADD=1
SET DLAYGO=9002012.4
DO FILE^DICN
KILL DIADD,DLAYGO,DD,DO,D0
+2 IF Y=-1
WRITE " adding failed."
QUIT
+3 SET DA=+Y
+4 QUIT
INSTALLD(AMHSTAL) ;EP - Determine if patch AMHSTAL was installed, where
+1 ; AMHSTAL 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:"")_" installed.",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
ADD ;
+1 ;;22.2;;INSOMNIA DUE TO MENTAL DISORDER;;327.02;;22;;PSYCHOSOCIAL PROBLEMS
+2 ;;22.3;;HYPERSOMNIA DUE TO MENTAL DISORDER;;327.15;;22;;PSYCHOSOCIAL PROBLEMS
+3 ;;22.4;;BEHAVIORAL INSOMNIA CHILDHOOD;;V69.50;;22;;PSYCHOSOCIAL PROBLEMS
+4 ;;
