- 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 Feb 18, 2025@23:27:22 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