RCFMPUR ;WASH-ISC@ALTOONA,PA/RGY-Purge AR Documents to FMS ;9/28/94 2:09 PM
V ;;4.5;Accounts Receivable;**270**;Mar 20, 1995;Build 25
;;Per VHA Directive 2004-038, this routine should not be modified.
EN ;
NEW %DT,PURDT,DATE
S X="T-34" D ^%DT S PURDT=Y
S DATE=0 F S DATE=$O(^RC(347,"AD",DATE)) Q:DATE>PURDT!'DATE S DOC=0 F S DOC=$O(^RC(347,"AD",DATE,DOC)) Q:'DOC D
.S STAT=$P($G(^RC(347,DOC,0)),"^",3)
.I ",0,1,3,"[(","_STAT_",") Q
.D DEL(DOC)
.Q
Q
DEL(DOC) ;Delete an FMS document
NEW DIK,DA,STA,N0
I $G(DOC)'?1N.N Q
S N0=$G(^RC(347,DOC,0))
I N0="" Q
; PRCA*4.5*270 this code was prefacing the Doc ID with a "BD-" even though that already existed in the DOC ID
;S STA=$P($G(^RC(347.1,+$P(N0,"^",2),0)),"^",2)_"-"_$P(N0,"^",9)_$E(" ",1,11-$L($P(N0,"^",9)))_$S($P(N0,"^",10)]"":"-"_$P(N0,"^",10),1:"")
I $E($P(N0,"^",9),1,2)'?2A S STA=$P($G(^RC(347.1,+$P(N0,"^",2),0)),"^",2)_"-"_$P(N0,"^",9)_$E(" ",1,11-$L($P(N0,"^",9)))_$S($P(N0,"^",10)]"":"-"_$P(N0,"^",10),1:"")
I $E($P(N0,"^",9),1,2)?2A S STA=$P(N0,"^",9)_$E(" ",1,11-$L($P(N0,"^",9)))_$S($P(N0,"^",10)]"":"-"_$P(N0,"^",10),1:"")
D KILLCS^GECSSDCT(STA)
S DA=DOC,DIK="^RC(347," D ^DIK
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRCFMPUR 1229 printed Sep 23, 2025@19:23:06 Page 2
RCFMPUR ;WASH-ISC@ALTOONA,PA/RGY-Purge AR Documents to FMS ;9/28/94 2:09 PM
V ;;4.5;Accounts Receivable;**270**;Mar 20, 1995;Build 25
+1 ;;Per VHA Directive 2004-038, this routine should not be modified.
EN ;
+1 NEW %DT,PURDT,DATE
+2 SET X="T-34"
DO ^%DT
SET PURDT=Y
+3 SET DATE=0
FOR
SET DATE=$ORDER(^RC(347,"AD",DATE))
if DATE>PURDT!'DATE
QUIT
SET DOC=0
FOR
SET DOC=$ORDER(^RC(347,"AD",DATE,DOC))
if 'DOC
QUIT
Begin DoDot:1
+4 SET STAT=$PIECE($GET(^RC(347,DOC,0)),"^",3)
+5 IF ",0,1,3,"[(","_STAT_",")
QUIT
+6 DO DEL(DOC)
+7 QUIT
End DoDot:1
+8 QUIT
DEL(DOC) ;Delete an FMS document
+1 NEW DIK,DA,STA,N0
+2 IF $GET(DOC)'?1N.N
QUIT
+3 SET N0=$GET(^RC(347,DOC,0))
+4 IF N0=""
QUIT
+5 ; PRCA*4.5*270 this code was prefacing the Doc ID with a "BD-" even though that already existed in the DOC ID
+6 ;S STA=$P($G(^RC(347.1,+$P(N0,"^",2),0)),"^",2)_"-"_$P(N0,"^",9)_$E(" ",1,11-$L($P(N0,"^",9)))_$S($P(N0,"^",10)]"":"-"_$P(N0,"^",10),1:"")
+7 IF $EXTRACT($PIECE(N0,"^",9),1,2)'?2A
SET STA=$PIECE($GET(^RC(347.1,+$PIECE(N0,"^",2),0)),"^",2)_"-"_$PIECE(N0,"^",9)_$EXTRACT(" ",1,11-$LENGTH($PIECE(N0,"^",9)))_$SELECT($PIECE(N0,"^",10)]"":"-"_$PIECE(N0,"^",10),1:"")
+8 IF $EXTRACT($PIECE(N0,"^",9),1,2)?2A
SET STA=$PIECE(N0,"^",9)_$EXTRACT(" ",1,11-$LENGTH($PIECE(N0,"^",9)))_$SELECT($PIECE(N0,"^",10)]"":"-"_$PIECE(N0,"^",10),1:"")
+9 DO KILLCS^GECSSDCT(STA)
+10 SET DA=DOC
SET DIK="^RC(347,"
DO ^DIK
+11 QUIT
