AMHGVDEL ; IHS/CMI/MAW - GUI V FILE VISIT CREATION ;
;;4.0;IHS BEHAVIORAL HEALTH;**1**;JUN 18, 2010;Build 8
;;
TEST ;
D EN(.RETVAL,24609)
Q
EN(BPCARRAY,AMHR) ;EP CALL
S BPCERR="" ;,ZTQUEUED=""
;AMHR must be ien of MHSS RECORD that is to be deleted
D
.NEW AMHACTN
.S AMHACTN=4
.D CHECKREC Q:BPCERR'=""
.D DELETE
I BPCERR="" D MSG("1"),KILL Q
I BPCERR'="" D ERROR(BPCERR)
D KILL
Q
;
CHECKREC ;
I '$G(AMHR) S BPCERR="IEN MISSING" Q
I '$D(^AMHREC(AMHR)) S BPCERR="INVALID RECORD IEN PASSED" Q
Q
DELETE ;
S AMHVDLT=$P(^AMHREC(AMHR,0),U,16)
S AMHGRP=$P(^AMHREC(AMHR,0),U,34)
S AMHPAT=$P(^AMHREC(AMHR,0),U,8)
S AMHRDEL=AMHR
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,DI
I $G(AMHGRP) D GRPDEL(AMHR,AMHPAT)
D EOJ
;D PCCCHECK cmi/maw 2/2/2011 not needed v4.0p1
D PCCLINK
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
INTAKE ;
Q ;;
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
;
PCCCHECK ;check to see if link to pcc active, set AMHLPCC IF SO
K AMHLPCC
S (AMHLPCC,AMHLPCCT)=$P(^AMHSITE(DUZ(2),0),U,12) I AMHLPCC S AMHLPCC=AMHLPCC-1
I AMHLPCC="" S AMHLPCC=0 Q
Q:'AMHLPCC
I $D(^AUTTSITE(1,0)),$P(^(0),U,8)="Y",'$D(^APCCCTRL(DUZ(2),0))#2 S AMHLPCC=0 Q
S AMHPKG=$O(^DIC(9.4,"C","AMH",""))
I '$D(^APCCCTRL(DUZ(2),11,AMHPKG,0))#2 S AMHLPCC=0 Q
I $D(^AUTTSITE(1,0)),$P(^(0),U,8)="Y",$D(^APCCCTRL(DUZ(2),0))#2,$D(^APCCCTRL(DUZ(2),11,AMHPKG,0))#2,$P(^(0),U,2) S AMHLPCC=AMHLPCC
E S AMHLPCC=0
K AMHPKG
Q
PCCLINK ;EP - PCCLINK
;Q:'AMHLPCC ;quit if no pcc link v4.0p1 cmi/maw not needed 2/2/2011
I $G(AMHVDLT)="",AMHACTN=4 Q
S AMHBL=1
S APCDVDLT=$G(AMHVDLT) I APCDVDLT="" Q
D ^APCDVDLT K APCDVDLT,AMHBL
Q
;
ERROR(BPCX) ;
D MSG("-1"_$C(30)_BPCX)
Q
;
MSG(BPCX) ;
S BPCARRAY=BPCX
Q
;
;
KILL ;
K APCDALVR,BPCPARM,BPCERR,BPCVAL,AMHR,AMHACTN,AMHBL,AMHLPCC,AMHVDLT,AMHLPCCT,AMHVISIT
Q
AMHGVDEL ; IHS/CMI/MAW - GUI V FILE VISIT CREATION ;
+1 ;;4.0;IHS BEHAVIORAL HEALTH;**1**;JUN 18, 2010;Build 8
+2 ;;
TEST ;
+1 DO EN(.RETVAL,24609)
+2 QUIT
EN(BPCARRAY,AMHR) ;EP CALL
+1 ;,ZTQUEUED=""
SET BPCERR=""
+2 ;AMHR must be ien of MHSS RECORD that is to be deleted
+3 Begin DoDot:1
+4 NEW AMHACTN
+5 SET AMHACTN=4
+6 DO CHECKREC
IF BPCERR'=""
QUIT
+7 DO DELETE
End DoDot:1
+8 IF BPCERR=""
DO MSG("1")
DO KILL
QUIT
+9 IF BPCERR'=""
DO ERROR(BPCERR)
+10 DO KILL
+11 QUIT
+12 ;
CHECKREC ;
+1 IF '$GET(AMHR)
SET BPCERR="IEN MISSING"
QUIT
+2 IF '$DATA(^AMHREC(AMHR))
SET BPCERR="INVALID RECORD IEN PASSED"
QUIT
+3 QUIT
DELETE ;
+1 SET AMHVDLT=$PIECE(^AMHREC(AMHR,0),U,16)
+2 SET AMHGRP=$PIECE(^AMHREC(AMHR,0),U,34)
+3 SET AMHPAT=$PIECE(^AMHREC(AMHR,0),U,8)
+4 SET AMHRDEL=AMHR
+5 SET AMHVFLE=9002011
FOR AMHVL=0:0
SET AMHVFLE=$ORDER(^DIC(AMHVFLE))
IF AMHVFLE>9002011.49!(AMHVFLE'=+AMHVFLE)
QUIT
DO DELETE2
+6 ;delete staging tool
SET DA=$ORDER(^AMHRCDST("B",AMHRDEL,0))
IF DA
SET DIK="^AMHRCDST("
DO ^DIK
+7 SET DIK="^AMHREC("
SET DA=AMHRDEL
SET X=2
DO ^DIK
KILL DA,DI
+8 IF $GET(AMHGRP)
DO GRPDEL(AMHR,AMHPAT)
+9 DO EOJ
+10 ;D PCCCHECK cmi/maw 2/2/2011 not needed v4.0p1
+11 DO PCCLINK
+12 QUIT
+13 ;
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
INTAKE ;
+1 ;;
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
+15 ;
PCCCHECK ;check to see if link to pcc active, set AMHLPCC IF SO
+1 KILL AMHLPCC
+2 SET (AMHLPCC,AMHLPCCT)=$PIECE(^AMHSITE(DUZ(2),0),U,12)
IF AMHLPCC
SET AMHLPCC=AMHLPCC-1
+3 IF AMHLPCC=""
SET AMHLPCC=0
QUIT
+4 IF 'AMHLPCC
QUIT
+5 IF $DATA(^AUTTSITE(1,0))
IF $PIECE(^(0),U,8)="Y"
IF '$DATA(^APCCCTRL(DUZ(2),0))#2
SET AMHLPCC=0
QUIT
+6 SET AMHPKG=$ORDER(^DIC(9.4,"C","AMH",""))
+7 IF '$DATA(^APCCCTRL(DUZ(2),11,AMHPKG,0))#2
SET AMHLPCC=0
QUIT
+8 IF $DATA(^AUTTSITE(1,0))
IF $PIECE(^(0),U,8)="Y"
IF $DATA(^APCCCTRL(DUZ(2),0))#2
IF $DATA(^APCCCTRL(DUZ(2),11,AMHPKG,0))#2
IF $PIECE(^(0),U,2)
SET AMHLPCC=AMHLPCC
+9 IF '$TEST
SET AMHLPCC=0
+10 KILL AMHPKG
+11 QUIT
PCCLINK ;EP - PCCLINK
+1 ;Q:'AMHLPCC ;quit if no pcc link v4.0p1 cmi/maw not needed 2/2/2011
+2 IF $GET(AMHVDLT)=""
IF AMHACTN=4
QUIT
+3 SET AMHBL=1
+4 SET APCDVDLT=$GET(AMHVDLT)
IF APCDVDLT=""
QUIT
+5 DO ^APCDVDLT
KILL APCDVDLT,AMHBL
+6 QUIT
+7 ;
ERROR(BPCX) ;
+1 DO MSG("-1"_$CHAR(30)_BPCX)
+2 QUIT
+3 ;
MSG(BPCX) ;
+1 SET BPCARRAY=BPCX
+2 QUIT
+3 ;
+4 ;
KILL ;
+1 KILL APCDALVR,BPCPARM,BPCERR,BPCVAL,AMHR,AMHACTN,AMHBL,AMHLPCC,AMHVDLT,AMHLPCCT,AMHVISIT
+2 QUIT
