PRCB139P.m

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 ---PRCB139P   1819     printed  Apr 09, 2024@21:09:29                                                                                                                                                                                                    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