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
