PRCIN45.m

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 ---PRCIN45   1573     printed  Apr 09, 2024@21:05:33                                                                                                                                                                                                     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       ;