DGDDC ;ALB/MRL,JAM - X-ECUTE KILL X-REFERENCES [PATIENT] ;25 JUL 88@1337
;;5.3;Registration;**489,244,527,700,673,997,1067**;Aug 13, 1993;Build 23
;
; DG*5.3*997 - jam - Make sure related Country, Province and Postal Code fields get cleaned up - tags 211, 2191, 331, 3311, 341
; DG*5.3*1067 - jam - Add new Relationship Type fields .224, .2104, .3309, .331015, .34015 for cleanup of NOK data
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^.221^.222^.223^.224^
2191 ;;.2192^.21925^.2193^.2194^.2195^.2196^.2197^.2198^.2199^.211011^.2203^.2101^.2102^.2103^.2104^
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^.3306^.3307^.3308^.3309^
3311 ;;.3312^.3313^.3314^.3315^.3316^.3317^.3318^.3319^.331011^.2204^.331012^.331013^.331014^.331015^
341 ;;.342^.3405^.343^.344^.345^.346^.347^.348^.349^.34011^.2202^.34012^.34013^.34014^.34015^
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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGDDC 3074 printed Sep 23, 2025@20:17:41 Page 2
DGDDC ;ALB/MRL,JAM - X-ECUTE KILL X-REFERENCES [PATIENT] ;25 JUL 88@1337
+1 ;;5.3;Registration;**489,244,527,700,673,997,1067**;Aug 13, 1993;Build 23
+2 ;
+3 ; DG*5.3*997 - jam - Make sure related Country, Province and Postal Code fields get cleaned up - tags 211, 2191, 331, 3311, 341
+4 ; DG*5.3*1067 - jam - Add new Relationship Type fields .224, .2104, .3309, .331015, .34015 for cleanup of NOK data
+5 ;Flag variable to prevent deletion cascade
if $DATA(DGNOFDEL)
QUIT
+6 ;
+7 if '$DATA(DGXRF)
QUIT
NEW DGXRFX,DGXRF1,DGXRF2,DGXRF3,DGXRF3,DGXRF4,DGXRF5,DGXRF6,DGXRF7,DGXRF8,DGXRFP,DGXRFX
+8 SET DGXRFX=X
SET DGXRF1=+$PIECE(DGXRF,".",2)
SET DGXRF2=$PIECE($TEXT(@DGXRF1),";;",2)
if DGXRF2=""
GOTO Q
+9 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
+10 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
+11 NEW DGFDA,DGERR
+12 ;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
+13 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
+14 IF DGXRF4'=".1213"
SET DGFDA(2,DA_",",DGXRF4)=""
End DoDot:1
+15 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^.221^.222^.223^.224^
2191 ;;.2192^.21925^.2193^.2194^.2195^.2196^.2197^.2198^.2199^.211011^.2203^.2101^.2102^.2103^.2104^
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^.3306^.3307^.3308^.3309^
3311 ;;.3312^.3313^.3314^.3315^.3316^.3317^.3318^.3319^.331011^.2204^.331012^.331013^.331014^.331015^
341 ;;.342^.3405^.343^.344^.345^.346^.347^.348^.349^.34011^.2202^.34012^.34013^.34014^.34015^
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
