- 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
