PRCH135P.m

PRCH135P ;VMP/RB - FIX XREF 'RB' FOR DUPLCATE ENTRIES #410 ;03/09/09

 ;;5.1;IFCAP;**135**;02/09/09;Build 7

 ;;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 [CHANGE EXISTING TRANSACTION NUMBER] or when editing

 ;   incomplete orders to new FCP.

 ;

BUILD K ^XTMP("PRCH135P") D NOW^%DTC S RMSTART=%

 S ^XTMP("PRCH135P","START COMPILE")=RMSTART

 S ^XTMP("PRCH135P","END COMPILE")="RUNNING"

 S ^XTMP("PRCH135P",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=""

 ;BUILD '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" G 3

 G 2

3 S ^XTMP("PRCH135P",410,REQNO,IEN,0)=R0_";"_WDS

 K ^PRCS(410,"RB",REQNO,IEN)

 G 2

EXIT ;

 D NOW^%DTC S RMEND=%

 S ^XTMP("PRCH135P","END COMPILE")=RMEND

 K RMEND,RMSTART,%,IEN,R0,REQNO,RBXREF,QTRDT,BREQ,DSH,R0REQ,WDS

 Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---PRCH135P   1292     printed  Apr 09, 2024@21:18:55                                                                                                                                                                                                    Page 2

PRCH135P  ;VMP/RB - FIX XREF 'RB' FOR DUPLCATE ENTRIES #410 ;03/09/09

 +1       ;;5.1;IFCAP;**135**;02/09/09;Build 7

 +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 [CHANGE EXISTING TRANSACTION NUMBER] or when editing

 +3       ;   incomplete orders to new FCP.

 +4       ;

BUILD      KILL ^XTMP("PRCH135P")

           DO NOW^%DTC

           SET RMSTART=%

 +1        SET ^XTMP("PRCH135P","START COMPILE")=RMSTART

 +2        SET ^XTMP("PRCH135P","END COMPILE")="RUNNING"

 +3        SET ^XTMP("PRCH135P",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       ;BUILD '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"

           GOTO 3

 +7        GOTO 2

3          SET ^XTMP("PRCH135P",410,REQNO,IEN,0)=R0_";"_WDS

 +1        KILL ^PRCS(410,"RB",REQNO,IEN)

 +2        GOTO 2

EXIT      ;

 +1        DO NOW^%DTC

           SET RMEND=%

 +2        SET ^XTMP("PRCH135P","END COMPILE")=RMEND

 +3        KILL RMEND,RMSTART,%,IEN,R0,REQNO,RBXREF,QTRDT,BREQ,DSH,R0REQ,WDS

 +4        QUIT