AMHPOST ; IHS/CMI/LAB - POST INIT BH ;
;;3.0;IHS BEHAVIORAL HEALTH;;JAN 27, 2003
;re-index all cross references on Designated provider fields
;
ENV ;EP
I $G(XPDENV)=1 S (XPDDIQ("XPZ1"),XPDDIQ("XPZ2"))=0
Q
;
PRE ;
;REMOVE IDENTIFIER NODES FOR FILEMAN 22
K ^DD(9002011.01,0,"ID")
K ^DD(9002011.02,0,"ID")
K ^DD(9002011.03,0,"ID")
K ^DD(9002011.04,0,"ID")
K ^DD(9002011.05,0,"ID")
S DIK="^DD(9002012.2,",DA=.04,DA(1)=9002012.2 D ^DIK
D ^AMHPREI
D ^AMHPREI1
D ^AMHPREI2
F DA=1:1:200 S DIK="^AMHSORT(" D ^DIK
S DA=$O(^AMHTSET("B","TELE-MENTAL HEALTH",0))
I DA S DIE="^AMHTSET(",DR=".02///15" D ^DIE K DA,DIE,DR
S DA=$O(^AMHTSET("B","RESIDENTIAL/DAY PROGRAM",0))
I DA S DIE="^AMHTSET(",DR=".01///RESIDENTIAL" D ^DIE
S DA=$O(^AMHTSET("B","OUTPATIENT CLINIC",0))
I DA S DIE="^AMHTSET(",DR=".01///OUTPATIENT" D ^DIE
S DA=$O(^DIC(19,"B","AMH DE ACT RECORD LOG",0)) I DA S DIK="^DIC(19," D ^DIK
S DA=$O(^DIC(19,"B","AMH E ADD CASE TRACKING",0)) I DA S DIK="^DIC(19," D ^DIK
S DA=$O(^DIC(19,"B","AMH DE PATIENT RELATED",0)) I DA S DIK="^DIC(19," D ^DIK
S DA=$O(^DIC(19,"B","AMH P TABLES TOC",0)) I DA S DIK="^DIC(19," D ^DIK
S DA=$O(^DIC(19,"B","AMH ENTER DNKA",0)) I DA S DIK="^DIC(19," D ^DIK
Q
POST ;EP
S DIK="^AMHRCDST(",DIK(1)=".02^AC" D ENALL^DIK
S DIK="^AMHPROB(",DIK(1)=".03^AC" D ENALL^DIK ;reindex problem ac index
K ^DD(9002012.2,.05,9)
PROB ;add problems, fix problems
G COM
P1 ;
I $D(^AMHPROB("B","302.85")) W !,"Code 302.85 already exists." G P2
S DIC="^AMHPROB(",X="302.85",DIC(0)="L",DIADD=1,DLAYGO=9002012.2,DIC("DR")=".02///GENDER IDENTITY DISORDER OF ADOLESCENT OR ADULT;.03///20;.05///302.85;.06///I" K DD,DO,D0 D FILE^DICN
I Y=-1 W !,"302.85 failed"
D ^XBFMK K DIADD,DLAYGO
P2 ;
I $D(^AMHPROB("B","50")) W !,"Code 50 already exists." G P3
S DIC="^AMHPROB(",X="50",DIC(0)="L",DIADD=1,DLAYGO=9002012.2,DIC("DR")=".02///TRAUMATIC BEREAVEMENT;.03///50;.05///V62.82;.08///1" K DD,DO,D0 D FILE^DICN
I Y=-1 W !,"50 failed"
D ^XBFMK K DIADD,DLAYGO
P3 ;
I $D(^AMHPROB("B","49.9")) W !,"Code 49.9 already exists." G P4
S DIC="^AMHPROB(",X="49.9",DIC(0)="L",DIADD=1,DLAYGO=9002012.2,DIC("DR")=".02///EXPLOITATION;.03///49.9;.05///V61.29" K DD,DO,D0 D FILE^DICN
I Y=-1 W !,"49.9 failed"
D ^XBFMK K DIADD,DLAYGO
P4 ;
I $D(^AMHPROB("B","47.1")) W !,"Code 47.1 already exists." G P5
S DIC="^AMHPROB(",X="47.1",DIC(0)="L",DIADD=1,DLAYGO=9002012.2,DIC("DR")=".02///CHILD NEGLECT (SUSPECTED), PHYSICAL;.03///47.1;.05///995.59;.08///1" K DD,DO,D0 D FILE^DICN
I Y=-1 W !,"47.1 failed"
D ^XBFMK K DIADD,DLAYGO
P5 ;
I $D(^AMHPROB("B","47.2")) W !,"Code 47.2 already exists." G P6
S DIC="^AMHPROB(",X="47.2",DIC(0)="L",DIADD=1,DLAYGO=9002012.2,DIC("DR")=".02///CHILD NEGLECT (SUSPECTED), MENTAL;.03///47.2;.05///995.51;.08///1" K DD,DO,D0 D FILE^DICN
I Y=-1 W !,"47.2 failed"
D ^XBFMK K DIADD,DLAYGO
P6 ;
I $D(^AMHPROB("B","48.1")) W !,"Code 48.1 already exists." G P7
S DIC="^AMHPROB(",X="48.1",DIC(0)="L",DIADD=1,DLAYGO=9002012.2,DIC("DR")=".02///ADULT NEGLECT (SUSPECTED), PHYSICAL;.03///48.1;.05///995.81;.08///1" K DD,DO,D0 D FILE^DICN
I Y=-1 W !,"48.1 failed"
D ^XBFMK K DIADD,DLAYGO
P7 ;
I $D(^AMHPROB("B","48.2")) W !,"Code 48.2 already exists." G P8
S DIC="^AMHPROB(",X="48.2",DIC(0)="L",DIADD=1,DLAYGO=9002012.2,DIC("DR")=".02///ADULT NEGLECT (SUSPECTED), MENTAL;.03///48.2;.05///995.82;.08///1" K DD,DO,D0 D FILE^DICN
I Y=-1 W !,"48.2 failed"
D ^XBFMK K DIADD,DLAYGO
P8 ;
I $D(^AMHPROB("B","49.1")) W !,"Code 49.1 already exists." G P9
S DIC="^AMHPROB(",X="49.1",DIC(0)="L",DIADD=1,DLAYGO=9002012.2,DIC("DR")=".02///PARTNER NEGLECT (SUSPECTED), PHYSICAL;.03///49.1;.05///995.81;.08///1" K DD,DO,D0 D FILE^DICN
I Y=-1 W !,"49.1 failed"
D ^XBFMK K DIADD,DLAYGO
P9 ;
I $D(^AMHPROB("B","49.2")) W !,"Code 49.2 already exists." G P10
S DIC="^AMHPROB(",X="49.2",DIC(0)="L",DIADD=1,DLAYGO=9002012.2,DIC("DR")=".02///PARTNER NEGLECT (SUSPECTED), MENTAL;.03///49.2;.05///995.82;.08///1" K DD,DO,D0 D FILE^DICN
I Y=-1 W !,"49.2 failed"
D ^XBFMK K DIADD,DLAYGO
P10 ;
I $D(^AMHPROB("B","312.39")) W !,"Code 312.39 already exists." G P11
S DIC="^AMHPROB(",X="312.39",DIC(0)="L",DIADD=1,DLAYGO=9002012.2,DIC("DR")=".02///IMPULSE CONTROL DIS NED;.03///26;.05///312.39;.06///I" K DD,DO,D0 D FILE^DICN
I Y=-1 W !,"312.39 failed"
D ^XBFMK K DIADD,DLAYGO
P11 ;
I $D(^AMHPROB("B","8.3")) W !,"Code 8.3 already exists." G FICD
S DIC="^AMHPROB(",X="8.3",DIC(0)="L",DIADD=1,DLAYGO=9002012.2,DIC("DR")=".02///DID NOT WAIT TO BE SEEN;.03///8.3;.05///V15.81" K DD,DO,D0 D FILE^DICN
I Y=-1 W !,"312.39 failed"
D ^XBFMK K DIADD,DLAYGO
FICD ;
S $P(^AMHPROB(492,0),U,5)=312.81
S $P(^AMHPROB(476,0),U,5)=312.82
S $P(^AMHPROB(477,0),U,5)=312.89
F AMHX=1:1 S AMHY=$T(ICDC+AMHX) Q:$P(AMHY,";;",2)="" D
.S D=$P(AMHY,";;",2),I=$P(AMHY,";;",3)
.S DA=$O(^AMHPROB("B",D,0))
.I 'DA W !!,"Updating ICD code for ",D," failed." Q
.S P=$O(^ICD9("AB",I,0)) I 'P W !,"Couldn't find ICD pointer value. ",D," ",I Q
.S DIE="^AMHPROB(",DR=".05///"_I D ^DIE
.W AMHY,!
.I $D(Y) W !,"Updating ICD code for ",D," failed die." Q
.K DIE,DA,DR
.Q
COM ;
NEW AMHX S AMHX=0 F S AMHX=$O(^AMHPATR(AMHX)) Q:AMHX'=+AMHX K ^AMHPATR(AMHX,31) W "."
S DIK="^AMHPATR(" D IXALL^DIK ;re index desg prov cross references
;move comment
S X=0 F S X=$O(^AMHREC(X)) Q:X'=+X D
.Q:'$D(^AMHREC(X,0))
.I $P(^AMHREC(X,0),U,17)=0 S $P(^AMHREC(X,0),U,17)=10
.Q:'$D(^AMHREC(X,12))
.S Y=^AMHREC(X,12)
.Q:Y=""
.Q:$D(^AMHREC(X,81,0))
.S ^AMHREC(X,81,0)="^^1^1^"_$P($P(^AMHREC(X,0),U),".")_"^"
.S ^AMHREC(X,81,1,0)=Y
.K ^AMHREC(X,12)
.Q
INTAKE ;convert intake documents
S AMHX=0 F S AMHX=$O(^AMHPINTK(AMHX)) Q:AMHX'=+AMHX D
.Q:$D(^AMHPINTK(AMHX,41)) ;already has open field
.S AMHC=0
.F AMHF=1100:100:2800 I $D(^DD(9002011.07,AMHF)),$O(^AMHPINTK(AMHX,$E(AMHF,1,2),0)) S AMHFN=$P(^DD(9002011.07,AMHF,0),U) D
..S AMHC=AMHC+1,^AMHPINTK(AMHX,41,AMHC,0)=AMHFN,AMHC=AMHC+1,^AMHPINTK(AMHX,41,AMHC,0)=""
..S AMHV=0 F S AMHV=$O(^AMHPINTK(AMHX,$E(AMHF,1,2),AMHV)) Q:AMHV'=+AMHV D
...S AMHC=AMHC+1,^AMHPINTK(AMHX,41,AMHC,0)=^AMHPINTK(AMHX,$E(AMHF,1,2),AMHV,0)
...Q
..S AMHC=AMHC+1,^AMHPINTK(AMHX,41,AMHC,0)=""
..Q
.S ^AMHPINTK(AMHX,41,0)="^^"_AMHC_"^"_AMHC_"^"_DT_"^^"
.Q
TP ;
S AMHTP=0 F S AMHTP=$O(^AMHPTXP(AMHTP)) Q:AMHTP'=+AMHTP D
.S AMHNEW=0
.I $O(^AMHPTXP(AMHTP,18,0)) S $P(^AMHPTXP(AMHTP,0),U,18)=1,$P(^AMHPTXP(AMHTP,0),U,19)=1
.Q:$P(^AMHPTXP(AMHTP,0),U,18)
.W ":",AMHTP
.;move axis I to wp
.S X=$G(^AMHPTXP(AMHTP,12))
.I X]"" S ^AMHPTXP(AMHTP,6,1,0)=X,^AMHPTXP(AMHTP,6,0)="^^1^1^"_DT
.S X=$G(^AMHPTXP(AMHTP,14))
.I X]"" S ^AMHPTXP(AMHTP,7,1,0)=X,^AMHPTXP(AMHTP,7,0)="^^1^1^"_DT
.S $P(^AMHPTXP(AMHTP,0),U,18)=1
.;move axis ii to wp
.S X=$G(^AMHPTXP(AMHTP,13))
.I X]"" S ^AMHPTXP(AMHTP,8,1,0)=X,^AMHPTXP(AMHTP,8,0)="^^1^1^"_DT
.;move nodes 3,4,5 to node 18
.S C=0 I $O(^AMHPTXP(AMHTP,3,0)) D
..;S C=C+1,^AMHPTXP(AMHTP,18,C,0)="PROBLEM DESCRIPTION"
..S X=0 F S X=$O(^AMHPTXP(AMHTP,3,X)) Q:X'=+X D
...S C=C+1,^AMHPTXP(AMHTP,18,C,0)=^AMHPTXP(AMHTP,3,X,0)
.I $O(^AMHPTXP(AMHTP,4,0)) D
..S C=C+2,^AMHPTXP(AMHTP,18,C,0)="GOALS"
..S X=0 F S X=$O(^AMHPTXP(AMHTP,4,X)) Q:X'=+X D
...S C=C+1,^AMHPTXP(AMHTP,18,C,0)=^AMHPTXP(AMHTP,4,X,0)
.I $O(^AMHPTXP(AMHTP,5,0)) D
..S C=C+2,^AMHPTXP(AMHTP,18,C,0)="OBJECTIVES"
..S X=0 F S X=$O(^AMHPTXP(AMHTP,3,X)) Q:X'=+X D
...S C=C+1,^AMHPTXP(AMHTP,18,C,0)=^AMHPTXP(AMHTP,3,X,0)
.K ^TMP($J,"AMHPOST1")
.D GUIR^XBLM("METHOD^AMHPOST1","^TMP($J,""AMHPOST1"",")
.S X=0 F S X=$O(^TMP($J,"AMHPOST1",X)) Q:X'=+X D
..S C=C+1
..S ^AMHPTXP(AMHTP,18,C,0)=^TMP($J,"AMHPOST1",X)
.S ^AMHPTXP(AMHTP,18,0)="^^"_C_"^"_C_"^"_DT_"^^"
.Q
TP2 ;convert again
S AMHC=0
S AMHXX=0 F S AMHXX=$O(^AMHPTXP(AMHXX)) Q:AMHXX'=+AMHXX D
.Q:$P(^AMHPTXP(AMHXX,0),U,19) ;converted 2nd time
.Q:$O(^AMHPTXP(AMHXX,18,1))
.K ^TMP($J,"AMHPOST1")
.D GUIR^XBLM("GATHER^AMHPOST1","^TMP($J,""AMHPOST1"",")
.S X=0,C=0 F S X=$O(^TMP($J,"AMHPOST1",X)) Q:X'=+X D
..S C=C+1
..S ^AMHPTXP(AMHXX,18,C,0)=^TMP($J,"AMHPOST1",X)
.S ^AMHPTXP(AMHXX,18,0)="^^"_C_"^"_C_"^"_DT_"^^"
.S AMHA=0 F S AMHA=$O(^AMHPTPP("AD",AMHXX,AMHA)) Q:AMHA'=+AMHA D
..S ^AMHPTXP(AMHXX,11)=$G(^AMHPTXP(AMHXX,11))_$P(^AMHPTPP(AMHA,0),U)_" "
..Q
.S $P(^AMHPTXP(AMHXX,0),U,19)=1 ;conversion 2
EDU ;fix education
S AMHXX=0 F S AMHXX=$O(^AMHREDU(AMHXX)) Q:AMHXX'=+AMHXX D
.S AMHV=$P(^AMHREDU(AMHXX,0),U,3)
.Q:'AMHV
.Q:$P(^AMHREDU(AMHXX,0),U,2)
.Q:'$D(^AMHREC(AMHV,0))
.S AMHP=$P(^AMHREC(AMHV,0),U,8)
.Q:'AMHP
.S DITC="",DIE="^AMHREDU(",DA=AMHXX,DR=".02////"_AMHP D ^DIE D ^XBFMK K DITC
FIXPROC ;
S AMHXX=0 F S AMHXX=$O(^AMHRPROC(AMHXX)) Q:AMHXX'=+AMHXX D
.S AMHV=$P(^AMHRPROC(AMHXX,0),U,3)
.Q:'AMHV
.Q:$P(^AMHRPROC(AMHXX,0),U,2)
.Q:'$D(^AMHREC(AMHV,0))
.S AMHP=$P(^AMHREC(AMHV,0),U,8)
.Q:'AMHP
.S DITC="",DIE="^AMHRPROC(",DA=AMHXX,DR=".02////"_AMHP D ^DIE D ^XBFMK K DITC
Q
ICDC ;;
;;2;;V62.4
;;294.1;;294.10
;;42;;V71.81
;;43;;V71.81
;;44;;V71.81
;;45;;V71.89
;;47;;V71.81
;;48;;V71.81
;;49;;V71.81
;;62;;V61.8
;;65;;V25.09
;;84;;V62.1
;;90;;V62.3
;;98;;V62.0
;;99;;V68.89
;;42.1;;V71.81
;;42.2;;V71.81
;;42.3;;V71.81
;;43.1;;V71.81
;;43.2;;V71.81
;;43.3;;V71.81
;;44.1;;V71.81
;;44.2;;V71.81
;;44.3;;V71.81
;;45.1;;V71.89
;;45.2;;V71.89
;;45.3;;V71.89
;;14;;296.20
;;16;;297.9
;;25;;312.89
;;46.1;;V62.83
;;995.5;;995.50
;;995.81;;995.80
;;46.2;;V15.41
;;294.8;;294.0
;;21.1;;292.9
;;290.3;;331.0
;;291.5;;291.89
;;312.82;;312.82
;;312.89;;312.9
;;314.9;;314.01
;;333.92;;333.92
;;54.1;;798.2
;;54.2;;V66.7
;;46.3;;V71.81
;;47.1;;V71.81
;;47.2;;V71.81
;;48.1;;V71.81
;;48.2;;V71.81
;;49.1;;V71.81
;;49.2;;V71.81
;;
;
;;
;
AMHPOST ; IHS/CMI/LAB - POST INIT BH ;
+1 ;;3.0;IHS BEHAVIORAL HEALTH;;JAN 27, 2003
+2 ;re-index all cross references on Designated provider fields
+3 ;
ENV ;EP
+1 IF $GET(XPDENV)=1
SET (XPDDIQ("XPZ1"),XPDDIQ("XPZ2"))=0
+2 QUIT
+3 ;
PRE ;
+1 ;REMOVE IDENTIFIER NODES FOR FILEMAN 22
+2 KILL ^DD(9002011.01,0,"ID")
+3 KILL ^DD(9002011.02,0,"ID")
+4 KILL ^DD(9002011.03,0,"ID")
+5 KILL ^DD(9002011.04,0,"ID")
+6 KILL ^DD(9002011.05,0,"ID")
+7 SET DIK="^DD(9002012.2,"
SET DA=.04
SET DA(1)=9002012.2
DO ^DIK
+8 DO ^AMHPREI
+9 DO ^AMHPREI1
+10 DO ^AMHPREI2
+11 FOR DA=1:1:200
SET DIK="^AMHSORT("
DO ^DIK
+12 SET DA=$ORDER(^AMHTSET("B","TELE-MENTAL HEALTH",0))
+13 IF DA
SET DIE="^AMHTSET("
SET DR=".02///15"
DO ^DIE
KILL DA,DIE,DR
+14 SET DA=$ORDER(^AMHTSET("B","RESIDENTIAL/DAY PROGRAM",0))
+15 IF DA
SET DIE="^AMHTSET("
SET DR=".01///RESIDENTIAL"
DO ^DIE
+16 SET DA=$ORDER(^AMHTSET("B","OUTPATIENT CLINIC",0))
+17 IF DA
SET DIE="^AMHTSET("
SET DR=".01///OUTPATIENT"
DO ^DIE
+18 SET DA=$ORDER(^DIC(19,"B","AMH DE ACT RECORD LOG",0))
IF DA
SET DIK="^DIC(19,"
DO ^DIK
+19 SET DA=$ORDER(^DIC(19,"B","AMH E ADD CASE TRACKING",0))
IF DA
SET DIK="^DIC(19,"
DO ^DIK
+20 SET DA=$ORDER(^DIC(19,"B","AMH DE PATIENT RELATED",0))
IF DA
SET DIK="^DIC(19,"
DO ^DIK
+21 SET DA=$ORDER(^DIC(19,"B","AMH P TABLES TOC",0))
IF DA
SET DIK="^DIC(19,"
DO ^DIK
+22 SET DA=$ORDER(^DIC(19,"B","AMH ENTER DNKA",0))
IF DA
SET DIK="^DIC(19,"
DO ^DIK
+23 QUIT
POST ;EP
+1 SET DIK="^AMHRCDST("
SET DIK(1)=".02^AC"
DO ENALL^DIK
+2 ;reindex problem ac index
SET DIK="^AMHPROB("
SET DIK(1)=".03^AC"
DO ENALL^DIK
+3 KILL ^DD(9002012.2,.05,9)
PROB ;add problems, fix problems
+1 GOTO COM
P1 ;
+1 IF $DATA(^AMHPROB("B","302.85"))
WRITE !,"Code 302.85 already exists."
GOTO P2
+2 SET DIC="^AMHPROB("
SET X="302.85"
SET DIC(0)="L"
SET DIADD=1
SET DLAYGO=9002012.2
SET DIC("DR")=".02///GENDER IDENTITY DISORDER OF ADOLESCENT OR ADULT;.03///20;.05///302.85;.06///I"
KILL DD,DO,D0
DO FILE^DICN
+3 IF Y=-1
WRITE !,"302.85 failed"
+4 DO ^XBFMK
KILL DIADD,DLAYGO
P2 ;
+1 IF $DATA(^AMHPROB("B","50"))
WRITE !,"Code 50 already exists."
GOTO P3
+2 SET DIC="^AMHPROB("
SET X="50"
SET DIC(0)="L"
SET DIADD=1
SET DLAYGO=9002012.2
SET DIC("DR")=".02///TRAUMATIC BEREAVEMENT;.03///50;.05///V62.82;.08///1"
KILL DD,DO,D0
DO FILE^DICN
+3 IF Y=-1
WRITE !,"50 failed"
+4 DO ^XBFMK
KILL DIADD,DLAYGO
P3 ;
+1 IF $DATA(^AMHPROB("B","49.9"))
WRITE !,"Code 49.9 already exists."
GOTO P4
+2 SET DIC="^AMHPROB("
SET X="49.9"
SET DIC(0)="L"
SET DIADD=1
SET DLAYGO=9002012.2
SET DIC("DR")=".02///EXPLOITATION;.03///49.9;.05///V61.29"
KILL DD,DO,D0
DO FILE^DICN
+3 IF Y=-1
WRITE !,"49.9 failed"
+4 DO ^XBFMK
KILL DIADD,DLAYGO
P4 ;
+1 IF $DATA(^AMHPROB("B","47.1"))
WRITE !,"Code 47.1 already exists."
GOTO P5
+2 SET DIC="^AMHPROB("
SET X="47.1"
SET DIC(0)="L"
SET DIADD=1
SET DLAYGO=9002012.2
SET DIC("DR")=".02///CHILD NEGLECT (SUSPECTED), PHYSICAL;.03///47.1;.05///995.59;.08///1"
KILL DD,DO,D0
DO FILE^DICN
+3 IF Y=-1
WRITE !,"47.1 failed"
+4 DO ^XBFMK
KILL DIADD,DLAYGO
P5 ;
+1 IF $DATA(^AMHPROB("B","47.2"))
WRITE !,"Code 47.2 already exists."
GOTO P6
+2 SET DIC="^AMHPROB("
SET X="47.2"
SET DIC(0)="L"
SET DIADD=1
SET DLAYGO=9002012.2
SET DIC("DR")=".02///CHILD NEGLECT (SUSPECTED), MENTAL;.03///47.2;.05///995.51;.08///1"
KILL DD,DO,D0
DO FILE^DICN
+3 IF Y=-1
WRITE !,"47.2 failed"
+4 DO ^XBFMK
KILL DIADD,DLAYGO
P6 ;
+1 IF $DATA(^AMHPROB("B","48.1"))
WRITE !,"Code 48.1 already exists."
GOTO P7
+2 SET DIC="^AMHPROB("
SET X="48.1"
SET DIC(0)="L"
SET DIADD=1
SET DLAYGO=9002012.2
SET DIC("DR")=".02///ADULT NEGLECT (SUSPECTED), PHYSICAL;.03///48.1;.05///995.81;.08///1"
KILL DD,DO,D0
DO FILE^DICN
+3 IF Y=-1
WRITE !,"48.1 failed"
+4 DO ^XBFMK
KILL DIADD,DLAYGO
P7 ;
+1 IF $DATA(^AMHPROB("B","48.2"))
WRITE !,"Code 48.2 already exists."
GOTO P8
+2 SET DIC="^AMHPROB("
SET X="48.2"
SET DIC(0)="L"
SET DIADD=1
SET DLAYGO=9002012.2
SET DIC("DR")=".02///ADULT NEGLECT (SUSPECTED), MENTAL;.03///48.2;.05///995.82;.08///1"
KILL DD,DO,D0
DO FILE^DICN
+3 IF Y=-1
WRITE !,"48.2 failed"
+4 DO ^XBFMK
KILL DIADD,DLAYGO
P8 ;
+1 IF $DATA(^AMHPROB("B","49.1"))
WRITE !,"Code 49.1 already exists."
GOTO P9
+2 SET DIC="^AMHPROB("
SET X="49.1"
SET DIC(0)="L"
SET DIADD=1
SET DLAYGO=9002012.2
SET DIC("DR")=".02///PARTNER NEGLECT (SUSPECTED), PHYSICAL;.03///49.1;.05///995.81;.08///1"
KILL DD,DO,D0
DO FILE^DICN
+3 IF Y=-1
WRITE !,"49.1 failed"
+4 DO ^XBFMK
KILL DIADD,DLAYGO
P9 ;
+1 IF $DATA(^AMHPROB("B","49.2"))
WRITE !,"Code 49.2 already exists."
GOTO P10
+2 SET DIC="^AMHPROB("
SET X="49.2"
SET DIC(0)="L"
SET DIADD=1
SET DLAYGO=9002012.2
SET DIC("DR")=".02///PARTNER NEGLECT (SUSPECTED), MENTAL;.03///49.2;.05///995.82;.08///1"
KILL DD,DO,D0
DO FILE^DICN
+3 IF Y=-1
WRITE !,"49.2 failed"
+4 DO ^XBFMK
KILL DIADD,DLAYGO
P10 ;
+1 IF $DATA(^AMHPROB("B","312.39"))
WRITE !,"Code 312.39 already exists."
GOTO P11
+2 SET DIC="^AMHPROB("
SET X="312.39"
SET DIC(0)="L"
SET DIADD=1
SET DLAYGO=9002012.2
SET DIC("DR")=".02///IMPULSE CONTROL DIS NED;.03///26;.05///312.39;.06///I"
KILL DD,DO,D0
DO FILE^DICN
+3 IF Y=-1
WRITE !,"312.39 failed"
+4 DO ^XBFMK
KILL DIADD,DLAYGO
P11 ;
+1 IF $DATA(^AMHPROB("B","8.3"))
WRITE !,"Code 8.3 already exists."
GOTO FICD
+2 SET DIC="^AMHPROB("
SET X="8.3"
SET DIC(0)="L"
SET DIADD=1
SET DLAYGO=9002012.2
SET DIC("DR")=".02///DID NOT WAIT TO BE SEEN;.03///8.3;.05///V15.81"
KILL DD,DO,D0
DO FILE^DICN
+3 IF Y=-1
WRITE !,"312.39 failed"
+4 DO ^XBFMK
KILL DIADD,DLAYGO
FICD ;
+1 SET $PIECE(^AMHPROB(492,0),U,5)=312.81
+2 SET $PIECE(^AMHPROB(476,0),U,5)=312.82
+3 SET $PIECE(^AMHPROB(477,0),U,5)=312.89
+4 FOR AMHX=1:1
SET AMHY=$TEXT(ICDC+AMHX)
IF $PIECE(AMHY,";;",2)=""
QUIT
Begin DoDot:1
+5 SET D=$PIECE(AMHY,";;",2)
SET I=$PIECE(AMHY,";;",3)
+6 SET DA=$ORDER(^AMHPROB("B",D,0))
+7 IF 'DA
WRITE !!,"Updating ICD code for ",D," failed."
QUIT
+8 SET P=$ORDER(^ICD9("AB",I,0))
IF 'P
WRITE !,"Couldn't find ICD pointer value. ",D," ",I
QUIT
+9 SET DIE="^AMHPROB("
SET DR=".05///"_I
DO ^DIE
+10 WRITE AMHY,!
+11 IF $DATA(Y)
WRITE !,"Updating ICD code for ",D," failed die."
QUIT
+12 KILL DIE,DA,DR
+13 QUIT
End DoDot:1
COM ;
+1 NEW AMHX
SET AMHX=0
FOR
SET AMHX=$ORDER(^AMHPATR(AMHX))
IF AMHX'=+AMHX
QUIT
KILL ^AMHPATR(AMHX,31)
WRITE "."
+2 ;re index desg prov cross references
SET DIK="^AMHPATR("
DO IXALL^DIK
+3 ;move comment
+4 SET X=0
FOR
SET X=$ORDER(^AMHREC(X))
IF X'=+X
QUIT
Begin DoDot:1
+5 IF '$DATA(^AMHREC(X,0))
QUIT
+6 IF $PIECE(^AMHREC(X,0),U,17)=0
SET $PIECE(^AMHREC(X,0),U,17)=10
+7 IF '$DATA(^AMHREC(X,12))
QUIT
+8 SET Y=^AMHREC(X,12)
+9 IF Y=""
QUIT
+10 IF $DATA(^AMHREC(X,81,0))
QUIT
+11 SET ^AMHREC(X,81,0)="^^1^1^"_$PIECE($PIECE(^AMHREC(X,0),U),".")_"^"
+12 SET ^AMHREC(X,81,1,0)=Y
+13 KILL ^AMHREC(X,12)
+14 QUIT
End DoDot:1
INTAKE ;convert intake documents
+1 SET AMHX=0
FOR
SET AMHX=$ORDER(^AMHPINTK(AMHX))
IF AMHX'=+AMHX
QUIT
Begin DoDot:1
+2 ;already has open field
IF $DATA(^AMHPINTK(AMHX,41))
QUIT
+3 SET AMHC=0
+4 FOR AMHF=1100:100:2800
IF $DATA(^DD(9002011.07,AMHF))
IF $ORDER(^AMHPINTK(AMHX,$EXTRACT(AMHF,1,2),0))
SET AMHFN=$PIECE(^DD(9002011.07,AMHF,0),U)
Begin DoDot:2
+5 SET AMHC=AMHC+1
SET ^AMHPINTK(AMHX,41,AMHC,0)=AMHFN
SET AMHC=AMHC+1
SET ^AMHPINTK(AMHX,41,AMHC,0)=""
+6 SET AMHV=0
FOR
SET AMHV=$ORDER(^AMHPINTK(AMHX,$EXTRACT(AMHF,1,2),AMHV))
IF AMHV'=+AMHV
QUIT
Begin DoDot:3
+7 SET AMHC=AMHC+1
SET ^AMHPINTK(AMHX,41,AMHC,0)=^AMHPINTK(AMHX,$EXTRACT(AMHF,1,2),AMHV,0)
+8 QUIT
End DoDot:3
+9 SET AMHC=AMHC+1
SET ^AMHPINTK(AMHX,41,AMHC,0)=""
+10 QUIT
End DoDot:2
+11 SET ^AMHPINTK(AMHX,41,0)="^^"_AMHC_"^"_AMHC_"^"_DT_"^^"
+12 QUIT
End DoDot:1
TP ;
+1 SET AMHTP=0
FOR
SET AMHTP=$ORDER(^AMHPTXP(AMHTP))
IF AMHTP'=+AMHTP
QUIT
Begin DoDot:1
+2 SET AMHNEW=0
+3 IF $ORDER(^AMHPTXP(AMHTP,18,0))
SET $PIECE(^AMHPTXP(AMHTP,0),U,18)=1
SET $PIECE(^AMHPTXP(AMHTP,0),U,19)=1
+4 IF $PIECE(^AMHPTXP(AMHTP,0),U,18)
QUIT
+5 WRITE ":",AMHTP
+6 ;move axis I to wp
+7 SET X=$GET(^AMHPTXP(AMHTP,12))
+8 IF X]""
SET ^AMHPTXP(AMHTP,6,1,0)=X
SET ^AMHPTXP(AMHTP,6,0)="^^1^1^"_DT
+9 SET X=$GET(^AMHPTXP(AMHTP,14))
+10 IF X]""
SET ^AMHPTXP(AMHTP,7,1,0)=X
SET ^AMHPTXP(AMHTP,7,0)="^^1^1^"_DT
+11 SET $PIECE(^AMHPTXP(AMHTP,0),U,18)=1
+12 ;move axis ii to wp
+13 SET X=$GET(^AMHPTXP(AMHTP,13))
+14 IF X]""
SET ^AMHPTXP(AMHTP,8,1,0)=X
SET ^AMHPTXP(AMHTP,8,0)="^^1^1^"_DT
+15 ;move nodes 3,4,5 to node 18
+16 SET C=0
IF $ORDER(^AMHPTXP(AMHTP,3,0))
Begin DoDot:2
+17 ;S C=C+1,^AMHPTXP(AMHTP,18,C,0)="PROBLEM DESCRIPTION"
+18 SET X=0
FOR
SET X=$ORDER(^AMHPTXP(AMHTP,3,X))
IF X'=+X
QUIT
Begin DoDot:3
+19 SET C=C+1
SET ^AMHPTXP(AMHTP,18,C,0)=^AMHPTXP(AMHTP,3,X,0)
End DoDot:3
End DoDot:2
+20 IF $ORDER(^AMHPTXP(AMHTP,4,0))
Begin DoDot:2
+21 SET C=C+2
SET ^AMHPTXP(AMHTP,18,C,0)="GOALS"
+22 SET X=0
FOR
SET X=$ORDER(^AMHPTXP(AMHTP,4,X))
IF X'=+X
QUIT
Begin DoDot:3
+23 SET C=C+1
SET ^AMHPTXP(AMHTP,18,C,0)=^AMHPTXP(AMHTP,4,X,0)
End DoDot:3
End DoDot:2
+24 IF $ORDER(^AMHPTXP(AMHTP,5,0))
Begin DoDot:2
+25 SET C=C+2
SET ^AMHPTXP(AMHTP,18,C,0)="OBJECTIVES"
+26 SET X=0
FOR
SET X=$ORDER(^AMHPTXP(AMHTP,3,X))
IF X'=+X
QUIT
Begin DoDot:3
+27 SET C=C+1
SET ^AMHPTXP(AMHTP,18,C,0)=^AMHPTXP(AMHTP,3,X,0)
End DoDot:3
End DoDot:2
+28 KILL ^TMP($JOB,"AMHPOST1")
+29 DO GUIR^XBLM("METHOD^AMHPOST1","^TMP($J,""AMHPOST1"",")
+30 SET X=0
FOR
SET X=$ORDER(^TMP($JOB,"AMHPOST1",X))
IF X'=+X
QUIT
Begin DoDot:2
+31 SET C=C+1
+32 SET ^AMHPTXP(AMHTP,18,C,0)=^TMP($JOB,"AMHPOST1",X)
End DoDot:2
+33 SET ^AMHPTXP(AMHTP,18,0)="^^"_C_"^"_C_"^"_DT_"^^"
+34 QUIT
End DoDot:1
TP2 ;convert again
+1 SET AMHC=0
+2 SET AMHXX=0
FOR
SET AMHXX=$ORDER(^AMHPTXP(AMHXX))
IF AMHXX'=+AMHXX
QUIT
Begin DoDot:1
+3 ;converted 2nd time
IF $PIECE(^AMHPTXP(AMHXX,0),U,19)
QUIT
+4 IF $ORDER(^AMHPTXP(AMHXX,18,1))
QUIT
+5 KILL ^TMP($JOB,"AMHPOST1")
+6 DO GUIR^XBLM("GATHER^AMHPOST1","^TMP($J,""AMHPOST1"",")
+7 SET X=0
SET C=0
FOR
SET X=$ORDER(^TMP($JOB,"AMHPOST1",X))
IF X'=+X
QUIT
Begin DoDot:2
+8 SET C=C+1
+9 SET ^AMHPTXP(AMHXX,18,C,0)=^TMP($JOB,"AMHPOST1",X)
End DoDot:2
+10 SET ^AMHPTXP(AMHXX,18,0)="^^"_C_"^"_C_"^"_DT_"^^"
+11 SET AMHA=0
FOR
SET AMHA=$ORDER(^AMHPTPP("AD",AMHXX,AMHA))
IF AMHA'=+AMHA
QUIT
Begin DoDot:2
+12 SET ^AMHPTXP(AMHXX,11)=$GET(^AMHPTXP(AMHXX,11))_$PIECE(^AMHPTPP(AMHA,0),U)_" "
+13 QUIT
End DoDot:2
+14 ;conversion 2
SET $PIECE(^AMHPTXP(AMHXX,0),U,19)=1
End DoDot:1
EDU ;fix education
+1 SET AMHXX=0
FOR
SET AMHXX=$ORDER(^AMHREDU(AMHXX))
IF AMHXX'=+AMHXX
QUIT
Begin DoDot:1
+2 SET AMHV=$PIECE(^AMHREDU(AMHXX,0),U,3)
+3 IF 'AMHV
QUIT
+4 IF $PIECE(^AMHREDU(AMHXX,0),U,2)
QUIT
+5 IF '$DATA(^AMHREC(AMHV,0))
QUIT
+6 SET AMHP=$PIECE(^AMHREC(AMHV,0),U,8)
+7 IF 'AMHP
QUIT
+8 SET DITC=""
SET DIE="^AMHREDU("
SET DA=AMHXX
SET DR=".02////"_AMHP
DO ^DIE
DO ^XBFMK
KILL DITC
End DoDot:1
FIXPROC ;
+1 SET AMHXX=0
FOR
SET AMHXX=$ORDER(^AMHRPROC(AMHXX))
IF AMHXX'=+AMHXX
QUIT
Begin DoDot:1
+2 SET AMHV=$PIECE(^AMHRPROC(AMHXX,0),U,3)
+3 IF 'AMHV
QUIT
+4 IF $PIECE(^AMHRPROC(AMHXX,0),U,2)
QUIT
+5 IF '$DATA(^AMHREC(AMHV,0))
QUIT
+6 SET AMHP=$PIECE(^AMHREC(AMHV,0),U,8)
+7 IF 'AMHP
QUIT
+8 SET DITC=""
SET DIE="^AMHRPROC("
SET DA=AMHXX
SET DR=".02////"_AMHP
DO ^DIE
DO ^XBFMK
KILL DITC
End DoDot:1
+9 QUIT
ICDC ;;
+1 ;;2;;V62.4
+2 ;;294.1;;294.10
+3 ;;42;;V71.81
+4 ;;43;;V71.81
+5 ;;44;;V71.81
+6 ;;45;;V71.89
+7 ;;47;;V71.81
+8 ;;48;;V71.81
+9 ;;49;;V71.81
+10 ;;62;;V61.8
+11 ;;65;;V25.09
+12 ;;84;;V62.1
+13 ;;90;;V62.3
+14 ;;98;;V62.0
+15 ;;99;;V68.89
+16 ;;42.1;;V71.81
+17 ;;42.2;;V71.81
+18 ;;42.3;;V71.81
+19 ;;43.1;;V71.81
+20 ;;43.2;;V71.81
+21 ;;43.3;;V71.81
+22 ;;44.1;;V71.81
+23 ;;44.2;;V71.81
+24 ;;44.3;;V71.81
+25 ;;45.1;;V71.89
+26 ;;45.2;;V71.89
+27 ;;45.3;;V71.89
+28 ;;14;;296.20
+29 ;;16;;297.9
+30 ;;25;;312.89
+31 ;;46.1;;V62.83
+32 ;;995.5;;995.50
+33 ;;995.81;;995.80
+34 ;;46.2;;V15.41
+35 ;;294.8;;294.0
+36 ;;21.1;;292.9
+37 ;;290.3;;331.0
+38 ;;291.5;;291.89
+39 ;;312.82;;312.82
+40 ;;312.89;;312.9
+41 ;;314.9;;314.01
+42 ;;333.92;;333.92
+43 ;;54.1;;798.2
+44 ;;54.2;;V66.7
+45 ;;46.3;;V71.81
+46 ;;47.1;;V71.81
+47 ;;47.2;;V71.81
+48 ;;48.1;;V71.81
+49 ;;48.2;;V71.81
+50 ;;49.1;;V71.81
+51 ;;49.2;;V71.81
+52 ;;
+53 ;
+54 ;;
+55 ;
