PRC5192P ;BP/TJH - IFCAP Post-Init for PRC*5.1*92 ; 28 Oct 2005 3:16 PM
;;5.1;IFCAP;**92**;Oct 20, 2000
QUIT
;
START ; remove invalid entries from the "C" xref of file #442
D BMES^XPDUTL("Removing invalid entries from the C xref of file #442...")
N PRCDA,PRCDB,PRCREC,PRCPO
S PRCDA=0,U="^"
F S PRCDA=$O(^PRC(442,"C",PRCDA)) Q:PRCDA="" D
. S PRCDB=0
. F S PRCDB=$O(^PRC(442,"C",PRCDA,PRCDB)) Q:PRCDB="" D
.. S PRCREC=$G(^PRC(442,PRCDB,0)) ; get associated record, zero node
.. S PRCPO=$P($P(PRCREC,U,1),"-",2) ; extract purchase order w/o STATION NUMBER
.. I PRCPO'=PRCDA K ^PRC(442,"C",PRCDA,PRCDB) ; if PO# doesn't match subscript, remove the xref entry.
D BMES^XPDUTL("Cleanup of C xref complete.")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRC5192P 738 printed Sep 23, 2025@19:35:49 Page 2
PRC5192P ;BP/TJH - IFCAP Post-Init for PRC*5.1*92 ; 28 Oct 2005 3:16 PM
+1 ;;5.1;IFCAP;**92**;Oct 20, 2000
+2 QUIT
+3 ;
START ; remove invalid entries from the "C" xref of file #442
+1 DO BMES^XPDUTL("Removing invalid entries from the C xref of file #442...")
+2 NEW PRCDA,PRCDB,PRCREC,PRCPO
+3 SET PRCDA=0
SET U="^"
+4 FOR
SET PRCDA=$ORDER(^PRC(442,"C",PRCDA))
if PRCDA=""
QUIT
Begin DoDot:1
+5 SET PRCDB=0
+6 FOR
SET PRCDB=$ORDER(^PRC(442,"C",PRCDA,PRCDB))
if PRCDB=""
QUIT
Begin DoDot:2
+7 ; get associated record, zero node
SET PRCREC=$GET(^PRC(442,PRCDB,0))
+8 ; extract purchase order w/o STATION NUMBER
SET PRCPO=$PIECE($PIECE(PRCREC,U,1),"-",2)
+9 ; if PO# doesn't match subscript, remove the xref entry.
IF PRCPO'=PRCDA
KILL ^PRC(442,"C",PRCDA,PRCDB)
End DoDot:2
End DoDot:1
+10 DO BMES^XPDUTL("Cleanup of C xref complete.")
+11 QUIT
