PRCS149P ;VMP/RB-PURGE ALL OLD PRCS(410,"B" REQUEST REFERENCES
;;5.1;IFCAP;**149**;Oct 01, 2009;Build 5
;;Per VHA Directive 2004-038, this routine should not be modified.
; Pre install routine in patch PRC*5.1*149 that will purge temporary
; request entries in cross reference ^PRCS(410,"B") that were left
; unkilled when the temporary request was changed via option
; 'CHANGE EXISTING TRANSACTION NUMBER'
; Also, temporary transaction entries in file 410 that are prior to
; 10/01/2009 will be purged.
;;
Q
START ;Kill off extraneous index xref left behind when using CHANGE EXISTING TRANSACTION NUMBER option
N RMSTART,REQ,IEN410,RMEND,R0,R1,TRANX,ENTDT,TOT,TOT1
I $D(^XTMP("PRCS149P")) Q
D NOW^%DTC S RMSTART=%
S ^XTMP("PRCS149P","START COMPILE")=RMSTART
S ^XTMP("PRCS149P","END COMPILE")="RUNNING"
S ^XTMP("PRCS149P",0)=$$FMADD^XLFDT(RMSTART,120)_"^"_RMSTART
S U="^",REQ="999-",(TOT,TOT1)=0
1 S REQ=$O(^PRCS(410,"B",REQ)),IEN410=0 G EXIT:REQ=""
I REQ+0>0 G 1
2 S IEN410=$O(^PRCS(410,"B",REQ,IEN410)) G 1:IEN410=""
S R0=$G(^PRCS(410,IEN410,0)),TRANX=$P(R0,U)
I REQ=TRANX,$P(R0,U,3)'="",$P(R0,U,2)'="CA",'$D(^PRCS(410,"H",$P(R0,U,3),IEN410)) D
. S ^PRCS(410,"H",$P(R0,U,3),IEN410)=$P($G(^PRCS(410,IEN410,1)),U,2)
. S ^XTMP("PRCS149P","H",REQ,IEN410)=R0
I REQ=TRANX G 4
3 ;KILL 'B' X-REF
K ^PRCS(410,"B",REQ,IEN410)
S ^XTMP("PRCS149P","B",REQ,IEN410)=R0,TOT=TOT+1
G 2
4 ;CHECK TEMP TX ENTRY DATE FOR OLD ENTRIES AND CANCEL ALL PRIOR TO 10/01/2009
I $P(R0,U,3)'="",$P(R0,U,2)'="CA",'$D(^PRCS(410,"H",$P(R0,U,3),IEN410)) D
. S ^PRCS(410,"H",$P(R0,U,3),IEN410)=$P($G(^PRCS(410,IEN410,1)),U,2)
. S ^XTMP("PRCS149P","H",REQ,IEN410)=R0
S R1=$G(^PRCS(410,IEN410,1)),ENTDT=+R1
I ENTDT>3090930 G 2
S ^XTMP("PRCS149P","DT",REQ,IEN410)=ENTDT_U_R0,TOT1=TOT1+1
S DIE="^PRCS(410,",DA=IEN410,DR="1////^S X=""CA""" D ^DIE K DIE,DA
G 2
EXIT ;
D NOW^%DTC S RMEND=%
S ^XTMP("PRCS149P","TOTALS")=TOT_U_TOT1
S ^XTMP("PRCS149P","END COMPILE")=RMEND
K %,DR
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCS149P 2033 printed Oct 16, 2024@18:17:47 Page 2
PRCS149P ;VMP/RB-PURGE ALL OLD PRCS(410,"B" REQUEST REFERENCES
+1 ;;5.1;IFCAP;**149**;Oct 01, 2009;Build 5
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ; Pre install routine in patch PRC*5.1*149 that will purge temporary
+4 ; request entries in cross reference ^PRCS(410,"B") that were left
+5 ; unkilled when the temporary request was changed via option
+6 ; 'CHANGE EXISTING TRANSACTION NUMBER'
+7 ; Also, temporary transaction entries in file 410 that are prior to
+8 ; 10/01/2009 will be purged.
+9 ;;
+10 QUIT
START ;Kill off extraneous index xref left behind when using CHANGE EXISTING TRANSACTION NUMBER option
+1 NEW RMSTART,REQ,IEN410,RMEND,R0,R1,TRANX,ENTDT,TOT,TOT1
+2 IF $DATA(^XTMP("PRCS149P"))
QUIT
+3 DO NOW^%DTC
SET RMSTART=%
+4 SET ^XTMP("PRCS149P","START COMPILE")=RMSTART
+5 SET ^XTMP("PRCS149P","END COMPILE")="RUNNING"
+6 SET ^XTMP("PRCS149P",0)=$$FMADD^XLFDT(RMSTART,120)_"^"_RMSTART
+7 SET U="^"
SET REQ="999-"
SET (TOT,TOT1)=0
1 SET REQ=$ORDER(^PRCS(410,"B",REQ))
SET IEN410=0
if REQ=""
GOTO EXIT
+1 IF REQ+0>0
GOTO 1
2 SET IEN410=$ORDER(^PRCS(410,"B",REQ,IEN410))
if IEN410=""
GOTO 1
+1 SET R0=$GET(^PRCS(410,IEN410,0))
SET TRANX=$PIECE(R0,U)
+2 IF REQ=TRANX
IF $PIECE(R0,U,3)'=""
IF $PIECE(R0,U,2)'="CA"
IF '$DATA(^PRCS(410,"H",$PIECE(R0,U,3),IEN410))
Begin DoDot:1
+3 SET ^PRCS(410,"H",$PIECE(R0,U,3),IEN410)=$PIECE($GET(^PRCS(410,IEN410,1)),U,2)
+4 SET ^XTMP("PRCS149P","H",REQ,IEN410)=R0
End DoDot:1
+5 IF REQ=TRANX
GOTO 4
3 ;KILL 'B' X-REF
+1 KILL ^PRCS(410,"B",REQ,IEN410)
+2 SET ^XTMP("PRCS149P","B",REQ,IEN410)=R0
SET TOT=TOT+1
+3 GOTO 2
4 ;CHECK TEMP TX ENTRY DATE FOR OLD ENTRIES AND CANCEL ALL PRIOR TO 10/01/2009
+1 IF $PIECE(R0,U,3)'=""
IF $PIECE(R0,U,2)'="CA"
IF '$DATA(^PRCS(410,"H",$PIECE(R0,U,3),IEN410))
Begin DoDot:1
+2 SET ^PRCS(410,"H",$PIECE(R0,U,3),IEN410)=$PIECE($GET(^PRCS(410,IEN410,1)),U,2)
+3 SET ^XTMP("PRCS149P","H",REQ,IEN410)=R0
End DoDot:1
+4 SET R1=$GET(^PRCS(410,IEN410,1))
SET ENTDT=+R1
+5 IF ENTDT>3090930
GOTO 2
+6 SET ^XTMP("PRCS149P","DT",REQ,IEN410)=ENTDT_U_R0
SET TOT1=TOT1+1
+7 SET DIE="^PRCS(410,"
SET DA=IEN410
SET DR="1////^S X=""CA"""
DO ^DIE
KILL DIE,DA
+8 GOTO 2
EXIT ;
+1 DO NOW^%DTC
SET RMEND=%
+2 SET ^XTMP("PRCS149P","TOTALS")=TOT_U_TOT1
+3 SET ^XTMP("PRCS149P","END COMPILE")=RMEND
+4 KILL %,DR
+5 QUIT
