PRCS156P.m

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 ---PRCS156P   1302     printed  Apr 09, 2024@21:03:56                                                                                                                                                                                                    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