PRCAATR ;WASH-ISC@ALTOONA,PA/RGY - VIEW TRANSACTION FOR BILLS ;2/14/96 2:46 PM
V ;;4.5;Accounts Receivable;**36,104,172,138,233,276,303,301,315,350,388**;Mar 20, 1995;Build 13
;;Per VA Directive 6402, this routine should not be modified.
;
; PRCAAPR cleans up DEBT, DTOUT
EN1(BILL) ;ENTRY POINT FROM PRCAAPR
NEW X,Y,COUNT,OUT,TRAN,SEL,PRCAATRX,PRCAIO,PRCAIOS,D0,PRCAQUE,POP,PRCAPRT,Y,ZTSK,PRCOUT,PRCA15,REJFLG
NEW CSDATE1,CSDATE2,CSFLG
I '$D(BILL) G Q
I BILL'?1N.N!'$D(^PRCA(430,+BILL,0)) G Q
; PRCA*4.5*276
S PRCOUT=$$COMP3^PRCAAPR(BILL) ; check for 1st and 3rd party payments
I PRCOUT'="%" S PRCOUT=$$IBEEOBCK^PRCAAPR1(BILL)
S PRCAPRT=1,PRCAIO=IO(0),PRCAIO(0)=IO(0),COUNT=0 K ^TMP("PRCAATR",$J)
D HDR,DIS,^%ZISC
Q K ^TMP("PRCAATR",$J),IO("Q") Q
HDR ;Header
D HDR^PRCAAPR1
I $P($G(^PRCA(430,BILL,13)),"^") W !,"MEDICARE CONTRACTUAL ADJUSTMENT: ",$J($P($G(^PRCA(430,BILL,13)),"^"),0,2)
I $P($G(^PRCA(430,BILL,13)),"^",2) W !,"UNREIMBURSED MEDICARE EXPENSE: ",$J($P($G(^PRCA(430,BILL,13)),"^",2),0,2)
; PRCA*4.5*303 - Adding reject indicator, 'x' to bill number when applicable
S REJFLG=$$BILLREJ^IBJTU6($P($P($G(^PRCA(430,BILL,0)),"^"),"-",2)) ; IA# 6060
; PRCA*4.5*315
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 CSFLG=$S(CSDATE1'="":"x",CSDATE2'="":"y",1:"")
; PRCA*4.5*276 - attach EEOB indicator to bill number
; PRCA*4.5*350 - Re-Referred
I +$G(^PRCA(430,BILL,15)) S PRCA15=^(15) I $P(PRCA15,U)]"" W !,"CS " W:$$RR^RCTCSPU(BILL) "Re-" W "Referred Date: " S Y=$P(PRCA15,U) D DD^%DT W Y ;prca*4.5*301
S PRCA15=$G(^PRCA(430,BILL,15)) D
.I $P(PRCA15,U,2)]"" W !,"CS Recall Reason: ",$E($$GET1^DIQ(430,BILL,154),1,31) W ?51,"CS Recall Date: " S Y=$P(PRCA15,U,3) D DD^%DT W Y Q ;prca*4.5*301
.I $P(PRCA15,U,4)]"",$P(PRCA15,U,2)="" W !,"CS Recall Reason: ",$E($$GET1^DIQ(430,BILL,154),1,31) W ?51,"CS Recall Date: "
; PRCA*4.5*350 - remove this and put some data from it on next line
; W ! D PROFRJ^RCTCSJS1(BILL) ; Reject history ;prca*4.5*301
W !,"Bill #: ",$G(PRCOUT)_CSFLG_$P(^PRCA(430,BILL,0),"^") D @($S($P(^(0),"^",9)'=+DEBT:"DEB",1:"CSREJ")) ; prca*4.5*315, PRCA*4.5*350
I REJFLG W !,"Bill #: ",$G(PRCOUT)_$S(REJFLG:"c",1:"")_$P(^PRCA(430,BILL,0),"^") D @($S($P(^(0),"^",9)'=+DEBT:"DEB",1:"CSREJ")) ; PRCA*4.5*350
W !!,"Bill #",?8,"Tr #",?20,"Type",?52,"Date",?70,"Amount"
S X="",$P(X,"-",IOM)="" W !,X
Q
DIS ;Display transactions
W !,?20,"Original Amount",?52,$$SLH^RCFN01($P(^PRCA(430,BILL,0),"^",10)),?65,$J($P(^(0),"^",3),11,2)
I '$O(^PRCA(433,"C",BILL,0)) D
. S X="",$P(X,"*",20)="" W !!,X," NO TRANSACTION INFORMATION AVAILABLE ",X
RD . R !!,"Press return to continue: ",X:DTIME S:'$T DTOUT=1 S OUT=1
. I X["?" W !!,"Press the return key to return to menu." G RD
. Q
F TRAN=0:0 S TRAN=$O(^PRCA(433,"C",BILL,TRAN)) Q:'TRAN!$D(OUT) D TLN
S X=$G(^PRCA(430,BILL,7))
I '$D(OUT) W !?65,"-----------",!,?64,"$",$J($P(X,"^")+$P(X,"^",2)+$P(X,"^",3)+$P(X,"^",4)+$P(X,"^",5),11,2) D READ
Q
TLN ;Display a transaction
N YR
I $Y+5>IOSL,COUNT D READ G:$D(DTOUT)!$D(OUT) Q1 D HDR
S COUNT=COUNT+1,X=$G(^PRCA(433,TRAN,1)),^TMP("PRCAATR",$J,COUNT)=TRAN
W !,COUNT,$S($P(^PRCA(433,TRAN,0),"^",4)=1!$P(^(0),"^",10):"(I)",1:""),?8,TRAN,?20
W $S($P($G(^PRCA(430.3,+$P(X,"^",2),0)),"^",3)=17:$P($G(^PRCA(433,TRAN,5)),"^",2),1:$P($G(^(0)),"^"))
; show decrease adjustments as negative (patch 4.5*172)
I $P(X,"^",2)=35 S:$P(X,"^",5)>0 $P(X,"^",5)=-$P(X,"^",5)
W ?52,$S(+X:$$SLH^RCFN01(+X),1:""),?65,$J($P(X,"^",5),11,2)
;
Q1 Q
READ ;Read a trans number
I IO'=IO(0) G Q2
ASK W !!,"Select 1-",COUNT,$S(PRCAPRT:" or 'P' to Print",1:" to print") W:TRAN " or return to continue" R ": ",X:DTIME I X["^"!'$T S:'$T DTOUT=1 S OUT=1 G Q2
I PRCAPRT,X="P" S %ZIS="MQ" D ^%ZIS D S PRCAPRT=0,PRCAIO=IO,PRCAIO(0)=IO(0) G:'POP ASK K POP S OUT=1 G Q2
. I $D(IO("S")) S PRCAIOS=ION D ^%ZISC
. Q
I X["?" W !!,"To see detailed information for a transaction number, enter the corresponding '#'",!,"next to the transaction. (Ex: 1 or 1,3)" G ASK
I X="" S:TRAN="" OUT=1 G Q2
S SEL=X
F X=1:1:$L(SEL,",") S Y=$P(SEL,",",X) I Y'?1N.N!'$D(^TMP("PRCAATR",$J,+Y)) W *7," ??" G READ
F PRCAATRX=1:1:$L(SEL,",") S Y=$P(SEL,",",PRCAATRX) D VT Q:$D(OUT)
S OUT=1
Q2 Q
VT ;View a transaction
N IOP,%ZIS,ZTRTN,ZTDESC,ZTSAVE,ZTDTH
S D0=$G(^TMP("PRCAATR",$J,+Y)) G:'D0 Q3
I $D(IO("Q")) S ZTSAVE("D0")="",ZTSAVE("PRCAIO")=IO,ZTSAVE("PRCAIO(0)")=IO(0),ZTRTN="DQ^PRCAATR",ZTDESC="AR TRANS PROFILE",ZTDTH=$H D ^%ZTLOAD W !,"*** Trans # ",D0," REQUEST QUEUED ***" G Q3
I IO'=IO(0) W !,"OK, Printing Transaction # ",D0," ..."
I $D(PRCAIOS) S IOP=PRCAIOS D ^%ZIS
U IO D DQ U IO(0)
Q3 Q
DQ ;
W @IOF S X="",$P(X,"=",30)="" W !,X," TRANSACTION PROFILE ",X,!!
K DXS D ^PRCATR3 K DXS S X=D0 D ENF^IBOLK
RD1 I $E(IOST)="C" R !!,"PRESS <RETURN> TO CONTINUE: ",X:DTIME S:'$T DTOUT=1,OUT=1 I X["?" W !!,"Press return to view next transaction or to continue" G RD1
Q
DEB ;View debtor
NEW PRCA
S PRCA=$P(^PRCA(430,BILL,0),"^",9) I PRCA S PRCA=$P(^RCD(340,PRCA,0),"^") W " ",$P($G(@("^"_$P(PRCA,";",2)_+PRCA_",0)")),"^")
Q
CSREJ ; Show last reject ; PRCA*4.5*350
N RJIEN,RJDT,RJCODE,RJZ,I
S RJIEN=0,RJDT="",RJCODE=""
F S RJDT=$O(^PRCA(430,BILL,18,"B",RJDT)) Q:RJDT="" Q:$O(^PRCA(430,BILL,18,"B",RJDT))=""
Q:'RJDT
F S RJIEN=$O(^PRCA(430,BILL,18,"B",RJDT,RJIEN)) Q:RJIEN="" Q:$O(^PRCA(430,BILL,18,"B",RJDT,RJIEN))=""
Q:'RJIEN
S RJZ=$G(^PRCA(430,BILL,18,RJIEN,0))
F I=3:1:11 I $P(RJZ,"^",I)'="" S RJCODE=$P(RJZ,"^",I)
Q:'RJCODE
W " Last CS REJECT CODE: ",$P($G(^RC(348.5,RJCODE,0)),"^")
W " Last CS REJECT DATE: ",$$FMTE^XLFDT(RJDT,"5Z")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCAATR 5764 printed Dec 13, 2024@01:38:55 Page 2
PRCAATR ;WASH-ISC@ALTOONA,PA/RGY - VIEW TRANSACTION FOR BILLS ;2/14/96 2:46 PM
V ;;4.5;Accounts Receivable;**36,104,172,138,233,276,303,301,315,350,388**;Mar 20, 1995;Build 13
+1 ;;Per VA Directive 6402, this routine should not be modified.
+2 ;
+3 ; PRCAAPR cleans up DEBT, DTOUT
EN1(BILL) ;ENTRY POINT FROM PRCAAPR
+1 NEW X,Y,COUNT,OUT,TRAN,SEL,PRCAATRX,PRCAIO,PRCAIOS,D0,PRCAQUE,POP,PRCAPRT,Y,ZTSK,PRCOUT,PRCA15,REJFLG
+2 NEW CSDATE1,CSDATE2,CSFLG
+3 IF '$DATA(BILL)
GOTO Q
+4 IF BILL'?1N.N!'$DATA(^PRCA(430,+BILL,0))
GOTO Q
+5 ; PRCA*4.5*276
+6 ; check for 1st and 3rd party payments
SET PRCOUT=$$COMP3^PRCAAPR(BILL)
+7 IF PRCOUT'="%"
SET PRCOUT=$$IBEEOBCK^PRCAAPR1(BILL)
+8 SET PRCAPRT=1
SET PRCAIO=IO(0)
SET PRCAIO(0)=IO(0)
SET COUNT=0
KILL ^TMP("PRCAATR",$JOB)
+9 DO HDR
DO DIS
DO ^%ZISC
Q KILL ^TMP("PRCAATR",$JOB),IO("Q")
QUIT
HDR ;Header
+1 DO HDR^PRCAAPR1
+2 IF $PIECE($GET(^PRCA(430,BILL,13)),"^")
WRITE !,"MEDICARE CONTRACTUAL ADJUSTMENT: ",$JUSTIFY($PIECE($GET(^PRCA(430,BILL,13)),"^"),0,2)
+3 IF $PIECE($GET(^PRCA(430,BILL,13)),"^",2)
WRITE !,"UNREIMBURSED MEDICARE EXPENSE: ",$JUSTIFY($PIECE($GET(^PRCA(430,BILL,13)),"^",2),0,2)
+4 ; PRCA*4.5*303 - Adding reject indicator, 'x' to bill number when applicable
+5 ; IA# 6060
SET REJFLG=$$BILLREJ^IBJTU6($PIECE($PIECE($GET(^PRCA(430,BILL,0)),"^"),"-",2))
+6 ; PRCA*4.5*315
+7 SET CSDATE1=$$GET1^DIQ(430,BILL,"DATE BILL REFERRED TO TCSP","I")
+8 SET CSDATE2=$$GET1^DIQ(430,BILL,"ORIGINAL DATE REFERRED TO TCSP","I")
+9 SET CSFLG=$SELECT(CSDATE1'="":"x",CSDATE2'="":"y",1:"")
+10 ; PRCA*4.5*276 - attach EEOB indicator to bill number
+11 ; PRCA*4.5*350 - Re-Referred
+12 ;prca*4.5*301
IF +$GET(^PRCA(430,BILL,15))
SET PRCA15=^(15)
IF $PIECE(PRCA15,U)]""
WRITE !,"CS "
if $$RR^RCTCSPU(BILL)
WRITE "Re-"
WRITE "Referred Date: "
SET Y=$PIECE(PRCA15,U)
DO DD^%DT
WRITE Y
+13 SET PRCA15=$GET(^PRCA(430,BILL,15))
Begin DoDot:1
+14 ;prca*4.5*301
IF $PIECE(PRCA15,U,2)]""
WRITE !,"CS Recall Reason: ",$EXTRACT($$GET1^DIQ(430,BILL,154),1,31)
WRITE ?51,"CS Recall Date: "
SET Y=$PIECE(PRCA15,U,3)
DO DD^%DT
WRITE Y
QUIT
+15 IF $PIECE(PRCA15,U,4)]""
IF $PIECE(PRCA15,U,2)=""
WRITE !,"CS Recall Reason: ",$EXTRACT($$GET1^DIQ(430,BILL,154),1,31)
WRITE ?51,"CS Recall Date: "
End DoDot:1
+16 ; PRCA*4.5*350 - remove this and put some data from it on next line
+17 ; W ! D PROFRJ^RCTCSJS1(BILL) ; Reject history ;prca*4.5*301
+18 ; prca*4.5*315, PRCA*4.5*350
WRITE !,"Bill #: ",$GET(PRCOUT)_CSFLG_$PIECE(^PRCA(430,BILL,0),"^")
DO @($SELECT($PIECE(^(0),"^",9)'=+DEBT:"DEB",1:"CSREJ"))
+19 ; PRCA*4.5*350
IF REJFLG
WRITE !,"Bill #: ",$GET(PRCOUT)_$SELECT(REJFLG:"c",1:"")_$PIECE(^PRCA(430,BILL,0),"^")
DO @($SELECT($PIECE(^(0),"^",9)'=+DEBT:"DEB",1:"CSREJ"))
+20 WRITE !!,"Bill #",?8,"Tr #",?20,"Type",?52,"Date",?70,"Amount"
+21 SET X=""
SET $PIECE(X,"-",IOM)=""
WRITE !,X
+22 QUIT
DIS ;Display transactions
+1 WRITE !,?20,"Original Amount",?52,$$SLH^RCFN01($PIECE(^PRCA(430,BILL,0),"^",10)),?65,$JUSTIFY($PIECE(^(0),"^",3),11,2)
+2 IF '$ORDER(^PRCA(433,"C",BILL,0))
Begin DoDot:1
+3 SET X=""
SET $PIECE(X,"*",20)=""
WRITE !!,X," NO TRANSACTION INFORMATION AVAILABLE ",X
RD READ !!,"Press return to continue: ",X:DTIME
if '$TEST
SET DTOUT=1
SET OUT=1
+1 IF X["?"
WRITE !!,"Press the return key to return to menu."
GOTO RD
+2 QUIT
End DoDot:1
+3 FOR TRAN=0:0
SET TRAN=$ORDER(^PRCA(433,"C",BILL,TRAN))
if 'TRAN!$DATA(OUT)
QUIT
DO TLN
+4 SET X=$GET(^PRCA(430,BILL,7))
+5 IF '$DATA(OUT)
Press return to continue: WRITE !?65,"-----------",!,?64,"$",$JUSTIFY($PIECE(X,"^")+$PIECE(X,"^",2)+$PIECE(X,"^",3)+$PIECE(X,"^",4)+$PIECE(X,"^",5),11,2)
DO READ
+6 QUIT
TLN ;Display a transaction
+1 NEW YR
+2 IF $Y+5>IOSL
IF COUNT
DO READ
if $DATA(DTOUT)!$DATA(OUT)
GOTO Q1
DO HDR
+3 SET COUNT=COUNT+1
SET X=$GET(^PRCA(433,TRAN,1))
SET ^TMP("PRCAATR",$JOB,COUNT)=TRAN
+4 WRITE !,COUNT,$SELECT($PIECE(^PRCA(433,TRAN,0),"^",4)=1!$PIECE(^(0),"^",10):"(I)",1:""),?8,TRAN,?20
+5 WRITE $SELECT($PIECE($GET(^PRCA(430.3,+$PIECE(X,"^",2),0)),"^",3)=17:$PIECE($GET(^PRCA(433,TRAN,5)),"^",2),1:$PIECE($GET(^(0)),"^"))
+6 ; show decrease adjustments as negative (patch 4.5*172)
+7 IF $PIECE(X,"^",2)=35
if $PIECE(X,"^",5)>0
SET $PIECE(X,"^",5)=-$PIECE(X,"^",5)
+8 WRITE ?52,$SELECT(+X:$$SLH^RCFN01(+X),1:""),?65,$JUSTIFY($PIECE(X,"^",5),11,2)
+9 ;
Q1 QUIT
READ ;Read a trans number
+1 IF IO'=IO(0)
GOTO Q2
ASK WRITE !!,"Select 1-",COUNT,$SELECT(PRCAPRT:" or 'P' to Print",1:" to print")
if TRAN
WRITE " or return to continue"
READ ": ",X:DTIME
IF X["^"!'$TEST
if '$TEST
SET DTOUT=1
SET OUT=1
GOTO Q2
+1 IF PRCAPRT
IF X="P"
SET %ZIS="MQ"
DO ^%ZIS
Begin DoDot:1
+2 IF $DATA(IO("S"))
SET PRCAIOS=ION
DO ^%ZISC
+3 QUIT
End DoDot:1
SET PRCAPRT=0
SET PRCAIO=IO
SET PRCAIO(0)=IO(0)
if 'POP
GOTO ASK
KILL POP
SET OUT=1
GOTO Q2
+4 IF X["?"
WRITE !!,"To see detailed information for a transaction number, enter the corresponding '#'",!,"next to the transaction. (Ex: 1 or 1,3)"
GOTO ASK
+5 IF X=""
if TRAN=""
SET OUT=1
GOTO Q2
+6 SET SEL=X
+7 FOR X=1:1:$LENGTH(SEL,",")
SET Y=$PIECE(SEL,",",X)
IF Y'?1N.N!'$DATA(^TMP("PRCAATR",$JOB,+Y))
WRITE *7," ??"
GOTO READ
+8 FOR PRCAATRX=1:1:$LENGTH(SEL,",")
SET Y=$PIECE(SEL,",",PRCAATRX)
DO VT
if $DATA(OUT)
QUIT
+9 SET OUT=1
Q2 QUIT
VT ;View a transaction
+1 NEW IOP,%ZIS,ZTRTN,ZTDESC,ZTSAVE,ZTDTH
+2 SET D0=$GET(^TMP("PRCAATR",$JOB,+Y))
if 'D0
GOTO Q3
+3 IF $DATA(IO("Q"))
SET ZTSAVE("D0")=""
SET ZTSAVE("PRCAIO")=IO
SET ZTSAVE("PRCAIO(0)")=IO(0)
SET ZTRTN="DQ^PRCAATR"
SET ZTDESC="AR TRANS PROFILE"
SET ZTDTH=$HOROLOG
DO ^%ZTLOAD
WRITE !,"*** Trans # ",D0," REQUEST QUEUED ***"
GOTO Q3
+4 IF IO'=IO(0)
WRITE !,"OK, Printing Transaction # ",D0," ..."
+5 IF $DATA(PRCAIOS)
SET IOP=PRCAIOS
DO ^%ZIS
+6 USE IO
DO DQ
USE IO(0)
Q3 QUIT
DQ ;
+1 WRITE @IOF
SET X=""
SET $PIECE(X,"=",30)=""
WRITE !,X," TRANSACTION PROFILE ",X,!!
+2 KILL DXS
DO ^PRCATR3
KILL DXS
SET X=D0
DO ENF^IBOLK
RD1 IF $EXTRACT(IOST)="C"
READ !!,"PRESS <RETURN> TO CONTINUE: ",X:DTIME
if '$TEST
SET DTOUT=1
SET OUT=1
IF X["?"
WRITE !!,"Press return to view next transaction or to continue"
GOTO RD1
+1 QUIT
DEB ;View debtor
+1 NEW PRCA
+2 SET PRCA=$PIECE(^PRCA(430,BILL,0),"^",9)
IF PRCA
SET PRCA=$PIECE(^RCD(340,PRCA,0),"^")
WRITE " ",$PIECE($GET(@("^"_$PIECE(PRCA,";",2)_+PRCA_",0)")),"^")
+3 QUIT
CSREJ ; Show last reject ; PRCA*4.5*350
+1 NEW RJIEN,RJDT,RJCODE,RJZ,I
+2 SET RJIEN=0
SET RJDT=""
SET RJCODE=""
+3 FOR
SET RJDT=$ORDER(^PRCA(430,BILL,18,"B",RJDT))
if RJDT=""
QUIT
if $ORDER(^PRCA(430,BILL,18,"B",RJDT))=""
QUIT
+4 if 'RJDT
QUIT
+5 FOR
SET RJIEN=$ORDER(^PRCA(430,BILL,18,"B",RJDT,RJIEN))
if RJIEN=""
QUIT
if $ORDER(^PRCA(430,BILL,18,"B",RJDT,RJIEN))=""
QUIT
+6 if 'RJIEN
QUIT
+7 SET RJZ=$GET(^PRCA(430,BILL,18,RJIEN,0))
+8 FOR I=3:1:11
IF $PIECE(RJZ,"^",I)'=""
SET RJCODE=$PIECE(RJZ,"^",I)
+9 if 'RJCODE
QUIT
+10 WRITE " Last CS REJECT CODE: ",$PIECE($GET(^RC(348.5,RJCODE,0)),"^")
+11 WRITE " Last CS REJECT DATE: ",$$FMTE^XLFDT(RJDT,"5Z")
+12 QUIT
