AMHCDBL1 ; IHS/CMI/LAB - backload pcc visits ;
;;4.0;IHS BEHAVIORAL HEALTH;;MAY 14, 2010
;
;backfill BH with CDMIS Data
IN ;EP
;create MHSS record first
S AMHCDST=$O(^ACDIIF("C",AMHIEN,0))
I 'AMHCDST W !!,"INITIAL entry not complete, skipping ",AMHIEN Q
I $E(AMHDATE,6,7)="00" S AMHDATE=$E(AMHDATE,1,5)_"01"
K DIC S DIC(0)="EL",DIC="^AMHREC(",DLAYGO=9002011,DIADD=1,X=AMHDATE,DIC("DR")=".02///C;.03///^S X=DT;.19////"_DUZ_";.33////R;.28////"_DUZ_";.22///A;.21///^S X=DT"
K DD,DO,D0 D FILE^DICN K DIC,DR,DIE,DIADD,DLAYGO,X,D0
I Y=-1 W !!,$C(7),$C(7),"Error creating Behavioral Health Record!! Deleting Record.",! Q
S AMHR=+Y,DIE="^AMHREC(",DA=AMHR,DR="5100///NOW",DR(2,9002011.5101)=".02////^S X=DUZ" D ^DIE K DIE,DA,DR
S AMHTIME=$P($G(^ACDIIF(AMHCDST,0)),U,6) S AMHTIME=AMHTIME*60 I 'AMHTIME S AMHTIME=1
S DIE="^AMHREC(",DA=AMHR
S DR=".04////"_AMHLOC_";.05////"_AMHDCOM_";.06///"_AMHACT_";.07///"_$S(AMHCOMP="PRIMARY RESID":11,1:2)_";.08////"_AMHPAT_";.09///1;1101///"_AMHCOMP_";.12///"_AMHTIME_";.25///43;.32///"_AMHTC_";1105///"_AMHCOMT,DIE="^AMHREC(" D ^DIE
I $D(Y) W !!,"error editing MHSS Record entry ",AMHIEN," ",AMHMIEN
;get initial entry and file activity time and mhss staging tool entry, get problem for later use
S AMHSTR0=^ACDIIF(AMHCDST,0)
K AMHPROB
S AMHPROB(1)=$P(AMHSTR0,U)_U_$P(^ACDPROB($P(AMHSTR0,U),0),U)_U_$P(^ACDPROB($P(AMHSTR0,U),0),U,2)
;S ^TMP($J,"ACDCONV",AMHPAT,9999999-AMHDATE)=AMHPROB(1)
S AMHC=1
S X=0 F S X=$O(^ACDIIF(AMHCDST,3,X)) Q:X'=+X D
.S AMHC=AMHC+1
.S P=$P(^ACDIIF(AMHCDST,3,X,0),U)
.S N="" I $P(^ACDIIF(AMHCDST,3,X,0),U,2)]"" S N=$P(^ACDIIF(AMHCDST,3,X,0),U,2)]""
.I N="" S N=$P(^ACDPROB(P,0),U)
.S AMHPROB(AMHC)=P_U_N_U_$P(^ACDPROB(P,0),U,2)
.Q
D PROBCONV
D ^XBFMK
I AMHTC="IR"!(AMHTC="OT") G PROVPOV
S X=AMHR,DIC("DR")=".02////"_AMHPAT_";.03////"_$P(AMHPROB(1),U,5)_";.04////"_DT_";.05////"_DUZ_";.19///"_AMHTC,DIC="^AMHRCDST(",DIC(0)="MLQ",DIADD=1,DLAYGO=9002011.06
K DD,DO D FILE^DICN K DIC,DA,DO,DD,D0,DG,DH,DI,DIW,DIU,DIADD,DIE,DQ,DLAYGO
I Y=-1 W !!,"Creating STAGING TOOL entry failed!!!",$C(7),$C(7) H 2
S AMHSTIEN=+Y
S $P(^AMHRCDST(AMHSTIEN,0),U,6)=$P(AMHSTR0,U,4)
S $P(^AMHRCDST(AMHSTIEN,0),U,7)=$P(AMHSTR0,U,5)
S $P(^AMHRCDST(AMHSTIEN,0),U,8)=$P(AMHSTR0,U,7)
S $P(^AMHRCDST(AMHSTIEN,0),U,9)=$P(AMHSTR0,U,8)
S $P(^AMHRCDST(AMHSTIEN,0),U,12)=$P(AMHSTR0,U,10)
S $P(^AMHRCDST(AMHSTIEN,0),U,13)=$P(AMHSTR0,U,11)
S $P(^AMHRCDST(AMHSTIEN,0),U,14)=$P(AMHSTR0,U,12)
S $P(^AMHRCDST(AMHSTIEN,0),U,15)=$P(AMHSTR0,U,13)
S $P(^AMHRCDST(AMHSTIEN,0),U,16)=$P(AMHSTR0,U,14)
S $P(^AMHRCDST(AMHSTIEN,0),U,17)=$P(AMHSTR0,U,15)
S $P(^AMHRCDST(AMHSTIEN,0),U,18)=$P(AMHSTR0,U,22)
S (AMHRCOMP,AMHACOMP,AMHDIFF)=""
S X=$$VAL^XBDIQ1(9002170,AMHCDST,15)
I X]"" S AMHRCOMP=$O(^AMHTCOMP("B",X,0))
S X=$$VAL^XBDIQ1(9002170,AMHCDST,17)
I X]"" S AMHACOMP=$O(^AMHTCOMP("B",X,0))
S X=$$VAL^XBDIQ1(9002170,AMHCDST,19)
I X]"" S AMHDIFF=$O(^AMHTCDDR("B",X,0))
S $P(^AMHRCDST(AMHSTIEN,0),U,21)=AMHRCOMP
S $P(^AMHRCDST(AMHSTIEN,0),U,22)=AMHACOMP
S $P(^AMHRCDST(AMHSTIEN,0),U,23)=AMHDIFF
S DA=AMHSTIEN,DIK="^AMHRCDST(" D IX1^DIK K DA,DIK
D ^XBFMK
PROVPOV ;now create pov/provider
S X=AMHPROV,DIC("DR")=".02////"_AMHPAT_";.03////"_AMHR_";.04///P",DIC="^AMHRPROV(",DIC(0)="MLQ",DIADD=1,DLAYGO=9002011.02
K DD,DO D FILE^DICN K DIC,DA,DO,DD,D0,DG,DH,DI,DIW,DIU,DIADD,DIE,DQ,DLAYGO
I Y=-1 W !!,"Creating Primary Provider entry failed!!!",$C(7),$C(7) H 2
D ^XBFMK
;now create POV
S AMHX=0 F S AMHX=$O(AMHPROB(AMHX)) Q:AMHX'=+AMHX D
.S X=$P(AMHPROB(AMHX),U,5),DIC("DR")=".02////"_AMHPAT_";.03////"_AMHR_";.04///"_$P(AMHPROB(AMHX),U,2),DIC="^AMHRPRO(",DIC(0)="MLQ",DIADD=1,DLAYGO=9002011.01 K DD,DO D FILE^DICN K DIC,DA,DO,DD,D0,DG,DH,DI,DIW,DIU,DIADD,DIE,DQ,DLAYGO
.I Y=-1 W !!,"Creating POV entry failed!!!",$C(7),$C(7) H 2
.D ^XBFMK
D PCCLINK^AMHCDBL
S AMHCDVS=AMHCDVS+1
Q
TD ;EP
;create MHSS record first
S AMHCDST=$O(^ACDTDC("C",AMHIEN,0))
I 'AMHCDST W !!,"TDC entry not complete, skipping ",AMHIEN Q
I $E(AMHDATE,6,7)="00" S AMHDATE=$E(AMHDATE,1,5)_"01"
K DIC S DIC(0)="EL",DIC="^AMHREC(",DLAYGO=9002011,DIADD=1,X=AMHDATE,DIC("DR")=".02///C;.03///^S X=DT;.19////"_DUZ_";.33////R;.28////"_DUZ_";.22///A;.21///^S X=DT"
K DD,DO,D0 D FILE^DICN K DIC,DR,DIE,DIADD,DLAYGO,X,D0
I Y=-1 W !!,$C(7),$C(7),"Error creating Behavioral Health Record!! Deleting Record.",! Q
S AMHR=+Y,DIE="^AMHREC(",DA=AMHR,DR="5100///NOW",DR(2,9002011.5101)=".02////^S X=DUZ" D ^DIE K DIE,DA,DR
S AMHTIME=$P($G(^ACDTDC(AMHCDST,0)),U,29) S AMHTIME=AMHTIME*60 I 'AMHTIME S AMHTIME=1
S DIE="^AMHREC(",DA=AMHR,DR=".04////"_AMHLOC_";.05////"_AMHDCOM_";.06///"_AMHACT_";.07///2;.08////"_AMHPAT_";.09///1;1101///"_AMHCOMP_";.12///"_AMHTIME_";.25///43;.32///"_AMHTC_";1105///"_AMHCOMT,DIE="^AMHREC(" D ^DIE
I $D(Y) W !!,"error editing MHSS Record entry ",AMHIEN," ",AMHMIEN
;get initial entry and file activity time and mhss staging tool entry, get problem for later use
S AMHSTR0=^ACDTDC(AMHCDST,0)
K AMHPROB
I '$P(AMHSTR0,U,27) W !,"no primary problem on discharge ",AMHIEN," ",AMHCDST S AMHC=0 G N
S AMHPROB(1)=$P(AMHSTR0,U,27)_U_$P(^ACDPROB($P(AMHSTR0,U,27),0),U)_U_$P(^ACDPROB($P(AMHSTR0,U,27),0),U,2)
S AMHC=1
N ;
S X=0 F S X=$O(^ACDTDC(AMHCDST,3,X)) Q:X'=+X D
.S AMHC=AMHC+1
.S P=$P(^ACDTDC(AMHCDST,3,X,0),U)
.S N="" I $P(^ACDTDC(AMHCDST,3,X,0),U,2)]"" S N=$P(^ACDTDC(AMHCDST,3,X,0),U,2)]""
.I N="" S N=$P(^ACDPROB(P,0),U)
.S AMHPROB(AMHC)=P_U_N_U_$P(^ACDPROB(P,0),U,2)
.Q
D PROBCONV
D ^XBFMK
S X=AMHR,DIC("DR")=".02////"_AMHPAT_";.03////"_$P($G(AMHPROB(1)),U,5)_";.04////"_DT_";.05////"_DUZ_";.19///"_AMHTC,DIC="^AMHRCDST(",DIC(0)="MLQ",DIADD=1,DLAYGO=9002011.06
K DD,DO D FILE^DICN K DIC,DA,DO,DD,D0,DG,DH,DI,DIW,DIU,DIADD,DIE,DQ,DLAYGO
I Y=-1 W !!,"Creating STAGING TOOL entry failed!!!",$C(7),$C(7) H 2
S AMHSTIEN=+Y
S $P(^AMHRCDST(AMHSTIEN,0),U,6)=$P(AMHSTR0,U,4)
S $P(^AMHRCDST(AMHSTIEN,0),U,7)=$P(AMHSTR0,U,5)
S $P(^AMHRCDST(AMHSTIEN,0),U,8)=$P(AMHSTR0,U,7)
S $P(^AMHRCDST(AMHSTIEN,0),U,9)=$P(AMHSTR0,U,8)
S $P(^AMHRCDST(AMHSTIEN,0),U,12)=$P(AMHSTR0,U,10)
S $P(^AMHRCDST(AMHSTIEN,0),U,13)=$P(AMHSTR0,U,11)
S $P(^AMHRCDST(AMHSTIEN,0),U,14)=$P(AMHSTR0,U,12)
S $P(^AMHRCDST(AMHSTIEN,0),U,15)=$P(AMHSTR0,U,13)
S $P(^AMHRCDST(AMHSTIEN,0),U,16)=$P(AMHSTR0,U,14)
S $P(^AMHRCDST(AMHSTIEN,0),U,17)=$P(AMHSTR0,U,15)
S $P(^AMHRCDST(AMHSTIEN,0),U,18)=$P(AMHSTR0,U,22)
S (AMHRCOMP,AMHACOMP,AMHDIFF)=""
S X=$$VAL^XBDIQ1(9002171,AMHCDST,15)
I X]"" S AMHRCOMP=$O(^AMHTCOMP("B",X,0))
S X=$$VAL^XBDIQ1(9002171,AMHCDST,17)
I X]"" S AMHACOMP=$O(^AMHTCOMP("B",X,0))
S X=$$VAL^XBDIQ1(9002171,AMHCDST,19)
I X]"" S AMHDIFF=$O(^AMHTCDDR("B",X,0))
S $P(^AMHRCDST(AMHSTIEN,0),U,21)=AMHRCOMP
S $P(^AMHRCDST(AMHSTIEN,0),U,22)=AMHACOMP
S $P(^AMHRCDST(AMHSTIEN,0),U,23)=AMHDIFF
S DA=AMHSTIEN,DIK="^AMHRCDST(" D IX1^DIK K DA,DIK
D ^XBFMK
;now create pov/provider
S X=AMHPROV,DIC("DR")=".02////"_AMHPAT_";.03////"_AMHR_";.04///P",DIC="^AMHRPROV(",DIC(0)="MLQ",DIADD=1,DLAYGO=9002011.02
K DD,DO D FILE^DICN K DIC,DA,DO,DD,D0,DG,DH,DI,DIW,DIU,DIADD,DIE,DQ,DLAYGO
I Y=-1 W !!,"Creating Primary Provider entry failed!!!",$C(7),$C(7) H 2
D ^XBFMK
;now create POV
Q:'$D(AMHPROB)
S AMHX=0 F S AMHX=$O(AMHPROB(AMHX)) Q:AMHX'=+AMHX D
.S X=$P(AMHPROB(AMHX),U,5),DIC("DR")=".02////"_AMHPAT_";.03////"_AMHR_";.04///"_$P(AMHPROB(AMHX),U,2),DIC="^AMHRPRO(",DIC(0)="MLQ",DIADD=1,DLAYGO=9002011.01 K DD,DO D FILE^DICN K DIC,DA,DO,DD,D0,DG,DH,DI,DIW,DIU,DIADD,DIE,DQ,DLAYGO
.I Y=-1 W !!,"Creating POV entry failed!!!",$C(7),$C(7) H 2
.D ^XBFMK
D PCCLINK^AMHCDBL S AMHCDVS=AMHCDVS+1
Q
PROBCONV ;
S X=0 F S X=$O(AMHPROB(X)) Q:X'=+X S %=$$PCONV($P(AMHPROB(X),U,3)),$P(AMHPROB(X),U,4)=%,$P(AMHPROB(X),U,5)=$O(^AMHPROB("B",%,0))
Q
PCONV(P) ;
I P=17 Q 89
I P=1 Q 29
I P=18 Q 94
I P=30 Q 43
I P=2 Q 30
I P=42 Q 23
I P=16 Q 3
I P=36 Q 42.2
I P=40 Q 44.2
I P=32 Q 43.2
I P=12 Q 59
I P=14 Q 79
I P=60 Q 312.31
I P=61 Q 26
I P=44 Q 302.6
I P=53 Q 80
I P=3 Q "305.90"
I P=13 Q 88
I P=11 Q 56
I P=15 Q 5
I P=55 Q 3
I P="MIA" Q 8
I P=37 Q 47
I P=41 Q 48
I P=33 Q 49
I P=19 Q 82
I P=20 Q 26
I P=34 Q 42.1
I P=38 Q 44.1
I P=49 Q 66
I P=35 Q 42.3
I P=39 Q 44.3
I P=31 Q 43.3
I P=43 Q 302.9
I P=50 Q 62
I P=10 Q 304.83
I P=9 Q 62
I P=47 Q "40"
I P=48 Q 41
I P=46 Q 41
I P=45 Q 39
I P=29 Q "305.10"
Q ""
AMHCDBL1 ; IHS/CMI/LAB - backload pcc visits ;
+1 ;;4.0;IHS BEHAVIORAL HEALTH;;MAY 14, 2010
+2 ;
+3 ;backfill BH with CDMIS Data
IN ;EP
+1 ;create MHSS record first
+2 SET AMHCDST=$ORDER(^ACDIIF("C",AMHIEN,0))
+3 IF 'AMHCDST
WRITE !!,"INITIAL entry not complete, skipping ",AMHIEN
QUIT
+4 IF $EXTRACT(AMHDATE,6,7)="00"
SET AMHDATE=$EXTRACT(AMHDATE,1,5)_"01"
+5 KILL DIC
SET DIC(0)="EL"
SET DIC="^AMHREC("
SET DLAYGO=9002011
SET DIADD=1
SET X=AMHDATE
SET DIC("DR")=".02///C;.03///^S X=DT;.19////"_DUZ_";.33////R;.28////"_DUZ_";.22///A;.21///^S X=DT"
+6 KILL DD,DO,D0
DO FILE^DICN
KILL DIC,DR,DIE,DIADD,DLAYGO,X,D0
+7 IF Y=-1
WRITE !!,$CHAR(7),$CHAR(7),"Error creating Behavioral Health Record!! Deleting Record.",!
QUIT
+8 SET AMHR=+Y
SET DIE="^AMHREC("
SET DA=AMHR
SET DR="5100///NOW"
SET DR(2,9002011.5101)=".02////^S X=DUZ"
DO ^DIE
KILL DIE,DA,DR
+9 SET AMHTIME=$PIECE($GET(^ACDIIF(AMHCDST,0)),U,6)
SET AMHTIME=AMHTIME*60
IF 'AMHTIME
SET AMHTIME=1
+10 SET DIE="^AMHREC("
SET DA=AMHR
+11 SET DR=".04////"_AMHLOC_";.05////"_AMHDCOM_";.06///"_AMHACT_";.07///"_$SELECT(AMHCOMP="PRIMARY RESID":11,1:2)_";.08////"_AMHPAT_";.09///1;1101///"_AMHCOMP_";.12///"_AMHTIME_";.25///43;.32///"_AMHTC_";1105///"_AMHCOMT
SET DIE="^AMHREC("
DO ^DIE
+12 IF $DATA(Y)
WRITE !!,"error editing MHSS Record entry ",AMHIEN," ",AMHMIEN
+13 ;get initial entry and file activity time and mhss staging tool entry, get problem for later use
+14 SET AMHSTR0=^ACDIIF(AMHCDST,0)
+15 KILL AMHPROB
+16 SET AMHPROB(1)=$PIECE(AMHSTR0,U)_U_$PIECE(^ACDPROB($PIECE(AMHSTR0,U),0),U)_U_$PIECE(^ACDPROB($PIECE(AMHSTR0,U),0),U,2)
+17 ;S ^TMP($J,"ACDCONV",AMHPAT,9999999-AMHDATE)=AMHPROB(1)
+18 SET AMHC=1
+19 SET X=0
FOR
SET X=$ORDER(^ACDIIF(AMHCDST,3,X))
IF X'=+X
QUIT
Begin DoDot:1
+20 SET AMHC=AMHC+1
+21 SET P=$PIECE(^ACDIIF(AMHCDST,3,X,0),U)
+22 SET N=""
IF $PIECE(^ACDIIF(AMHCDST,3,X,0),U,2)]""
SET N=$PIECE(^ACDIIF(AMHCDST,3,X,0),U,2)]""
+23 IF N=""
SET N=$PIECE(^ACDPROB(P,0),U)
+24 SET AMHPROB(AMHC)=P_U_N_U_$PIECE(^ACDPROB(P,0),U,2)
+25 QUIT
End DoDot:1
+26 DO PROBCONV
+27 DO ^XBFMK
+28 IF AMHTC="IR"!(AMHTC="OT")
GOTO PROVPOV
+29 SET X=AMHR
SET DIC("DR")=".02////"_AMHPAT_";.03////"_$PIECE(AMHPROB(1),U,5)_";.04////"_DT_";.05////"_DUZ_";.19///"_AMHTC
SET DIC="^AMHRCDST("
SET DIC(0)="MLQ"
SET DIADD=1
SET DLAYGO=9002011.06
+30 KILL DD,DO
DO FILE^DICN
KILL DIC,DA,DO,DD,D0,DG,DH,DI,DIW,DIU,DIADD,DIE,DQ,DLAYGO
+31 IF Y=-1
WRITE !!,"Creating STAGING TOOL entry failed!!!",$CHAR(7),$CHAR(7)
HANG 2
+32 SET AMHSTIEN=+Y
+33 SET $PIECE(^AMHRCDST(AMHSTIEN,0),U,6)=$PIECE(AMHSTR0,U,4)
+34 SET $PIECE(^AMHRCDST(AMHSTIEN,0),U,7)=$PIECE(AMHSTR0,U,5)
+35 SET $PIECE(^AMHRCDST(AMHSTIEN,0),U,8)=$PIECE(AMHSTR0,U,7)
+36 SET $PIECE(^AMHRCDST(AMHSTIEN,0),U,9)=$PIECE(AMHSTR0,U,8)
+37 SET $PIECE(^AMHRCDST(AMHSTIEN,0),U,12)=$PIECE(AMHSTR0,U,10)
+38 SET $PIECE(^AMHRCDST(AMHSTIEN,0),U,13)=$PIECE(AMHSTR0,U,11)
+39 SET $PIECE(^AMHRCDST(AMHSTIEN,0),U,14)=$PIECE(AMHSTR0,U,12)
+40 SET $PIECE(^AMHRCDST(AMHSTIEN,0),U,15)=$PIECE(AMHSTR0,U,13)
+41 SET $PIECE(^AMHRCDST(AMHSTIEN,0),U,16)=$PIECE(AMHSTR0,U,14)
+42 SET $PIECE(^AMHRCDST(AMHSTIEN,0),U,17)=$PIECE(AMHSTR0,U,15)
+43 SET $PIECE(^AMHRCDST(AMHSTIEN,0),U,18)=$PIECE(AMHSTR0,U,22)
+44 SET (AMHRCOMP,AMHACOMP,AMHDIFF)=""
+45 SET X=$$VAL^XBDIQ1(9002170,AMHCDST,15)
+46 IF X]""
SET AMHRCOMP=$ORDER(^AMHTCOMP("B",X,0))
+47 SET X=$$VAL^XBDIQ1(9002170,AMHCDST,17)
+48 IF X]""
SET AMHACOMP=$ORDER(^AMHTCOMP("B",X,0))
+49 SET X=$$VAL^XBDIQ1(9002170,AMHCDST,19)
+50 IF X]""
SET AMHDIFF=$ORDER(^AMHTCDDR("B",X,0))
+51 SET $PIECE(^AMHRCDST(AMHSTIEN,0),U,21)=AMHRCOMP
+52 SET $PIECE(^AMHRCDST(AMHSTIEN,0),U,22)=AMHACOMP
+53 SET $PIECE(^AMHRCDST(AMHSTIEN,0),U,23)=AMHDIFF
+54 SET DA=AMHSTIEN
SET DIK="^AMHRCDST("
DO IX1^DIK
KILL DA,DIK
+55 DO ^XBFMK
PROVPOV ;now create pov/provider
+1 SET X=AMHPROV
SET DIC("DR")=".02////"_AMHPAT_";.03////"_AMHR_";.04///P"
SET DIC="^AMHRPROV("
SET DIC(0)="MLQ"
SET DIADD=1
SET DLAYGO=9002011.02
+2 KILL DD,DO
DO FILE^DICN
KILL DIC,DA,DO,DD,D0,DG,DH,DI,DIW,DIU,DIADD,DIE,DQ,DLAYGO
+3 IF Y=-1
WRITE !!,"Creating Primary Provider entry failed!!!",$CHAR(7),$CHAR(7)
HANG 2
+4 DO ^XBFMK
+5 ;now create POV
+6 SET AMHX=0
FOR
SET AMHX=$ORDER(AMHPROB(AMHX))
IF AMHX'=+AMHX
QUIT
Begin DoDot:1
+7 SET X=$PIECE(AMHPROB(AMHX),U,5)
SET DIC("DR")=".02////"_AMHPAT_";.03////"_AMHR_";.04///"_$PIECE(AMHPROB(AMHX),U,2)
SET DIC="^AMHRPRO("
SET DIC(0)="MLQ"
SET DIADD=1
SET DLAYGO=9002011.01
KILL DD,DO
DO FILE^DICN
KILL DIC,DA,DO,DD,D0,DG,DH,DI,DIW,DIU,DIADD,DIE,DQ,DLAYGO
+8 IF Y=-1
WRITE !!,"Creating POV entry failed!!!",$CHAR(7),$CHAR(7)
HANG 2
+9 DO ^XBFMK
End DoDot:1
+10 DO PCCLINK^AMHCDBL
+11 SET AMHCDVS=AMHCDVS+1
+12 QUIT
TD ;EP
+1 ;create MHSS record first
+2 SET AMHCDST=$ORDER(^ACDTDC("C",AMHIEN,0))
+3 IF 'AMHCDST
WRITE !!,"TDC entry not complete, skipping ",AMHIEN
QUIT
+4 IF $EXTRACT(AMHDATE,6,7)="00"
SET AMHDATE=$EXTRACT(AMHDATE,1,5)_"01"
+5 KILL DIC
SET DIC(0)="EL"
SET DIC="^AMHREC("
SET DLAYGO=9002011
SET DIADD=1
SET X=AMHDATE
SET DIC("DR")=".02///C;.03///^S X=DT;.19////"_DUZ_";.33////R;.28////"_DUZ_";.22///A;.21///^S X=DT"
+6 KILL DD,DO,D0
DO FILE^DICN
KILL DIC,DR,DIE,DIADD,DLAYGO,X,D0
+7 IF Y=-1
WRITE !!,$CHAR(7),$CHAR(7),"Error creating Behavioral Health Record!! Deleting Record.",!
QUIT
+8 SET AMHR=+Y
SET DIE="^AMHREC("
SET DA=AMHR
SET DR="5100///NOW"
SET DR(2,9002011.5101)=".02////^S X=DUZ"
DO ^DIE
KILL DIE,DA,DR
+9 SET AMHTIME=$PIECE($GET(^ACDTDC(AMHCDST,0)),U,29)
SET AMHTIME=AMHTIME*60
IF 'AMHTIME
SET AMHTIME=1
+10 SET DIE="^AMHREC("
SET DA=AMHR
SET DR=".04////"_AMHLOC_";.05////"_AMHDCOM_";.06///"_AMHACT_";.07///2;.08////"_AMHPAT_";.09///1;1101///"_AMHCOMP_";.12///"_AMHTIME_";.25///43;.32///"_AMHTC_";1105///"_AMHCOMT
SET DIE="^AMHREC("
DO ^DIE
+11 IF $DATA(Y)
WRITE !!,"error editing MHSS Record entry ",AMHIEN," ",AMHMIEN
+12 ;get initial entry and file activity time and mhss staging tool entry, get problem for later use
+13 SET AMHSTR0=^ACDTDC(AMHCDST,0)
+14 KILL AMHPROB
+15 IF '$PIECE(AMHSTR0,U,27)
WRITE !,"no primary problem on discharge ",AMHIEN," ",AMHCDST
SET AMHC=0
GOTO N
+16 SET AMHPROB(1)=$PIECE(AMHSTR0,U,27)_U_$PIECE(^ACDPROB($PIECE(AMHSTR0,U,27),0),U)_U_$PIECE(^ACDPROB($PIECE(AMHSTR0,U,27),0),U,2)
+17 SET AMHC=1
N ;
+1 SET X=0
FOR
SET X=$ORDER(^ACDTDC(AMHCDST,3,X))
IF X'=+X
QUIT
Begin DoDot:1
+2 SET AMHC=AMHC+1
+3 SET P=$PIECE(^ACDTDC(AMHCDST,3,X,0),U)
+4 SET N=""
IF $PIECE(^ACDTDC(AMHCDST,3,X,0),U,2)]""
SET N=$PIECE(^ACDTDC(AMHCDST,3,X,0),U,2)]""
+5 IF N=""
SET N=$PIECE(^ACDPROB(P,0),U)
+6 SET AMHPROB(AMHC)=P_U_N_U_$PIECE(^ACDPROB(P,0),U,2)
+7 QUIT
End DoDot:1
+8 DO PROBCONV
+9 DO ^XBFMK
+10 SET X=AMHR
SET DIC("DR")=".02////"_AMHPAT_";.03////"_$PIECE($GET(AMHPROB(1)),U,5)_";.04////"_DT_";.05////"_DUZ_";.19///"_AMHTC
SET DIC="^AMHRCDST("
SET DIC(0)="MLQ"
SET DIADD=1
SET DLAYGO=9002011.06
+11 KILL DD,DO
DO FILE^DICN
KILL DIC,DA,DO,DD,D0,DG,DH,DI,DIW,DIU,DIADD,DIE,DQ,DLAYGO
+12 IF Y=-1
WRITE !!,"Creating STAGING TOOL entry failed!!!",$CHAR(7),$CHAR(7)
HANG 2
+13 SET AMHSTIEN=+Y
+14 SET $PIECE(^AMHRCDST(AMHSTIEN,0),U,6)=$PIECE(AMHSTR0,U,4)
+15 SET $PIECE(^AMHRCDST(AMHSTIEN,0),U,7)=$PIECE(AMHSTR0,U,5)
+16 SET $PIECE(^AMHRCDST(AMHSTIEN,0),U,8)=$PIECE(AMHSTR0,U,7)
+17 SET $PIECE(^AMHRCDST(AMHSTIEN,0),U,9)=$PIECE(AMHSTR0,U,8)
+18 SET $PIECE(^AMHRCDST(AMHSTIEN,0),U,12)=$PIECE(AMHSTR0,U,10)
+19 SET $PIECE(^AMHRCDST(AMHSTIEN,0),U,13)=$PIECE(AMHSTR0,U,11)
+20 SET $PIECE(^AMHRCDST(AMHSTIEN,0),U,14)=$PIECE(AMHSTR0,U,12)
+21 SET $PIECE(^AMHRCDST(AMHSTIEN,0),U,15)=$PIECE(AMHSTR0,U,13)
+22 SET $PIECE(^AMHRCDST(AMHSTIEN,0),U,16)=$PIECE(AMHSTR0,U,14)
+23 SET $PIECE(^AMHRCDST(AMHSTIEN,0),U,17)=$PIECE(AMHSTR0,U,15)
+24 SET $PIECE(^AMHRCDST(AMHSTIEN,0),U,18)=$PIECE(AMHSTR0,U,22)
+25 SET (AMHRCOMP,AMHACOMP,AMHDIFF)=""
+26 SET X=$$VAL^XBDIQ1(9002171,AMHCDST,15)
+27 IF X]""
SET AMHRCOMP=$ORDER(^AMHTCOMP("B",X,0))
+28 SET X=$$VAL^XBDIQ1(9002171,AMHCDST,17)
+29 IF X]""
SET AMHACOMP=$ORDER(^AMHTCOMP("B",X,0))
+30 SET X=$$VAL^XBDIQ1(9002171,AMHCDST,19)
+31 IF X]""
SET AMHDIFF=$ORDER(^AMHTCDDR("B",X,0))
+32 SET $PIECE(^AMHRCDST(AMHSTIEN,0),U,21)=AMHRCOMP
+33 SET $PIECE(^AMHRCDST(AMHSTIEN,0),U,22)=AMHACOMP
+34 SET $PIECE(^AMHRCDST(AMHSTIEN,0),U,23)=AMHDIFF
+35 SET DA=AMHSTIEN
SET DIK="^AMHRCDST("
DO IX1^DIK
KILL DA,DIK
+36 DO ^XBFMK
+37 ;now create pov/provider
+38 SET X=AMHPROV
SET DIC("DR")=".02////"_AMHPAT_";.03////"_AMHR_";.04///P"
SET DIC="^AMHRPROV("
SET DIC(0)="MLQ"
SET DIADD=1
SET DLAYGO=9002011.02
+39 KILL DD,DO
DO FILE^DICN
KILL DIC,DA,DO,DD,D0,DG,DH,DI,DIW,DIU,DIADD,DIE,DQ,DLAYGO
+40 IF Y=-1
WRITE !!,"Creating Primary Provider entry failed!!!",$CHAR(7),$CHAR(7)
HANG 2
+41 DO ^XBFMK
+42 ;now create POV
+43 IF '$DATA(AMHPROB)
QUIT
+44 SET AMHX=0
FOR
SET AMHX=$ORDER(AMHPROB(AMHX))
IF AMHX'=+AMHX
QUIT
Begin DoDot:1
+45 SET X=$PIECE(AMHPROB(AMHX),U,5)
SET DIC("DR")=".02////"_AMHPAT_";.03////"_AMHR_";.04///"_$PIECE(AMHPROB(AMHX),U,2)
SET DIC="^AMHRPRO("
SET DIC(0)="MLQ"
SET DIADD=1
SET DLAYGO=9002011.01
KILL DD,DO
DO FILE^DICN
KILL DIC,DA,DO,DD,D0,DG,DH,DI,DIW,DIU,DIADD,DIE,DQ,DLAYGO
+46 IF Y=-1
WRITE !!,"Creating POV entry failed!!!",$CHAR(7),$CHAR(7)
HANG 2
+47 DO ^XBFMK
End DoDot:1
+48 DO PCCLINK^AMHCDBL
SET AMHCDVS=AMHCDVS+1
+49 QUIT
PROBCONV ;
+1 SET X=0
FOR
SET X=$ORDER(AMHPROB(X))
IF X'=+X
QUIT
SET %=$$PCONV($PIECE(AMHPROB(X),U,3))
SET $PIECE(AMHPROB(X),U,4)=%
SET $PIECE(AMHPROB(X),U,5)=$ORDER(^AMHPROB("B",%,0))
+2 QUIT
PCONV(P) ;
+1 IF P=17
QUIT 89
+2 IF P=1
QUIT 29
+3 IF P=18
QUIT 94
+4 IF P=30
QUIT 43
+5 IF P=2
QUIT 30
+6 IF P=42
QUIT 23
+7 IF P=16
QUIT 3
+8 IF P=36
QUIT 42.2
+9 IF P=40
QUIT 44.2
+10 IF P=32
QUIT 43.2
+11 IF P=12
QUIT 59
+12 IF P=14
QUIT 79
+13 IF P=60
QUIT 312.31
+14 IF P=61
QUIT 26
+15 IF P=44
QUIT 302.6
+16 IF P=53
QUIT 80
+17 IF P=3
QUIT "305.90"
+18 IF P=13
QUIT 88
+19 IF P=11
QUIT 56
+20 IF P=15
QUIT 5
+21 IF P=55
QUIT 3
+22 IF P="MIA"
QUIT 8
+23 IF P=37
QUIT 47
+24 IF P=41
QUIT 48
+25 IF P=33
QUIT 49
+26 IF P=19
QUIT 82
+27 IF P=20
QUIT 26
+28 IF P=34
QUIT 42.1
+29 IF P=38
QUIT 44.1
+30 IF P=49
QUIT 66
+31 IF P=35
QUIT 42.3
+32 IF P=39
QUIT 44.3
+33 IF P=31
QUIT 43.3
+34 IF P=43
QUIT 302.9
+35 IF P=50
QUIT 62
+36 IF P=10
QUIT 304.83
+37 IF P=9
QUIT 62
+38 IF P=47
QUIT "40"
+39 IF P=48
QUIT 41
+40 IF P=46
QUIT 41
+41 IF P=45
QUIT 39
+42 IF P=29
QUIT "305.10"
+43 QUIT ""
