AMH30P10.m

AMH30P10 ; IHS/CMI/LAB - POST INIT BH ;   [ 01/20/2009  3:15 PM ]

 ;;3.0;IHS BEHAVIORAL HEALTH;**10**;JAN 27, 2003

 ;

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*9") D SORRY(2)

 Q

 ;

 ;

PRE ;EP

 S DA=0 F  S DA=$O(^AMHSORT(DA)) Q:DA'=+DA  S DIK="^AMHSORT(" D ^DIK

 S DA=0 F  S DA=$O(^AMHRECD(DA)) Q:DA'=+DA  S DIK="^AMHRECD(" D ^DIK

 S DA=0 F  S DA=$O(^AMHTPCAD(DA)) Q:DA'=+DA  S DIK="^AMHTPCAD(" D ^DIK

 Q

 ;

POST ;EP

 D DELETE^XPDMENU("AMH M DATA ENTRY MENU","AMH DE DUPLICATE VISIT")

 D DELETE^XPDMENU("AMH DE MENU MORE","AMH R UNSIGNED")

 ;delete keys and remove them from any options

 F AMHKEY="AMHBHA","AMHBHDEL","AMHBHG","AMHBHR","AMHBHT","AMHBHV","AMHFSP","AMHHSD" D  D DELKEY

 .S AMHX=0 F  S AMHX=$O(^DIC(19,AMHX)) Q:AMHX'=+AMHX  D

 .Q:$E($P(^DIC(19,AMHX,0),U),1,3)'="AMH"

 .Q:$P(^DIC(19,AMHX,0),U,6)'=AMHKEY

 .S DA=AMHX,DIE="^DIC(19,",DR="3///@" D ^DIE K DA,DR,DIE

 ;send message

 ;

 ;UPDATE NEW CODES

 S AMHX=0 F  S AMHX=$O(^AMHTPCAD(AMHX)) Q:AMHX'=+AMHX  D

 .S AMHC=$P(^AMHTPCAD(AMHX,0),U)

 .S AMHN=$P(^AMHTPCAD(AMHX,0),U,2)

 .S AMHPC=$P(^AMHTPCAD(AMHX,0),U,3)

 .S AMHPCI=$O(^AMHPROBC("B",AMHPC,0))

 .I 'AMHPCI S AMHPCI=$O(^AMHPROBC("B","99.9",0))

 .I $D(^AMHPROB("B",AMHC)) D EDIT Q

 .;ADD NEW PROBLEM

 .S X=AMHC,DIC="^AMHPROB(",DIADD=1,DLAYGO=9002012.2,DIC("DR")=".03////"_AMHPCI_";.05///"_AMHC,DIC(0)="L"

 .K DD,D0,DO

 .D FILE^DICN

 .I Y=-1 D EN^DDIOL("failure adding code "_AMHC) K DIC,DIADD,DR,DA,X,DLAYGO Q

 .S $P(^AMHPROB(+Y,0),U,2)=AMHN

 .S DA=+Y,DIK="^AMHPROB(" D IX^DIK K DA,DIK

 .K DIC,DIADD,DLAYGO

 .Q

 ;deactivate codes

 F AMHX=58,82,84 S DA=$O(^AMHPROBC("B",AMHX,0)) I DA S DIE="^AMHPROBC(",DR=".04///1" D ^DIE K DIE,DA,DR

 F AMHX=58,82,84 S DA=$O(^AMHPROB("B",AMHX,0)) I DA S DIE="^AMHPROB(",DR=".13///1;.14////"_DT D ^DIE K DIE,DA,DR

 ;REINDEX ALM xref

 NEW DIK

 S DIK="^AMHREC(",DIK(1)=".21^ALM" D ENALL^DIK

 Q

 ;

EDIT ;

 S DA=$O(^AMHPROB("B",AMHC,0))

 I 'DA Q

 S DIE="^AMHPROB(",DR=".03////"_AMHPCI_";.05///"_AMHC D ^DIE

 S $P(^AMHPROB(DA,0),U,2)=AMHN

 S DIK="^AMHPROB(" D EN1^DIK K DA,DIK

 K DIE,DA,DR

 Q

DELKEY ;

 S DA=$O(^DIC(19.1,"B",AMHKEY,0))

 I DA S DIK="^DIC(19.1," D ^DIK

 K DIK,DA

 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

AMH30P10  ; IHS/CMI/LAB - POST INIT BH ;   [ 01/20/2009  3:15 PM ]

 +1       ;;3.0;IHS BEHAVIORAL HEALTH;**10**;JAN 27, 2003

 +2       ;

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*9")

               DO SORRY(2)

 +4        QUIT 

 +5       ;

 +6       ;

PRE       ;EP

 +1        SET DA=0

           FOR 

               SET DA=$ORDER(^AMHSORT(DA))

               IF DA'=+DA

                   QUIT 

               SET DIK="^AMHSORT("

               DO ^DIK

 +2        SET DA=0

           FOR 

               SET DA=$ORDER(^AMHRECD(DA))

               IF DA'=+DA

                   QUIT 

               SET DIK="^AMHRECD("

               DO ^DIK

 +3        SET DA=0

           FOR 

               SET DA=$ORDER(^AMHTPCAD(DA))

               IF DA'=+DA

                   QUIT 

               SET DIK="^AMHTPCAD("

               DO ^DIK

 +4        QUIT 

 +5       ;

POST      ;EP

 +1        DO DELETE^XPDMENU("AMH M DATA ENTRY MENU","AMH DE DUPLICATE VISIT")

 +2        DO DELETE^XPDMENU("AMH DE MENU MORE","AMH R UNSIGNED")

 +3       ;delete keys and remove them from any options

 +4        FOR AMHKEY="AMHBHA","AMHBHDEL","AMHBHG","AMHBHR","AMHBHT","AMHBHV","AMHFSP","AMHHSD"

               Begin DoDot:1

 +5                SET AMHX=0

                   FOR 

                       SET AMHX=$ORDER(^DIC(19,AMHX))

                       IF AMHX'=+AMHX

                           QUIT 

                       Begin DoDot:2

                       End DoDot:2

 +6                IF $EXTRACT($PIECE(^DIC(19,AMHX,0),U),1,3)'="AMH"

                       QUIT 

 +7                IF $PIECE(^DIC(19,AMHX,0),U,6)'=AMHKEY

                       QUIT 

 +8                SET DA=AMHX

                   SET DIE="^DIC(19,"

                   SET DR="3///@"

                   DO ^DIE

                   KILL DA,DR,DIE

               End DoDot:1

               DO DELKEY

 +9       ;send message

 +10      ;

 +11      ;UPDATE NEW CODES

 +12       SET AMHX=0

           FOR 

               SET AMHX=$ORDER(^AMHTPCAD(AMHX))

               IF AMHX'=+AMHX

                   QUIT 

               Begin DoDot:1

 +13               SET AMHC=$PIECE(^AMHTPCAD(AMHX,0),U)

 +14               SET AMHN=$PIECE(^AMHTPCAD(AMHX,0),U,2)

 +15               SET AMHPC=$PIECE(^AMHTPCAD(AMHX,0),U,3)

 +16               SET AMHPCI=$ORDER(^AMHPROBC("B",AMHPC,0))

 +17               IF 'AMHPCI

                       SET AMHPCI=$ORDER(^AMHPROBC("B","99.9",0))

 +18               IF $DATA(^AMHPROB("B",AMHC))

                       DO EDIT

                       QUIT 

 +19      ;ADD NEW PROBLEM

 +20               SET X=AMHC

                   SET DIC="^AMHPROB("

                   SET DIADD=1

                   SET DLAYGO=9002012.2

                   SET DIC("DR")=".03////"_AMHPCI_";.05///"_AMHC

                   SET DIC(0)="L"

 +21               KILL DD,D0,DO

 +22               DO FILE^DICN

 +23               IF Y=-1

                       DO EN^DDIOL("failure adding code "_AMHC)

                       KILL DIC,DIADD,DR,DA,X,DLAYGO

                       QUIT 

 +24               SET $PIECE(^AMHPROB(+Y,0),U,2)=AMHN

 +25               SET DA=+Y

                   SET DIK="^AMHPROB("

                   DO IX^DIK

                   KILL DA,DIK

 +26               KILL DIC,DIADD,DLAYGO

 +27               QUIT 

               End DoDot:1

 +28      ;deactivate codes

 +29       FOR AMHX=58,82,84

               SET DA=$ORDER(^AMHPROBC("B",AMHX,0))

               IF DA

                   SET DIE="^AMHPROBC("

                   SET DR=".04///1"

                   DO ^DIE

                   KILL DIE,DA,DR

 +30       FOR AMHX=58,82,84

               SET DA=$ORDER(^AMHPROB("B",AMHX,0))

               IF DA

                   SET DIE="^AMHPROB("

                   SET DR=".13///1;.14////"_DT

                   DO ^DIE

                   KILL DIE,DA,DR

 +31      ;REINDEX ALM xref

 +32       NEW DIK

 +33       SET DIK="^AMHREC("

           SET DIK(1)=".21^ALM"

           DO ENALL^DIK

 +34       QUIT 

 +35      ;

EDIT      ;

 +1        SET DA=$ORDER(^AMHPROB("B",AMHC,0))

 +2        IF 'DA

               QUIT 

 +3        SET DIE="^AMHPROB("

           SET DR=".03////"_AMHPCI_";.05///"_AMHC

           DO ^DIE

 +4        SET $PIECE(^AMHPROB(DA,0),U,2)=AMHN

 +5        SET DIK="^AMHPROB("

           DO EN1^DIK

           KILL DA,DIK

 +6        KILL DIE,DA,DR

 +7        QUIT 

DELKEY    ;

 +1        SET DA=$ORDER(^DIC(19.1,"B",AMHKEY,0))

 +2        IF DA

               SET DIK="^DIC(19.1,"

               DO ^DIK

 +3        KILL DIK,DA

 +4        QUIT 

 +5       ;

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