Routine: PRCALST

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

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 *** "

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  Mar 13, 2025@20:44:59                                                                                                                                                                                                     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

PRCALST.m