- 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 Feb 18, 2025@23:31:22 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