AMH40P4 ; IHS/CMI/LAB - POST INIT BH 16 Apr 2009 7:37 AM 01 Aug 2009 5:37 AM ; 13 Apr 2010 3:54 PM
;;4.0;IHS BEHAVIORAL HEALTH;**4**;JUN 18, 2010;Build 28
;
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*3") D SORRY(2)
Q
;
PRE ;
S AMHPAIN=0
S DA=0 F S DA=$O(^AMHSORT(DA)) Q:DA'=+DA S DIK="^AMHSORT(" D ^DIK
S DA=0 F S DA=$O(^AMHPCIN(DA)) Q:DA'=+DA S DIK="^AMHPCIN(" 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
K DA,DIK
S DA=$O(^AMHPROBC("B",14,0))
I DA S DIE="^AMHPROBC(",DR=".02///DEPRESSIVE DISORDERS" D ^DIE
K DIE,DA
I $$INSTALLD("AMH*4.0*4") S AMHPAIN=1 ;PATCH ALREADY INSTALLED ONCE
Q
SETDSMD ;
S AMHX=0 F S AMHX=$O(^AMHSITE(AMHX)) Q:AMHX'=+AMHX D
.Q:$P($G(^AMHSITE(AMHX,18)),U,11)]""
.S DA=AMHX,DIE="^AMHSITE(",DR="1811////3151001" D ^DIE K DIE,DA,DR
.Q
Q
;
POST ;EP
;STUFF DSM 5 DATE
D SETDSMD
S AMHX=$O(^DIC(19.1,"B","AMHZ PCC PROBLEM LIST",0))
I AMHX D DEL^XPDKEY(AMHX)
D DELETE^XPDMENU("AMH M PRINT TABLES","AMH P TABLES MH/SS PROBLEM DSM")
D RENAME^XPDMENU("AMH P FREQ PROBLEMS (DSM)","AMH P FREQ PROBLEMS DX")
D DELETE^XPDMENU("AMH M PROBLEM SPECIFIC","AMH P FREQ PROBLEMS DX")
D ADD^XPDMENU("AMH M PROBLEM SPECIFIC","AMH P FREQ PROBLEMS DX","FDX",40)
D ADD^XPDMENU("AMH M DATA ENTRY MENU","AMH DSM-5 COPYRIGHT","DSM",92)
D FLAG4
D INACTPC
;D FLAG5
D FLAGOC
D FLAGTP
D BMXPO
D ADDDSMV
Q
;
ADDDSMV ;add all new dsm v codes
Q:$$INSTALLD("AMH*4.0*4")
S AMHX=0 F S AMHX=$O(^AMHTPCAD(AMHX)) Q:AMHX'=+AMHX D
.I $P(^AMHTPCAD(AMHX,0),U,5)="" G DSM10
.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")
.;I AMHPCC S AMHPCC="`"_AMHPCC
.S AMHICD=$P(^AMHTPCAD(AMHX,0),U,5)
.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
.;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^XLFST(AMHNARR)
.;.S DA=AMHY
.;I DA D EDIT9
.;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_";.05///"_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
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")
.;I AMHPCC S AMHPCC="`"_AMHPCC
.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
.;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^XLFST(AMHNARR)
.;.S DA=AMHY
.;I DA D EDIT9
.;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
Q
FLAGTP ;
;FLAG ALL TP'S with "old format", .22 field = 1
;FIRST CHECK TO SEE IF THIS RAN ALREADY, IF IT DID QUIT
Q:$G(AMHPAIN)
S AMHX=0 F S AMHX=$O(^AMHPTXP(AMHX)) Q:AMHX'=+AMHX D
.S DA=AMHX,DIE="^AMHPTXP(",DR=".22///1" D ^DIE K DIE,DA,DR
.Q
Q
FLAGOC ;FLAG ALL OTHER CODES AS DSV IV OR PC
;SKIP IF ALREADY FLAGGED
S AMHX=0 F S AMHX=$O(^AMHPROB(AMHX)) Q:AMHX'=+AMHX D
.Q:$P(^AMHPROB(AMHX,0),U,10)]""
.S C=$P(^AMHPROB(AMHX,0),U,1),S="",T=""
.I $P(C,".")]"",$L($P(C,"."))<3 S S="P"
.I S="" D
..I $T(^ICDEX)]"" S T=$P($$ICDDX^ICDEX(C),U,20) S:T=1 S=9 S:T=30 S=0 Q
..S S=9
.S DA=AMHX,DIE="^AMHPROB(",DR=".1///"_S D ^DIE K DA,DIE,DR
.W !,C," ",S
Q
INACTPC ;
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 to 4
.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////"_DT D ^DIE K DA,DIE,DR
..;W AMHC,"."
..Q
.Q
Q
FLAG4 ;
S AMHX=0 F S AMHX=$O(^AMHPCIN(AMHX)) Q:AMHX'=+AMHX D
.Q:$P(^AMHPCIN(AMHX,0),U,2)'=1
.S AMHC=$P(^AMHPCIN(AMHX,0),U,1)
.;loop through "B" on AMHPROB and flag all that are not already flagged to 4
.S AMHY=0 F S AMHY=$O(^AMHPROB("B",AMHC,AMHY)) Q:AMHY'=+AMHY D
..I '$D(^AMHPROB(AMHY,0)) Q
..Q:$P(^AMHPROB(AMHY,0),U,10)]"" ;already flagged
..S DA=AMHY,DIE="^AMHPROB(",DR=".1///4" D ^DIE K DA,DIE,DR
..;W AMHC,"."
..Q
.Q
Q
BMXPO ;-- update the RPC file
N AMHRPC
S AMHRPC=$O(^DIC(19,"B","AMHGRPC",0))
Q:'AMHRPC
D CLEAN(AMHRPC)
D GUIEP^BMXPO(.RETVAL,AMHRPC_"|AMH")
Q
;
CLEAN(APP) ;-- clean out the RPC multiple first
S DA(1)=APP
S DIK="^DIC(19,"_DA(1)_","_"""RPC"""_","
N AMHDA
S AMHDA=0 F S AMHDA=$O(^DIC(19,APP,"RPC",AMHDA)) Q:'AMHDA D
. S DA=AMHDA
. D ^DIK
K ^DIC(19,APP,"RPC","B")
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
AMH40P4 ; IHS/CMI/LAB - POST INIT BH 16 Apr 2009 7:37 AM 01 Aug 2009 5:37 AM ; 13 Apr 2010 3:54 PM
+1 ;;4.0;IHS BEHAVIORAL HEALTH;**4**;JUN 18, 2010;Build 28
+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*3")
DO SORRY(2)
+9 QUIT
+10 ;
PRE ;
+1 SET AMHPAIN=0
+2 SET DA=0
FOR
SET DA=$ORDER(^AMHSORT(DA))
IF DA'=+DA
QUIT
SET DIK="^AMHSORT("
DO ^DIK
+3 SET DA=0
FOR
SET DA=$ORDER(^AMHPCIN(DA))
IF DA'=+DA
QUIT
SET DIK="^AMHPCIN("
DO ^DIK
+4 SET DA=0
FOR
SET DA=$ORDER(^AMHRECD(DA))
IF DA'=+DA
QUIT
SET DIK="^AMHRECD("
DO ^DIK
+5 SET DA=0
FOR
SET DA=$ORDER(^AMHTPCAD(DA))
IF DA'=+DA
QUIT
SET DIK="^AMHTPCAD("
DO ^DIK
+6 KILL DA,DIK
+7 SET DA=$ORDER(^AMHPROBC("B",14,0))
+8 IF DA
SET DIE="^AMHPROBC("
SET DR=".02///DEPRESSIVE DISORDERS"
DO ^DIE
+9 KILL DIE,DA
+10 ;PATCH ALREADY INSTALLED ONCE
IF $$INSTALLD("AMH*4.0*4")
SET AMHPAIN=1
+11 QUIT
SETDSMD ;
+1 SET AMHX=0
FOR
SET AMHX=$ORDER(^AMHSITE(AMHX))
IF AMHX'=+AMHX
QUIT
Begin DoDot:1
+2 IF $PIECE($GET(^AMHSITE(AMHX,18)),U,11)]""
QUIT
+3 SET DA=AMHX
SET DIE="^AMHSITE("
SET DR="1811////3151001"
DO ^DIE
KILL DIE,DA,DR
+4 QUIT
End DoDot:1
+5 QUIT
+6 ;
POST ;EP
+1 ;STUFF DSM 5 DATE
+2 DO SETDSMD
+3 SET AMHX=$ORDER(^DIC(19.1,"B","AMHZ PCC PROBLEM LIST",0))
+4 IF AMHX
DO DEL^XPDKEY(AMHX)
+5 DO DELETE^XPDMENU("AMH M PRINT TABLES","AMH P TABLES MH/SS PROBLEM DSM")
+6 DO RENAME^XPDMENU("AMH P FREQ PROBLEMS (DSM)","AMH P FREQ PROBLEMS DX")
+7 DO DELETE^XPDMENU("AMH M PROBLEM SPECIFIC","AMH P FREQ PROBLEMS DX")
+8 DO ADD^XPDMENU("AMH M PROBLEM SPECIFIC","AMH P FREQ PROBLEMS DX","FDX",40)
+9 DO ADD^XPDMENU("AMH M DATA ENTRY MENU","AMH DSM-5 COPYRIGHT","DSM",92)
+10 DO FLAG4
+11 DO INACTPC
+12 ;D FLAG5
+13 DO FLAGOC
+14 DO FLAGTP
+15 DO BMXPO
+16 DO ADDDSMV
+17 QUIT
+18 ;
ADDDSMV ;add all new dsm v codes
+1 IF $$INSTALLD("AMH*4.0*4")
QUIT
+2 SET AMHX=0
FOR
SET AMHX=$ORDER(^AMHTPCAD(AMHX))
IF AMHX'=+AMHX
QUIT
Begin DoDot:1
+3 IF $PIECE(^AMHTPCAD(AMHX,0),U,5)=""
GOTO DSM10
+4 SET AMHCODE=$PIECE(^AMHTPCAD(AMHX,0),U,1)
+5 IF AMHCODE=""
QUIT
+6 SET AMHNARR=$PIECE(^AMHTPCAD(AMHX,0),U,2)
+7 SET AMHPC=$PIECE(^AMHTPCAD(AMHX,0),U,3)
+8 SET AMHPCC=$ORDER(^AMHPROBC("B",AMHPC,0))
+9 IF 'AMHPCC
DO MES^XPDUTL("PROBLEM CODE MISSING: "_AMHPC_" CODE "_AMHCODE_" NOT UPLOADED")
+10 ;I AMHPCC S AMHPCC="`"_AMHPCC
+11 SET AMHICD=$PIECE(^AMHTPCAD(AMHX,0),U,5)
+12 SET AMHEHR=$PIECE(^AMHTPCAD(AMHX,0),U,15)
+13 SET AMHNOBH=$PIECE(^AMHTPCAD(AMHX,0),U,18)
+14 SET AMHCS=$PIECE(^AMHTPCAD(AMHX,0),U,10)
+15 ;FIND EXISTING AND OVERLAY
+16 ;S DA=""
+17 ;S AMHY=0 F S AMHY=$O(^AMHPROB("B",AMHCODE,AMHY)) Q:AMHY'=+AMHY!(DA) D
+18 ;.Q:$P(^AMHPROB(AMHY,0),U,10)'=5 ;ONLY DSMV
+19 ;.Q:$$UP^XLFSTR($P(^AMHPROB(AMHY,0),U,2))'=$$UP^XLFST(AMHNARR)
+20 ;.S DA=AMHY
+21 ;I DA D EDIT9
+22 ;ADD THEN EDIT
+23 KILL DIC,DLAYGO,DIADD,DD,D0
+24 SET DITC=1
+25 SET X=AMHCODE
SET DIC="^AMHPROB("
SET DLAYGO=9002012.2
SET DIADD=1
SET DIC(0)="EMQ"
+26 SET DIC("DR")=".02///"_AMHNARR_";.03////"_AMHPCC_";.05///"_AMHICD_";.1///"_AMHCS_";.15///"_AMHEHR_";.18///"_AMHNOBH
+27 DO FILE^DICN
+28 IF Y=-1
WRITE !,"ERROR ON ",AMHX," ",AMHCODE," ",DIC("DR")
+29 KILL DA,DIC,DIADD,DLAYGO,DR,DD,D0,DO,DITC
+30 QUIT
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")
+7 ;I AMHPCC S AMHPCC="`"_AMHPCC
+8 SET AMHICD=$PIECE(^AMHTPCAD(AMHX,0),U,17)
+9 SET AMHEHR=$PIECE(^AMHTPCAD(AMHX,0),U,15)
+10 SET AMHNOBH=$PIECE(^AMHTPCAD(AMHX,0),U,18)
+11 SET AMHCS=$PIECE(^AMHTPCAD(AMHX,0),U,10)
+12 ;FIND EXISTING AND OVERLAY
+13 ;S DA=""
+14 ;S AMHY=0 F S AMHY=$O(^AMHPROB("B",AMHCODE,AMHY)) Q:AMHY'=+AMHY!(DA) D
+15 ;.Q:$P(^AMHPROB(AMHY,0),U,10)'=5 ;ONLY DSMV
+16 ;.Q:$$UP^XLFSTR($P(^AMHPROB(AMHY,0),U,2))'=$$UP^XLFST(AMHNARR)
+17 ;.S DA=AMHY
+18 ;I DA D EDIT9
+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")
+26 KILL DA,DIC,DIADD,DLAYGO,DR,DD,D0,DO,DITC
+27 QUIT
End DoDot:1
+28 QUIT
FLAGTP ;
+1 ;FLAG ALL TP'S with "old format", .22 field = 1
+2 ;FIRST CHECK TO SEE IF THIS RAN ALREADY, IF IT DID QUIT
+3 IF $GET(AMHPAIN)
QUIT
+4 SET AMHX=0
FOR
SET AMHX=$ORDER(^AMHPTXP(AMHX))
IF AMHX'=+AMHX
QUIT
Begin DoDot:1
+5 SET DA=AMHX
SET DIE="^AMHPTXP("
SET DR=".22///1"
DO ^DIE
KILL DIE,DA,DR
+6 QUIT
End DoDot:1
+7 QUIT
FLAGOC ;FLAG ALL OTHER CODES AS DSV IV OR PC
+1 ;SKIP IF ALREADY FLAGGED
+2 SET AMHX=0
FOR
SET AMHX=$ORDER(^AMHPROB(AMHX))
IF AMHX'=+AMHX
QUIT
Begin DoDot:1
+3 IF $PIECE(^AMHPROB(AMHX,0),U,10)]""
QUIT
+4 SET C=$PIECE(^AMHPROB(AMHX,0),U,1)
SET S=""
SET T=""
+5 IF $PIECE(C,".")]""
IF $LENGTH($PIECE(C,"."))<3
SET S="P"
+6 IF S=""
Begin DoDot:2
+7 IF $TEXT(^ICDEX)]""
SET T=$PIECE($$ICDDX^ICDEX(C),U,20)
IF T=1
SET S=9
IF T=30
SET S=0
QUIT
+8 SET S=9
End DoDot:2
+9 SET DA=AMHX
SET DIE="^AMHPROB("
SET DR=".1///"_S
DO ^DIE
KILL DA,DIE,DR
+10 WRITE !,C," ",S
End DoDot:1
+11 QUIT
INACTPC ;
+1 SET AMHX=0
FOR
SET AMHX=$ORDER(^AMHPCIN(AMHX))
IF AMHX'=+AMHX
QUIT
Begin DoDot:1
+2 IF $PIECE(^AMHPCIN(AMHX,0),U,3)'=1
QUIT
+3 SET AMHC=$PIECE(^AMHPCIN(AMHX,0),U,1)
+4 ;loop through "B" on AMHPROB and flag all that are not already flagged to 4
+5 SET AMHY=0
FOR
SET AMHY=$ORDER(^AMHPROB("B",AMHC,AMHY))
IF AMHY'=+AMHY
QUIT
Begin DoDot:2
+6 IF '$DATA(^AMHPROB(AMHY,0))
QUIT
+7 ;already flagged
IF $PIECE(^AMHPROB(AMHY,0),U,13)
IF $PIECE(^AMHPROB(AMHY,0),U,14)]""
QUIT
+8 SET DA=AMHY
SET DIE="^AMHPROB("
SET DR=".13///1;.14////"_DT
DO ^DIE
KILL DA,DIE,DR
+9 ;W AMHC,"."
+10 QUIT
End DoDot:2
+11 QUIT
End DoDot:1
+12 QUIT
FLAG4 ;
+1 SET AMHX=0
FOR
SET AMHX=$ORDER(^AMHPCIN(AMHX))
IF AMHX'=+AMHX
QUIT
Begin DoDot:1
+2 IF $PIECE(^AMHPCIN(AMHX,0),U,2)'=1
QUIT
+3 SET AMHC=$PIECE(^AMHPCIN(AMHX,0),U,1)
+4 ;loop through "B" on AMHPROB and flag all that are not already flagged to 4
+5 SET AMHY=0
FOR
SET AMHY=$ORDER(^AMHPROB("B",AMHC,AMHY))
IF AMHY'=+AMHY
QUIT
Begin DoDot:2
+6 IF '$DATA(^AMHPROB(AMHY,0))
QUIT
+7 ;already flagged
IF $PIECE(^AMHPROB(AMHY,0),U,10)]""
QUIT
+8 SET DA=AMHY
SET DIE="^AMHPROB("
SET DR=".1///4"
DO ^DIE
KILL DA,DIE,DR
+9 ;W AMHC,"."
+10 QUIT
End DoDot:2
+11 QUIT
End DoDot:1
+12 QUIT
BMXPO ;-- update the RPC file
+1 NEW AMHRPC
+2 SET AMHRPC=$ORDER(^DIC(19,"B","AMHGRPC",0))
+3 IF 'AMHRPC
QUIT
+4 DO CLEAN(AMHRPC)
+5 DO GUIEP^BMXPO(.RETVAL,AMHRPC_"|AMH")
+6 QUIT
+7 ;
CLEAN(APP) ;-- clean out the RPC multiple first
+1 SET DA(1)=APP
+2 SET DIK="^DIC(19,"_DA(1)_","_"""RPC"""_","
+3 NEW AMHDA
+4 SET AMHDA=0
FOR
SET AMHDA=$ORDER(^DIC(19,APP,"RPC",AMHDA))
IF 'AMHDA
QUIT
Begin DoDot:1
+5 SET DA=AMHDA
+6 DO ^DIK
End DoDot:1
+7 KILL ^DIC(19,APP,"RPC","B")
+8 QUIT
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
