PRCS156P ;VMP/RB - FIX XREF 'RB' FOR DUPLCATE ENTRIES #410 ;12/09/10
;;5.1;IFCAP;**156**;Dec 9, 2010;Build 5
;;Per VHA Directive 2004-038, this routine should not be modified.
;;
Q
FIX410 ;
;1. Post install to delete duplicate entries in x-rec 'RB' caused when
; using option [PRCH CONV TEMP].
;
Q:$D(^XTMP("PRCS156P"))
BUILD K ^XTMP("PRCS156P") D NOW^%DTC S RMSTART=%,TT=0
S ^XTMP("PRCS156P","START COMPILE")=RMSTART
S ^XTMP("PRCS156P","END COMPILE")="RUNNING"
S ^XTMP("PRCS156P",0)=$$FMADD^XLFDT(RMSTART,120)_"^"_RMSTART
0 ;FIND DUPLICATE ENTRIES IN ^PRC(410,"RB") INDEX
S REQNO="",IEN=0,U="^",DSH="-"
1 S REQNO=$O(^PRCS(410,"RB",REQNO)) G EXIT:REQNO=""!(REQNO]"@")
2 S IEN=$O(^PRCS(410,"RB",REQNO,IEN)) G 1:IEN=""
;AUDIT 'RB' X-REF
S R0=$G(^PRCS(410,IEN,0)) I R0="" S WDS="MISSING 0 NODE" G 3
S R0REQ=$P(R0,U),QTRDT=$P(R0,U,11) G 2:QTRDT'>0
S BREQ=QTRDT_DSH_$P(R0REQ,DSH)_DSH_$P(R0REQ,DSH,4)_DSH_$P(R0REQ,DSH,2)_DSH_$P(R0REQ,DSH,5)
I REQNO=BREQ G 2
S WDS="DUPLICATE RB"
3 S ^XTMP("PRCS156P",410,REQNO,IEN,0)=R0_";"_WDS,TT=TT+1
K ^PRCS(410,"RB",REQNO,IEN)
G 2
EXIT ;
D NOW^%DTC S RMEND=%
S ^XTMP("PRCS156P","END COMPILE")=RMEND_U_TT
W !!,"NUMBER IEN 'RB' MISMATCHES: ",TT
K RMEND,RMSTART,%,IEN,R0,REQNO,RBXREF,QTRDT,BREQ,DSH,R0REQ,WDS,TT
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCS156P 1302 printed Sep 23, 2025@19:53:10 Page 2
PRCS156P ;VMP/RB - FIX XREF 'RB' FOR DUPLCATE ENTRIES #410 ;12/09/10
+1 ;;5.1;IFCAP;**156**;Dec 9, 2010;Build 5
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;;
+4 QUIT
FIX410 ;
+1 ;1. Post install to delete duplicate entries in x-rec 'RB' caused when
+2 ; using option [PRCH CONV TEMP].
+3 ;
+4 if $DATA(^XTMP("PRCS156P"))
QUIT
BUILD KILL ^XTMP("PRCS156P")
DO NOW^%DTC
SET RMSTART=%
SET TT=0
+1 SET ^XTMP("PRCS156P","START COMPILE")=RMSTART
+2 SET ^XTMP("PRCS156P","END COMPILE")="RUNNING"
+3 SET ^XTMP("PRCS156P",0)=$$FMADD^XLFDT(RMSTART,120)_"^"_RMSTART
0 ;FIND DUPLICATE ENTRIES IN ^PRC(410,"RB") INDEX
+1 SET REQNO=""
SET IEN=0
SET U="^"
SET DSH="-"
1 SET REQNO=$ORDER(^PRCS(410,"RB",REQNO))
if REQNO=""!(REQNO]"@")
GOTO EXIT
2 SET IEN=$ORDER(^PRCS(410,"RB",REQNO,IEN))
if IEN=""
GOTO 1
+1 ;AUDIT 'RB' X-REF
+2 SET R0=$GET(^PRCS(410,IEN,0))
IF R0=""
SET WDS="MISSING 0 NODE"
GOTO 3
+3 SET R0REQ=$PIECE(R0,U)
SET QTRDT=$PIECE(R0,U,11)
if QTRDT'>0
GOTO 2
+4 SET BREQ=QTRDT_DSH_$PIECE(R0REQ,DSH)_DSH_$PIECE(R0REQ,DSH,4)_DSH_$PIECE(R0REQ,DSH,2)_DSH_$PIECE(R0REQ,DSH,5)
+5 IF REQNO=BREQ
GOTO 2
+6 SET WDS="DUPLICATE RB"
3 SET ^XTMP("PRCS156P",410,REQNO,IEN,0)=R0_";"_WDS
SET TT=TT+1
+1 KILL ^PRCS(410,"RB",REQNO,IEN)
+2 GOTO 2
EXIT ;
+1 DO NOW^%DTC
SET RMEND=%
+2 SET ^XTMP("PRCS156P","END COMPILE")=RMEND_U_TT
+3 WRITE !!,"NUMBER IEN 'RB' MISMATCHES: ",TT
+4 KILL RMEND,RMSTART,%,IEN,R0,REQNO,RBXREF,QTRDT,BREQ,DSH,R0REQ,WDS,TT
+5 QUIT
