PRCF131P.m

PRCF131P ;VMP/RB - PURGE FILE ^PRCF(421.9 IF 442 ENTRY PURGED #410 ;03/09/09

 ;;5.1;IFCAP;**131**;02/09/09;Build 13

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

 ;;

 Q

FIX ;

 ;1. Post install to delete entries in file ^PRCF(421.9) that have .01

 ;   field with no existing ^PRC(442) corresponding endtry for PO number

 ;

BUILD K ^XTMP("PRCF131P") D NOW^%DTC S RMSTART=%

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

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

 S ^XTMP("PRCF131P",0)=$$FMADD^XLFDT(RMSTART,120)_"^"_RMSTART

0 ;FIND ^PRCF(421.9) entries with no ^PRC(442) matching rec for po#

 S IEN4219=0,IEN442=0,U="^"

1 S IENREC0="",PRCFPO="",IEN442=0

 S IEN4219=$O(^PRCF(421.9,IEN4219)) G EXIT:IEN4219=""!(IEN4219]"@")

 S IENREC0=$G(^PRCF(421.9,IEN4219,0)) I IENREC0="" S ERTYP=1,IENREC0="MISSING 0 NODE" G 3

 S PRCFPO=$P(IENREC0,U) I PRCFPO="" S ERTYP=2 G 3

 S IEN442=$O(^PRC(442,"B",PRCFPO,0)) I IEN442="" S ERTYP=3 G 3

 I '$D(^PRC(442,IEN442,0)) S ERTYP=4 G 3

 G 1

3 S ^XTMP("PRCF131P",421.9,IEN4219,ERTYP)=IENREC0

 S $P(^XTMP("PRCF131P",421.9,IEN4219,ERTYP),U,5)=$G(IEN442)

 S DA=IEN4219,DIK="^PRCF(421.9," D ^DIK K DA,DIK

 G 1

EXIT ;

 D NOW^%DTC S RMEND=%

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

 K IEN4219,IENREC0,PRCFPO,IEN442,ERTYP,%,DA,RMEND,RMSTART

 Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---PRCF131P   1318     printed  Mar 13, 2025@21:06:27                                                                                                                                                                                                    Page 2

PRCF131P  ;VMP/RB - PURGE FILE ^PRCF(421.9 IF 442 ENTRY PURGED #410 ;03/09/09

 +1       ;;5.1;IFCAP;**131**;02/09/09;Build 13

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

 +3       ;;

 +4        QUIT 

FIX       ;

 +1       ;1. Post install to delete entries in file ^PRCF(421.9) that have .01

 +2       ;   field with no existing ^PRC(442) corresponding endtry for PO number

 +3       ;

BUILD      KILL ^XTMP("PRCF131P")

           DO NOW^%DTC

           SET RMSTART=%

 +1        SET ^XTMP("PRCF131P","START COMPILE")=RMSTART

 +2        SET ^XTMP("PRCF131P","END COMPILE")="RUNNING"

 +3        SET ^XTMP("PRCF131P",0)=$$FMADD^XLFDT(RMSTART,120)_"^"_RMSTART

0         ;FIND ^PRCF(421.9) entries with no ^PRC(442) matching rec for po#

 +1        SET IEN4219=0

           SET IEN442=0

           SET U="^"

1          SET IENREC0=""

           SET PRCFPO=""

           SET IEN442=0

 +1        SET IEN4219=$ORDER(^PRCF(421.9,IEN4219))

           if IEN4219=""!(IEN4219]"@")

               GOTO EXIT

 +2        SET IENREC0=$GET(^PRCF(421.9,IEN4219,0))

           IF IENREC0=""

               SET ERTYP=1

               SET IENREC0="MISSING 0 NODE"

               GOTO 3

 +3        SET PRCFPO=$PIECE(IENREC0,U)

           IF PRCFPO=""

               SET ERTYP=2

               GOTO 3

 +4        SET IEN442=$ORDER(^PRC(442,"B",PRCFPO,0))

           IF IEN442=""

               SET ERTYP=3

               GOTO 3

 +5        IF '$DATA(^PRC(442,IEN442,0))

               SET ERTYP=4

               GOTO 3

 +6        GOTO 1

3          SET ^XTMP("PRCF131P",421.9,IEN4219,ERTYP)=IENREC0

 +1        SET $PIECE(^XTMP("PRCF131P",421.9,IEN4219,ERTYP),U,5)=$GET(IEN442)

 +2        SET DA=IEN4219

           SET DIK="^PRCF(421.9,"

           DO ^DIK

           KILL DA,DIK

 +3        GOTO 1

EXIT      ;

 +1        DO NOW^%DTC

           SET RMEND=%

 +2        SET ^XTMP("PRCF131P","END COMPILE")=RMEND

 +3        KILL IEN4219,IENREC0,PRCFPO,IEN442,ERTYP,%,DA,RMEND,RMSTART

 +4        QUIT