- 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 Feb 18, 2025@23:05:20 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
- Press return to continue: 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)
- 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