DGPMDDLD.m

DGPMDDLD ;ALB/MRL - DETERMINE LODGER X-REF'S; 9 FEB 89

 ;;5.3;Registration;**54,1015**;Aug 13, 1993;Build 21

 ;

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

DGPMDDLD  ;ALB/MRL - DETERMINE LODGER X-REF'S; 9 FEB 89

 +1       ;;5.3;Registration;**54,1015**;Aug 13, 1993;Build 21

 +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