AMHLEDEL ; IHS/CMI/LAB - DELETE BH RECORD ;
;;4.0;IHS BEHAVIORAL HEALTH;;MAY 14, 2010
;
EN ;EP
;
NEW X,Y,AMHX,AMHY,AMHGO
DELETE ;
S AMHGRP=$P(^AMHREC(AMHRDEL,0),U,34)
S AMHPAT=$P(^AMHREC(AMHRDEL,0),U,8)
Q:$$IINTAKE(AMHRDEL) ;quit if the visit has an initial intake with update documents
S AMHVFLE=9002011 F AMHVL=0:0 S AMHVFLE=$O(^DIC(AMHVFLE)) Q:AMHVFLE>9002011.49!(AMHVFLE'=+AMHVFLE) D DELETE2
S DA=$O(^AMHRCDST("B",AMHRDEL,0)) I DA S DIK="^AMHRCDST(" D ^DIK ;delete staging tool
S DIK="^AMHREC(",DA=AMHRDEL,X=2 D ^DIK K DA,DIK
I $G(AMHGRP) D GRPDEL(AMHRDEL,AMHPAT) ;cmi/maw added for group delete
D EOJ
Q
;
DELETE2 ;
I AMHVFLE=9002011.13 D INTAKE Q
S AMHVNM=$P(^DIC(AMHVFLE,0),U)
S AMHVDG=^DIC(AMHVFLE,0,"GL"),AMHVIGR=AMHVDG_"""AD"",AMHRDEL,AMHVDFN)"
S AMHVDFN="" F AMHVI=1:1 S AMHVDFN=$O(@AMHVIGR) Q:AMHVDFN="" W:'$D(ZTQUEUED) "." S DIK=AMHVDG,DA=AMHVDFN D ^DIK
Q
;
GRPDEL(REC,PAT) ;-- delete the group record and patient entry from group
N GDA
S GDA=0 F S GDA=$O(^AMHGROUP("AREC",REC,GDA)) Q:'GDA D
. S GIEN=0 F S GIEN=$O(^AMHGROUP("AREC",REC,GDA,GIEN)) Q:'GIEN D
.. D GRECDIK(GDA,GIEN)
.. D GPATDIK(PAT,GDA)
Q
;
GRECDIK(D,I) ;-- delete the record from the group 6101 multiple
S DA(1)=GDA
S DA=I
S DIK="^AMHGROUP("_DA(1)_",61,"
D ^DIK
Q
;
GPATDIK(PT,D) ;-- remove the patient from the group 5101 multiple
K DA
S DA=$O(^AMHGROUP(D,51,"B",PT,0))
Q:'DA
S DA(1)=D
S DIK="^AMHGROUP("_DA(1)_",51,"
D ^DIK
Q
;
EOJ ; EOJ CLEANUP
K AMHVDFN,AMHVDG,AMHRDEL,AMHVFLE,AMHVI,AMHVIGR,AMHVL,AMHVNM,AMHGRP,AMHPAT
K %,X
K D,D0,DA,DIC,DICR,DIE,DIG,DIH,DIU,DIV,DIW,DQ,DR,DIK,DITC
Q
IINTAKE(R) ;EP - does this visit have an initial intake with updates?
NEW X,Y,G
S G=""
S X=0 F S X=$O(^AMHRINTK("AD",R,X)) Q:X'=+X!(G) D
.I $O(^AMHRINTK("AI",X,0)) S G=1
.Q
Q G
INTAKE ;
Q ;;NO VISIT LINK ANYMORE
S (C,AMHX)=0 F S AMHX=$O(^AMHRINTK("AD",AMHRDEL,AMHX)) Q:AMHX'=+AMHX D
.I $P(^AMHRINTK(AMHX,0),U,3)=AMHRDEL D
..S DITC=1,DIE="^AMHRINTK(",DA=AMHX,DR=".03///@" D ^DIE K DIE,DA,DR,DITC
..S Z=$O(^AMHRINTK(AMHX,11,"B",AMHRDEL,0)) I 'Z Q
..S DIE="^AMHRINTK("_AMHX_",11,",DA(1)=AMHX,DA=Z,DR=".01///@" D ^DIE K DIE,DA,DR,DITC
.S AMHY=0 F S AMHY=$O(^AMHRINTK("AD",AMHRDEL,AMHX,AMHY)) Q:AMHY'=+AMHY D
..I $P(^AMHRINTK(AMHX,11,AMHY,0),U)=AMHRDEL S DIE="^AMHRINTK("_AMHX_",11,",DA(1)=AMHX,DA=AMHY,DR=".01///@" D ^DIE K DIE,DA,DR
.I $P(^AMHRINTK(AMHX,0),U,3)="",'$O(^AMHRINTK(AMHX,11,0)) S DIK="^AMHRINTK(",DA=AMHX D ^DIK Q
.Q:$P(^AMHRINTK(AMHX,0),U,3)
.S X=$O(^AMHRINTK(AMHX,11,0)),X=$P(^AMHRINTK(AMHX,11,X,0),U,1)
.S DA=AMHX,DIE="^AMHRINTK(",DITC=1,DR=".03////"_X D ^DIE K DIE,DA,DR,DITC
.Q
Q
AMHLEDEL ; IHS/CMI/LAB - DELETE BH RECORD ;
+1 ;;4.0;IHS BEHAVIORAL HEALTH;;MAY 14, 2010
+2 ;
EN ;EP
+1 ;
+2 NEW X,Y,AMHX,AMHY,AMHGO
DELETE ;
+1 SET AMHGRP=$PIECE(^AMHREC(AMHRDEL,0),U,34)
+2 SET AMHPAT=$PIECE(^AMHREC(AMHRDEL,0),U,8)
+3 ;quit if the visit has an initial intake with update documents
IF $$IINTAKE(AMHRDEL)
QUIT
+4 SET AMHVFLE=9002011
FOR AMHVL=0:0
SET AMHVFLE=$ORDER(^DIC(AMHVFLE))
IF AMHVFLE>9002011.49!(AMHVFLE'=+AMHVFLE)
QUIT
DO DELETE2
+5 ;delete staging tool
SET DA=$ORDER(^AMHRCDST("B",AMHRDEL,0))
IF DA
SET DIK="^AMHRCDST("
DO ^DIK
+6 SET DIK="^AMHREC("
SET DA=AMHRDEL
SET X=2
DO ^DIK
KILL DA,DIK
+7 ;cmi/maw added for group delete
IF $GET(AMHGRP)
DO GRPDEL(AMHRDEL,AMHPAT)
+8 DO EOJ
+9 QUIT
+10 ;
DELETE2 ;
+1 IF AMHVFLE=9002011.13
DO INTAKE
QUIT
+2 SET AMHVNM=$PIECE(^DIC(AMHVFLE,0),U)
+3 SET AMHVDG=^DIC(AMHVFLE,0,"GL")
SET AMHVIGR=AMHVDG_"""AD"",AMHRDEL,AMHVDFN)"
+4 SET AMHVDFN=""
FOR AMHVI=1:1
SET AMHVDFN=$ORDER(@AMHVIGR)
IF AMHVDFN=""
QUIT
IF '$DATA(ZTQUEUED)
WRITE "."
SET DIK=AMHVDG
SET DA=AMHVDFN
DO ^DIK
+5 QUIT
+6 ;
GRPDEL(REC,PAT) ;-- delete the group record and patient entry from group
+1 NEW GDA
+2 SET GDA=0
FOR
SET GDA=$ORDER(^AMHGROUP("AREC",REC,GDA))
IF 'GDA
QUIT
Begin DoDot:1
+3 SET GIEN=0
FOR
SET GIEN=$ORDER(^AMHGROUP("AREC",REC,GDA,GIEN))
IF 'GIEN
QUIT
Begin DoDot:2
+4 DO GRECDIK(GDA,GIEN)
+5 DO GPATDIK(PAT,GDA)
End DoDot:2
End DoDot:1
+6 QUIT
+7 ;
GRECDIK(D,I) ;-- delete the record from the group 6101 multiple
+1 SET DA(1)=GDA
+2 SET DA=I
+3 SET DIK="^AMHGROUP("_DA(1)_",61,"
+4 DO ^DIK
+5 QUIT
+6 ;
GPATDIK(PT,D) ;-- remove the patient from the group 5101 multiple
+1 KILL DA
+2 SET DA=$ORDER(^AMHGROUP(D,51,"B",PT,0))
+3 IF 'DA
QUIT
+4 SET DA(1)=D
+5 SET DIK="^AMHGROUP("_DA(1)_",51,"
+6 DO ^DIK
+7 QUIT
+8 ;
EOJ ; EOJ CLEANUP
+1 KILL AMHVDFN,AMHVDG,AMHRDEL,AMHVFLE,AMHVI,AMHVIGR,AMHVL,AMHVNM,AMHGRP,AMHPAT
+2 KILL %,X
+3 KILL D,D0,DA,DIC,DICR,DIE,DIG,DIH,DIU,DIV,DIW,DQ,DR,DIK,DITC
+4 QUIT
IINTAKE(R) ;EP - does this visit have an initial intake with updates?
+1 NEW X,Y,G
+2 SET G=""
+3 SET X=0
FOR
SET X=$ORDER(^AMHRINTK("AD",R,X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+4 IF $ORDER(^AMHRINTK("AI",X,0))
SET G=1
+5 QUIT
End DoDot:1
+6 QUIT G
INTAKE ;
+1 ;;NO VISIT LINK ANYMORE
QUIT
+2 SET (C,AMHX)=0
FOR
SET AMHX=$ORDER(^AMHRINTK("AD",AMHRDEL,AMHX))
IF AMHX'=+AMHX
QUIT
Begin DoDot:1
+3 IF $PIECE(^AMHRINTK(AMHX,0),U,3)=AMHRDEL
Begin DoDot:2
+4 SET DITC=1
SET DIE="^AMHRINTK("
SET DA=AMHX
SET DR=".03///@"
DO ^DIE
KILL DIE,DA,DR,DITC
+5 SET Z=$ORDER(^AMHRINTK(AMHX,11,"B",AMHRDEL,0))
IF 'Z
QUIT
+6 SET DIE="^AMHRINTK("_AMHX_",11,"
SET DA(1)=AMHX
SET DA=Z
SET DR=".01///@"
DO ^DIE
KILL DIE,DA,DR,DITC
End DoDot:2
+7 SET AMHY=0
FOR
SET AMHY=$ORDER(^AMHRINTK("AD",AMHRDEL,AMHX,AMHY))
IF AMHY'=+AMHY
QUIT
Begin DoDot:2
+8 IF $PIECE(^AMHRINTK(AMHX,11,AMHY,0),U)=AMHRDEL
SET DIE="^AMHRINTK("_AMHX_",11,"
SET DA(1)=AMHX
SET DA=AMHY
SET DR=".01///@"
DO ^DIE
KILL DIE,DA,DR
End DoDot:2
+9 IF $PIECE(^AMHRINTK(AMHX,0),U,3)=""
IF '$ORDER(^AMHRINTK(AMHX,11,0))
SET DIK="^AMHRINTK("
SET DA=AMHX
DO ^DIK
QUIT
+10 IF $PIECE(^AMHRINTK(AMHX,0),U,3)
QUIT
+11 SET X=$ORDER(^AMHRINTK(AMHX,11,0))
SET X=$PIECE(^AMHRINTK(AMHX,11,X,0),U,1)
+12 SET DA=AMHX
SET DIE="^AMHRINTK("
SET DITC=1
SET DR=".03////"_X
DO ^DIE
KILL DIE,DA,DR,DITC
+13 QUIT
End DoDot:1
+14 QUIT
