DGPMDDLD ;ALB/MRL - DETERMINE LODGER X-REF'S; 9 FEB 89
;;5.3;Registration;**54**;Aug 13, 1993
;
EN ; -- lodger x-ref on ward field in
I $S(('$D(DA)#2):1,'$D(DGPMDDF):1,'$D(DGPMDDT):1,1:0) G KX
I DGPMDDF'=6,DGPMDDF'=7 G KX
N DFN S DFN=+$P(^DGPM(+DA,0),"^",3) I '$D(^DPT(DFN,0)) G KX
I 'DGPMDDT D @("K"_+DGPMDDF) G Q
D FIND
I $S('DGWD:1,1:$P(DGWD,"^",2)="") D G Q
. N VAWD
. D INPTCK^DGPMDDCN
. I VAWD,($P(VAWD,"^",2)]"") D 1^DGPMDDCN Q
. K X
D @("S"_+DGPMDDF)
G Q
;
KX K X
Q K DGPMX,DGPMX,DGWD,DGRM,DGMV,DGMV0,DGFLD,DGPMDD,DGPMDDF,DGPMDDT Q
;
S6 ; -- ward x-ref
S DGFLD=.107 I $D(^DPT(DFN,.107)) S DGPMX=^(.107) I DGPMX]"" K ^DGPM("LD",DGPMX,DA) D KILL^DGPMDDCN
S DGPMX=$P(DGWD,"^",2),^DGPM("LD",DGPMX,DGMV)=""
D SET^DGPMDDCN
Q
;
K6 ;
I X S W=$S($D(^DIC(42,+X,0)):$P(^(0),"^",1),1:"") I W]"" K ^DGPM("LD",W,DA) I $D(^DPT(DFN,.107)),^(.107)=W S DGPMX=W,DGFLD=.107 D KILL^DGPMDDCN
K W
Q
;
S7 S DGFLD=.108
I $D(^DPT(DFN,.108)) S DGPMX=^(.108),DGFLD=.108 D KILL^DGPMDDCN F DGPMX1=0:0 S DGPMX1=+$O(^DGPM("ARM",DGPMX,DGPMX1)) D CHK I $T K ^DGPM("ARM",DGPMX,DGPMX1) Q
S DGPMX=+DGRM D SET^DGPMDDCN:DGPMX
I +DGRM S DGFLD=.108,DGPMX=+DGRM,^DGPM("ARM",DGPMX,DGMV)=1 D SET^DGPMDDCN
Q
;
K7 I $D(^DPT(DFN,.108)),X=+^(.108) S DGPMX=X I $D(^DGPM("ARM",DGPMX,DA)) K ^(DA) S DGFLD=.108 D KILL^DGPMDDCN
Q
;
CHK ;
I '$D(^DGPM(DGPMX1,0)) Q
I $P(^DGPM(DGPMX1,0),"^",3)=DFN Q
Q
;
LD ; -- set "LD" x-ref for file #2 equal to corresp adm mv (#.107)
N DFN,DGMV,DGMV0,DGX S DFN=DA
S DGX=X D FIND S:$P(DGWD,U,2)=DGX ^DPT("LD",DGX,DFN)=DGMV
Q
;
FIND ;
D NOW^%DTC S DGID=9999999.999999-%,(DGMV,DGMV0)=0,(DGWD,DGRM)=""
F DGID=DGID:0 S DGID=$O(^DGPM("ATID4",DFN,DGID)) Q:'DGID S DGMV=+$O(^(DGID,0)) I $D(^DGPM(DGMV,0)) S DGMV0=^(0) S:$S('$D(^DGPM(+$P(DGMV0,"^",17),0)):0,1:+^(0)'>%) (DGMV,DGMV0)=0 Q
I $D(^DIC(42,+$P(DGMV0,"^",6),0)) S DGWD=$P(DGMV0,"^",6)_"^"_$P(^(0),"^")
I $D(^DG(405.4,+$P(DGMV0,"^",7),0)) S DGRM=+$P(DGMV0,"^",7)_"^"_$P(^(0),"^")
K DGID Q
;
RESET ; -- reset ^DPT nodes and x-refs
; input: DFN
;
; -- kill data and x-refs
I $D(^DPT(DFN,.107)) S DGPMX=^(.107),DGFLD=.107 I DGPMX]"" K ^DGPM("LD",DGPMX,DA) D KILL^DGPMDDCN
I $D(^DPT(DFN,.108)) S DGPMX=^(.108),DGFLD=.108 D KILL^DGPMDDCN F DGPMX1=0:0 S DGPMX1=+$O(^DGPM("ARM",DGPMX,DGPMX1)) D CHK I $T K ^DGPM("ARM",DGPMX,DGPMX1) Q
; -- reset data and x-refs
D FIND
I $S('DGWD:1,1:$P(DGWD,"^",2)="") D G RESETQ
. N VAWD
. D INPTCK^DGPMDDCN
. I VAWD,($P(VAWD,"^",2)]"") D RESET^DGPMDDCN
D S6,S7
;
RESETQ K DGWD,DGRM,DGPMX,DGPMX1,DGFLD,I,DGMV,DGMV0 Q
;
XREF ;
Q:$P(^DGPM(DA,0),U,2)'=4
N DFN S DFN=+$P(^DGPM(DA,0),U,3) D RESET
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPMDDLD 2705 printed Sep 23, 2025@20:25:19 Page 2
DGPMDDLD ;ALB/MRL - DETERMINE LODGER X-REF'S; 9 FEB 89
+1 ;;5.3;Registration;**54**;Aug 13, 1993
+2 ;
EN ; -- lodger x-ref on ward field in
+1 IF $SELECT(('$DATA(DA)#2):1,'$DATA(DGPMDDF):1,'$DATA(DGPMDDT):1,1:0)
GOTO KX
+2 IF DGPMDDF'=6
IF DGPMDDF'=7
GOTO KX
+3 NEW DFN
SET DFN=+$PIECE(^DGPM(+DA,0),"^",3)
IF '$DATA(^DPT(DFN,0))
GOTO KX
+4 IF 'DGPMDDT
DO @("K"_+DGPMDDF)
GOTO Q
+5 DO FIND
+6 IF $SELECT('DGWD:1,1:$PIECE(DGWD,"^",2)="")
Begin DoDot:1
+7 NEW VAWD
+8 DO INPTCK^DGPMDDCN
+9 IF VAWD
IF ($PIECE(VAWD,"^",2)]"")
DO 1^DGPMDDCN
QUIT
+10 KILL X
End DoDot:1
GOTO Q
+11 DO @("S"_+DGPMDDF)
+12 GOTO Q
+13 ;
KX KILL X
Q KILL DGPMX,DGPMX,DGWD,DGRM,DGMV,DGMV0,DGFLD,DGPMDD,DGPMDDF,DGPMDDT
QUIT
+1 ;
S6 ; -- ward x-ref
+1 SET DGFLD=.107
IF $DATA(^DPT(DFN,.107))
SET DGPMX=^(.107)
IF DGPMX]""
KILL ^DGPM("LD",DGPMX,DA)
DO KILL^DGPMDDCN
+2 SET DGPMX=$PIECE(DGWD,"^",2)
SET ^DGPM("LD",DGPMX,DGMV)=""
+3 DO SET^DGPMDDCN
+4 QUIT
+5 ;
K6 ;
+1 IF X
SET W=$SELECT($DATA(^DIC(42,+X,0)):$PIECE(^(0),"^",1),1:"")
IF W]""
KILL ^DGPM("LD",W,DA)
IF $DATA(^DPT(DFN,.107))
IF ^(.107)=W
SET DGPMX=W
SET DGFLD=.107
DO KILL^DGPMDDCN
+2 KILL W
+3 QUIT
+4 ;
S7 SET DGFLD=.108
+1 IF $DATA(^DPT(DFN,.108))
SET DGPMX=^(.108)
SET DGFLD=.108
DO KILL^DGPMDDCN
FOR DGPMX1=0:0
SET DGPMX1=+$ORDER(^DGPM("ARM",DGPMX,DGPMX1))
DO CHK
IF $TEST
KILL ^DGPM("ARM",DGPMX,DGPMX1)
QUIT
+2 SET DGPMX=+DGRM
if DGPMX
DO SET^DGPMDDCN
+3 IF +DGRM
SET DGFLD=.108
SET DGPMX=+DGRM
SET ^DGPM("ARM",DGPMX,DGMV)=1
DO SET^DGPMDDCN
+4 QUIT
+5 ;
K7 IF $DATA(^DPT(DFN,.108))
IF X=+^(.108)
SET DGPMX=X
IF $DATA(^DGPM("ARM",DGPMX,DA))
KILL ^(DA)
SET DGFLD=.108
DO KILL^DGPMDDCN
+1 QUIT
+2 ;
CHK ;
+1 IF '$DATA(^DGPM(DGPMX1,0))
QUIT
+2 IF $PIECE(^DGPM(DGPMX1,0),"^",3)=DFN
QUIT
+3 QUIT
+4 ;
LD ; -- set "LD" x-ref for file #2 equal to corresp adm mv (#.107)
+1 NEW DFN,DGMV,DGMV0,DGX
SET DFN=DA
+2 SET DGX=X
DO FIND
if $PIECE(DGWD,U,2)=DGX
SET ^DPT("LD",DGX,DFN)=DGMV
+3 QUIT
+4 ;
FIND ;
+1 DO NOW^%DTC
SET DGID=9999999.999999-%
SET (DGMV,DGMV0)=0
SET (DGWD,DGRM)=""
+2 FOR DGID=DGID:0
SET DGID=$ORDER(^DGPM("ATID4",DFN,DGID))
if 'DGID
QUIT
SET DGMV=+$ORDER(^(DGID,0))
IF $DATA(^DGPM(DGMV,0))
SET DGMV0=^(0)
if $SELECT('$DATA(^DGPM(+$PIECE(DGMV0,"^",17),0))
SET (DGMV,DGMV0)=0
QUIT
+3 IF $DATA(^DIC(42,+$PIECE(DGMV0,"^",6),0))
SET DGWD=$PIECE(DGMV0,"^",6)_"^"_$PIECE(^(0),"^")
+4 IF $DATA(^DG(405.4,+$PIECE(DGMV0,"^",7),0))
SET DGRM=+$PIECE(DGMV0,"^",7)_"^"_$PIECE(^(0),"^")
+5 KILL DGID
QUIT
+6 ;
RESET ; -- reset ^DPT nodes and x-refs
+1 ; input: DFN
+2 ;
+3 ; -- kill data and x-refs
+4 IF $DATA(^DPT(DFN,.107))
SET DGPMX=^(.107)
SET DGFLD=.107
IF DGPMX]""
KILL ^DGPM("LD",DGPMX,DA)
DO KILL^DGPMDDCN
+5 IF $DATA(^DPT(DFN,.108))
SET DGPMX=^(.108)
SET DGFLD=.108
DO KILL^DGPMDDCN
FOR DGPMX1=0:0
SET DGPMX1=+$ORDER(^DGPM("ARM",DGPMX,DGPMX1))
DO CHK
IF $TEST
KILL ^DGPM("ARM",DGPMX,DGPMX1)
QUIT
+6 ; -- reset data and x-refs
+7 DO FIND
+8 IF $SELECT('DGWD:1,1:$PIECE(DGWD,"^",2)="")
Begin DoDot:1
+9 NEW VAWD
+10 DO INPTCK^DGPMDDCN
+11 IF VAWD
IF ($PIECE(VAWD,"^",2)]"")
DO RESET^DGPMDDCN
End DoDot:1
GOTO RESETQ
+12 DO S6
DO S7
+13 ;
RESETQ KILL DGWD,DGRM,DGPMX,DGPMX1,DGFLD,I,DGMV,DGMV0
QUIT
+1 ;
XREF ;
+1 if $PIECE(^DGPM(DA,0),U,2)'=4
QUIT
+2 NEW DFN
SET DFN=+$PIECE(^DGPM(DA,0),U,3)
DO RESET
+3 QUIT
