PRCCL406 ;BP-OIFO/SWS-IFCAP ARCHIVE/PURGE UTILITY ROUTINE ;12/07/2005 12:16
V ;;5.1;IFCAP;**95**;Oct 20, 2000
Q
START S IPIEN=0,NREC=0,TREC=0
F S IPIEN=$O(^PRCH(440.6,"PO",IPIEN)) Q:IPIEN'>0 D
.S IEN=0
.I '$D(^PRC(442,IPIEN)) D
..S TREC=TREC+1
..S IEN=0
..F S IEN=$O(^PRCH(440.6,"PO",IPIEN,IEN)) Q:'IEN D KILL4406
..Q
.Q
D CLEAN
Q
KILL4406 ;set temp files then kill invalid 440.6 records
N DA
S NREC=NREC+1
S ^XTMP("IFCAP-PURGE-440-6",IPIEN,IEN)=^PRCH(440.6,IEN,0)
S ^XTMP("IFCAP-PURGE-440-6-REF",IPIEN,IEN)="PO^"_IPIEN_"^"_IEN
S DA=IEN
S DIK="^PRCH(440.6," D ^DIK
K DIK,DA
Q
CLEAN K IEN,IPIEN,TREC,NREC
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCCL406 656 printed Dec 13, 2024@02:00:59 Page 2
PRCCL406 ;BP-OIFO/SWS-IFCAP ARCHIVE/PURGE UTILITY ROUTINE ;12/07/2005 12:16
V ;;5.1;IFCAP;**95**;Oct 20, 2000
+1 QUIT
START SET IPIEN=0
SET NREC=0
SET TREC=0
+1 FOR
SET IPIEN=$ORDER(^PRCH(440.6,"PO",IPIEN))
if IPIEN'>0
QUIT
Begin DoDot:1
+2 SET IEN=0
+3 IF '$DATA(^PRC(442,IPIEN))
Begin DoDot:2
+4 SET TREC=TREC+1
+5 SET IEN=0
+6 FOR
SET IEN=$ORDER(^PRCH(440.6,"PO",IPIEN,IEN))
if 'IEN
QUIT
DO KILL4406
+7 QUIT
End DoDot:2
+8 QUIT
End DoDot:1
+9 DO CLEAN
+10 QUIT
KILL4406 ;set temp files then kill invalid 440.6 records
+1 NEW DA
+2 SET NREC=NREC+1
+3 SET ^XTMP("IFCAP-PURGE-440-6",IPIEN,IEN)=^PRCH(440.6,IEN,0)
+4 SET ^XTMP("IFCAP-PURGE-440-6-REF",IPIEN,IEN)="PO^"_IPIEN_"^"_IEN
+5 SET DA=IEN
+6 SET DIK="^PRCH(440.6,"
DO ^DIK
+7 KILL DIK,DA
+8 QUIT
CLEAN KILL IEN,IPIEN,TREC,NREC
+1 QUIT
