AMHLEDEL.m

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