- 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 Feb 18, 2025@23:59:54 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
