PRC176P ;ALBANY/BJR-RE-INDEX BOC FILE ;5/9/13 15:59
;;5.1;IFCAP;**176**;Oct 20, 2000;Build 11
;Per VHA Directive 2004-038, this routine should not be modified.
;
;
Q
;
;
EN ;Entry point for post install routine
D MES^XPDUTL(" ")
D BMES^XPDUTL("Re-Indexing ""B"" Cross Reference for Budget Object Code (#420.2) file...")
D MES^XPDUTL(" ")
N DIK,PRCNME,PRCIEN
S DIK="^PRCD(420.2,",DIK(1)=".01^B"
D:$D(^PRCD(420.2,"B")) ENALL2^DIK ;Kill existing "B" cross-reference.
I $D(^PRCD(420.2,"B")) S PRCNME="" F S PRCNME=$O(^PRCD(420.2,"B",PRCNME)) Q:PRCNME="" D ;Loop through invalid not killed by Fileman
.S PRCIEN="" F S PRCIEN=$O(^PRCD(420.2,"B",PRCNME,PRCIEN)) Q:PRCIEN="" D
..K ^PRCD(420.2,"B",PRCNME,PRCIEN) ;Kill invalid not killed by Fileman
D ENALL^DIK ;Re-create "B" cross-reference.
D MES^XPDUTL(" ")
D BMES^XPDUTL("Re-Indexing ""B"" Cross Reference IS COMPLETE...")
D MES^XPDUTL(" ")
D BMES^XPDUTL("Re-Indexing ""C"" Cross Reference for Budget Object Code (#420.2) file...")
D MES^XPDUTL(" ")
S DIK="^PRCD(420.2,",DIK(1)=".01^C"
D:$D(^PRCD(420.2,"C")) ENALL2^DIK ;Kill existing "C" cross-reference.
I $D(^PRCD(420.2,"C")) S PRCNME="" F S PRCNME=$O(^PRCD(420.2,"C",PRCNME)) Q:PRCNME="" D ;Loop through invalid not killed by Fileman
.S PRCIEN="" F S PRCIEN=$O(^PRCD(420.2,"C",PRCNME,PRCIEN)) Q:PRCIEN="" D
..K ^PRCD(420.2,"C",PRCNME,PRCIEN) ;Kill invalid not killed by Fileman
D ENALL^DIK ;Re-create "C" cross-reference.
D MES^XPDUTL(" ")
D BMES^XPDUTL("Re-Indexing ""C"" Cross Reference IS COMPLETE...")
D MES^XPDUTL(" ")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRC176P 1604 printed Dec 13, 2024@01:59:27 Page 2
PRC176P ;ALBANY/BJR-RE-INDEX BOC FILE ;5/9/13 15:59
+1 ;;5.1;IFCAP;**176**;Oct 20, 2000;Build 11
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 ;
+5 QUIT
+6 ;
+7 ;
EN ;Entry point for post install routine
+1 DO MES^XPDUTL(" ")
+2 DO BMES^XPDUTL("Re-Indexing ""B"" Cross Reference for Budget Object Code (#420.2) file...")
+3 DO MES^XPDUTL(" ")
+4 NEW DIK,PRCNME,PRCIEN
+5 SET DIK="^PRCD(420.2,"
SET DIK(1)=".01^B"
+6 ;Kill existing "B" cross-reference.
if $DATA(^PRCD(420.2,"B"))
DO ENALL2^DIK
+7 ;Loop through invalid not killed by Fileman
IF $DATA(^PRCD(420.2,"B"))
SET PRCNME=""
FOR
SET PRCNME=$ORDER(^PRCD(420.2,"B",PRCNME))
if PRCNME=""
QUIT
Begin DoDot:1
+8 SET PRCIEN=""
FOR
SET PRCIEN=$ORDER(^PRCD(420.2,"B",PRCNME,PRCIEN))
if PRCIEN=""
QUIT
Begin DoDot:2
+9 ;Kill invalid not killed by Fileman
KILL ^PRCD(420.2,"B",PRCNME,PRCIEN)
End DoDot:2
End DoDot:1
+10 ;Re-create "B" cross-reference.
DO ENALL^DIK
+11 DO MES^XPDUTL(" ")
+12 DO BMES^XPDUTL("Re-Indexing ""B"" Cross Reference IS COMPLETE...")
+13 DO MES^XPDUTL(" ")
+14 DO BMES^XPDUTL("Re-Indexing ""C"" Cross Reference for Budget Object Code (#420.2) file...")
+15 DO MES^XPDUTL(" ")
+16 SET DIK="^PRCD(420.2,"
SET DIK(1)=".01^C"
+17 ;Kill existing "C" cross-reference.
if $DATA(^PRCD(420.2,"C"))
DO ENALL2^DIK
+18 ;Loop through invalid not killed by Fileman
IF $DATA(^PRCD(420.2,"C"))
SET PRCNME=""
FOR
SET PRCNME=$ORDER(^PRCD(420.2,"C",PRCNME))
if PRCNME=""
QUIT
Begin DoDot:1
+19 SET PRCIEN=""
FOR
SET PRCIEN=$ORDER(^PRCD(420.2,"C",PRCNME,PRCIEN))
if PRCIEN=""
QUIT
Begin DoDot:2
+20 ;Kill invalid not killed by Fileman
KILL ^PRCD(420.2,"C",PRCNME,PRCIEN)
End DoDot:2
End DoDot:1
+21 ;Re-create "C" cross-reference.
DO ENALL^DIK
+22 DO MES^XPDUTL(" ")
+23 DO BMES^XPDUTL("Re-Indexing ""C"" Cross Reference IS COMPLETE...")
+24 DO MES^XPDUTL(" ")
+25 QUIT
