- PRCAACC ;WASH-ISC@ALTOONA,PA/CMS-AR ACCRUAL TOTALS ;10/19/10 1:36pm
- ;;4.5;Accounts Receivable;**60,74,90,101,157,203,220,273,310,338**;Mar 20, 1995;Build 69
- ;Per VA Directive 6402, this routine should not be modified.
- NEW PRCAQUE,PRCADEV,PRCA,ZTSK
- S PRCA("MESS")="Do you wish to queue this report" D QUE^PRCAQUE G:'$D(PRCAQUE) Q
- I $D(IO("Q")) S ZTRTN="DQ^PRCAACC",ZTDESC="AR Accrual Totals" D ^%ZTLOAD G Q
- DQ ;
- U IO
- NEW BILLN,COM,TOT,STAT,X,Y
- S BILLN=0
- D COM G:$O(COM(""))="" RPT
- F STAT=42,16 F S BILLN=$O(^PRCA(430,"AC",STAT,BILLN)) Q:'BILLN I $$ACCK(BILLN) D
- .S X=(","_$P(^PRCA(430,BILLN,0),"^",2)_",")
- .S TOT(X)=$G(TOT(X))+$G(^PRCA(430,BILLN,7))
- .QUIT
- RPT D NOW^%DTC W @IOF,!!,?23,"Accrual Totals Report",!?20,"As of: " S Y=% X ^DD("DD") W Y,!
- S X="",$P(X,"=",80)="" W X
- W:$O(COM(""))="" !!,"WARNING: Accruals are *NOT* set-up correctly.",!,"No RX accrual common numbering series are set-up in AR Bill Number File!",!!
- S TOT=$G(TOT(",22,"))+$G(TOT(",23,")) I TOT W !!!,"RX CO-PAYMENT Accrual Amount: $",$FN(TOT,",",2)
- I $G(TOT(",18,"))>0 W !!!,"C (MEANS TEST) Accrual Amount: $",$FN(TOT(",18,"),",",2)
- W !!!!,"Includes Common Numbering Series:",! S COM="" F S COM=$O(COM(COM)) Q:COM="" W !,COM,?20,COM(COM)
- Q D ^%ZISC S IOP=IO(0) D ^%ZIS K IOP,IO("Q") Q
- ACCK(BN) ;Check BILLN to see if Accrual
- N ACC,ACTDATE,CAT,FUND,DB
- S CAT=+$P(^PRCA(430,BN,0),"^",2)
- ; field 12, ACCRUED ? where 0=no 1=yes, 2=could be either
- S ACC=+$P($G(^PRCA(430.2,CAT,0)),"^",9)
- ; it could be either accrued or non-accrued
- I ACC=2 D
- . S FUND=$P($G(^PRCA(430,BN,11)),"^",17)
- . S ACC=$S(FUND=5014:1,FUND=2431:1,1:0)
- . I $E(FUND,1,4)=5287 S ACC=$$PTACCT(FUND)
- . ; special case with Workman's Comp
- . I ACC=0,CAT=6,FUND="" D
- . . S DB=$P($G(^RCD(340,+$P($G(^PRCA(430,BN,0)),U,9),0)),U)
- . . I DB[";DPT"!($P($G(^PRCA(430,BN,0)),U,7)'="") S ACC=1
- ;
- ; public law states that bills in the category ineligible (1),
- ; emerg/human (2), torts (10), or medicare (21) which are older
- ; than oct 1, 1992 should be treated as non-accrued.
- I CAT=1!(CAT=2)!(CAT=10)!(CAT=21) D
- . S ACTDATE=$P($G(^PRCA(430,BN,6)),"^",21) I 'ACTDATE S ACTDATE=DT
- . I ACTDATE<2921001 S ACC=0
- . ;
- . ; patch157 changes ineligibles. an ineligible created before
- . ; oct 1, 1992 or after sep 30, 2000 will be non-accrued.
- . ; otherwise it will be accrued.
- . I CAT=1,ACTDATE>3000930 S ACC=0
- ;
- Q ACC
- COM ;Find Accrual common numbering series
- S COM=0
- F S COM=$O(^PRCA(430.4,COM)) Q:'COM I $P(^PRCA(430.4,COM,0),"^",6) S COM($P(^PRCA(430.4,COM,0),"^"))=$P($G(^DIC(49,$P(^(0),"^",5),0)),"^",1)
- Q
- PTACCT(FUND) ;Determines whether Point Accounts are accrued
- ;returns 1 for accrued funds 528701,528702,528703,528704,528709,528711
- ;returns 0 for any other fund
- ;PRCA*4.5*310/DRF Added 528713 to accrued funds
- ;PRCA*4.5*338/OB Added 528714 to accrued funds
- I FUND'[5287 Q 0
- S X=$E(FUND,5,6),X=$S(X="09"!(X="11")!(X="13")!(X="14"):1,X<"05":1,1:0)
- Q X
- ADDPTEDT() ;Effective date of additional point accounts
- ; (528705 - 528708 and 528710)
- ;Effective date of switch from 4032 to 528709
- Q 3040928
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCAACC 3195 printed Jan 18, 2025@02:40:06 Page 2
- PRCAACC ;WASH-ISC@ALTOONA,PA/CMS-AR ACCRUAL TOTALS ;10/19/10 1:36pm
- +1 ;;4.5;Accounts Receivable;**60,74,90,101,157,203,220,273,310,338**;Mar 20, 1995;Build 69
- +2 ;Per VA Directive 6402, this routine should not be modified.
- +3 NEW PRCAQUE,PRCADEV,PRCA,ZTSK
- +4 SET PRCA("MESS")="Do you wish to queue this report"
- DO QUE^PRCAQUE
- if '$DATA(PRCAQUE)
- GOTO Q
- +5 IF $DATA(IO("Q"))
- SET ZTRTN="DQ^PRCAACC"
- SET ZTDESC="AR Accrual Totals"
- DO ^%ZTLOAD
- GOTO Q
- DQ ;
- +1 USE IO
- +2 NEW BILLN,COM,TOT,STAT,X,Y
- +3 SET BILLN=0
- +4 DO COM
- if $ORDER(COM(""))=""
- GOTO RPT
- +5 FOR STAT=42,16
- FOR
- SET BILLN=$ORDER(^PRCA(430,"AC",STAT,BILLN))
- if 'BILLN
- QUIT
- IF $$ACCK(BILLN)
- Begin DoDot:1
- +6 SET X=(","_$PIECE(^PRCA(430,BILLN,0),"^",2)_",")
- +7 SET TOT(X)=$GET(TOT(X))+$GET(^PRCA(430,BILLN,7))
- +8 QUIT
- End DoDot:1
- RPT DO NOW^%DTC
- WRITE @IOF,!!,?23,"Accrual Totals Report",!?20,"As of: "
- SET Y=%
- XECUTE ^DD("DD")
- WRITE Y,!
- +1 SET X=""
- SET $PIECE(X,"=",80)=""
- WRITE X
- +2 if $ORDER(COM(""))=""
- WRITE !!,"WARNING: Accruals are *NOT* set-up correctly.",!,"No RX accrual common numbering series are set-up in AR Bill Number File!",!!
- +3 SET TOT=$GET(TOT(",22,"))+$GET(TOT(",23,"))
- IF TOT
- WRITE !!!,"RX CO-PAYMENT Accrual Amount: $",$FNUMBER(TOT,",",2)
- +4 IF $GET(TOT(",18,"))>0
- WRITE !!!,"C (MEANS TEST) Accrual Amount: $",$FNUMBER(TOT(",18,"),",",2)
- +5 WRITE !!!!,"Includes Common Numbering Series:",!
- SET COM=""
- FOR
- SET COM=$ORDER(COM(COM))
- if COM=""
- QUIT
- WRITE !,COM,?20,COM(COM)
- Q DO ^%ZISC
- SET IOP=IO(0)
- DO ^%ZIS
- KILL IOP,IO("Q")
- QUIT
- ACCK(BN) ;Check BILLN to see if Accrual
- +1 NEW ACC,ACTDATE,CAT,FUND,DB
- +2 SET CAT=+$PIECE(^PRCA(430,BN,0),"^",2)
- +3 ; field 12, ACCRUED ? where 0=no 1=yes, 2=could be either
- +4 SET ACC=+$PIECE($GET(^PRCA(430.2,CAT,0)),"^",9)
- +5 ; it could be either accrued or non-accrued
- +6 IF ACC=2
- Begin DoDot:1
- +7 SET FUND=$PIECE($GET(^PRCA(430,BN,11)),"^",17)
- +8 SET ACC=$SELECT(FUND=5014:1,FUND=2431:1,1:0)
- +9 IF $EXTRACT(FUND,1,4)=5287
- SET ACC=$$PTACCT(FUND)
- +10 ; special case with Workman's Comp
- +11 IF ACC=0
- IF CAT=6
- IF FUND=""
- Begin DoDot:2
- +12 SET DB=$PIECE($GET(^RCD(340,+$PIECE($GET(^PRCA(430,BN,0)),U,9),0)),U)
- +13 IF DB[";DPT"!($PIECE($GET(^PRCA(430,BN,0)),U,7)'="")
- SET ACC=1
- End DoDot:2
- End DoDot:1
- +14 ;
- +15 ; public law states that bills in the category ineligible (1),
- +16 ; emerg/human (2), torts (10), or medicare (21) which are older
- +17 ; than oct 1, 1992 should be treated as non-accrued.
- +18 IF CAT=1!(CAT=2)!(CAT=10)!(CAT=21)
- Begin DoDot:1
- +19 SET ACTDATE=$PIECE($GET(^PRCA(430,BN,6)),"^",21)
- IF 'ACTDATE
- SET ACTDATE=DT
- +20 IF ACTDATE<2921001
- SET ACC=0
- +21 ;
- +22 ; patch157 changes ineligibles. an ineligible created before
- +23 ; oct 1, 1992 or after sep 30, 2000 will be non-accrued.
- +24 ; otherwise it will be accrued.
- +25 IF CAT=1
- IF ACTDATE>3000930
- SET ACC=0
- End DoDot:1
- +26 ;
- +27 QUIT ACC
- COM ;Find Accrual common numbering series
- +1 SET COM=0
- +2 FOR
- SET COM=$ORDER(^PRCA(430.4,COM))
- if 'COM
- QUIT
- IF $PIECE(^PRCA(430.4,COM,0),"^",6)
- SET COM($PIECE(^PRCA(430.4,COM,0),"^"))=$PIECE($GET(^DIC(49,$PIECE(^(0),"^",5),0)),"^",1)
- +3 QUIT
- PTACCT(FUND) ;Determines whether Point Accounts are accrued
- +1 ;returns 1 for accrued funds 528701,528702,528703,528704,528709,528711
- +2 ;returns 0 for any other fund
- +3 ;PRCA*4.5*310/DRF Added 528713 to accrued funds
- +4 ;PRCA*4.5*338/OB Added 528714 to accrued funds
- +5 IF FUND'[5287
- QUIT 0
- +6 SET X=$EXTRACT(FUND,5,6)
- SET X=$SELECT(X="09"!(X="11")!(X="13")!(X="14"):1,X<"05":1,1:0)
- +7 QUIT X
- ADDPTEDT() ;Effective date of additional point accounts
- +1 ; (528705 - 528708 and 528710)
- +2 ;Effective date of switch from 4032 to 528709
- +3 QUIT 3040928