DGDDC.m

DGDDC ;ALB/MRL - X-ECUTE KILL X-REFERENCES [PATIENT] ;25 JUL 88@1337

 ;;5.3;Registration;**489,244,527,700,673,1015**;Aug 13, 1993;Build 21

 ;

 Q:$D(DGNOFDEL)  ;Flag variable to prevent deletion cascade

 ;

 Q:'$D(DGXRF)  N DGXRFX,DGXRF1,DGXRF2,DGXRF3,DGXRF3,DGXRF4,DGXRF5,DGXRF6,DGXRF7,DGXRF8,DGXRFP,DGXRFX

 S DGXRFX=X,DGXRF1=+$P(DGXRF,".",2),DGXRF2=$P($T(@DGXRF1),";;",2) G Q:DGXRF2=""

 I $D(^DD(2,DGXRF,0)) S DGXRFP=$P(^(0),"^",4),DGXRF6=$P(DGXRFP,";",2),DGXRF5=$P(DGXRFP,";",1) I $D(^DPT(DA,DGXRF5)),($P(^(DGXRF5),"^",DGXRF6)=DGXRFX) G Q

 I DGXRF=".1212",($D(^DPT(DA,DGXRF5))),($P(^(DGXRF5),"^",DGXRF6)="") S DGFDA(2,DA_",",.1213)="" D FILE^DIE("","DGFDA","DGERR") K DGFDA,DGERR G Q

 N DGFDA,DGERR

 ;F DGXRF3=1:1 S DGXRF4=$P(DGXRF2,"^",DGXRF3) Q:DGXRF4=""  I $D(^DD(2,DGXRF4,0)) S DGXRF5=$P(^(0),"^",4),DGXRF6=$P(DGXRF5,";",2),DGXRF5=$P(DGXRF5,";",1) I $D(^DPT(DA,DGXRF5)),$P(^(DGXRF5),"^",DGXRF6)'="" D KILL

 F DGXRF3=1:1 S DGXRF4=$P(DGXRF2,"^",DGXRF3) Q:DGXRF4=""  I $D(^DD(2,DGXRF4,0)) S DGXRF5=$P(^(0),"^",4),DGXRF6=$P(DGXRF5,";",2),DGXRF5=$P(DGXRF5,";",1) I $D(^DPT(DA,DGXRF5)),$P(^(DGXRF5),"^",DGXRF6)'="",DGXRF4'=".1212" D

 .I DGXRF4'=".1213" S DGFDA(2,DA_",",DGXRF4)=""

 I $D(DGFDA) D FILE^DIE("","DGFDA","DGERR")

Q S X=DGXRFX K DGXRF Q  ;,DGXRFX,DGXRF1,DGXRF2,DGXRF3,DGXRF3,DGXRF4,DGXRF5,DGXRF6,DGXRF7,DGXRF8,DGXRFP,DGXRFX Q

KILL S DGXRF7=$P(^DPT(DA,DGXRF5),"^",DGXRF6),$P(^DPT(DA,DGXRF5),"^",DGXRF6)=""

 F DGXRF8=0:0 S DGXRF8=$O(^DD(2,DGXRF4,1,DGXRF8)) Q:'DGXRF8  I $D(^DD(2,DGXRF4,1,DGXRF8,2)) S X=DGXRF7 X:^(2)'["DGXRF" ^(2) D SET I $D(^DD(2,DGXRF4,1,DGXRF8,1)) D SET

 Q

SET Q:^DD(2,DGXRF4,1,DGXRF8,1)'["DGXRF"  S X="" X ^(1) Q

 ;

152 ;;.1651^.1653^.1654^.1656^.307^

153 ;;.1657^.1658^.1659^

211 ;;.212^.2125^.213^.214^.215^.216^.217^.218^.219^.21011^.2207^

2191 ;;.2192^.21925^.2193^.2194^.2195^.2196^.2197^.2198^.2199^.211011^.2203^

251 ;;.252^.253^.254^.255^.256^.257^.258^.2206^

3111 ;;.3113^.3114^.3115^.3116^.3117^.3118^.3119^.2205^

331 ;;.332^.3305^.333^.334^.335^.336^.337^.338^.339^.33011^.2201^

3311 ;;.3312^.3313^.3314^.3315^.3316^.3317^.3318^.3319^.331011^.2204^

341 ;;.342^.3405^.343^.344^.345^.346^.347^.348^.349^.34011^.2202^

3285 ;;.329^.3291^.3292^.3293^.3294^.32912^

32945 ;;.3295^.3296^.3297^.3298^.3299^.32913^

3291 ;;.32912

3296 ;;.32913

325 ;;.32911

111 ;;.112^.113

112 ;;.113

12105 ;;.1217^.1218

1211 ;;.1212^.1213

1212 ;;.1213

14105 ;;.1417^.1418

1411 ;;.1412^.1413

1412 ;;.1413

213 ;;.214^.215

214 ;;.215

2193 ;;.2194^.2195

2194 ;;.2195

252 ;;.253^.254

253 ;;.254

3113 ;;.3114^.3115

3114 ;;.3115

3313 ;;.3314^.3315

3314 ;;.3315

333 ;;.334^.335

334 ;;.335

343 ;;.344^.345

344 ;;.345

361 ;;.3611

DGDDC     ;ALB/MRL - X-ECUTE KILL X-REFERENCES [PATIENT] ;25 JUL 88@1337

 +1       ;;5.3;Registration;**489,244,527,700,673,1015**;Aug 13, 1993;Build 21

 +2       ;

 +3       ;Flag variable to prevent deletion cascade

           IF $DATA(DGNOFDEL)

               QUIT 

 +4       ;

 +5        IF '$DATA(DGXRF)

               QUIT 

           NEW DGXRFX,DGXRF1,DGXRF2,DGXRF3,DGXRF3,DGXRF4,DGXRF5,DGXRF6,DGXRF7,DGXRF8,DGXRFP,DGXRFX

 +6        SET DGXRFX=X

           SET DGXRF1=+$PIECE(DGXRF,".",2)

           SET DGXRF2=$PIECE($TEXT(@DGXRF1),";;",2)

           IF DGXRF2=""

               GOTO Q

 +7        IF $DATA(^DD(2,DGXRF,0))

               SET DGXRFP=$PIECE(^(0),"^",4)

               SET DGXRF6=$PIECE(DGXRFP,";",2)

               SET DGXRF5=$PIECE(DGXRFP,";",1)

               IF $DATA(^DPT(DA,DGXRF5))

                   IF ($PIECE(^(DGXRF5),"^",DGXRF6)=DGXRFX)

                       GOTO Q

 +8        IF DGXRF=".1212"

               IF ($DATA(^DPT(DA,DGXRF5)))

                   IF ($PIECE(^(DGXRF5),"^",DGXRF6)="")

                       SET DGFDA(2,DA_",",.1213)=""

                       DO FILE^DIE("","DGFDA","DGERR")

                       KILL DGFDA,DGERR

                       GOTO Q

 +9        NEW DGFDA,DGERR

 +10      ;F DGXRF3=1:1 S DGXRF4=$P(DGXRF2,"^",DGXRF3) Q:DGXRF4=""  I $D(^DD(2,DGXRF4,0)) S DGXRF5=$P(^(0),"^",4),DGXRF6=$P(DGXRF5,";",2),DGXRF5=$P(DGXRF5,";",1) I $D(^DPT(DA,DGXRF5)),$P(^(DGXRF5),"^",DGXRF6)'="" D KILL

 +11       FOR DGXRF3=1:1

               SET DGXRF4=$PIECE(DGXRF2,"^",DGXRF3)

               IF DGXRF4=""

                   QUIT 

               IF $DATA(^DD(2,DGXRF4,0))

                   SET DGXRF5=$PIECE(^(0),"^",4)

                   SET DGXRF6=$PIECE(DGXRF5,";",2)

                   SET DGXRF5=$PIECE(DGXRF5,";",1)

                   IF $DATA(^DPT(DA,DGXRF5))

                       IF $PIECE(^(DGXRF5),"^",DGXRF6)'=""

                           IF DGXRF4'=".1212"

                               Begin DoDot:1

 +12                               IF DGXRF4'=".1213"

                                       SET DGFDA(2,DA_",",DGXRF4)=""

                               End DoDot:1

 +13       IF $DATA(DGFDA)

               DO FILE^DIE("","DGFDA","DGERR")

Q         ;,DGXRFX,DGXRF1,DGXRF2,DGXRF3,DGXRF3,DGXRF4,DGXRF5,DGXRF6,DGXRF7,DGXRF8,DGXRFP,DGXRFX Q

           SET X=DGXRFX

           KILL DGXRF

           QUIT 

KILL       SET DGXRF7=$PIECE(^DPT(DA,DGXRF5),"^",DGXRF6)

           SET $PIECE(^DPT(DA,DGXRF5),"^",DGXRF6)=""

 +1        FOR DGXRF8=0:0

               SET DGXRF8=$ORDER(^DD(2,DGXRF4,1,DGXRF8))

               IF 'DGXRF8

                   QUIT 

               IF $DATA(^DD(2,DGXRF4,1,DGXRF8,2))

                   SET X=DGXRF7

                   IF ^(2)'["DGXRF"

                       XECUTE ^(2)

                   DO SET

                   IF $DATA(^DD(2,DGXRF4,1,DGXRF8,1))

                       DO SET

 +2        QUIT 

SET        IF ^DD(2,DGXRF4,1,DGXRF8,1)'["DGXRF"

               QUIT 

           SET X=""

           XECUTE ^(1)

           QUIT 

 +1       ;

152       ;;.1651^.1653^.1654^.1656^.307^

153       ;;.1657^.1658^.1659^

211       ;;.212^.2125^.213^.214^.215^.216^.217^.218^.219^.21011^.2207^

2191      ;;.2192^.21925^.2193^.2194^.2195^.2196^.2197^.2198^.2199^.211011^.2203^

251       ;;.252^.253^.254^.255^.256^.257^.258^.2206^

3111      ;;.3113^.3114^.3115^.3116^.3117^.3118^.3119^.2205^

331       ;;.332^.3305^.333^.334^.335^.336^.337^.338^.339^.33011^.2201^

3311      ;;.3312^.3313^.3314^.3315^.3316^.3317^.3318^.3319^.331011^.2204^

341       ;;.342^.3405^.343^.344^.345^.346^.347^.348^.349^.34011^.2202^

3285      ;;.329^.3291^.3292^.3293^.3294^.32912^

32945     ;;.3295^.3296^.3297^.3298^.3299^.32913^

3291      ;;.32912

3296      ;;.32913

325       ;;.32911

111       ;;.112^.113

112       ;;.113

12105     ;;.1217^.1218

1211      ;;.1212^.1213

1212      ;;.1213

14105     ;;.1417^.1418

1411      ;;.1412^.1413

1412      ;;.1413

213       ;;.214^.215

214       ;;.215

2193      ;;.2194^.2195

2194      ;;.2195

252       ;;.253^.254

253       ;;.254

3113      ;;.3114^.3115

3114      ;;.3115

3313      ;;.3314^.3315

3314      ;;.3315

333       ;;.334^.335

334       ;;.335

343       ;;.344^.345

344       ;;.345

361       ;;.3611