- 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 Feb 18, 2025@23:05:28 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
