DGRPCF1.m

DGRPCF1 ;ALB/MRL - REMOVE INCONSISTENCIES FROM FILE; 21 SEP 88@2231

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

 I '$D(^DGIN(38.5,DFN,0)) Q

1 W:DGEDCN !!,"===> Removing patient from Inconsistency file..." D START^DGRPC S DGF=38.51 D XRS D INC:DGXRC K DGXRC S DGF=38.5,DGD=^DGIN(38.5,DFN,0) D XRS D:DGXRC RXR

 K ^DGIN(38.5,DFN) L +^DGIN(38.5,0) S $P(^DGIN(38.5,0),"^",4)=$P(^(0),"^",4)-1 S X=$P(^(0),"^",3) G Q:DFN'=X S (P,N)=$P(^DPT(0),"^",3),A=$S($O(^DGIN(38.5,DFN))>0:1,1:0),X=DFN,G=$S(A:P,1:DFN),E1=0

 G Q:$O(^DGIN(38.5,N))'>0

LN S N=N\2 S:A X=X+N S:'A X=X-N I X'>0 S E=P G LNL

 S E=$O(^DGIN(38.5,X)) I E>0,$O(^DGIN(38.5,E))'>0 G SET

 I E'>0 S A=0,G=$S(G>X:X,1:G) G LN

 I +E1,E1=E!(E1&('E)) S (G,X)=E,A=0 G LN

 S E1=E I E>0 S A=$S(+E>G:0,1:1) G LN

LNL S L=E F I=0:0 S E=$O(^DGIN(38.5,E)) G:E="" Q S L=E

 S E=L

SET S $P(^DGIN(38.5,0),"^",3)=E I DGEDCN S DGCON=2 D TIME^DGRPC

Q L -^DGIN(38.5,0) K A,DA,DGD,DGD1,DGF,DGI,DGI1,DGXRC,E,E1,G,I,I1,L,N,P,X,X1 Q

 ;

XRS S DGXRC=0 F I=0:0 S I=$O(^DD(DGF,I)) Q:'I  F I1=0:0 S I1=$O(^DD(DGF,I,1,I1)) Q:'I1  I $D(^DD(DGF,I,1,I1,2)) S X=^(2),X1=+$P($P(^DD(DGF,I,0),"^",4),";",2),DGXRC(X1,I1)=X,DGXRC=DGXRC+1

 Q

INC F DGI=0:0 S DGI=$O(^DGIN(38.5,DFN,"I",DGI)) Q:'DGI  I $D(^(DGI,0)) S DGD=^(0) D RXR

 Q

RXR F DGI=0:0 S DGI=$O(DGXRC(DGI)) Q:'DGI  I $P(DGD,"^",DGI)]"" S DGD1=$P(DGD,"^",DGI) F DGI1=0:0 S DGI1=$O(DGXRC(DGI,DGI1)) Q:'DGI1  S X=DGD1,DA=$S(DGF=38.5:DFN,1:DGI) S:DGF=38.51 DA(1)=DFN X DGXRC(DGI,DGI1) K DA

 K DGI,DGI1,X,DGD1 Q

DGRPCF1   ;ALB/MRL - REMOVE INCONSISTENCIES FROM FILE; 21 SEP 88@2231

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

 +2        IF '$DATA(^DGIN(38.5,DFN,0))

               QUIT 

1          IF DGEDCN

               WRITE !!,"===> Removing patient from Inconsistency file..."

           DO START^DGRPC

           SET DGF=38.51

           DO XRS

           IF DGXRC

               DO INC

           KILL DGXRC

           SET DGF=38.5

           SET DGD=^DGIN(38.5,DFN,0)

           DO XRS

           IF DGXRC

               DO RXR

 +1        KILL ^DGIN(38.5,DFN)

           LOCK +^DGIN(38.5,0)

           SET $PIECE(^DGIN(38.5,0),"^",4)=$PIECE(^(0),"^",4)-1

           SET X=$PIECE(^(0),"^",3)

           IF DFN'=X

               GOTO Q

           SET (P,N)=$PIECE(^DPT(0),"^",3)

           SET A=$SELECT($ORDER(^DGIN(38.5,DFN))>0:1,1:0)

           SET X=DFN

           SET G=$SELECT(A:P,1:DFN)

           SET E1=0

 +2        IF $ORDER(^DGIN(38.5,N))'>0

               GOTO Q

LN         SET N=N\2

           IF A

               SET X=X+N

           IF 'A

               SET X=X-N

           IF X'>0

               SET E=P

               GOTO LNL

 +1        SET E=$ORDER(^DGIN(38.5,X))

           IF E>0

               IF $ORDER(^DGIN(38.5,E))'>0

                   GOTO SET

 +2        IF E'>0

               SET A=0

               SET G=$SELECT(G>X:X,1:G)

               GOTO LN

 +3        IF +E1

               IF E1=E!(E1&('E))

                   SET (G,X)=E

                   SET A=0

                   GOTO LN

 +4        SET E1=E

           IF E>0

               SET A=$SELECT(+E>G:0,1:1)

               GOTO LN

LNL        SET L=E

           FOR I=0:0

               SET E=$ORDER(^DGIN(38.5,E))

               IF E=""

                   GOTO Q

               SET L=E

 +1        SET E=L

SET        SET $PIECE(^DGIN(38.5,0),"^",3)=E

           IF DGEDCN

               SET DGCON=2

               DO TIME^DGRPC

Q          LOCK -^DGIN(38.5,0)

           KILL A,DA,DGD,DGD1,DGF,DGI,DGI1,DGXRC,E,E1,G,I,I1,L,N,P,X,X1

           QUIT 

 +1       ;

XRS        SET DGXRC=0

           FOR I=0:0

               SET I=$ORDER(^DD(DGF,I))

               IF 'I

                   QUIT 

               FOR I1=0:0

                   SET I1=$ORDER(^DD(DGF,I,1,I1))

                   IF 'I1

                       QUIT 

                   IF $DATA(^DD(DGF,I,1,I1,2))

                       SET X=^(2)

                       SET X1=+$PIECE($PIECE(^DD(DGF,I,0),"^",4),";",2)

                       SET DGXRC(X1,I1)=X

                       SET DGXRC=DGXRC+1

 +1        QUIT 

INC        FOR DGI=0:0

               SET DGI=$ORDER(^DGIN(38.5,DFN,"I",DGI))

               IF 'DGI

                   QUIT 

               IF $DATA(^(DGI,0))

                   SET DGD=^(0)

                   DO RXR

 +1        QUIT 

RXR        FOR DGI=0:0

               SET DGI=$ORDER(DGXRC(DGI))

               IF 'DGI

                   QUIT 

               IF $PIECE(DGD,"^",DGI)]""

                   SET DGD1=$PIECE(DGD,"^",DGI)

                   FOR DGI1=0:0

                       SET DGI1=$ORDER(DGXRC(DGI,DGI1))

                       IF 'DGI1

                           QUIT 

                       SET X=DGD1

                       SET DA=$SELECT(DGF=38.5:DFN,1:DGI)

                       IF DGF=38.51

                           SET DA(1)=DFN

                       XECUTE DGXRC(DGI,DGI1)

                       KILL DA

 +1        KILL DGI,DGI1,X,DGD1

           QUIT