PRC46PT.m

PRC46PT ;WIRMFO/DHH-CLEAN UP FILE 410.1 ;1/17/02  11:01 AM

V ;;5.1;IFCAP;**46**;Oct 20, 2000

 ;Per VHA Directive 10-93-142, this routine should not be modified.

 ;

 ;

QUIT Q

 ;

CLEAN ;

 ; clean up file 410.1

 ; if entry is no longer in 442 then delete 1358 entry in 410.1

 ;

 D MES^XPDUTL(">>>Starting clean up of file 410.1.<<<")

 D MES^XPDUTL("  ")

 N PAT

 S PAT="" F  S PAT=$O(^PRCS(410.1,"B",PAT)) Q:PAT=""  D

 . ;check for pattern match X?3N1"-"6AN

 . Q:'(PAT?3N1"-"6AN)

 . ;check to see if transaction exists in 442

 . Q:$D(^PRC(442,"B",PAT))

 . N DA

 . S DA=$O(^PRCS(410.1,"B",PAT,0))

 . Q:'$D(^PRCS(410.1,DA,0))

 . D MES^XPDUTL("   >>>Deleting entry - "_PAT)

 . S DIK="^PRCS(410.1," D ^DIK

 . K DIK,X

 D MES^XPDUTL("  ")

 D MES^XPDUTL(">>>Clean up of file 410.1 COMPLETED.")

 Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---PRC46PT   814     printed  Apr 09, 2024@21:13:28                                                                                                                                                                                                      Page 2

PRC46PT   ;WIRMFO/DHH-CLEAN UP FILE 410.1 ;1/17/02  11:01 AM

V         ;;5.1;IFCAP;**46**;Oct 20, 2000

 +1       ;Per VHA Directive 10-93-142, this routine should not be modified.

 +2       ;

 +3       ;

QUIT       QUIT 

 +1       ;

CLEAN     ;

 +1       ; clean up file 410.1

 +2       ; if entry is no longer in 442 then delete 1358 entry in 410.1

 +3       ;

 +4        DO MES^XPDUTL(">>>Starting clean up of file 410.1.<<<")

 +5        DO MES^XPDUTL("  ")

 +6        NEW PAT

 +7        SET PAT=""

           FOR 

               SET PAT=$ORDER(^PRCS(410.1,"B",PAT))

               if PAT=""

                   QUIT 

               Begin DoDot:1

 +8       ;check for pattern match X?3N1"-"6AN

 +9                if '(PAT?3N1"-"6AN)

                       QUIT 

 +10      ;check to see if transaction exists in 442

 +11               if $DATA(^PRC(442,"B",PAT))

                       QUIT 

 +12               NEW DA

 +13               SET DA=$ORDER(^PRCS(410.1,"B",PAT,0))

 +14               if '$DATA(^PRCS(410.1,DA,0))

                       QUIT 

 +15               DO MES^XPDUTL("   >>>Deleting entry - "_PAT)

 +16               SET DIK="^PRCS(410.1,"

                   DO ^DIK

 +17               KILL DIK,X

               End DoDot:1

 +18       DO MES^XPDUTL("  ")

 +19       DO MES^XPDUTL(">>>Clean up of file 410.1 COMPLETED.")

 +20       QUIT