AMH30P6.m

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       ;;