PRCABJ1 ;WASH-ISC@ALTOONA,PA/LDB-NIGHTLY PROCESS FOR OPEN BILL UPDATE ;4/18/95 2:06 PM
V ;;4.5;Accounts Receivable;**7**;Mar 20, 1995
;;Per VHA Directive 10-93-142, this routine should not be modified.
;Update Open status PREPAYMENT bills to REFUND REVIEW
;Update Open status bills to Active or Cancellation status
OPEN N DAY,BN,DEBTOR,DA,DIE,DR,P,AMT
S DAY=+$E(DT,6,7),DEBTOR=0 F S DEBTOR=$O(^RCD(340,"AC",DAY,DEBTOR)) Q:'DEBTOR D
.S BN=0 F S BN=$O(^PRCA(430,"AS",DEBTOR,$O(^PRCA(430.3,"AC",112,0)),BN)) Q:'BN D
..S AMT=0 F P=1:1:5 S AMT=$P($G(^PRCA(430,+BN,7)),"^",P)+AMT
..I $P($G(^PRCA(430,+BN,0)),"^",2)=$O(^PRCA(430.2,"AC",33,0)),AMT Q
..S DIE="^PRCA(430,",DA=+BN,DR="8////^S X="_$S(AMT:$O(^PRCA(430.3,"AC",102,0)),1:$O(^PRCA(430.3,"AC",111,0))) D ^DIE K DA,DIE,DR
..Q
.Q
Q
REFUND NEW DEBTOR,DAY,BN
S DEBTOR=0,DAY=+$E(DT,6,7)+3#28 S:'DAY DAY=28
F S DEBTOR=$O(^RCD(340,"AC",DAY,DEBTOR)) Q:'DEBTOR D
.S BN=0 F S BN=$O(^PRCA(430,"AS",DEBTOR,$O(^PRCA(430.3,"AC",112,0)),BN)) Q:'BN D
..I $P($G(^PRCA(430,+BN,0)),"^",2)=$O(^PRCA(430.2,"AC",33,0)) S X=$$EN^PRCARFU(+BN)
..Q
.Q
Q
STM ;RESET STATEMENT DATES
NEW DEB,DIE,DA,DR,TYPE,STAT,BILL,ACT
S STAT=+$O(^PRCA(430.3,"AC",102,0))
I 'STAT Q
F TYPE="VA(200,","DIC(4,","PRC(440," S DEB=0 F S DEB=$O(^RCD(340,"AB",TYPE,DEB)) Q:'DEB S X=$G(^RCD(340,DEB,0)) D:X]""
.I $P(X,"^",3),'$O(^PRCA(430,"AS",DEB,STAT,0)) S DIE="^RCD(340,",DR=".03////@",DA=DEB D ^DIE Q
.I '$P(X,"^",3),$O(^PRCA(430,"AS",DEB,STAT,0)) S DIE="^RCD(340,",DR=".03////^S X=+$E(DT,6,7) S:X>28 X=1",DA=DEB D ^DIE
.Q
S TYPE="DIC(36," S DEB=0 F S DEB=$O(^RCD(340,"AB",TYPE,DEB)) Q:'DEB D
.S ACT=0,BILL=0 F S BILL=$O(^PRCA(430,"AS",DEB,STAT,BILL)) Q:'BILL I $P($G(^PRCA(430,BILL,0)),"^",2)'=9 S ACT=1 Q
.S X=$G(^RCD(340,DEB,0))
.I $P(X,"^",3),'ACT S DIE="^RCD(340,",DR=".03////@",DA=DEB D ^DIE Q
.I '$P(X,"^",3),ACT S DIE="^RCD(340,",DR=".03////^S X=+$E(DT,6,7) S:X>28 X=1",DA=DEB D ^DIE
.Q
Q
UDLIST ;Print Unprocessed Document List
N IOP,ZTIO,ZTSAVE,ZTRTN,ZTDESC,ZTASK,%ZIS,ZTDTH,RCFMDEV
S IOP=$P($G(^RC(342,1,0)),"^",8) I IOP]"" D
.S %ZIS="N0" D ^%ZIS Q:POP
.S ZTRTN="EN^RCFMUDL",ZTDTH=$H,RCFMDEV=ION_";"_IOST_";"_IOM_";"_IOSL_";"_$G(IO("DOC"))
.S ZTSAVE("RCFMDEV")="",ZTDESC="Unprocessed Document List"
.D ^%ZTLOAD,^%ZISC
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCABJ1 2331 printed Oct 16, 2024@17:39:56 Page 2
PRCABJ1 ;WASH-ISC@ALTOONA,PA/LDB-NIGHTLY PROCESS FOR OPEN BILL UPDATE ;4/18/95 2:06 PM
V ;;4.5;Accounts Receivable;**7**;Mar 20, 1995
+1 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+2 ;Update Open status PREPAYMENT bills to REFUND REVIEW
+3 ;Update Open status bills to Active or Cancellation status
OPEN NEW DAY,BN,DEBTOR,DA,DIE,DR,P,AMT
+1 SET DAY=+$EXTRACT(DT,6,7)
SET DEBTOR=0
FOR
SET DEBTOR=$ORDER(^RCD(340,"AC",DAY,DEBTOR))
if 'DEBTOR
QUIT
Begin DoDot:1
+2 SET BN=0
FOR
SET BN=$ORDER(^PRCA(430,"AS",DEBTOR,$ORDER(^PRCA(430.3,"AC",112,0)),BN))
if 'BN
QUIT
Begin DoDot:2
+3 SET AMT=0
FOR P=1:1:5
SET AMT=$PIECE($GET(^PRCA(430,+BN,7)),"^",P)+AMT
+4 IF $PIECE($GET(^PRCA(430,+BN,0)),"^",2)=$ORDER(^PRCA(430.2,"AC",33,0))
IF AMT
QUIT
+5 SET DIE="^PRCA(430,"
SET DA=+BN
SET DR="8////^S X="_$SELECT(AMT:$ORDER(^PRCA(430.3,"AC",102,0)),1:$ORDER(^PRCA(430.3,"AC",111,0)))
DO ^DIE
KILL DA,DIE,DR
+6 QUIT
End DoDot:2
+7 QUIT
End DoDot:1
+8 QUIT
REFUND NEW DEBTOR,DAY,BN
+1 SET DEBTOR=0
SET DAY=+$EXTRACT(DT,6,7)+3#28
if 'DAY
SET DAY=28
+2 FOR
SET DEBTOR=$ORDER(^RCD(340,"AC",DAY,DEBTOR))
if 'DEBTOR
QUIT
Begin DoDot:1
+3 SET BN=0
FOR
SET BN=$ORDER(^PRCA(430,"AS",DEBTOR,$ORDER(^PRCA(430.3,"AC",112,0)),BN))
if 'BN
QUIT
Begin DoDot:2
+4 IF $PIECE($GET(^PRCA(430,+BN,0)),"^",2)=$ORDER(^PRCA(430.2,"AC",33,0))
SET X=$$EN^PRCARFU(+BN)
+5 QUIT
End DoDot:2
+6 QUIT
End DoDot:1
+7 QUIT
STM ;RESET STATEMENT DATES
+1 NEW DEB,DIE,DA,DR,TYPE,STAT,BILL,ACT
+2 SET STAT=+$ORDER(^PRCA(430.3,"AC",102,0))
+3 IF 'STAT
QUIT
+4 FOR TYPE="VA(200,","DIC(4,","PRC(440,"
SET DEB=0
FOR
SET DEB=$ORDER(^RCD(340,"AB",TYPE,DEB))
if 'DEB
QUIT
SET X=$GET(^RCD(340,DEB,0))
if X]""
Begin DoDot:1
+5 IF $PIECE(X,"^",3)
IF '$ORDER(^PRCA(430,"AS",DEB,STAT,0))
SET DIE="^RCD(340,"
SET DR=".03////@"
SET DA=DEB
DO ^DIE
QUIT
+6 IF '$PIECE(X,"^",3)
IF $ORDER(^PRCA(430,"AS",DEB,STAT,0))
SET DIE="^RCD(340,"
SET DR=".03////^S X=+$E(DT,6,7) S:X>28 X=1"
SET DA=DEB
DO ^DIE
+7 QUIT
End DoDot:1
+8 SET TYPE="DIC(36,"
SET DEB=0
FOR
SET DEB=$ORDER(^RCD(340,"AB",TYPE,DEB))
if 'DEB
QUIT
Begin DoDot:1
+9 SET ACT=0
SET BILL=0
FOR
SET BILL=$ORDER(^PRCA(430,"AS",DEB,STAT,BILL))
if 'BILL
QUIT
IF $PIECE($GET(^PRCA(430,BILL,0)),"^",2)'=9
SET ACT=1
QUIT
+10 SET X=$GET(^RCD(340,DEB,0))
+11 IF $PIECE(X,"^",3)
IF 'ACT
SET DIE="^RCD(340,"
SET DR=".03////@"
SET DA=DEB
DO ^DIE
QUIT
+12 IF '$PIECE(X,"^",3)
IF ACT
SET DIE="^RCD(340,"
SET DR=".03////^S X=+$E(DT,6,7) S:X>28 X=1"
SET DA=DEB
DO ^DIE
+13 QUIT
End DoDot:1
+14 QUIT
UDLIST ;Print Unprocessed Document List
+1 NEW IOP,ZTIO,ZTSAVE,ZTRTN,ZTDESC,ZTASK,%ZIS,ZTDTH,RCFMDEV
+2 SET IOP=$PIECE($GET(^RC(342,1,0)),"^",8)
IF IOP]""
Begin DoDot:1
+3 SET %ZIS="N0"
DO ^%ZIS
if POP
QUIT
+4 SET ZTRTN="EN^RCFMUDL"
SET ZTDTH=$HOROLOG
SET RCFMDEV=ION_";"_IOST_";"_IOM_";"_IOSL_";"_$GET(IO("DOC"))
+5 SET ZTSAVE("RCFMDEV")=""
SET ZTDESC="Unprocessed Document List"
+6 DO ^%ZTLOAD
DO ^%ZISC
End DoDot:1
+7 QUIT
