DGRPCF1 ;ALB/MRL - REMOVE INCONSISTENCIES FROM FILE; 21 SEP 88@2231
;;5.3;Registration;;Aug 13, 1993
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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGRPCF1 1487 printed Dec 13, 2024@02:56:01 Page 2
DGRPCF1 ;ALB/MRL - REMOVE INCONSISTENCIES FROM FILE; 21 SEP 88@2231
+1 ;;5.3;Registration;;Aug 13, 1993
+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
