PRCS150P.m

PRCS150P ;MNT/RB-PURGE ALL OLD PRCS(410,"B" REQUEST REFERENCES 

 ;;5.1;IFCAP;**150**;Oct 20, 2000;Build 24

 ;;Per VHA Directive 2004-038, this routine should not be modified.

 ;  Pre install routine in patch PRC*5.1*150 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/2010 will be deleted. 

 ;;

 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,HIEN

 K ^XTMP("PRCS150P")

 D NOW^%DTC S RMSTART=%

 S ^XTMP("PRCS150P","START COMPILE")=RMSTART

 S ^XTMP("PRCS150P","END COMPILE")="RUNNING"

 S ^XTMP("PRCS150P",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("PRCS150P","H",REQ,IEN410)=R0

 I REQ=TRANX G 4

3 ;KILL EXTRANEOUS 'B' X-REFS

 K ^PRCS(410,"B",REQ,IEN410)

 S ^XTMP("PRCS150P","B",REQ,IEN410)=R0,TOT=TOT+1

 G 2

4 ;CHECK TEMP TX ENTRY DATE FOR OLD ENTRIES AND DELETE ALL PRIOR TO 10/01/2010

 S R1=$G(^PRCS(410,IEN410,1)),ENTDT=+R1

 I ENTDT>3100930,$P(R0,U,2)'="CA" G 2

 S ^XTMP("PRCS150P","DT-CA",REQ,IEN410)=ENTDT_U_R0,TOT1=TOT1+1

 S HIEN=$P(^PRCS(410,0),U,3)+1

 S DA=IEN410,DIK="^PRCS(410," D ^DIK K DIK

 S $P(^PRCS(410,0),U,3)=HIEN

 G 2

EXIT ;

 D NOW^%DTC S RMEND=%

 S ^XTMP("PRCS150P","TOTALS")=TOT_U_TOT1

 S ^XTMP("PRCS150P","END COMPILE")=RMEND

 K %,DA,HIEN

 Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---PRCS150P   1919     printed  Apr 23, 2025@18:31:35                                                                                                                                                                                                    Page 2

PRCS150P  ;MNT/RB-PURGE ALL OLD PRCS(410,"B" REQUEST REFERENCES 

 +1       ;;5.1;IFCAP;**150**;Oct 20, 2000;Build 24

 +2       ;;Per VHA Directive 2004-038, this routine should not be modified.

 +3       ;  Pre install routine in patch PRC*5.1*150 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/2010 will be deleted. 

 +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,HIEN

 +2        KILL ^XTMP("PRCS150P")

 +3        DO NOW^%DTC

           SET RMSTART=%

 +4        SET ^XTMP("PRCS150P","START COMPILE")=RMSTART

 +5        SET ^XTMP("PRCS150P","END COMPILE")="RUNNING"

 +6        SET ^XTMP("PRCS150P",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("PRCS150P","H",REQ,IEN410)=R0

                           End DoDot:1

 +5        IF REQ=TRANX

               GOTO 4

3         ;KILL EXTRANEOUS 'B' X-REFS

 +1        KILL ^PRCS(410,"B",REQ,IEN410)

 +2        SET ^XTMP("PRCS150P","B",REQ,IEN410)=R0

           SET TOT=TOT+1

 +3        GOTO 2

4         ;CHECK TEMP TX ENTRY DATE FOR OLD ENTRIES AND DELETE ALL PRIOR TO 10/01/2010

 +1        SET R1=$GET(^PRCS(410,IEN410,1))

           SET ENTDT=+R1

 +2        IF ENTDT>3100930

               IF $PIECE(R0,U,2)'="CA"

                   GOTO 2

 +3        SET ^XTMP("PRCS150P","DT-CA",REQ,IEN410)=ENTDT_U_R0

           SET TOT1=TOT1+1

 +4        SET HIEN=$PIECE(^PRCS(410,0),U,3)+1

 +5        SET DA=IEN410

           SET DIK="^PRCS(410,"

           DO ^DIK

           KILL DIK

 +6        SET $PIECE(^PRCS(410,0),U,3)=HIEN

 +7        GOTO 2

EXIT      ;

 +1        DO NOW^%DTC

           SET RMEND=%

 +2        SET ^XTMP("PRCS150P","TOTALS")=TOT_U_TOT1

 +3        SET ^XTMP("PRCS150P","END COMPILE")=RMEND

 +4        KILL %,DA,HIEN

 +5        QUIT