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 Dec 13, 2024@01:59:34 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
