PRCALST ;SF-ISC/YJK-AR LIST,REPORT ;6/20/95 9:50 AM
V ;;4.5;Accounts Receivable;**17,63,107**;Mar 20, 1995
;;Per VHA Directive 10-93-142, this routine should not be modified.
;This is a routine for list of new accounts, accounts with
;incompleted data , RC/DOJ ,pending CALM code sheet.
PENDBIL ;list the pending CALM code sheet accounts.
S PRCAHDR="@",(PRCAFT,PRCALAST)=",107",PRCATEMP="[PRCAT NEW AR]"
WRLST S DIC="^PRCA(430," S:'$D(PRCATEMP) PRCATEMP="[PRCA AR LIST]"
S PRCASORT="DATE BILL PREPARED,@CURRENT STATUS:STATUS NUMBER"
D PRINT^PRCAREPT Q
;
INCOMPL S PRCAHDR="INCOMPLETE ACCOUNTS RECEIVABLE",(PRCAFT,PRCALAST)=",101"
D WRLST Q
;
NEWBILL ;list new bills
S PRCAHDR="LIST OF NEW BILLS",(PRCAFT,PRCALAST)=",104"
S PRCATEMP="[PRCA NEWB LIST]" D WRLST Q
;
WROFF ;list of written-off accounts receivable.
S PRCAHDR="LIST OF WRITTEN-OFF ACCOUNTS RECEIVABLE",(PRCAFT,PRCALAST)=",109"
D WRLST Q
;
ACTBIL ;list of active accounts receivable
S PRCAHDR="LIST OF ACTIVE ACCOUNTS RECEIVABLE",(PRCAFT,PRCALAST)=",102"
D WRLST Q
;
RETNAR ;returned AR list
S PRCAHDR="RETURNED AR LIST",PRCASORT="@CURRENT STATUS:STATUS NUMBER,@DATE RETURNED TO SERVICE",PRCAFT="220,",PRCALAST="230,"
S PRCATEMP="[PRCAC RETURN AR]",DIC="^PRCA(430," D PRINT^PRCAREPT Q
;
RC ;list of AR to be referred to RC
N PRCA
S PRCAHDR="ACCOUNTS RECEIVABLE POSSIBLE REFERRALS TO REGIONAL COUNSEL" D MINMAX
S PRCASORT="DEBTOR,@OVER LETTER3,@RC/DOJ REFERRAL DATE,@CURRENT STATUS:STATUS NUMBER",PRCAFT=",30,@,102",PRCALAST=",,@,102",PRCATEMP="[PRCAL L DC-DOJ]",DIS(0)="I $D(^PRCA(430,D0,7)),+^(7)'<PRCAMIN,+^(7)'>PRCAMAX"
S DIC="^PRCA(430,"
S:$D(ZTSK) IOP=ION
D @$S($D(ZTSK):"DIP^PRCAREPT",1:"PRINT^PRCAREPT")
K DIOBEG,DIS,PRCAMIN,PRCAMAX Q
;
DOJ ;list of AR to be referred to Dept. of Justice.
N PRCA
S PRCAHDR="ACCOUNTS RECEIVABLE POSSIBLE REFERRALS TO DEPT. OF JUSTICE" D MINMAX
S PRCASORT="DEBTOR,@OVER LETTER3,@RC/DOJ REFERRAL DATE,@CURRENT STATUS:STATUS NUMBER",PRCAFT=",30,@,102",PRCALAST=",,@,102",PRCATEMP="[PRCAL L DC-DOJ]",DIS(0)="I $D(^PRCA(430,D0,7)),+^(7)'<PRCAMAX"
S DIC="^PRCA(430,"
D @$S($D(ZTSK):"DIP^PRCAREPT",1:"PRINT^PRCAREPT")
K DIOBEG,DIS,PRCAMIN,PRCAMAX Q
;
COWC ;List of the accounts referred to COWC.
S PRCA("DATE")="DATE REFERRED TO COWC" D ASKDT^PRCAQUE I (PRCADT1="")!(PRCADT2="") K PRCADT1,PRCADT2 Q
S PRCAHDR="ACCOUNTS RECEIVABLE REFERRED TO COWC",PRCATEMP="[PRCAD COWC LIST]",PRCASORT="REFERRAL DATE TO COWC,DEBTOR"
S PRCAFT=PRCADT1_",",PRCALAST=PRCADT2_",",DIC="^PRCA(430,"
D PRINT^PRCAREPT,END Q
;
MINMAX ;get the minimum and maximum referral amount to the RC/DOJ.
;Returns: PRCAMIN, PRCAMAX
N PRCAKDA,Z0,Z1,Z2
S PRCAMIN=1,PRCAMAX=5000,PRCAKDA=$O(^RC(342.1,"B","REGIONAL COUNSEL",0))
I +PRCAKDA'>0 Q
S Z1=$G(^RC(342.1,PRCAKDA,2))
S Z2=+$P(Z1,"^",2),Z1=+Z1
S:(Z1>0)&(Z2>0) PRCAMIN=Z1,PRCAMAX=Z2 K Z0,Z1,Z2,PRCAKDA
Q
;
PRCOMM ;print comment field
Q:'$D(D0)!('$D(PRCAPC)) Q:'$D(^PRCA(430,D0,3)) S PRCAKGL=$P(^(3),U,PRCAPC) G:PRCAKGL="" EXCOMM
I $L(PRCAKGL)<70 W !,?3,PRCAKGL K PRCAKGL Q
F PRCAK=70:-1:1 Q:$E(PRCAKGL,PRCAK)=" "
W !,?3 F PRCAJ=1:1:PRCAK W $E(PRCAKGL,PRCAJ)
W !,?3 F PRCAI=PRCAK+1:1:$L(PRCAKGL) W $E(PRCAKGL,PRCAI)
EXCOMM K PRCAKGL,PRCAK,PRCAJ,PRCAI Q
;
END K PRCA Q
;
;============== COUNT NEW CALM PENDING TRANSACTIONS=================
COUNTR I $O(^PRCA(433,"AE",1,0)) W *7,!!,"*** You have new transactions from the AR section pending CALM transmission *** "
Q
;
RETN ;returned bills list
NEW ZTSK,POP,PRCAP,PRCASVC
D SVC^PRCABIL Q:'$D(PRCAP("S"))
S PRCASVC=PRCAP("S")
S %ZIS="MQ" D ^%ZIS G:POP Q1
I $D(IO("Q")) S ZTRTN="RETNDQ^PRCALST",ZTDESC="Returned Bill List",ZTSAVE("PRCASVC")="" D ^%ZTLOAD G Q1
RETNDQ ;
NEW BILL,STAT,DIC,L,FR,TO,FLDS
I $E(IOST)="C" W @IOF
F STAT=$O(^PRCA(430.3,"AC",220,0)),$O(^PRCA(430.3,"AC",230,0)) D
.S BILL=0 F S BILL=$O(^PRCA(430,"AC",STAT,BILL)) Q:'BILL I $D(^PRCA(430,BILL,100)),$P(^(100),"^",2)=PRCASVC D
..S D0=BILL K DXS D ^PRCATP6 K DXS I $Y+15>IOSL D
...I $E(IOST)="C" W *7 W ! R X:DTIME I X["^"!'$T S STAT=-1 Q
...W @IOF
...Q
..Q
.Q
Q1 D ^%ZISC Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCALST 4170 printed Sep 23, 2025@19:16:19 Page 2
PRCALST ;SF-ISC/YJK-AR LIST,REPORT ;6/20/95 9:50 AM
V ;;4.5;Accounts Receivable;**17,63,107**;Mar 20, 1995
+1 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+2 ;This is a routine for list of new accounts, accounts with
+3 ;incompleted data , RC/DOJ ,pending CALM code sheet.
PENDBIL ;list the pending CALM code sheet accounts.
+1 SET PRCAHDR="@"
SET (PRCAFT,PRCALAST)=",107"
SET PRCATEMP="[PRCAT NEW AR]"
WRLST SET DIC="^PRCA(430,"
if '$DATA(PRCATEMP)
SET PRCATEMP="[PRCA AR LIST]"
+1 SET PRCASORT="DATE BILL PREPARED,@CURRENT STATUS:STATUS NUMBER"
+2 DO PRINT^PRCAREPT
QUIT
+3 ;
INCOMPL SET PRCAHDR="INCOMPLETE ACCOUNTS RECEIVABLE"
SET (PRCAFT,PRCALAST)=",101"
+1 DO WRLST
QUIT
+2 ;
NEWBILL ;list new bills
+1 SET PRCAHDR="LIST OF NEW BILLS"
SET (PRCAFT,PRCALAST)=",104"
+2 SET PRCATEMP="[PRCA NEWB LIST]"
DO WRLST
QUIT
+3 ;
WROFF ;list of written-off accounts receivable.
+1 SET PRCAHDR="LIST OF WRITTEN-OFF ACCOUNTS RECEIVABLE"
SET (PRCAFT,PRCALAST)=",109"
+2 DO WRLST
QUIT
+3 ;
ACTBIL ;list of active accounts receivable
+1 SET PRCAHDR="LIST OF ACTIVE ACCOUNTS RECEIVABLE"
SET (PRCAFT,PRCALAST)=",102"
+2 DO WRLST
QUIT
+3 ;
RETNAR ;returned AR list
+1 SET PRCAHDR="RETURNED AR LIST"
SET PRCASORT="@CURRENT STATUS:STATUS NUMBER,@DATE RETURNED TO SERVICE"
SET PRCAFT="220,"
SET PRCALAST="230,"
+2 SET PRCATEMP="[PRCAC RETURN AR]"
SET DIC="^PRCA(430,"
DO PRINT^PRCAREPT
QUIT
+3 ;
RC ;list of AR to be referred to RC
+1 NEW PRCA
+2 SET PRCAHDR="ACCOUNTS RECEIVABLE POSSIBLE REFERRALS TO REGIONAL COUNSEL"
DO MINMAX
+3 SET PRCASORT="DEBTOR,@OVER LETTER3,@RC/DOJ REFERRAL DATE,@CURRENT STATUS:STATUS NUMBER"
SET PRCAFT=",30,@,102"
SET PRCALAST=",,@,102"
SET PRCATEMP="[PRCAL L DC-DOJ]"
SET DIS(0)="I $D(^PRCA(430,D0,7)),+^(7)'<PRCAMIN,+^(7)'>PRCAMAX"
+4 SET DIC="^PRCA(430,"
+5 if $DATA(ZTSK)
SET IOP=ION
+6 DO @$SELECT($DATA(ZTSK):"DIP^PRCAREPT",1:"PRINT^PRCAREPT")
+7 KILL DIOBEG,DIS,PRCAMIN,PRCAMAX
QUIT
+8 ;
DOJ ;list of AR to be referred to Dept. of Justice.
+1 NEW PRCA
+2 SET PRCAHDR="ACCOUNTS RECEIVABLE POSSIBLE REFERRALS TO DEPT. OF JUSTICE"
DO MINMAX
+3 SET PRCASORT="DEBTOR,@OVER LETTER3,@RC/DOJ REFERRAL DATE,@CURRENT STATUS:STATUS NUMBER"
SET PRCAFT=",30,@,102"
SET PRCALAST=",,@,102"
SET PRCATEMP="[PRCAL L DC-DOJ]"
SET DIS(0)="I $D(^PRCA(430,D0,7)),+^(7)'<PRCAMAX"
+4 SET DIC="^PRCA(430,"
+5 DO @$SELECT($DATA(ZTSK):"DIP^PRCAREPT",1:"PRINT^PRCAREPT")
+6 KILL DIOBEG,DIS,PRCAMIN,PRCAMAX
QUIT
+7 ;
COWC ;List of the accounts referred to COWC.
+1 SET PRCA("DATE")="DATE REFERRED TO COWC"
DO ASKDT^PRCAQUE
IF (PRCADT1="")!(PRCADT2="")
KILL PRCADT1,PRCADT2
QUIT
+2 SET PRCAHDR="ACCOUNTS RECEIVABLE REFERRED TO COWC"
SET PRCATEMP="[PRCAD COWC LIST]"
SET PRCASORT="REFERRAL DATE TO COWC,DEBTOR"
+3 SET PRCAFT=PRCADT1_","
SET PRCALAST=PRCADT2_","
SET DIC="^PRCA(430,"
+4 DO PRINT^PRCAREPT
DO END
QUIT
+5 ;
MINMAX ;get the minimum and maximum referral amount to the RC/DOJ.
+1 ;Returns: PRCAMIN, PRCAMAX
+2 NEW PRCAKDA,Z0,Z1,Z2
+3 SET PRCAMIN=1
SET PRCAMAX=5000
SET PRCAKDA=$ORDER(^RC(342.1,"B","REGIONAL COUNSEL",0))
+4 IF +PRCAKDA'>0
QUIT
+5 SET Z1=$GET(^RC(342.1,PRCAKDA,2))
+6 SET Z2=+$PIECE(Z1,"^",2)
SET Z1=+Z1
+7 if (Z1>0)&(Z2>0)
SET PRCAMIN=Z1
SET PRCAMAX=Z2
KILL Z0,Z1,Z2,PRCAKDA
+8 QUIT
+9 ;
PRCOMM ;print comment field
+1 if '$DATA(D0)!('$DATA(PRCAPC))
QUIT
if '$DATA(^PRCA(430,D0,3))
QUIT
SET PRCAKGL=$PIECE(^(3),U,PRCAPC)
if PRCAKGL=""
GOTO EXCOMM
+2 IF $LENGTH(PRCAKGL)<70
WRITE !,?3,PRCAKGL
KILL PRCAKGL
QUIT
+3 FOR PRCAK=70:-1:1
if $EXTRACT(PRCAKGL,PRCAK)=" "
QUIT
+4 WRITE !,?3
FOR PRCAJ=1:1:PRCAK
WRITE $EXTRACT(PRCAKGL,PRCAJ)
+5 WRITE !,?3
FOR PRCAI=PRCAK+1:1:$LENGTH(PRCAKGL)
WRITE $EXTRACT(PRCAKGL,PRCAI)
EXCOMM KILL PRCAKGL,PRCAK,PRCAJ,PRCAI
QUIT
+1 ;
END KILL PRCA
QUIT
+1 ;
+2 ;============== COUNT NEW CALM PENDING TRANSACTIONS=================
COUNTR IF $ORDER(^PRCA(433,"AE",1,0))
WRITE *7,!!,"*** You have new transactions from the AR section pending CALM transmission *** "
+1 QUIT
+2 ;
RETN ;returned bills list
+1 NEW ZTSK,POP,PRCAP,PRCASVC
+2 DO SVC^PRCABIL
if '$DATA(PRCAP("S"))
QUIT
+3 SET PRCASVC=PRCAP("S")
+4 SET %ZIS="MQ"
DO ^%ZIS
if POP
GOTO Q1
+5 IF $DATA(IO("Q"))
SET ZTRTN="RETNDQ^PRCALST"
SET ZTDESC="Returned Bill List"
SET ZTSAVE("PRCASVC")=""
DO ^%ZTLOAD
GOTO Q1
RETNDQ ;
+1 NEW BILL,STAT,DIC,L,FR,TO,FLDS
+2 IF $EXTRACT(IOST)="C"
WRITE @IOF
+3 FOR STAT=$ORDER(^PRCA(430.3,"AC",220,0)),$ORDER(^PRCA(430.3,"AC",230,0))
Begin DoDot:1
+4 SET BILL=0
FOR
SET BILL=$ORDER(^PRCA(430,"AC",STAT,BILL))
if 'BILL
QUIT
IF $DATA(^PRCA(430,BILL,100))
IF $PIECE(^(100),"^",2)=PRCASVC
Begin DoDot:2
+5 SET D0=BILL
KILL DXS
DO ^PRCATP6
KILL DXS
IF $Y+15>IOSL
Begin DoDot:3
+6 IF $EXTRACT(IOST)="C"
WRITE *7
WRITE !
READ X:DTIME
IF X["^"!'$TEST
SET STAT=-1
QUIT
+7 WRITE @IOF
+8 QUIT
End DoDot:3
+9 QUIT
End DoDot:2
+10 QUIT
End DoDot:1
Q1 DO ^%ZISC
QUIT
