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 ---[H[J[2J[HPRCH135P 1292 printed Dec 13, 2024@02:04:59 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
