PRCINAR ;BP-OIFO/SWS-IFCAP ARCHIVE/PURGE FIX ;12/07/2005 12:16
V ;;5.1;IFCAP;**95**;Oct 20, 2000
Q
START S (MYREC,MYPTR,SUBREC,NREC)=0
S ^XTMP("IFCAP-PURGE-424-1",0)=$$FMADD^XLFDT(DT,7)_"^"_DT_"^RECORDS PURGED FROM FILE 424.1 BY PRC*5.1*95"
S ^XTMP("IFCAP-PURGE-424-1-REF",0)=$$FMADD^XLFDT(DT,7)_"^"_DT_"^C CROSS REFERENCES PURGED FROM FILE 424.1 BY PRC*5.1*95"
F S MYPTR=$O(^PRC(424.1,"C",MYPTR)) Q:'MYPTR D
. I '$D(^PRC(424,MYPTR)) D
. . S SUBREC=0
. . F S SUBREC=$O(^PRC(424.1,"C",MYPTR,SUBREC)) Q:'SUBREC D
. . . S ^XTMP("IFCAP-PURGE-424-1",SUBREC)=^PRC(424.1,SUBREC,0)
. . . S ^XTMP("IFCAP-PURGE-424-1-REF",SUBREC)="C^"_MYPTR_"^"_SUBREC
. . . S DA=SUBREC,DIK="^PRC(424.1," D ^DIK
. . . K DIK
. . . S NREC=NREC+1
D WTOTAL,CLEAN
D START2
D FINDREC
Q
WTOTAL ;
D BMES^XPDUTL(NREC_" RECORDS DELETED FROM FILE 424.1")
D BMES^XPDUTL("BACKUP RECORDS STORED IN THE FOLLOWING LOCATIONS FOR 7 DAYS:")
D BMES^XPDUTL("^XTMP(""IFCAP-PURGE-424-1"")")
D BMES^XPDUTL("^XTMP(""IFCAP-PURGE-424-1-REF"")")
Q
;
CLEAN K MYREC,MYPTR,SUBREC,NREC
Q
;
START2 S IPIEN=0,NREC=0,TREC=0
S ^XTMP("IFCAP-PURGE-440-6",0)=$$FMADD^XLFDT(DT,7)_"^"_DT_"^RECORDS PURGED FROM FILE 440.6 BY PRC*5.1*95"
S ^XTMP("IFCAP-PURGE-440-6-REF",0)=$$FMADD^XLFDT(DT,7)_"^"_DT_"^B CROSS REFERENCES PURGED FROM FILE 440.6 BY PRC*5.1*95"
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 WTOTAL2,CLEAN2
Q
WTOTAL2 ;
D BMES^XPDUTL(NREC_" RECORDS DELETED FROM FILE 440.6")
D BMES^XPDUTL("BACKUP RECORDS STORED IN THE FOLLOWING LOCATIONS FOR 7 DAYS:")
D BMES^XPDUTL("^XTMP(""IFCAP-PURGE-440-6"")")
D BMES^XPDUTL("^XTMP(""IFCAP-PURGE-440-6-REF"")")
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
CLEAN2 K IEN,IPIEN,TREC,NREC
Q
;
FINDREC N DIC,Y,NREC,MREC,DIE,X
D BMES^XPDUTL("Adding new option to PRCG ARCHIVE/PURGE MENU option.")
S DIC="^DIC(19,",X="PRCG LOAD 417 PURGMASTER"
D ^DIC
I Y'=-1 S NREC=+Y
FINDMNU S (DIC,Y)=""
S DIC="^DIC(19,",X="PRCG ARCHIVE/PURGE MASTER MENU"
D ^DIC
I Y'=-1 S MREC=+Y
UPDMNU S (DIC,Y)=""
S (BFLAG,NTHIS)=0
F S NTHIS=$O(^DIC(19,MREC,10,NTHIS)) Q:'NTHIS!(BFLAG=1) D
. S MYIEN=$G(^DIC(19,MREC,10,NTHIS,0))
. I MYIEN=NREC S BFLAG=1
I BFLAG=0 D
. S DIC="^DIC(19,"_MREC_",10,",DIC(0)="",DIC("P")="19.01IP"
. S X=NREC
. S DA(1)=MREC
. D FILE^DICN
CLNREC K BFLAG,NTHIS,MREC,NREC
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCINAR 2749 printed Apr 09, 2024@21:02:50 Page 2
PRCINAR ;BP-OIFO/SWS-IFCAP ARCHIVE/PURGE FIX ;12/07/2005 12:16
V ;;5.1;IFCAP;**95**;Oct 20, 2000
+1 QUIT
START SET (MYREC,MYPTR,SUBREC,NREC)=0
+1 SET ^XTMP("IFCAP-PURGE-424-1",0)=$$FMADD^XLFDT(DT,7)_"^"_DT_"^RECORDS PURGED FROM FILE 424.1 BY PRC*5.1*95"
+2 SET ^XTMP("IFCAP-PURGE-424-1-REF",0)=$$FMADD^XLFDT(DT,7)_"^"_DT_"^C CROSS REFERENCES PURGED FROM FILE 424.1 BY PRC*5.1*95"
+3 FOR
SET MYPTR=$ORDER(^PRC(424.1,"C",MYPTR))
if 'MYPTR
QUIT
Begin DoDot:1
+4 IF '$DATA(^PRC(424,MYPTR))
Begin DoDot:2
+5 SET SUBREC=0
+6 FOR
SET SUBREC=$ORDER(^PRC(424.1,"C",MYPTR,SUBREC))
if 'SUBREC
QUIT
Begin DoDot:3
+7 SET ^XTMP("IFCAP-PURGE-424-1",SUBREC)=^PRC(424.1,SUBREC,0)
+8 SET ^XTMP("IFCAP-PURGE-424-1-REF",SUBREC)="C^"_MYPTR_"^"_SUBREC
+9 SET DA=SUBREC
SET DIK="^PRC(424.1,"
DO ^DIK
+10 KILL DIK
+11 SET NREC=NREC+1
End DoDot:3
End DoDot:2
End DoDot:1
+12 DO WTOTAL
DO CLEAN
+13 DO START2
+14 DO FINDREC
+15 QUIT
WTOTAL ;
+1 DO BMES^XPDUTL(NREC_" RECORDS DELETED FROM FILE 424.1")
+2 DO BMES^XPDUTL("BACKUP RECORDS STORED IN THE FOLLOWING LOCATIONS FOR 7 DAYS:")
+3 DO BMES^XPDUTL("^XTMP(""IFCAP-PURGE-424-1"")")
+4 DO BMES^XPDUTL("^XTMP(""IFCAP-PURGE-424-1-REF"")")
+5 QUIT
+6 ;
CLEAN KILL MYREC,MYPTR,SUBREC,NREC
+1 QUIT
+2 ;
START2 SET IPIEN=0
SET NREC=0
SET TREC=0
+1 SET ^XTMP("IFCAP-PURGE-440-6",0)=$$FMADD^XLFDT(DT,7)_"^"_DT_"^RECORDS PURGED FROM FILE 440.6 BY PRC*5.1*95"
+2 SET ^XTMP("IFCAP-PURGE-440-6-REF",0)=$$FMADD^XLFDT(DT,7)_"^"_DT_"^B CROSS REFERENCES PURGED FROM FILE 440.6 BY PRC*5.1*95"
+3 FOR
SET IPIEN=$ORDER(^PRCH(440.6,"PO",IPIEN))
if IPIEN'>0
QUIT
Begin DoDot:1
+4 SET IEN=0
+5 IF '$DATA(^PRC(442,IPIEN))
Begin DoDot:2
+6 SET TREC=TREC+1
+7 SET IEN=0
+8 FOR
SET IEN=$ORDER(^PRCH(440.6,"PO",IPIEN,IEN))
if 'IEN
QUIT
DO KILL4406
+9 QUIT
End DoDot:2
+10 QUIT
End DoDot:1
+11 DO WTOTAL2
DO CLEAN2
+12 QUIT
WTOTAL2 ;
+1 DO BMES^XPDUTL(NREC_" RECORDS DELETED FROM FILE 440.6")
+2 DO BMES^XPDUTL("BACKUP RECORDS STORED IN THE FOLLOWING LOCATIONS FOR 7 DAYS:")
+3 DO BMES^XPDUTL("^XTMP(""IFCAP-PURGE-440-6"")")
+4 DO BMES^XPDUTL("^XTMP(""IFCAP-PURGE-440-6-REF"")")
+5 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
CLEAN2 KILL IEN,IPIEN,TREC,NREC
+1 QUIT
+2 ;
FINDREC NEW DIC,Y,NREC,MREC,DIE,X
+1 DO BMES^XPDUTL("Adding new option to PRCG ARCHIVE/PURGE MENU option.")
+2 SET DIC="^DIC(19,"
SET X="PRCG LOAD 417 PURGMASTER"
+3 DO ^DIC
+4 IF Y'=-1
SET NREC=+Y
FINDMNU SET (DIC,Y)=""
+1 SET DIC="^DIC(19,"
SET X="PRCG ARCHIVE/PURGE MASTER MENU"
+2 DO ^DIC
+3 IF Y'=-1
SET MREC=+Y
UPDMNU SET (DIC,Y)=""
+1 SET (BFLAG,NTHIS)=0
+2 FOR
SET NTHIS=$ORDER(^DIC(19,MREC,10,NTHIS))
if 'NTHIS!(BFLAG=1)
QUIT
Begin DoDot:1
+3 SET MYIEN=$GET(^DIC(19,MREC,10,NTHIS,0))
+4 IF MYIEN=NREC
SET BFLAG=1
End DoDot:1
+5 IF BFLAG=0
Begin DoDot:1
+6 SET DIC="^DIC(19,"_MREC_",10,"
SET DIC(0)=""
SET DIC("P")="19.01IP"
+7 SET X=NREC
+8 SET DA(1)=MREC
+9 DO FILE^DICN
End DoDot:1
CLNREC KILL BFLAG,NTHIS,MREC,NREC
+1 QUIT
