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 ---[H[J[2J[HPRCF131P 1318 printed Dec 13, 2024@02:01:38 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
