PRCB139P ;VMP/RB-MODIFY ALL FY01 THROUGH FY11 CEILING TRANSACTIONS TO 5 DIGIT SEQ NUMBER
;;5.1;IFCAP;**139**;Oct 01, 2009;Build 16
;;Per VHA Directive 2004-038, this routine should not be modified.
; Post install routine in patch PRC*5.1*139 that will modify all existing
; ceiling Transaction in file #421 for FY 2001-2011 from 4 digit sequence
; number to 5 digit sequence number
;;
Q
START ;Modify ceiling tx sequence numbers from 4 to 5 digits for FY 2001-2011
I $D(^XTMP("PRCB139P")) Q
K ^XTMP("PRCB139P") D NOW^%DTC S RMSTART=%
S ^XTMP("PRCB139P","START COMPILE")=RMSTART
S ^XTMP("PRCB139P","END COMPILE")="RUNNING"
S ^XTMP("PRCB139P",0)=$$FMADD^XLFDT(RMSTART,120)_"^"_RMSTART
S U="^",IEN421=0
1 S IEN421=$O(^PRCF(421,IEN421)) G EXIT:'IEN421
S R0=$G(^PRCF(421,IEN421,0)) I R0="" G 1
S TX421=$P(R0,U) I $P(TX421,"-",2)<01!($P(TX421,"-",2)>11) G 1
I $L($P(TX421,"-",3))=5 G 1
2 ;.01 FIELD IN 0 NODE
S SEQ=$P(TX421,"-",3),WSEQ="0000"_SEQ,WSEQ=$E(WSEQ,$L(WSEQ)-4,$L(WSEQ))
S WTX421=$P(TX421,"-",1,2)_"-"_WSEQ
;W !,IEN421,?10,TX421,?30,SEQ,?40,WSEQ,?50,WTX421
3 ;'B' X-REF
S $P(R0,U)=WTX421,^PRCF(421,IEN421,0)=R0
K ^PRCF(421,"B",TX421,IEN421) S ^PRCF(421,"B",WTX421,IEN421)=""
4 ;'AD' X-REF
S RVSEQ=10000-SEQ,NRVSEQ=100000-SEQ
S ^XTMP("PRCB139P",2,"AD",$P(TX421,"-",1,2),RVSEQ)=""
S ^XTMP("PRCB139P",2,"B",TX421,IEN421)=""
S ^XTMP("PRCB139P",2,"D",SEQ,IEN421)=""
K ^PRCF(421,"AD",$P(TX421,"-",1,2),RVSEQ) S ^PRCF(421,"AD",$P(WTX421,"-",1,2),NRVSEQ)=""
S ^XTMP("PRCB139P",1,IEN421,0)=TX421_U_WTX421_U_SEQ_U_WSEQ_U_RVSEQ_U_NRVSEQ
5 ;'AD' X-REF
K ^PRCF(421,"D",SEQ,IEN421) S ^PRCF(421,"D",WSEQ,IEN421)=""
G 1
EXIT ;
D NOW^%DTC S RMEND=%
S ^XTMP("PRCB139P","END COMPILE")=RMEND
K RMEND,RMSTART,%,IEN421,R0,TX421,SEQ,WSEQ,WTX421,RVSEQ,NRVSEQ
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCB139P 1819 printed Sep 23, 2025@19:36:13 Page 2
PRCB139P ;VMP/RB-MODIFY ALL FY01 THROUGH FY11 CEILING TRANSACTIONS TO 5 DIGIT SEQ NUMBER
+1 ;;5.1;IFCAP;**139**;Oct 01, 2009;Build 16
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ; Post install routine in patch PRC*5.1*139 that will modify all existing
+4 ; ceiling Transaction in file #421 for FY 2001-2011 from 4 digit sequence
+5 ; number to 5 digit sequence number
+6 ;;
+7 QUIT
START ;Modify ceiling tx sequence numbers from 4 to 5 digits for FY 2001-2011
+1 IF $DATA(^XTMP("PRCB139P"))
QUIT
+2 KILL ^XTMP("PRCB139P")
DO NOW^%DTC
SET RMSTART=%
+3 SET ^XTMP("PRCB139P","START COMPILE")=RMSTART
+4 SET ^XTMP("PRCB139P","END COMPILE")="RUNNING"
+5 SET ^XTMP("PRCB139P",0)=$$FMADD^XLFDT(RMSTART,120)_"^"_RMSTART
+6 SET U="^"
SET IEN421=0
1 SET IEN421=$ORDER(^PRCF(421,IEN421))
if 'IEN421
GOTO EXIT
+1 SET R0=$GET(^PRCF(421,IEN421,0))
IF R0=""
GOTO 1
+2 SET TX421=$PIECE(R0,U)
IF $PIECE(TX421,"-",2)<01!($PIECE(TX421,"-",2)>11)
GOTO 1
+3 IF $LENGTH($PIECE(TX421,"-",3))=5
GOTO 1
2 ;.01 FIELD IN 0 NODE
+1 SET SEQ=$PIECE(TX421,"-",3)
SET WSEQ="0000"_SEQ
SET WSEQ=$EXTRACT(WSEQ,$LENGTH(WSEQ)-4,$LENGTH(WSEQ))
+2 SET WTX421=$PIECE(TX421,"-",1,2)_"-"_WSEQ
+3 ;W !,IEN421,?10,TX421,?30,SEQ,?40,WSEQ,?50,WTX421
3 ;'B' X-REF
+1 SET $PIECE(R0,U)=WTX421
SET ^PRCF(421,IEN421,0)=R0
+2 KILL ^PRCF(421,"B",TX421,IEN421)
SET ^PRCF(421,"B",WTX421,IEN421)=""
4 ;'AD' X-REF
+1 SET RVSEQ=10000-SEQ
SET NRVSEQ=100000-SEQ
+2 SET ^XTMP("PRCB139P",2,"AD",$PIECE(TX421,"-",1,2),RVSEQ)=""
+3 SET ^XTMP("PRCB139P",2,"B",TX421,IEN421)=""
+4 SET ^XTMP("PRCB139P",2,"D",SEQ,IEN421)=""
+5 KILL ^PRCF(421,"AD",$PIECE(TX421,"-",1,2),RVSEQ)
SET ^PRCF(421,"AD",$PIECE(WTX421,"-",1,2),NRVSEQ)=""
+6 SET ^XTMP("PRCB139P",1,IEN421,0)=TX421_U_WTX421_U_SEQ_U_WSEQ_U_RVSEQ_U_NRVSEQ
5 ;'AD' X-REF
+1 KILL ^PRCF(421,"D",SEQ,IEN421)
SET ^PRCF(421,"D",WSEQ,IEN421)=""
+2 GOTO 1
EXIT ;
+1 DO NOW^%DTC
SET RMEND=%
+2 SET ^XTMP("PRCB139P","END COMPILE")=RMEND
+3 KILL RMEND,RMSTART,%,IEN421,R0,TX421,SEQ,WSEQ,WTX421,RVSEQ,NRVSEQ
+4 QUIT
