PRCA399C ;MNTVBB/RGB - Restores any changes to AR files to allow re-testing ; FEB 05, 2022
;;4.5;Accounts Receivable;**399**;Feb 05, 2022;Build 67
;;Per VA Directive 6402, this routine should not be modified.
;
Q
EN(PRCADEB) D NOW^%DTC S ^XTMP("PRCA399",$J,999,"FBEGINDEBTORCHECK")=%
S (PRCANFLG,PRCAZ,PRCAX,PRCAXX,PRCAXXX)=0,PRCAW=^XTMP("PRCA399",$J,2,0)
RD S ^XTMP("PRCA399",$J,999,"FBEGCHKDEB")=PRCADEB
W:PRCAW !!!,"DEBTOR: ",PRCADEB
S (PRCAPBAL,PRCABBAL,PRCATBAL,PRCAAMT)=0,PRCAHDEB=PRCADEB K ^TMP("PRCAGT",$J)
S PRCADAT=0 ;$O(^XTMP("PRCA399",$J,2,4,PRCADEB,0))-.001
;S PRCARCDT=9999999.999999-PRCADAT,PRCAPBAL=0
D BBAL(PRCADEB,.PRCABBAL) S PRCADAT=0 ;I PRCARCDT S PRCADAT=9999999.999999-PRCARCDT
A1 W:PRCAW !,"DATE USED: ",PRCADAT
S PRCAPBAL=0
;D PBAL(PRCADEB,PRCARCDT,.PRCAPBAL) I PRCARCDT S PRCADAT=9999999.999999-PRCARCDT
F PRCAXX="PB","INT","ADM","MF","CT" S PRCAPBAL(PRCAXX)=0
W:PRCAW !,"BACK0"
D EN^PRCA399D(PRCADEB,PRCADAT)
D TBAL^PRCA399D(PRCADEB,.PRCATBAL)
K ^TMP("PRCAGT",$J)
A17 I (PRCAPBAL+PRCATBAL=PRCABBAL) S PRCAY=1 W:PRCAW !!,"This patient's account is currently in balance!"
E S PRCAY=0,^XTMP("PRCA399",$J,9,1,PRCADEB)=PRCAPBAL_U_PRCATBAL_U_PRCABBAL_U_U_U_$G(^XTMP("PRCA399",$J,2,1,PRCADEB,0)) W:PRCAW !!,"This patient's account is currently out of balance!"
I PRCAW W !!,PRCAPBAL," + ",PRCATBAL," = ",PRCABBAL," (",$G(^XTMP("PRCA399",$J,2,1,PRCADEB,0)),") NEG:",$S(PRCANFLG=0:"NO",1:"YES")
I PRCAW W !,"DEBTOR: ",PRCADEB R:'PRCAXXX&PRCAW PRCAXXX:1
S ^XTMP("PRCA399",$J,9,2,PRCADEB)=PRCAPBAL_U_PRCATBAL_U_PRCABBAL_U_U_U_$G(^XTMP("PRCA399",$J,2,1,PRCADEB,0))
S ^XTMP("PRCA399",$J,999,"FENDCHKDEB")=PRCADEB_U_PRCAPBAL_U_PRCATBAL_U_PRCABBAL
K PRCATBAL,PRCABBAL,PRCADT,PRCASEL,PRCADB,PRCAPBAL,PRCAAC,PRCAADM
K PRCABAL,PRCABEG,PRCABILL,PRCABN,PRCAZ,PRCAX,PRCAXX,PRCADEB,PRCANFLG
K PRCAAMT,PRCAWKDT,PRCAXXX,PRCAW
Q
BBAL(PRCADB,PRCABAL,PRCADT) ;get bills balances return array
S (PRCABAL,PRCAPB,PRCAINT,PRCAADM,PRCAMF,PRCACT,PRCAPNEG,PRCATTY)=0,PRCALET3="",PRCACFLG=$D(PRCACSBB)
G:'PRCADB BBALQ
S PRCAAC=+$O(^PRCA(430.3,"AC",102,0)),PRCAOP=+$O(^PRCA(430.3,"AC",112,0))
S PRCAPRE=+$O(^PRCA(430.2,"AC",33,0)),PRCARVW=+$O(^PRCA(430.3,"AC",113,0))
XXX F PRCASTAT=PRCAAC,PRCAOP F PRCABN=0:0 S PRCABN=$O(^PRCA(430,"AS",PRCADB,PRCASTAT,PRCABN)) Q:'PRCABN D
.S PRCABAL=$G(^XTMP("PRCA399",$J,1,1,PRCABN,8)),PRCACS=$D(^PRCA(430,"TCSP",PRCABN)) ; set flag for CS bills
AA .I $D(^PRCA(430,PRCABN,6)) S PRCALET3=$P(^(6),U,3) S ^TMP("PRCAGU",$J,PRCADB,PRCABN)="" S:'$D(^XTMP("PRCA399",$J,2,1,PRCADB,0,PRCABN)) ^XTMP("PRCA399",$J,2,1,PRCADB,0,PRCABN)="0^0" ;I LET3="" S ^TMP("PRCAGU",$J,PRCADB,PRCABN)=""
.I $P(^PRCA(430,PRCABN,0),U,2)=PRCAPRE S PRCAPB=PRCAPB-PRCABAL W:PRCAW !,PRCABN," PREPAY: ",PRCABAL," ",PRCAPB Q
.I $D(^XTMP("PRCA399",$J,1,1,PRCABN,8)) W:PRCAW !,PRCABN," BILL BAL: ",PRCABAL S PRCABAL=^XTMP("PRCA399",$J,1,1,PRCABN,8) W:PRCAW !,PRCABN," CALC BAL: ",PRCABAL R:PRCAW PRCAX:10
BB .S PRCATBAL=0 F PRCAI=1:1:5 S PRCATBAL=PRCATBAL+$P(PRCABAL,U,PRCAI)
.Q:PRCATBAL=0
.S PRCAPB=PRCAPB+$P(PRCABAL,U,1),PRCAINT=PRCAINT+$P(PRCABAL,U,2),PRCAADM=PRCAADM+$P(PRCABAL,U,3),PRCAMF=PRCAMF+$P(PRCABAL,U,4),PRCACT=PRCACT+$P(PRCABAL,U,5)
.; for CS bills, update the CS bill balance
DD .I PRCACS S PRCACSBB=$G(PRCACSBB)+$P(PRCABAL,U,1)+$P(PRCABAL,U,2)+$P(PRCABAL,U,3)+$P(PRCABAL,U,4)+$P(PRCABAL,U,5)
I $D(^XTMP("PRCA399",$J,2,1,PRCADB,0)) D ;temp to account for new calc prepay
.S PRCAPNEG=0 F PRCAI=1,2 S PRCAPNEG=PRCAPNEG+$P(^XTMP("PRCA399",$J,2,1,PRCADB,0),U,PRCAI)
.Q:+PRCAPNEG=0
.W:PRCAW !,"BILL PRE/NEG BBAL: ",PRCAPNEG R:PRCAW PRCAXXX:10 S PRCAPB=PRCAPB-PRCAPNEG
S PRCABAL=PRCAPB+PRCAINT+PRCAADM+PRCAMF+PRCACT W:PRCAW !,"BBAL: ",PRCABAL_"="_PRCAPB_"+"_PRCAINT_"+"_PRCAADM_"+"_PRCAMF_"+"_PRCACT R:PRCAW PRCAXXX:10
F PRCAX="PRCAPB","PRCAINT","PRCAADM","PRCAMF","PRCACT" S PRCABAL(PRCAX)=@PRCAX
BBALQ I 'PRCACFLG K PRCACSBB
K PRCAADM,PRCAAC,PRCACT,PRCAI,PRCAINT,PRCAMF,PRCAOP,PRCAPB,PRCAPRE,PRCASTAT,PRCACS,PRCACFLG
K PRCADBT,PRCAI,PRCAHDEB,PRCAHYY,PRCALET3,PRCAPDAT,PRCAPNEG,PRCASTS,PRCATTY
K PRCZABDT,PRCAHHY,PRCAPPTX,PRCAPPYB
Q PRCABAL
PBAL(PRCADB,PRCARCDT,PRCAPBAL,PRCASTMT) ;get previous balance and date of last transaction
W:PRCAW !,"PBAL"
S PRCAEVN=0,PRCAI=0,PRCAY=0 G:'PRCADB PBALQ
S:'PRCARCDT PRCARCDT=+$O(^RC(341,"AD",PRCADB,+$O(^RC(341.1,"AC",2,0)),0))
S PRCAEVN=$O(^RC(341,"AD",PRCADB,+$O(^RC(341.1,"AC",2,0)),PRCARCDT,0))
I '$G(PRCAEVN) S:$G(PRCASTMT) PRCADAT=PRCAPDAT G PBALQ ;PRCA*4.5*348
S PRCAY=$G(^RC(341,PRCAEVN,1)) F PRCAI=1:1:5 S PRCAPBAL=PRCAPBAL+$P(PRCAY,U,PRCAI)
W:PRCAW !,"EVENT BAL: ",PRCAPBAL,?22,9999999.999999-PRCADAT," ",PRCAY R:PRCAW PRCAXXX:10
S PRCAPBAL=0 K PRCAEVN,PRCAI,PRCAY
PBALQ Q
LST(PRCADB,TYPE,PRCASTMT) ;Get last type of event for DBtor PRCA*4.5*348
;PRCASTMT Set to 1 when called from statement compiler for no event 2 condition handling
NEW PRCAY,PRCABIL,PRCATX,PRCADT,PRCATX0,PRCABDT,PRCABLDT ;PRCA*4.5*348
OLD D NOW^%DTC
S PRCAY=-1 G:'$G(PRCADB)!'$G(TYPE) Q4
S:PRCADBT?1N.N1";"1A.A1"(" PRCADBT=$O(^RCD(340,"B",PRCADBT,0))
S TYPE=+$O(^RC(341.1,"AC",TYPE,0)),PRCAY=0
A11 S PRCAY=+$O(^RC(341,"AD",PRCADB,TYPE,PRCAY)) G Q4:'PRCAY I $D(^XTMP("PRCA399",$J,2,1,PRCADB))&(+PRCAY<(6789471.999999)) G A11 ;I 'PRCAY,'$G(PRCASTMT) S PRCAY=-1 G Q4
I 'PRCAY,$G(PRCASTMT) D G Q4
. S PRCABIL=0,PRCABLDT=0 F S PRCABIL=$O(^PRCA(430,"C",PRCADB,PRCABIL)) Q:'PRCABIL D
. . I ":16:42:"[(":"_$P($G(^PRCA(430,PRCABIL,0)),"^",8)_":") D
. . . S PRCABDT=$P($G(^PRCA(430,PRCABIL,6)),"^",21)
. . . I 'PRCABLDT S PRCABLDT=PRCABIL_U_PRCABDT Q
. . . I PRCABDT<$P(PRCABLDT,U,2) S PRCABLDT=PRCABIL_U_PRCABDT
. S PRCAY=$S(PRCABLDT:$P(PRCABLDT,U,2),1:%) S PRCAY=PRCAY-.000001
. F PRCADT=PRCAY:0 S PRCADT=$O(^PRCA(433,"ATD",PRCADB,PRCADT)) Q:'PRCADT F PRCATX=0:0 S PRCATX=$O(^PRCA(433,"ATD",PRCADB,PRCADT,PRCATX)) Q:'PRCATX D
. . S PRCATX0=$G(^PRCA(433,PRCATX,0)) Q:'PRCATX0
. . S PRCZABDT=$P($G(^PRCA(430,$P(PRCATX0,U,2),6)),U,21)
. . I PRCABDT,PRCABDT<PRCAY S PRCAY=PRCABDT-.000001,PRCADT=PRCAY,PRCATX="Z"
. S PRCAY=PRCAY_"^0",PRCAPBAL=0
S PRCAY=9999999.999999-PRCAY_"^"_$O(^RC(341,"AD",PRCADB,TYPE,PRCAY,0))
Q4 S (PRCAHHY,PRCADAT)=PRCAY Q PRCAY
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCA399C 6271 printed Jul 11, 2026@01:35:28 Page 2
PRCA399C ;MNTVBB/RGB - Restores any changes to AR files to allow re-testing ; FEB 05, 2022
+1 ;;4.5;Accounts Receivable;**399**;Feb 05, 2022;Build 67
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 QUIT
EN(PRCADEB) DO NOW^%DTC
SET ^XTMP("PRCA399",$JOB,999,"FBEGINDEBTORCHECK")=%
+1 SET (PRCANFLG,PRCAZ,PRCAX,PRCAXX,PRCAXXX)=0
SET PRCAW=^XTMP("PRCA399",$JOB,2,0)
RD SET ^XTMP("PRCA399",$JOB,999,"FBEGCHKDEB")=PRCADEB
+1 if PRCAW
WRITE !!!,"DEBTOR: ",PRCADEB
+2 SET (PRCAPBAL,PRCABBAL,PRCATBAL,PRCAAMT)=0
SET PRCAHDEB=PRCADEB
KILL ^TMP("PRCAGT",$JOB)
+3 ;$O(^XTMP("PRCA399",$J,2,4,PRCADEB,0))-.001
SET PRCADAT=0
+4 ;S PRCARCDT=9999999.999999-PRCADAT,PRCAPBAL=0
+5 ;I PRCARCDT S PRCADAT=9999999.999999-PRCARCDT
DO BBAL(PRCADEB,.PRCABBAL)
SET PRCADAT=0
A1 if PRCAW
WRITE !,"DATE USED: ",PRCADAT
+1 SET PRCAPBAL=0
+2 ;D PBAL(PRCADEB,PRCARCDT,.PRCAPBAL) I PRCARCDT S PRCADAT=9999999.999999-PRCARCDT
+3 FOR PRCAXX="PB","INT","ADM","MF","CT"
SET PRCAPBAL(PRCAXX)=0
+4 if PRCAW
WRITE !,"BACK0"
+5 DO EN^PRCA399D(PRCADEB,PRCADAT)
+6 DO TBAL^PRCA399D(PRCADEB,.PRCATBAL)
+7 KILL ^TMP("PRCAGT",$JOB)
A17 IF (PRCAPBAL+PRCATBAL=PRCABBAL)
SET PRCAY=1
if PRCAW
WRITE !!,"This patient's account is currently in balance!"
+1 IF '$TEST
SET PRCAY=0
SET ^XTMP("PRCA399",$JOB,9,1,PRCADEB)=PRCAPBAL_U_PRCATBAL_U_PRCABBAL_U_U_U_$GET(^XTMP("PRCA399",$JOB,2,1,PRCADEB,0))
if PRCAW
WRITE !!,"This patient's account is currently out of balance!"
+2 IF PRCAW
WRITE !!,PRCAPBAL," + ",PRCATBAL," = ",PRCABBAL," (",$GET(^XTMP("PRCA399",$JOB,2,1,PRCADEB,0)),") NEG:",$SELECT(PRCANFLG=0:"NO",1:"YES")
+3 IF PRCAW
WRITE !,"DEBTOR: ",PRCADEB
if 'PRCAXXX&PRCAW
READ PRCAXXX:1
+4 SET ^XTMP("PRCA399",$JOB,9,2,PRCADEB)=PRCAPBAL_U_PRCATBAL_U_PRCABBAL_U_U_U_$GET(^XTMP("PRCA399",$JOB,2,1,PRCADEB,0))
+5 SET ^XTMP("PRCA399",$JOB,999,"FENDCHKDEB")=PRCADEB_U_PRCAPBAL_U_PRCATBAL_U_PRCABBAL
+6 KILL PRCATBAL,PRCABBAL,PRCADT,PRCASEL,PRCADB,PRCAPBAL,PRCAAC,PRCAADM
+7 KILL PRCABAL,PRCABEG,PRCABILL,PRCABN,PRCAZ,PRCAX,PRCAXX,PRCADEB,PRCANFLG
+8 KILL PRCAAMT,PRCAWKDT,PRCAXXX,PRCAW
+9 QUIT
BBAL(PRCADB,PRCABAL,PRCADT) ;get bills balances return array
+1 SET (PRCABAL,PRCAPB,PRCAINT,PRCAADM,PRCAMF,PRCACT,PRCAPNEG,PRCATTY)=0
SET PRCALET3=""
SET PRCACFLG=$DATA(PRCACSBB)
+2 if 'PRCADB
GOTO BBALQ
+3 SET PRCAAC=+$ORDER(^PRCA(430.3,"AC",102,0))
SET PRCAOP=+$ORDER(^PRCA(430.3,"AC",112,0))
+4 SET PRCAPRE=+$ORDER(^PRCA(430.2,"AC",33,0))
SET PRCARVW=+$ORDER(^PRCA(430.3,"AC",113,0))
XXX FOR PRCASTAT=PRCAAC,PRCAOP
FOR PRCABN=0:0
SET PRCABN=$ORDER(^PRCA(430,"AS",PRCADB,PRCASTAT,PRCABN))
if 'PRCABN
QUIT
Begin DoDot:1
+1 ; set flag for CS bills
SET PRCABAL=$GET(^XTMP("PRCA399",$JOB,1,1,PRCABN,8))
SET PRCACS=$DATA(^PRCA(430,"TCSP",PRCABN))
AA ;I LET3="" S ^TMP("PRCAGU",$J,PRCADB,PRCABN)=""
IF $DATA(^PRCA(430,PRCABN,6))
SET PRCALET3=$PIECE(^(6),U,3)
SET ^TMP("PRCAGU",$JOB,PRCADB,PRCABN)=""
if '$DATA(^XTMP("PRCA399",$JOB,2,1,PRCADB,0,PRCABN))
SET ^XTMP("PRCA399",$JOB,2,1,PRCADB,0,PRCABN)="0^0"
+1 IF $PIECE(^PRCA(430,PRCABN,0),U,2)=PRCAPRE
SET PRCAPB=PRCAPB-PRCABAL
if PRCAW
WRITE !,PRCABN," PREPAY: ",PRCABAL," ",PRCAPB
QUIT
+2 IF $DATA(^XTMP("PRCA399",$JOB,1,1,PRCABN,8))
if PRCAW
WRITE !,PRCABN," BILL BAL: ",PRCABAL
SET PRCABAL=^XTMP("PRCA399",$JOB,1,1,PRCABN,8)
if PRCAW
WRITE !,PRCABN," CALC BAL: ",PRCABAL
if PRCAW
READ PRCAX:10
BB SET PRCATBAL=0
FOR PRCAI=1:1:5
SET PRCATBAL=PRCATBAL+$PIECE(PRCABAL,U,PRCAI)
+1 if PRCATBAL=0
QUIT
+2 SET PRCAPB=PRCAPB+$PIECE(PRCABAL,U,1)
SET PRCAINT=PRCAINT+$PIECE(PRCABAL,U,2)
SET PRCAADM=PRCAADM+$PIECE(PRCABAL,U,3)
SET PRCAMF=PRCAMF+$PIECE(PRCABAL,U,4)
SET PRCACT=PRCACT+$PIECE(PRCABAL,U,5)
+3 ; for CS bills, update the CS bill balance
DD IF PRCACS
SET PRCACSBB=$GET(PRCACSBB)+$PIECE(PRCABAL,U,1)+$PIECE(PRCABAL,U,2)+$PIECE(PRCABAL,U,3)+$PIECE(PRCABAL,U,4)+$PIECE(PRCABAL,U,5)
End DoDot:1
+1 ;temp to account for new calc prepay
IF $DATA(^XTMP("PRCA399",$JOB,2,1,PRCADB,0))
Begin DoDot:1
+2 SET PRCAPNEG=0
FOR PRCAI=1,2
SET PRCAPNEG=PRCAPNEG+$PIECE(^XTMP("PRCA399",$JOB,2,1,PRCADB,0),U,PRCAI)
+3 if +PRCAPNEG=0
QUIT
+4 if PRCAW
WRITE !,"BILL PRE/NEG BBAL: ",PRCAPNEG
if PRCAW
READ PRCAXXX:10
SET PRCAPB=PRCAPB-PRCAPNEG
End DoDot:1
+5 SET PRCABAL=PRCAPB+PRCAINT+PRCAADM+PRCAMF+PRCACT
if PRCAW
WRITE !,"BBAL: ",PRCABAL_"="_PRCAPB_"+"_PRCAINT_"+"_PRCAADM_"+"_PRCAMF_"+"_PRCACT
if PRCAW
READ PRCAXXX:10
+6 FOR PRCAX="PRCAPB","PRCAINT","PRCAADM","PRCAMF","PRCACT"
SET PRCABAL(PRCAX)=@PRCAX
BBALQ IF 'PRCACFLG
KILL PRCACSBB
+1 KILL PRCAADM,PRCAAC,PRCACT,PRCAI,PRCAINT,PRCAMF,PRCAOP,PRCAPB,PRCAPRE,PRCASTAT,PRCACS,PRCACFLG
+2 KILL PRCADBT,PRCAI,PRCAHDEB,PRCAHYY,PRCALET3,PRCAPDAT,PRCAPNEG,PRCASTS,PRCATTY
+3 KILL PRCZABDT,PRCAHHY,PRCAPPTX,PRCAPPYB
+4 QUIT PRCABAL
PBAL(PRCADB,PRCARCDT,PRCAPBAL,PRCASTMT) ;get previous balance and date of last transaction
+1 if PRCAW
WRITE !,"PBAL"
+2 SET PRCAEVN=0
SET PRCAI=0
SET PRCAY=0
if 'PRCADB
GOTO PBALQ
+3 if 'PRCARCDT
SET PRCARCDT=+$ORDER(^RC(341,"AD",PRCADB,+$ORDER(^RC(341.1,"AC",2,0)),0))
+4 SET PRCAEVN=$ORDER(^RC(341,"AD",PRCADB,+$ORDER(^RC(341.1,"AC",2,0)),PRCARCDT,0))
+5 ;PRCA*4.5*348
IF '$GET(PRCAEVN)
if $GET(PRCASTMT)
SET PRCADAT=PRCAPDAT
GOTO PBALQ
+6 SET PRCAY=$GET(^RC(341,PRCAEVN,1))
FOR PRCAI=1:1:5
SET PRCAPBAL=PRCAPBAL+$PIECE(PRCAY,U,PRCAI)
+7 if PRCAW
WRITE !,"EVENT BAL: ",PRCAPBAL,?22,9999999.999999-PRCADAT," ",PRCAY
if PRCAW
READ PRCAXXX:10
+8 SET PRCAPBAL=0
KILL PRCAEVN,PRCAI,PRCAY
PBALQ QUIT
LST(PRCADB,TYPE,PRCASTMT) ;Get last type of event for DBtor PRCA*4.5*348
+1 ;PRCASTMT Set to 1 when called from statement compiler for no event 2 condition handling
+2 ;PRCA*4.5*348
NEW PRCAY,PRCABIL,PRCATX,PRCADT,PRCATX0,PRCABDT,PRCABLDT
OLD DO NOW^%DTC
+1 SET PRCAY=-1
if '$GET(PRCADB)!'$GET(TYPE)
GOTO Q4
+2 if PRCADBT?1N.N1";"1A.A1"("
SET PRCADBT=$ORDER(^RCD(340,"B",PRCADBT,0))
+3 SET TYPE=+$ORDER(^RC(341.1,"AC",TYPE,0))
SET PRCAY=0
A11 ;I 'PRCAY,'$G(PRCASTMT) S PRCAY=-1 G Q4
SET PRCAY=+$ORDER(^RC(341,"AD",PRCADB,TYPE,PRCAY))
if 'PRCAY
GOTO Q4
IF $DATA(^XTMP("PRCA399",$JOB,2,1,PRCADB))&(+PRCAY<(6789471.999999))
GOTO A11
+1 IF 'PRCAY
IF $GET(PRCASTMT)
Begin DoDot:1
+2 SET PRCABIL=0
SET PRCABLDT=0
FOR
SET PRCABIL=$ORDER(^PRCA(430,"C",PRCADB,PRCABIL))
if 'PRCABIL
QUIT
Begin DoDot:2
+3 IF ":16:42:"[(":"_$PIECE($GET(^PRCA(430,PRCABIL,0)),"^",8)_":")
Begin DoDot:3
+4 SET PRCABDT=$PIECE($GET(^PRCA(430,PRCABIL,6)),"^",21)
+5 IF 'PRCABLDT
SET PRCABLDT=PRCABIL_U_PRCABDT
QUIT
+6 IF PRCABDT<$PIECE(PRCABLDT,U,2)
SET PRCABLDT=PRCABIL_U_PRCABDT
End DoDot:3
End DoDot:2
+7 SET PRCAY=$SELECT(PRCABLDT:$PIECE(PRCABLDT,U,2),1:%)
SET PRCAY=PRCAY-.000001
+8 FOR PRCADT=PRCAY:0
SET PRCADT=$ORDER(^PRCA(433,"ATD",PRCADB,PRCADT))
if 'PRCADT
QUIT
FOR PRCATX=0:0
SET PRCATX=$ORDER(^PRCA(433,"ATD",PRCADB,PRCADT,PRCATX))
if 'PRCATX
QUIT
Begin DoDot:2
+9 SET PRCATX0=$GET(^PRCA(433,PRCATX,0))
if 'PRCATX0
QUIT
+10 SET PRCZABDT=$PIECE($GET(^PRCA(430,$PIECE(PRCATX0,U,2),6)),U,21)
+11 IF PRCABDT
IF PRCABDT<PRCAY
SET PRCAY=PRCABDT-.000001
SET PRCADT=PRCAY
SET PRCATX="Z"
End DoDot:2
+12 SET PRCAY=PRCAY_"^0"
SET PRCAPBAL=0
End DoDot:1
GOTO Q4
+13 SET PRCAY=9999999.999999-PRCAY_"^"_$ORDER(^RC(341,"AD",PRCADB,TYPE,PRCAY,0))
Q4 SET (PRCAHHY,PRCADAT)=PRCAY
QUIT PRCAY
