AMHGVDEL.m

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