PRCIN45 ;BP-OIFO/SWS-IFCAP UTILITY TO CLEAN UP BAD LINKS IN FILE 445 TO 410 ;12/07/2005 12:16
V ;;5.1;IFCAP;**95**;Oct 20, 2000
Q
START S IPIEN=0,NREC=0,TREC=0
S ^XTMP("IFCAP-PURGE-445",0)=$$FMADD^XLFDT(DT,7)_"^"_DT_"^RECORDS PURGED FROM FILE 445 BY PRC*5.1*95"
S ^XTMP("IFCAP-PURGE-445-REF",0)=$$FMADD^XLFDT(DT,7)_"^"_DT_"^B CROSS REFERENCES PURGED FROM FILE 445 BY PRC*5.1*95"
F S IPIEN=$O(^PRCP(445,IPIEN)) Q:IPIEN'>0 D
.S IEN=0
.F S IEN=$O(^PRCP(445,IPIEN,1,IEN)) Q:IEN'>0 D
..S TREC=TREC+1
..Q:'$D(^PRCP(445,IPIEN,1,IEN,7))
..S TTLI=$P(^PRCP(445,IPIEN,1,IEN,7,0),U,4)
..S ITIEN=0
..F S ITIEN=$O(^PRCP(445,IPIEN,1,IEN,7,ITIEN)) Q:ITIEN'>0 D
...I '$D(^PRCS(410,ITIEN)) D KILL445
..S $P(^PRCP(445,IPIEN,1,IEN,7,0),U,4)=TTLI
..;-leave this with zero amount don't delete? - I TTLI=0 S ^PRCP(445,IPIEN,1,IEN,7) Q
..Q
.Q
D WTOTAL,CLEAN
Q
WTOTAL ;
D BMES^XPDUTL(NREC_" RECORDS DELETED FROM FILE 445")
D BMES^XPDUTL("BACKUP RECORDS STORED IN THE FOLLOWING LOCATIONS FOR 7 DAYS:")
D BMES^XPDUTL("^XTMP(""IFCAP-PURGE-445"")")
D BMES^XPDUTL("^XTMP(""IFCAP-PURGE-445-REF"")")
Q
KILL445 ;set temp files then kill invalid 445 records
S NREC=NREC+1
S ^XTMP("IFCAP-PURGE-445",IPIEN,1,IEN,7,ITIEN,0)=^PRCP(445,IPIEN,1,IEN,7,ITIEN,0)
S ^XTMP("IFCAP-PURGE-445-REF",IPIEN,1,IEN,7,"B",ITIEN,ITIEN)="B^"_ITIEN_"^"_ITIEN
Q:'$D(^PRCP(445,IPIEN,1,IEN,7,ITIEN,0))
S DA(2)=IPIEN,DA(1)=IEN,DA=ITIEN
S DIK="^PRCP(445,"_DA(2)_",1,"_DA(1)_",7,"
D ^DIK
K DIK
S TTLI=TTLI-1
Q
CLEAN K TTLI,IEN,IPIEN,ITIEN,TREC,NREC
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCIN45 1573 printed Oct 16, 2024@18:12:15 Page 2
PRCIN45 ;BP-OIFO/SWS-IFCAP UTILITY TO CLEAN UP BAD LINKS IN FILE 445 TO 410 ;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 SET ^XTMP("IFCAP-PURGE-445",0)=$$FMADD^XLFDT(DT,7)_"^"_DT_"^RECORDS PURGED FROM FILE 445 BY PRC*5.1*95"
+2 SET ^XTMP("IFCAP-PURGE-445-REF",0)=$$FMADD^XLFDT(DT,7)_"^"_DT_"^B CROSS REFERENCES PURGED FROM FILE 445 BY PRC*5.1*95"
+3 FOR
SET IPIEN=$ORDER(^PRCP(445,IPIEN))
if IPIEN'>0
QUIT
Begin DoDot:1
+4 SET IEN=0
+5 FOR
SET IEN=$ORDER(^PRCP(445,IPIEN,1,IEN))
if IEN'>0
QUIT
Begin DoDot:2
+6 SET TREC=TREC+1
+7 if '$DATA(^PRCP(445,IPIEN,1,IEN,7))
QUIT
+8 SET TTLI=$PIECE(^PRCP(445,IPIEN,1,IEN,7,0),U,4)
+9 SET ITIEN=0
+10 FOR
SET ITIEN=$ORDER(^PRCP(445,IPIEN,1,IEN,7,ITIEN))
if ITIEN'>0
QUIT
Begin DoDot:3
+11 IF '$DATA(^PRCS(410,ITIEN))
DO KILL445
End DoDot:3
+12 SET $PIECE(^PRCP(445,IPIEN,1,IEN,7,0),U,4)=TTLI
+13 ;-leave this with zero amount don't delete? - I TTLI=0 S ^PRCP(445,IPIEN,1,IEN,7) Q
+14 QUIT
End DoDot:2
+15 QUIT
End DoDot:1
+16 DO WTOTAL
DO CLEAN
+17 QUIT
WTOTAL ;
+1 DO BMES^XPDUTL(NREC_" RECORDS DELETED FROM FILE 445")
+2 DO BMES^XPDUTL("BACKUP RECORDS STORED IN THE FOLLOWING LOCATIONS FOR 7 DAYS:")
+3 DO BMES^XPDUTL("^XTMP(""IFCAP-PURGE-445"")")
+4 DO BMES^XPDUTL("^XTMP(""IFCAP-PURGE-445-REF"")")
+5 QUIT
KILL445 ;set temp files then kill invalid 445 records
+1 SET NREC=NREC+1
+2 SET ^XTMP("IFCAP-PURGE-445",IPIEN,1,IEN,7,ITIEN,0)=^PRCP(445,IPIEN,1,IEN,7,ITIEN,0)
+3 SET ^XTMP("IFCAP-PURGE-445-REF",IPIEN,1,IEN,7,"B",ITIEN,ITIEN)="B^"_ITIEN_"^"_ITIEN
+4 if '$DATA(^PRCP(445,IPIEN,1,IEN,7,ITIEN,0))
QUIT
+5 SET DA(2)=IPIEN
SET DA(1)=IEN
SET DA=ITIEN
+6 SET DIK="^PRCP(445,"_DA(2)_",1,"_DA(1)_",7,"
+7 DO ^DIK
+8 KILL DIK
+9 SET TTLI=TTLI-1
+10 QUIT
CLEAN KILL TTLI,IEN,IPIEN,ITIEN,TREC,NREC
+1 QUIT
+2 ;
