PRCINAR.m

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 ---PRCINAR   2749     printed  Mar 13, 2025@21:16:18                                                                                                                                                                                                     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