| 1 | RCFMPUR ;WASH-ISC@ALTOONA,PA/RGY-Purge AR Documents to FMS ;9/28/94 2:09 PM
|
|---|
| 2 | V ;;4.5;Accounts Receivable;;Mar 20, 1995
|
|---|
| 3 | ;;Per VHA Directive 10-93-142, this routine should not be modified.
|
|---|
| 4 | EN ;
|
|---|
| 5 | NEW %DT,PURDT,DATE
|
|---|
| 6 | S X="T-34" D ^%DT S PURDT=Y
|
|---|
| 7 | 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
|
|---|
| 8 | .S STAT=$P($G(^RC(347,DOC,0)),"^",3)
|
|---|
| 9 | .I ",0,1,3,"[(","_STAT_",") Q
|
|---|
| 10 | .D DEL(DOC)
|
|---|
| 11 | .Q
|
|---|
| 12 | Q
|
|---|
| 13 | DEL(DOC) ;Delete an FMS document
|
|---|
| 14 | NEW DIK,DA,STA,N0
|
|---|
| 15 | I $G(DOC)'?1N.N Q
|
|---|
| 16 | S N0=$G(^RC(347,DOC,0))
|
|---|
| 17 | I N0="" Q
|
|---|
| 18 | 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:"")
|
|---|
| 19 | D KILLCS^GECSSDCT(STA)
|
|---|
| 20 | S DA=DOC,DIK="^RC(347," D ^DIK
|
|---|
| 21 | Q
|
|---|
