- PRCAAPR1 ;WASH-ISC@ALTOONA,PA/RGY - PATIENT ACCOUNT PROFILE ;2/12/97 11:48 AM
- ;;4.5;Accounts Receivable;**34,45,108,143,141,206,192,218,276,275,284,303,301,315,350,343,404,405,406**;Mar 20, 1995;Build 5
- ;;Per VA Directive 6402, this routine should not be modified.
- ;
- ;PRCA*4.5*343 Ensure displayed phone number has format 111-222-3333
- ;
- HDR ;Head for Account profile
- S X="",$P(X,"=",23)="" W @IOF,!,X," A c c o u n t P r o f i l e ",X
- HDR1 N DMC,IBRX,RSN,TOP4,TOP6,DPTFLG,RCACCTN,RCCV ;PRCA*4.5*405
- S IBRX=0,DPTFLG=0
- ;
- ; PRCAAPR cleans up BILL, COUNT, DEBT, DTOUT, DIC, OUT, PRCADB, SEL, X
- ;Display new 'Statement Account Number" (Patch 206)
- I PRCADB["DPT(" S DPTFLG=1,RCACCTN=$$ACCT(PRCADB) ;PRCA*4.5*405
- ;
- W !,$P(DEBT,"^",2) I DPTFLG!(PRCADB["VA(200,") S X=$S(PRCADB["DPT(":$P(^DPT(+PRCADB,0),"^",9),1:$P($G(^VA(200,+PRCADB,1)),"^",9)) W " (",$E(X,1,3),"-",$E(X,4,5),"-",$E(X,6,9),")"
- W ?53,"Statement Day: ",$S($$PST^RCAMFN01(+DEBT)>0:$$PST^RCAMFN01(+DEBT),1:"N/A")
- K Y S X("ADD")=$$DADD^RCAMADD(PRCADB)
- ;
- ;Display new 'Statement Account Number" (Patch 206)
- I DPTFLG W !,"Statement Account #: ",RCACCTN,?52,"Last Statement: " ;PRCA*4.5*405
- E W !?52,"Last Statement: "
- ;
- S Y=+$$LST^RCFN01(PRCADB,2)
- I Y>0 S Y("CCPC")=$$FPS^RCCPCFN(+DEBT) S:Y("CCPC") Y=+$P(Y("CCPC"),"^")
- W $S(Y=-1:"N/A",1:$$SLH^RCFN01(Y))
- W !,$P(X("ADD"),"^")
- W:+$G(Y("CCPC")) ?52,"Activity as of: ",$$SLH^RCFN01($$ASOF^RCCPCFN($P(Y("CCPC"),"^",2)))
- W:$P(X("ADD"),"^",2)]"" !,$P(X("ADD"),"^",2) W:$P(X("ADD"),"^",3)]"" !,$P(X("ADD"),"^",3)
- W ! W:$P(X("ADD"),"^",4)]"" $P(X("ADD"),"^",4),", ",$P(X("ADD"),"^",5)," ",$S($P(X("ADD"),"^",6):$P(X("ADD"),"^",6),1:$P(X("ADD"),"^",8))
- W ?55,"Amount Owed: ",?69,$J(+$G(^TMP("PRCAAPR",$J,"C")),9,2)
- I $P(X("ADD"),"^",7)?10N D ;PRCA*4.5*343
- . N PRCHPHN
- . S PRCAPHN=$P(X("ADD"),"^",7),PRCAPHN=$E(PRCAPHN,1,3)_"-"_$E(PRCAPHN,4,6)_"-"_$E(PRCAPHN,7,10)
- . S $P(X("ADD"),"^",7)=PRCAPHN
- W !,"Phone #: ",$S($P(X("ADD"),"^",7)]"":$P(X("ADD"),"^",7),1:"N/A")
- I PRCADB["DPT(" W ?51,"RX Copay Exempt: " S IBRX=$$RXST^IBARXEU(+PRCADB,DT) W $S($P(IBRX,U)=1:"YES",$P(IBRX,U)=0:"NO",1:"N/A")
- I PRCADB["DPT(" W !?57,"CV Status: " S RCCV=$$CVEDT^DGCV(+PRCADB,DT) W $S($P(RCCV,U,3)>0:"YES",1:"NO") I $P(RCCV,U,2) W !?52,"CV Status Ends: ",$$SLH^RCFN01($P(RCCV,U,2))
- ; *108 add exemption reason/dmc info
- I IBRX>0,($P(IBRX,U)=1) S DIC="^IBE(354.2,",DIC(0)="M",X=+$P(IBRX,"^",3) D ^DIC I Y>0 W !,?54,"(",$P(Y,"^",2),")"
- I $D(^RCD(340,"DMC",1,+DEBT)) S DMC=$G(^RCD(340,+DEBT,3)) D
- .I $P(DMC,"^",2) W !,"** Account forwarded to DMC: ",$$SLH^RCFN01($P(DMC,"^",2)),?50,"Total DMC Amount: ",?69,$J($P(DMC,"^",5),9,2)
- .I $P(DMC,"^",9)'="" W !,?49,"Lesser Amt to DMC: ",?69,$J($P(DMC,"^",9),9,2)
- .Q
- I $D(^RCD(340,"TOP",+DEBT)) S TOP4=$G(^RCD(340,+DEBT,4)),TOP6=$G(^(6)) D
- .I +TOP6 W !,"** Account forwarded to TOP: ",$$SLH^RCFN01($P(TOP6,"^")),?45,"Total TOP Amount: ",?65,$J($P(TOP4,"^",3),13,2)
- .I $P(TOP6,"^",6) W !,?45,"TOP HOLD DATE: ",$$SLH^RCFN01($P(TOP6,"^",6))
- .Q
- ; "Put Re-" if rerefer
- I $D(^RCD(340,"TCSP",+DEBT)) D
- .;PRCA*4.5*350
- .W !,"x Debt "_$S($$RRD^RCTCSPU(+DEBT):"Re-",1:"")_"Referred to Cross-Servicing",?45,"Total CS Debt: ",?65,$J($$TOTALB^RCTCSPU(+DEBT),13,2)
- .Q
- I $O(^RCD(340,+DEBT,2,0)) D
- .S Y=0 F X=0:0 S X=$O(^RCD(340,+DEBT,2,X)) Q:'X W:'Y ! W !,$G(^(X,0)) S Y=Y+1 W:Y=3&$O(^RCD(340,+DEBT,2,X)) "..." Q:Y=3
- .Q
- ; PRCA*4.5*378/PRCA*4.5*404
- S RPIEN=+$O(^RCRP(340.5,"E",+DEBT,""),-1) I RPIEN D
- .S RPIENS=RPIEN_","
- .W !,"Repayment Plan: ",$$GET1^DIQ(340.5,RPIENS,.01)
- .W ?45,"Repayment Plan Status: ",$$GET1^DIQ(340.5,RPIENS,.07)
- .Q
- ;
- Q
- ; PRCA*4.5*276 - moved headers right to add EOB indicator to bill #, adjusted at tag BLN accordingly
- ; PRCA*4.5*275 - moved headers to line up with column changes
- HDR2 W !!,"#",?7,"Bill #",?20,"Est",?31,"Type",?43,"Paid",?52,"Prin",?58,"Int",?64,"Adm",?72,"Balance"
- Q
- DIS ;Display bill line items
- NEW STAT1
- I '$O(^TMP("PRCAAPR",$J,"C",0)) S X="",$P(X,"*",22)="" W !!,X," NO ACCOUNT INFORMATION AVAILABLE ",X G Q1
- F STAT1=0:0 S STAT1=$O(^TMP("PRCAAPR",$J,"C",STAT1)) Q:'STAT1!$D(OUT) D BHDR S BILL=0 F S BILL=$O(^TMP("PRCAAPR",$J,"C",STAT1,BILL)) Q:BILL=""!$D(OUT) D BLN
- I '$D(OUT) D READ
- Q1 Q
- BHDR ;Display status line
- S X=$S(+$P(^TMP("PRCAAPR",$J,"C",STAT1),"^",2)=99:"PAYMENTS",1:$P($G(^PRCA(430.3,+$O(^PRCA(430.3,"AC",+$P(^TMP("PRCAAPR",$J,"C",STAT1),"^",2),0)),0)),"^"))
- S Y=" "_X_" ("_$J(+^TMP("PRCAAPR",$J,"C",STAT1),0,2)_") " W ! F X=1:1:80-$L(Y)/2 W "-"
- W Y F X=1:1:IOM-$X-1 W "-"
- Q
- BLN ;
- N PRCOUT,REJFLAG,CSCSTAT,DEBTOR,CSDATE1,CSDATE2,RCIND
- I $Y+5>IOSL,COUNT D READ G:$D(OUT) Q2 D HDR,HDR2,BHDR
- ; PRCA*4.5*276, attach EOB indicator '%' to bill # when applicable
- S PRCOUT=$$COMP3^PRCAAPR(BILL)
- I STAT1'=99,PRCOUT'="%" S PRCOUT=$$IBEEOBCK(BILL)
- ; PRCA*4.5*303 - add reject indicator to kbill if applicable ; #IA 6060
- S REJFLAG=0 S:STAT1'=99 REJFLAG=$$BILLREJ^IBJTU6($P($P($G(^PRCA(430,BILL,0)),"^"),"-",2))
- S:STAT1'=99 COUNT=COUNT+1,^TMP("PRCAAPR",$J,"O",COUNT)=BILL S X=$S(STAT1=99:BILL,1:$G(PRCOUT)_$S(REJFLAG:"c",1:"")_$G(^PRCA(430,BILL,0)))
- ; PRCA*4.5*303 - End
- ;
- ; PRCA*4.5*315: AR File #430 - set historical indicator set to "y" if an entry exists in the
- ; ORIGINAL DATE REFERRED TO TCSP (field #156) to CS bill number. If an entry in the
- ; DATE REFERRED TO TCSP (field #151), then an "x" indicator displays on the bill,
- ; otherwise neither indicator.
- ;
- S CSDATE1=$$GET1^DIQ(430,BILL,"DATE BILL REFERRED TO TCSP","I")
- S CSDATE2=$$GET1^DIQ(430,BILL,"ORIGINAL DATE REFERRED TO TCSP","I")
- S RCIND=$S(CSDATE1'="":"x",CSDATE2'="":"y",1:"")
- ;W !,$S(STAT1'=99:COUNT,1:"*"),?4,$P(X,"^") W:STAT1'=99 ?20,$$SLH^RCFN01($P(X,"^",10))
- I RCIND]"" W !,$S(STAT1'=99:COUNT,1:"*"),?5,$P(RCIND_X,"^") W:STAT1'=99 ?20,$$SLH^RCFN01($P(X,"^",10))
- I RCIND="" W !,$S(STAT1'=99:COUNT,1:"*"),?6,$P(X,"^") W:STAT1'=99 ?20,$$SLH^RCFN01($P(X,"^",10))
- W:STAT1'=99 ?31,$S($P(X,"^",2)=31:"TRIC PT",1:$E($P($G(^PRCA(430.2,$S($O(^PRCA(430.2,"AC",24,0))=$P(X,"^",2):+$P(X,"^",16),1:+$P(X,"^",2)),0)),"^"),1,7)) ; PRCA*4.5*192 changed CHMP PT to TRIC PT
- W:STAT1=99 ?31,"PAYMENT"
- S X=$S(STAT1=99:"^^^^^^"_^TMP("PRCAAPR",$J,"C",STAT1,BILL),1:$G(^PRCA(430,BILL,7))) W ?39 W:STAT1=99 "-" W $J($P(X,"^",7)+$P(X,"^",8)+$P(X,"^",9)+$P(X,"^",10)+$P(X,"^",11),8,2)
- W ?48 W:STAT1=99 " " W:STAT1'=99 $S($P(^PRCA(430,BILL,0),"^",2)=$O(^PRCA(430.2,"AC",33,0)):"-",1:" ")
- W $J($P(X,"^"),7,2),?57,$J($P(X,"^",2),5,2),?63,$J($P(X,"^",3),5,2),?69,$S(STAT1=99:"-",$P(^PRCA(430,BILL,0),"^",2)=$O(^PRCA(430.2,"AC",33,0)):"-",1:" ")
- W $S(STAT1=99:$J(^TMP("PRCAAPR",$J,"C",STAT1,BILL),9,2),1:$J($P(X,"^")+$P(X,"^",2)+$P(X,"^",3)+$P(X,"^",4)+$P(X,"^",5),9,2))
- K ^TMP("PRCAAPR",$J,"C",STAT1,BILL) K:$O(^TMP("PRCAAPR",$J,"C",STAT1,""))="" ^TMP("PRCAAPR",$J,"C",STAT1)
- Q2 Q
- READ ;Read bill number
- W !!,"Select 1-",COUNT W:$O(^TMP("PRCAAPR",$J,"C","")) " or return to continue" R ": ",X:DTIME I X["^"!'$T S:'$T DTOUT=1 S OUT=1 G Q3
- I X["?" W !!,"To see detailed information for a bill number, enter the corresponding '#'",!,"next to the bill. (Ex: 1 or 1,3)" G READ
- I X="",'$O(^TMP("PRCAAPR",$J,"C","")) S OUT=1 G Q3
- G:X="" Q3 S SEL=X
- F X=1:1:$L(SEL,",") S Y=$P(SEL,",",X) I Y'?1N.N!'$D(^TMP("PRCAAPR",$J,"O",+Y)) W *7," ??" G READ
- S OUT=1 F X=1:1:$L(SEL,",") S Y=$P(SEL,",",X) D EN1^PRCAATR($G(^TMP("PRCAAPR",$J,"O",+Y)))
- Q3 Q
- ;
- ACCT(DFN) ;Get account number. Join station with DFN (Patch 206)
- ;PRCA*4.5*406 - Added Parameter comments
- ;Input Declared: DFN - Patient IEN
- ;Input Undeclared: DEBT - Debtor IEN^Debtor Name
- ;end PRCA*4.5*406
- ;
- N SITE,ACCT,ACCT1,LEN
- S DFN=+DFN
- ;I 'DFN S ACCT1="" Q ACCT1 ;PRCA*4.5*405 ; Removed PRCA*4.5*406
- S LEN=$L(DFN)-1
- S SITE=$$SITE^RCMSITE ;station number
- S ACCT=$$RJ^XLFSTR(DFN,13,0) ;add leading zeroes
- S ACCT1=SITE_"-"_$E(ACCT,1,$L(ACCT)-$L(DFN)) ;add hyphen
- S ACCT1=ACCT1_"-"_$E(ACCT,$L(ACCT)-LEN,99) ;add hyphen
- S ACCT1=ACCT1_"-"_$E($P($P(DEBT,U,2),","),1,5) ;add last name
- Q ACCT1
- ;
- ; PRCA*4.5*276 - Use Event Date to find an associated 3rd Party bill with an associated EEOB
- IBEEOBCK(PRCAAR) ; Passed AR Bill
- ; Function will quit as soon as a 3rd party bill is located that has an associated EEOB
- ;
- ; Find 3rd Party Bills with an Event Date
- N PRCAREF,PRCAEEOB,PRCADT,DFN,DBTR,X1
- ; Get DFN
- S DBTR=+$P($G(^PRCA(430,PRCAAR,0)),U,9)
- S X1=$P($G(^RCD(340,DBTR,0)),U) I X1'["DPT" Q ""
- S DFN=+X1
- S PRCAEEOB=""
- ; Loop through Xref of ARbill (#430) to Action file (#350)
- I +$G(PRCAAR) S PRCAREF=0 F S PRCAREF=$O(^IB("ABIL",$P($G(^PRCA(430,PRCAAR,0)),"^"),PRCAREF)) Q:'PRCAREF D Q:PRCAEEOB="%"
- . S PRCADT=$P($G(^IB(PRCAREF,0)),"^",17) ;Get event Date
- . I PRCADT S PRCAEEOB=$$TPEVDT(DFN,PRCADT) Q:PRCAEEOB="%"
- . I PRCADT S PRCAEEOB=$$TPOPV(DFN,PRCADT)
- ;
- Q PRCAEEOB
- ;
- ; PRCA*4.5*276 - Traverse all THIRD PARTY bills for a patient with a specific Event Date (399,.03)
- TPEVDT(DFN,EVDT) ;
- ; Function will quit as soon as a 3rd party bill is located that has an associated EEOB
- ; PRCA*4.5*284 - Use the 399,"APDT" (by patient) index instead of the 399,"D" index for efficiency
- I '$G(DFN)!'$G(EVDT) Q ""
- N PRCAIFN,PRCAEEOB
- S PRCAEEOB="",PRCAIFN=""
- F S PRCAIFN=$O(^DGCR(399,"APDT",DFN,PRCAIFN),-1) Q:'PRCAIFN D Q:PRCAEEOB="%"
- . I $D(^DGCR(399,"APDT",DFN,PRCAIFN,9999999-EVDT)) S PRCAEEOB=$$COMP3^PRCAAPR(PRCAIFN)
- Q PRCAEEOB
- ;
- ; PRCA*4.5*276 - Traverse all THIRD PARTY bills for a patient with any Opt Visit Dates same as Event Date (399,43)
- TPOPV(DFN,EVDT) ;
- ; Function will quit as soon as a 3rd party bill is located that has an associated EEOB
- N PRCAIFN,PRCAEEOB
- S PRCAEEOB=""
- I +$G(DFN),+$G(EVDT) S PRCAIFN=0 F S PRCAIFN=$O(^DGCR(399,"AOPV",DFN,EVDT,PRCAIFN)) Q:'PRCAIFN D Q:PRCAEEOB="%"
- . ; attach EOB indicator '%' to bill # when applicable
- . S PRCAEEOB=$$COMP3^PRCAAPR(PRCAIFN)
- Q PRCAEEOB
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCAAPR1 10049 printed Feb 18, 2025@23:05:19 Page 2
- PRCAAPR1 ;WASH-ISC@ALTOONA,PA/RGY - PATIENT ACCOUNT PROFILE ;2/12/97 11:48 AM
- +1 ;;4.5;Accounts Receivable;**34,45,108,143,141,206,192,218,276,275,284,303,301,315,350,343,404,405,406**;Mar 20, 1995;Build 5
- +2 ;;Per VA Directive 6402, this routine should not be modified.
- +3 ;
- +4 ;PRCA*4.5*343 Ensure displayed phone number has format 111-222-3333
- +5 ;
- HDR ;Head for Account profile
- +1 SET X=""
- SET $PIECE(X,"=",23)=""
- WRITE @IOF,!,X," A c c o u n t P r o f i l e ",X
- HDR1 ;PRCA*4.5*405
- NEW DMC,IBRX,RSN,TOP4,TOP6,DPTFLG,RCACCTN,RCCV
- +1 SET IBRX=0
- SET DPTFLG=0
- +2 ;
- +3 ; PRCAAPR cleans up BILL, COUNT, DEBT, DTOUT, DIC, OUT, PRCADB, SEL, X
- +4 ;Display new 'Statement Account Number" (Patch 206)
- +5 ;PRCA*4.5*405
- IF PRCADB["DPT("
- SET DPTFLG=1
- SET RCACCTN=$$ACCT(PRCADB)
- +6 ;
- +7 WRITE !,$PIECE(DEBT,"^",2)
- IF DPTFLG!(PRCADB["VA(200,")
- SET X=$SELECT(PRCADB["DPT(":$PIECE(^DPT(+PRCADB,0),"^",9),1:$PIECE($GET(^VA(200,+PRCADB,1)),"^",9))
- WRITE " (",$EXTRACT(X,1,3),"-",$EXTRACT(X,4,5),"-",$EXTRACT(X,6,9),")"
- +8 WRITE ?53,"Statement Day: ",$SELECT($$PST^RCAMFN01(+DEBT)>0:$$PST^RCAMFN01(+DEBT),1:"N/A")
- +9 KILL Y
- SET X("ADD")=$$DADD^RCAMADD(PRCADB)
- +10 ;
- +11 ;Display new 'Statement Account Number" (Patch 206)
- +12 ;PRCA*4.5*405
- IF DPTFLG
- WRITE !,"Statement Account #: ",RCACCTN,?52,"Last Statement: "
- +13 IF '$TEST
- WRITE !?52,"Last Statement: "
- +14 ;
- +15 SET Y=+$$LST^RCFN01(PRCADB,2)
- +16 IF Y>0
- SET Y("CCPC")=$$FPS^RCCPCFN(+DEBT)
- if Y("CCPC")
- SET Y=+$PIECE(Y("CCPC"),"^")
- +17 WRITE $SELECT(Y=-1:"N/A",1:$$SLH^RCFN01(Y))
- +18 WRITE !,$PIECE(X("ADD"),"^")
- +19 if +$GET(Y("CCPC"))
- WRITE ?52,"Activity as of: ",$$SLH^RCFN01($$ASOF^RCCPCFN($PIECE(Y("CCPC"),"^",2)))
- +20 if $PIECE(X("ADD"),"^",2)]""
- WRITE !,$PIECE(X("ADD"),"^",2)
- if $PIECE(X("ADD"),"^",3)]""
- WRITE !,$PIECE(X("ADD"),"^",3)
- +21 WRITE !
- if $PIECE(X("ADD"),"^",4)]""
- WRITE $PIECE(X("ADD"),"^",4),", ",$PIECE(X("ADD"),"^",5)," ",$SELECT($PIECE(X("ADD"),"^",6):$PIECE(X("ADD"),"^",6),1:$PIECE(X("ADD"),"^",8))
- +22 WRITE ?55,"Amount Owed: ",?69,$JUSTIFY(+$GET(^TMP("PRCAAPR",$JOB,"C")),9,2)
- +23 ;PRCA*4.5*343
- IF $PIECE(X("ADD"),"^",7)?10N
- Begin DoDot:1
- +24 NEW PRCHPHN
- +25 SET PRCAPHN=$PIECE(X("ADD"),"^",7)
- SET PRCAPHN=$EXTRACT(PRCAPHN,1,3)_"-"_$EXTRACT(PRCAPHN,4,6)_"-"_$EXTRACT(PRCAPHN,7,10)
- +26 SET $PIECE(X("ADD"),"^",7)=PRCAPHN
- End DoDot:1
- +27 WRITE !,"Phone #: ",$SELECT($PIECE(X("ADD"),"^",7)]"":$PIECE(X("ADD"),"^",7),1:"N/A")
- +28 IF PRCADB["DPT("
- WRITE ?51,"RX Copay Exempt: "
- SET IBRX=$$RXST^IBARXEU(+PRCADB,DT)
- WRITE $SELECT($PIECE(IBRX,U)=1:"YES",$PIECE(IBRX,U)=0:"NO",1:"N/A")
- +29 IF PRCADB["DPT("
- WRITE !?57,"CV Status: "
- SET RCCV=$$CVEDT^DGCV(+PRCADB,DT)
- WRITE $SELECT($PIECE(RCCV,U,3)>0:"YES",1:"NO")
- IF $PIECE(RCCV,U,2)
- WRITE !?52,"CV Status Ends: ",$$SLH^RCFN01($PIECE(RCCV,U,2))
- +30 ; *108 add exemption reason/dmc info
- +31 IF IBRX>0
- IF ($PIECE(IBRX,U)=1)
- SET DIC="^IBE(354.2,"
- SET DIC(0)="M"
- SET X=+$PIECE(IBRX,"^",3)
- DO ^DIC
- IF Y>0
- WRITE !,?54,"(",$PIECE(Y,"^",2),")"
- +32 IF $DATA(^RCD(340,"DMC",1,+DEBT))
- SET DMC=$GET(^RCD(340,+DEBT,3))
- Begin DoDot:1
- +33 IF $PIECE(DMC,"^",2)
- WRITE !,"** Account forwarded to DMC: ",$$SLH^RCFN01($PIECE(DMC,"^",2)),?50,"Total DMC Amount: ",?69,$JUSTIFY($PIECE(DMC,"^",5),9,2)
- +34 IF $PIECE(DMC,"^",9)'=""
- WRITE !,?49,"Lesser Amt to DMC: ",?69,$JUSTIFY($PIECE(DMC,"^",9),9,2)
- +35 QUIT
- End DoDot:1
- +36 IF $DATA(^RCD(340,"TOP",+DEBT))
- SET TOP4=$GET(^RCD(340,+DEBT,4))
- SET TOP6=$GET(^(6))
- Begin DoDot:1
- +37 IF +TOP6
- WRITE !,"** Account forwarded to TOP: ",$$SLH^RCFN01($PIECE(TOP6,"^")),?45,"Total TOP Amount: ",?65,$JUSTIFY($PIECE(TOP4,"^",3),13,2)
- +38 IF $PIECE(TOP6,"^",6)
- WRITE !,?45,"TOP HOLD DATE: ",$$SLH^RCFN01($PIECE(TOP6,"^",6))
- +39 QUIT
- End DoDot:1
- +40 ; "Put Re-" if rerefer
- +41 IF $DATA(^RCD(340,"TCSP",+DEBT))
- Begin DoDot:1
- +42 ;PRCA*4.5*350
- +43 WRITE !,"x Debt "_$SELECT($$RRD^RCTCSPU(+DEBT):"Re-",1:"")_"Referred to Cross-Servicing",?45,"Total CS Debt: ",?65,$JUSTIFY($$TOTALB^RCTCSPU(+DEBT),13,2)
- +44 QUIT
- End DoDot:1
- +45 IF $ORDER(^RCD(340,+DEBT,2,0))
- Begin DoDot:1
- +46 SET Y=0
- FOR X=0:0
- SET X=$ORDER(^RCD(340,+DEBT,2,X))
- if 'X
- QUIT
- if 'Y
- WRITE !
- WRITE !,$GET(^(X,0))
- SET Y=Y+1
- if Y=3&$ORDER(^RCD(340,+DEBT,2,X))
- WRITE "..."
- if Y=3
- QUIT
- +47 QUIT
- End DoDot:1
- +48 ; PRCA*4.5*378/PRCA*4.5*404
- +49 SET RPIEN=+$ORDER(^RCRP(340.5,"E",+DEBT,""),-1)
- IF RPIEN
- Begin DoDot:1
- +50 SET RPIENS=RPIEN_","
- +51 WRITE !,"Repayment Plan: ",$$GET1^DIQ(340.5,RPIENS,.01)
- +52 WRITE ?45,"Repayment Plan Status: ",$$GET1^DIQ(340.5,RPIENS,.07)
- +53 QUIT
- End DoDot:1
- +54 ;
- +55 QUIT
- +56 ; PRCA*4.5*276 - moved headers right to add EOB indicator to bill #, adjusted at tag BLN accordingly
- +57 ; PRCA*4.5*275 - moved headers to line up with column changes
- HDR2 WRITE !!,"#",?7,"Bill #",?20,"Est",?31,"Type",?43,"Paid",?52,"Prin",?58,"Int",?64,"Adm",?72,"Balance"
- +1 QUIT
- DIS ;Display bill line items
- +1 NEW STAT1
- +2 IF '$ORDER(^TMP("PRCAAPR",$JOB,"C",0))
- SET X=""
- SET $PIECE(X,"*",22)=""
- WRITE !!,X," NO ACCOUNT INFORMATION AVAILABLE ",X
- GOTO Q1
- +3 FOR STAT1=0:0
- SET STAT1=$ORDER(^TMP("PRCAAPR",$JOB,"C",STAT1))
- if 'STAT1!$DATA(OUT)
- QUIT
- DO BHDR
- SET BILL=0
- FOR
- SET BILL=$ORDER(^TMP("PRCAAPR",$JOB,"C",STAT1,BILL))
- if BILL=""!$DATA(OUT)
- QUIT
- DO BLN
- +4 IF '$DATA(OUT)
- DO READ
- Q1 QUIT
- BHDR ;Display status line
- +1 SET X=$SELECT(+$PIECE(^TMP("PRCAAPR",$JOB,"C",STAT1),"^",2)=99:"PAYMENTS",1:$PIECE($GET(^PRCA(430.3,+$ORDER(^PRCA(430.3,"AC",+$PIECE(^TMP("PRCAAPR",$JOB,"C",STAT1),"^",2),0)),0)),"^"))
- +2 SET Y=" "_X_" ("_$JUSTIFY(+^TMP("PRCAAPR",$JOB,"C",STAT1),0,2)_") "
- WRITE !
- FOR X=1:1:80-$LENGTH(Y)/2
- WRITE "-"
- +3 WRITE Y
- FOR X=1:1:IOM-$X-1
- WRITE "-"
- +4 QUIT
- BLN ;
- +1 NEW PRCOUT,REJFLAG,CSCSTAT,DEBTOR,CSDATE1,CSDATE2,RCIND
- +2 IF $Y+5>IOSL
- IF COUNT
- DO READ
- if $DATA(OUT)
- GOTO Q2
- DO HDR
- DO HDR2
- DO BHDR
- +3 ; PRCA*4.5*276, attach EOB indicator '%' to bill # when applicable
- +4 SET PRCOUT=$$COMP3^PRCAAPR(BILL)
- +5 IF STAT1'=99
- IF PRCOUT'="%"
- SET PRCOUT=$$IBEEOBCK(BILL)
- +6 ; PRCA*4.5*303 - add reject indicator to kbill if applicable ; #IA 6060
- +7 SET REJFLAG=0
- if STAT1'=99
- SET REJFLAG=$$BILLREJ^IBJTU6($PIECE($PIECE($GET(^PRCA(430,BILL,0)),"^"),"-",2))
- +8 if STAT1'=99
- SET COUNT=COUNT+1
- SET ^TMP("PRCAAPR",$JOB,"O",COUNT)=BILL
- SET X=$SELECT(STAT1=99:BILL,1:$GET(PRCOUT)_$SELECT(REJFLAG:"c",1:"")_$GET(^PRCA(430,BILL,0)))
- +9 ; PRCA*4.5*303 - End
- +10 ;
- +11 ; PRCA*4.5*315: AR File #430 - set historical indicator set to "y" if an entry exists in the
- +12 ; ORIGINAL DATE REFERRED TO TCSP (field #156) to CS bill number. If an entry in the
- +13 ; DATE REFERRED TO TCSP (field #151), then an "x" indicator displays on the bill,
- +14 ; otherwise neither indicator.
- +15 ;
- +16 SET CSDATE1=$$GET1^DIQ(430,BILL,"DATE BILL REFERRED TO TCSP","I")
- +17 SET CSDATE2=$$GET1^DIQ(430,BILL,"ORIGINAL DATE REFERRED TO TCSP","I")
- +18 SET RCIND=$SELECT(CSDATE1'="":"x",CSDATE2'="":"y",1:"")
- +19 ;W !,$S(STAT1'=99:COUNT,1:"*"),?4,$P(X,"^") W:STAT1'=99 ?20,$$SLH^RCFN01($P(X,"^",10))
- +20 IF RCIND]""
- WRITE !,$SELECT(STAT1'=99:COUNT,1:"*"),?5,$PIECE(RCIND_X,"^")
- if STAT1'=99
- WRITE ?20,$$SLH^RCFN01($PIECE(X,"^",10))
- +21 IF RCIND=""
- WRITE !,$SELECT(STAT1'=99:COUNT,1:"*"),?6,$PIECE(X,"^")
- if STAT1'=99
- WRITE ?20,$$SLH^RCFN01($PIECE(X,"^",10))
- +22 ; PRCA*4.5*192 changed CHMP PT to TRIC PT
- if STAT1'=99
- WRITE ?31,$SELECT($PIECE(X,"^",2)=31:"TRIC PT",1:$EXTRACT($PIECE($GET(^PRCA(430.2,$SELECT($ORDER(^PRCA(430.2,"AC",24,0))=$PIECE(X,"^",2):+$PIECE(X,"^",16),1:+$PIECE(X,"^",2)),0)),"^"),1,7))
- +23 if STAT1=99
- WRITE ?31,"PAYMENT"
- +24 SET X=$SELECT(STAT1=99:"^^^^^^"_^TMP("PRCAAPR",$JOB,"C",STAT1,BILL),1:$GET(^PRCA(430,BILL,7)))
- WRITE ?39
- if STAT1=99
- WRITE "-"
- WRITE $JUSTIFY($PIECE(X,"^",7)+$PIECE(X,"^",8)+$PIECE(X,"^",9)+$PIECE(X,"^",10)+$PIECE(X,"^",11),8,2)
- +25 WRITE ?48
- if STAT1=99
- WRITE " "
- if STAT1'=99
- WRITE $SELECT($PIECE(^PRCA(430,BILL,0),"^",2)=$ORDER(^PRCA(430.2,"AC",33,0)):"-",1:" ")
- +26 WRITE $JUSTIFY($PIECE(X,"^"),7,2),?57,$JUSTIFY($PIECE(X,"^",2),5,2),?63,$JUSTIFY($PIECE(X,"^",3),5,2),?69,$SELECT(STAT1=99:"-",$PIECE(^PRCA(430,BILL,0),"^",2)=$ORDER(^PRCA(430.2,"AC",33,0)):"-",1:" ")
- +27 WRITE $SELECT(STAT1=99:$JUSTIFY(^TMP("PRCAAPR",$JOB,"C",STAT1,BILL),9,2),1:$JUSTIFY($PIECE(X,"^")+$PIECE(X,"^",2)+$PIECE(X,"^",3)+$PIECE(X,"^",4)+$PIECE(X,"^",5),9,2))
- +28 KILL ^TMP("PRCAAPR",$JOB,"C",STAT1,BILL)
- if $ORDER(^TMP("PRCAAPR",$JOB,"C",STAT1,""))=""
- KILL ^TMP("PRCAAPR",$JOB,"C",STAT1)
- Q2 QUIT
- READ ;Read bill number
- +1 WRITE !!,"Select 1-",COUNT
- if $ORDER(^TMP("PRCAAPR",$JOB,"C",""))
- WRITE " or return to continue"
- READ ": ",X:DTIME
- IF X["^"!'$TEST
- if '$TEST
- SET DTOUT=1
- SET OUT=1
- GOTO Q3
- +2 IF X["?"
- WRITE !!,"To see detailed information for a bill number, enter the corresponding '#'",!,"next to the bill. (Ex: 1 or 1,3)"
- GOTO READ
- +3 IF X=""
- IF '$ORDER(^TMP("PRCAAPR",$JOB,"C",""))
- SET OUT=1
- GOTO Q3
- +4 if X=""
- GOTO Q3
- SET SEL=X
- +5 FOR X=1:1:$LENGTH(SEL,",")
- SET Y=$PIECE(SEL,",",X)
- IF Y'?1N.N!'$DATA(^TMP("PRCAAPR",$JOB,"O",+Y))
- WRITE *7," ??"
- GOTO READ
- +6 SET OUT=1
- FOR X=1:1:$LENGTH(SEL,",")
- SET Y=$PIECE(SEL,",",X)
- DO EN1^PRCAATR($GET(^TMP("PRCAAPR",$JOB,"O",+Y)))
- Q3 QUIT
- +1 ;
- ACCT(DFN) ;Get account number. Join station with DFN (Patch 206)
- +1 ;PRCA*4.5*406 - Added Parameter comments
- +2 ;Input Declared: DFN - Patient IEN
- +3 ;Input Undeclared: DEBT - Debtor IEN^Debtor Name
- +4 ;end PRCA*4.5*406
- +5 ;
- +6 NEW SITE,ACCT,ACCT1,LEN
- +7 SET DFN=+DFN
- +8 ;I 'DFN S ACCT1="" Q ACCT1 ;PRCA*4.5*405 ; Removed PRCA*4.5*406
- +9 SET LEN=$LENGTH(DFN)-1
- +10 ;station number
- SET SITE=$$SITE^RCMSITE
- +11 ;add leading zeroes
- SET ACCT=$$RJ^XLFSTR(DFN,13,0)
- +12 ;add hyphen
- SET ACCT1=SITE_"-"_$EXTRACT(ACCT,1,$LENGTH(ACCT)-$LENGTH(DFN))
- +13 ;add hyphen
- SET ACCT1=ACCT1_"-"_$EXTRACT(ACCT,$LENGTH(ACCT)-LEN,99)
- +14 ;add last name
- SET ACCT1=ACCT1_"-"_$EXTRACT($PIECE($PIECE(DEBT,U,2),","),1,5)
- +15 QUIT ACCT1
- +16 ;
- +17 ; PRCA*4.5*276 - Use Event Date to find an associated 3rd Party bill with an associated EEOB
- IBEEOBCK(PRCAAR) ; Passed AR Bill
- +1 ; Function will quit as soon as a 3rd party bill is located that has an associated EEOB
- +2 ;
- +3 ; Find 3rd Party Bills with an Event Date
- +4 NEW PRCAREF,PRCAEEOB,PRCADT,DFN,DBTR,X1
- +5 ; Get DFN
- +6 SET DBTR=+$PIECE($GET(^PRCA(430,PRCAAR,0)),U,9)
- +7 SET X1=$PIECE($GET(^RCD(340,DBTR,0)),U)
- IF X1'["DPT"
- QUIT ""
- +8 SET DFN=+X1
- +9 SET PRCAEEOB=""
- +10 ; Loop through Xref of ARbill (#430) to Action file (#350)
- +11 IF +$GET(PRCAAR)
- SET PRCAREF=0
- FOR
- SET PRCAREF=$ORDER(^IB("ABIL",$PIECE($GET(^PRCA(430,PRCAAR,0)),"^"),PRCAREF))
- if 'PRCAREF
- QUIT
- Begin DoDot:1
- +12 ;Get event Date
- SET PRCADT=$PIECE($GET(^IB(PRCAREF,0)),"^",17)
- +13 IF PRCADT
- SET PRCAEEOB=$$TPEVDT(DFN,PRCADT)
- if PRCAEEOB="%"
- QUIT
- +14 IF PRCADT
- SET PRCAEEOB=$$TPOPV(DFN,PRCADT)
- End DoDot:1
- if PRCAEEOB="%"
- QUIT
- +15 ;
- +16 QUIT PRCAEEOB
- +17 ;
- +18 ; PRCA*4.5*276 - Traverse all THIRD PARTY bills for a patient with a specific Event Date (399,.03)
- TPEVDT(DFN,EVDT) ;
- +1 ; Function will quit as soon as a 3rd party bill is located that has an associated EEOB
- +2 ; PRCA*4.5*284 - Use the 399,"APDT" (by patient) index instead of the 399,"D" index for efficiency
- +3 IF '$GET(DFN)!'$GET(EVDT)
- QUIT ""
- +4 NEW PRCAIFN,PRCAEEOB
- +5 SET PRCAEEOB=""
- SET PRCAIFN=""
- +6 FOR
- SET PRCAIFN=$ORDER(^DGCR(399,"APDT",DFN,PRCAIFN),-1)
- if 'PRCAIFN
- QUIT
- Begin DoDot:1
- +7 IF $DATA(^DGCR(399,"APDT",DFN,PRCAIFN,9999999-EVDT))
- SET PRCAEEOB=$$COMP3^PRCAAPR(PRCAIFN)
- End DoDot:1
- if PRCAEEOB="%"
- QUIT
- +8 QUIT PRCAEEOB
- +9 ;
- +10 ; PRCA*4.5*276 - Traverse all THIRD PARTY bills for a patient with any Opt Visit Dates same as Event Date (399,43)
- TPOPV(DFN,EVDT) ;
- +1 ; Function will quit as soon as a 3rd party bill is located that has an associated EEOB
- +2 NEW PRCAIFN,PRCAEEOB
- +3 SET PRCAEEOB=""
- +4 IF +$GET(DFN)
- IF +$GET(EVDT)
- SET PRCAIFN=0
- FOR
- SET PRCAIFN=$ORDER(^DGCR(399,"AOPV",DFN,EVDT,PRCAIFN))
- if 'PRCAIFN
- QUIT
- Begin DoDot:1
- +5 ; attach EOB indicator '%' to bill # when applicable
- +6 SET PRCAEEOB=$$COMP3^PRCAAPR(PRCAIFN)
- End DoDot:1
- if PRCAEEOB="%"
- QUIT
- +7 QUIT PRCAEEOB