- 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 ---[H[J[2J[HPRC46PT 814 printed Jan 18, 2025@03:00:47 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