RMPR8PG1 ;VM/RB - check/purge file ^RMPR(668) 'L'/'L1' x-ref not matching zero node info ;03/27/08
;;3.0;Prosthetics;**163**;13/27/08;Build 9
;;
Q
AUDIT ; Post suspense purge audit to check for any 'L' and 'L1' x-ref that
; no longer have an associated master record to ien data that
; matches File ^RMPR(668,ien,0) data
;
Q:$D(^XTMP("RMPR8PG1")) ;Will run this index cleanse portion no sooner than 90 days after the last cleansing.
N U,TOT1,TOT2,TOT3,TOT4,TOT5,TOT6,RMPRSS,RMPRDT,RMPRST,RMPRIEN,DFN,RDPT0,SSN,SSN2,RMSTART,RMEND,R0
D NOW^%DTC S RMSTART=%
S ^XTMP("RMPR8PG1","START COMPILE")=RMSTART
S ^XTMP("RMPR8PG1","END COMPILE")="RUNNING"
S ^XTMP("RMPR8PG1",0)=$$FMADD^XLFDT(RMSTART,90)_"^"_RMSTART
0 ;FIND 668 'L' and 'L1' x-refs with missing master record
S U="^",(TOT1,TOT2,TOT3,TOT4,TOT5,TOT6)=0,RMPRSS=0
1 F S RMPRSS=$O(^RMPR(668,"L",RMPRSS)),RMPRDT=0 Q:RMPRSS="" D
. F S RMPRDT=$O(^RMPR(668,"L",RMPRSS,RMPRDT)),RMPRST="" Q:RMPRDT="" D
.. F S RMPRST=$O(^RMPR(668,"L",RMPRSS,RMPRDT,RMPRST)),RMPRIEN=0 Q:RMPRST="" D
... F S RMPRIEN=$O(^RMPR(668,"L",RMPRSS,RMPRDT,RMPRST,RMPRIEN)) Q:RMPRIEN="" D
.... I '$D(^RMPR(668,RMPRIEN,0)) D Q
..... S ^XTMP("RMPR8PG1","L",0,RMPRSS,RMPRDT,RMPRST,RMPRIEN)="PAT POINTER MISSING IN NODE 0"
..... S TOT1=TOT1+1
..... K ^RMPR(668,"L",RMPRSS,RMPRDT,RMPRST,RMPRIEN)
.... S R0=$G(^RMPR(668,RMPRIEN,0)),DFN=$P(R0,U,2)
.... I +$G(DFN)>0,$D(^DPT(+$G(DFN),0)) D Q
..... S RDPT0=$G(^DPT(DFN,0)),SSN=$P(RDPT0,U,9),SSN2=$E(SSN,8,9)
..... I RMPRSS'=SSN2!(RMPRDT'=$P($P(R0,U),"."))!(RMPRST'=$P(R0,U,10)) D
...... S ^XTMP("RMPR8PG1","L",2,RMPRSS,RMPRDT,RMPRST,RMPRIEN)=SSN_U_$P(R0,U)_U_$P(R0,U,10)
...... S TOT2=TOT2+1
...... K ^RMPR(668,"L",RMPRSS,RMPRDT,RMPRST,RMPRIEN)
...... I +R0>0,SSN2>0,$P(R0,U,10)'="" S ^RMPR(668,"L",$P($P(R0,U),"."),SSN2,$P(R0,U,10),RMPRIEN)=""
.... S ^XTMP("RMPR8PG1","L",3,RMPRSS,RMPRDT,RMPRST,RMPRIEN)="BAD DFN IN 0 RECORD"
.... S TOT3=TOT3+1
.... K ^RMPR(668,"L",RMPRSS,RMPRDT,RMPRST,RMPRIEN)
5 S RMPRSS=0
F S RMPRSS=$O(^RMPR(668,"L1",RMPRSS)),RMPRST="" Q:RMPRSS="" D
. F S RMPRST=$O(^RMPR(668,"L1",RMPRSS,RMPRST)),RMPRIEN=0 Q:RMPRST="" D
.. F S RMPRIEN=$O(^RMPR(668,"L1",RMPRSS,RMPRST,RMPRIEN)) Q:RMPRIEN="" D
... I '$D(^RMPR(668,RMPRIEN,0)) D Q
.... S ^XTMP("RMPR8PG1","L1",0,RMPRSS,RMPRST,RMPRIEN)="PAT POINTER MISSING IN NODE 0"
.... S TOT4=TOT4+1
.... K ^RMPR(668,"L1",RMPRSS,RMPRST,RMPRIEN)
... S R0=$G(^RMPR(668,RMPRIEN,0)),DFN=$P(R0,U,2)
... I +$G(DFN)>0,$D(^DPT(+$G(DFN),0)) D Q
.... S RDPT0=$G(^DPT(DFN,0)),SSN=$P(RDPT0,U,9),SSN2=$E(SSN,8,9)
.... I RMPRSS'=SSN2!(RMPRST'=$P(R0,U,10)) D
..... S ^XTMP("RMPR8PG1","L1",1,RMPRSS,RMPRST,RMPRIEN)=SSN_U_$P(R0,U)_U_$P(R0,U,10)
..... S TOT5=TOT5+1
..... K ^RMPR(668,"L1",RMPRSS,RMPRST,RMPRIEN)
..... I SSN2>0,$P(R0,U,10)'="" S ^RMPR(668,"L1",SSN2,$P(R0,U,10),RMPRIEN)=""
... S ^XTMP("RMPR8PG1","L1",2,RMPRSS,RMPRST,RMPRIEN)="BAD DFN IN 0 RECORD"
... S TOT6=TOT6+1
... K ^RMPR(668,"L",RMPRSS,RMPRST,RMPRIEN)
9 W !!!!,"MISSING 'L' 0 NODE TOTAL: ",TOT1
W !,"MISSING 'L' MISMATCH W/DFN TOTAL: ",TOT2
W !,"MISSING 'L' MISMATCH W/O DFN TOTAL: ",TOT3
W !,"MISSING 'L1' 0 NODE TOTAL: ",TOT4
W !,"MISSING 'L1' MISMATCH W/DFN TOTAL: ",TOT5
W !,"MISSING 'L1' MISMATCH W/O DFN TOTAL: ",TOT6
D NOW^%DTC S RMEND=%
S ^XTMP("RMPR8PG1","TOTALS")=TOT1_U_TOT2_U_TOT3_U_TOT4_U_TOT5_U_TOT6
S ^XTMP("RMPR8PG1","END COMPILE")=RMEND
K %
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPR8PG1 3482 printed Apr 09, 2024@21:37:56 Page 2
RMPR8PG1 ;VM/RB - check/purge file ^RMPR(668) 'L'/'L1' x-ref not matching zero node info ;03/27/08
+1 ;;3.0;Prosthetics;**163**;13/27/08;Build 9
+2 ;;
+3 QUIT
AUDIT ; Post suspense purge audit to check for any 'L' and 'L1' x-ref that
+1 ; no longer have an associated master record to ien data that
+2 ; matches File ^RMPR(668,ien,0) data
+3 ;
+4 ;Will run this index cleanse portion no sooner than 90 days after the last cleansing.
if $DATA(^XTMP("RMPR8PG1"))
QUIT
+5 NEW U,TOT1,TOT2,TOT3,TOT4,TOT5,TOT6,RMPRSS,RMPRDT,RMPRST,RMPRIEN,DFN,RDPT0,SSN,SSN2,RMSTART,RMEND,R0
+6 DO NOW^%DTC
SET RMSTART=%
+7 SET ^XTMP("RMPR8PG1","START COMPILE")=RMSTART
+8 SET ^XTMP("RMPR8PG1","END COMPILE")="RUNNING"
+9 SET ^XTMP("RMPR8PG1",0)=$$FMADD^XLFDT(RMSTART,90)_"^"_RMSTART
0 ;FIND 668 'L' and 'L1' x-refs with missing master record
+1 SET U="^"
SET (TOT1,TOT2,TOT3,TOT4,TOT5,TOT6)=0
SET RMPRSS=0
1 FOR
SET RMPRSS=$ORDER(^RMPR(668,"L",RMPRSS))
SET RMPRDT=0
if RMPRSS=""
QUIT
Begin DoDot:1
+1 FOR
SET RMPRDT=$ORDER(^RMPR(668,"L",RMPRSS,RMPRDT))
SET RMPRST=""
if RMPRDT=""
QUIT
Begin DoDot:2
+2 FOR
SET RMPRST=$ORDER(^RMPR(668,"L",RMPRSS,RMPRDT,RMPRST))
SET RMPRIEN=0
if RMPRST=""
QUIT
Begin DoDot:3
+3 FOR
SET RMPRIEN=$ORDER(^RMPR(668,"L",RMPRSS,RMPRDT,RMPRST,RMPRIEN))
if RMPRIEN=""
QUIT
Begin DoDot:4
+4 IF '$DATA(^RMPR(668,RMPRIEN,0))
Begin DoDot:5
+5 SET ^XTMP("RMPR8PG1","L",0,RMPRSS,RMPRDT,RMPRST,RMPRIEN)="PAT POINTER MISSING IN NODE 0"
+6 SET TOT1=TOT1+1
+7 KILL ^RMPR(668,"L",RMPRSS,RMPRDT,RMPRST,RMPRIEN)
End DoDot:5
QUIT
+8 SET R0=$GET(^RMPR(668,RMPRIEN,0))
SET DFN=$PIECE(R0,U,2)
+9 IF +$GET(DFN)>0
IF $DATA(^DPT(+$GET(DFN),0))
Begin DoDot:5
+10 SET RDPT0=$GET(^DPT(DFN,0))
SET SSN=$PIECE(RDPT0,U,9)
SET SSN2=$EXTRACT(SSN,8,9)
+11 IF RMPRSS'=SSN2!(RMPRDT'=$PIECE($PIECE(R0,U),"."))!(RMPRST'=$PIECE(R0,U,10))
Begin DoDot:6
+12 SET ^XTMP("RMPR8PG1","L",2,RMPRSS,RMPRDT,RMPRST,RMPRIEN)=SSN_U_$PIECE(R0,U)_U_$PIECE(R0,U,10)
+13 SET TOT2=TOT2+1
+14 KILL ^RMPR(668,"L",RMPRSS,RMPRDT,RMPRST,RMPRIEN)
+15 IF +R0>0
IF SSN2>0
IF $PIECE(R0,U,10)'=""
SET ^RMPR(668,"L",$PIECE($PIECE(R0,U),"."),SSN2,$PIECE(R0,U,10),RMPRIEN)=""
End DoDot:6
End DoDot:5
QUIT
+16 SET ^XTMP("RMPR8PG1","L",3,RMPRSS,RMPRDT,RMPRST,RMPRIEN)="BAD DFN IN 0 RECORD"
+17 SET TOT3=TOT3+1
+18 KILL ^RMPR(668,"L",RMPRSS,RMPRDT,RMPRST,RMPRIEN)
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
5 SET RMPRSS=0
+1 FOR
SET RMPRSS=$ORDER(^RMPR(668,"L1",RMPRSS))
SET RMPRST=""
if RMPRSS=""
QUIT
Begin DoDot:1
+2 FOR
SET RMPRST=$ORDER(^RMPR(668,"L1",RMPRSS,RMPRST))
SET RMPRIEN=0
if RMPRST=""
QUIT
Begin DoDot:2
+3 FOR
SET RMPRIEN=$ORDER(^RMPR(668,"L1",RMPRSS,RMPRST,RMPRIEN))
if RMPRIEN=""
QUIT
Begin DoDot:3
+4 IF '$DATA(^RMPR(668,RMPRIEN,0))
Begin DoDot:4
+5 SET ^XTMP("RMPR8PG1","L1",0,RMPRSS,RMPRST,RMPRIEN)="PAT POINTER MISSING IN NODE 0"
+6 SET TOT4=TOT4+1
+7 KILL ^RMPR(668,"L1",RMPRSS,RMPRST,RMPRIEN)
End DoDot:4
QUIT
+8 SET R0=$GET(^RMPR(668,RMPRIEN,0))
SET DFN=$PIECE(R0,U,2)
+9 IF +$GET(DFN)>0
IF $DATA(^DPT(+$GET(DFN),0))
Begin DoDot:4
+10 SET RDPT0=$GET(^DPT(DFN,0))
SET SSN=$PIECE(RDPT0,U,9)
SET SSN2=$EXTRACT(SSN,8,9)
+11 IF RMPRSS'=SSN2!(RMPRST'=$PIECE(R0,U,10))
Begin DoDot:5
+12 SET ^XTMP("RMPR8PG1","L1",1,RMPRSS,RMPRST,RMPRIEN)=SSN_U_$PIECE(R0,U)_U_$PIECE(R0,U,10)
+13 SET TOT5=TOT5+1
+14 KILL ^RMPR(668,"L1",RMPRSS,RMPRST,RMPRIEN)
+15 IF SSN2>0
IF $PIECE(R0,U,10)'=""
SET ^RMPR(668,"L1",SSN2,$PIECE(R0,U,10),RMPRIEN)=""
End DoDot:5
End DoDot:4
QUIT
+16 SET ^XTMP("RMPR8PG1","L1",2,RMPRSS,RMPRST,RMPRIEN)="BAD DFN IN 0 RECORD"
+17 SET TOT6=TOT6+1
+18 KILL ^RMPR(668,"L",RMPRSS,RMPRST,RMPRIEN)
End DoDot:3
End DoDot:2
End DoDot:1
9 WRITE !!!!,"MISSING 'L' 0 NODE TOTAL: ",TOT1
+1 WRITE !,"MISSING 'L' MISMATCH W/DFN TOTAL: ",TOT2
+2 WRITE !,"MISSING 'L' MISMATCH W/O DFN TOTAL: ",TOT3
+3 WRITE !,"MISSING 'L1' 0 NODE TOTAL: ",TOT4
+4 WRITE !,"MISSING 'L1' MISMATCH W/DFN TOTAL: ",TOT5
+5 WRITE !,"MISSING 'L1' MISMATCH W/O DFN TOTAL: ",TOT6
+6 DO NOW^%DTC
SET RMEND=%
+7 SET ^XTMP("RMPR8PG1","TOTALS")=TOT1_U_TOT2_U_TOT3_U_TOT4_U_TOT5_U_TOT6
+8 SET ^XTMP("RMPR8PG1","END COMPILE")=RMEND
+9 KILL %
+10 QUIT
