RCTRAN ;WASH-ISC@ALTOONA,PA/LDB-Transaction History Report ;1/19/95 4:33 PM
;;4.5;Accounts Receivable;**104,154,315**;Mar 20, 1995;Build 67
;;Per VA Directive 6402, this routine should not be modified.
;
N AMT,APP,BDATE,BILL,BY,CAT,DIC,DIR,DIRUT,EDATE,FUND,LINE,LN,NODE0,NODE1,NODE2,NODE3,PG,POP,PX2,RCX,RCX1,TDAT,TYP
N X,X1,X11,X12,X1A,X2,X3,XFND,XF1,Y,ZTDESC,ZTRTN,ZTSAVE,%ZIS
EN S X=$$DATE^RCEVUTL1("")
Q:X<0
S BDATE=+X,EDATE=$P(X,"^",2)
TYPE S DIC="^PRCA(430.3,",DIC(0)="QEMZ"
S Y=0 W !,"TRANSACTION TYPE: "_$S('$O(TYP("")):"ALL// ",1:"")
R X:DTIME I '$T!(X="^") Q
I ((X="")!(X="ALL")),'$O(TYP("")) S (TYP,X)="ALL" G CAT
I X="" G CAT
I X'="ALL" D ^DIC S TYP=+Y
I X["?" W !!,"Enter 'ALL' for all types of transactions in the AR TRANSACTION TYPE FILE",! G TYPE
;I $P($G(^PRCA(430.3,+Y,0)),"^",3)>100 W !!,"This is a STATUS. Enter a transaction type only.",! G TYPE
I TYP'="ALL",(+TYP>0) S TYP(+TYP)="" G TYPE
G:+TYP<0 TYPE
CAT K DIC S Y=0 W !,"CATEGORY OF BILL: "_$S('$O(CAT("")):"ALL// ",1:"")
R X:DTIME I '$T!(X="^") Q
I ((X="")!(X="ALL")),'$O(CAT("")) S (CAT,X)="ALL" G DEV
I X="" G DEV
I X'="ALL" S DIC="^PRCA(430.2,",DIC(0)="QEMZ" D ^DIC S CAT=+Y
I X["?" W !!,"Enter 'ALL' for all categories of bills.",! G CAT
I CAT'="ALL",(+CAT>0) S CAT(+CAT)="" G CAT
G:+CAT<0 CAT
DEV W !!,"This report takes a long time to compile."
W !,"It is recommended that it be queued to print later.",!!
S %ZIS="AEQ" D ^%ZIS G:POP EXIT
I $D(IO("Q")) D Q
.S ZTSAVE("BDATE")="",ZTSAVE("EDATE")="",ZTSAVE("TYP")="",ZTSAVE("CAT")="",ZTRTN="DQ^RCTRAN",ZTDESC="Transaction History Report"
.S:$O(TYP("")) ZTSAVE("TYP(")=""
.S:$O(CAT("")) ZTSAVE("CAT(")=""
.D ^%ZTLOAD,^%ZISC,EXIT K ZTSAVE,ZTRTN Q
;
DQ ;Call to build array of payment transactions
;
U IO
D DT^DICRW W:$E(IOST,1,2)'="P-" @IOF S PG=0,LINE="",$P(LINE,"-",79)=""
K ^TMP($J) D TRANS^RCTRAN1
I '$D(^TMP($J)) D HDR^RCTRAN1 W !!,"There is no activity of this type during this time period."
I $D(^TMP($J)) D PRINT
K ^TMP($J) D ^%ZISC
Q
;
PRINT ;Print transactions of type within selected date range
D HDR^RCTRAN1
S (AMT("TOT"),RCX)=0
F S RCX1=RCX,RCX=$O(^TMP($J,RCX)) Q:$D(DIRUT)!'RCX S X11=0 F S X12=X11,X11=$O(^TMP($J,RCX,X11)) Q:$D(DIRUT) Q:'X11 S XFND="" F S XFND=$O(^TMP($J,RCX,X11,XFND)) Q:$D(DIRUT)!(XFND="") D FCHK D
.S AMT(X11)=0,X2=0,PX2=X2 F S X2=$O(^TMP($J,RCX,X11,XFND,X2)) Q:$D(DIRUT) D:'X2 SUB^RCTRAN1 Q:'X2 S X3=0 F S AMT(X11,XFND)=0,X3=$O(^TMP($J,RCX,X11,XFND,X2,X3)) Q:'X3!$D(DIRUT) D
..W:$$SLH^RCFN01(X2)'=$$SLH^RCFN01(PX2)!'LN !,$$SLH^RCFN01(X2)
..W:RCX'=RCX1!'LN ?12,$E($P($G(^PRCA(430.3,+RCX,0)),"^"),1,23)
..W ?37,$P($G(^PRCA(430.2,+X11,0)),"^",2)
..S BILL=$P(^TMP($J,RCX,X11,XFND,X2,X3),"^",2) W ?41,BILL
..W ?55,$J(X3,8)
..S AMT=+^TMP($J,RCX,X11,XFND,X2,X3)
..I ",2,8,9,10,11,14,19,47,34,35,29,"[(","_TYP_",") I AMT'<0 S AMT=-AMT
..I ",2,8,9,10,11,12,14,19,47,34,35,29,"'[(","_TYP_",") I AMT<0 S AMT=-AMT
..I +CAT=26,TYP=1 I AMT'<0 S AMT=-AMT
..I +CAT=26,TYP=35 I AMT'<0 S AMT=-AMT
..S AMT("TOT")=AMT("TOT")+AMT
..S AMT(X11)=AMT(X11)+AMT
..S AMT(X11,XFND)=AMT(X11,XFND)+AMT
..S:AMT<0 AMT=-AMT W ?64,$J(AMT,11,2)
..S BY=$P(^TMP($J,RCX,X11,XFND,X2,X3),"^",3) S:BY BY=$P($G(^VA(200,+BY,0)),"^",2)
..W ?76,BY
..I RCX=45 W !?10,$P($G(^PRCA(433,+X3,5)),"^",2),!
..S LN=LN+1
..I $O(^TMP($J,RCX))!TYP,$Y+3>IOSL D
...I $E(IOST,1,2)="C-" S DIR(0)="E" K DIRUT D ^DIR Q:$D(DIRUT)
...W @IOF D HDR^RCTRAN1
Q:$D(DIRUT)
I $O(^TMP($J,RCX))!TYP,($Y+10>IOSL) D
.I $E(IOST,1,2)="C-" S DIR(0)="E" K DIRUT D ^DIR Q:$D(DIRUT)
.W @IOF D HDR^RCTRAN1
Q:$D(DIRUT)
S:AMT("TOT")<0 AMT("TOT")=-AMT("TOT") W:TYP !?64,"------------",!,?57,"TOTAL:",?64,$J(AMT("TOT"),12,2)
D KEY^RCTRAN1
Q
;
FCHK ;Check fund
W !,"FUND: ",XFND
Q
;
EXIT ;Exit routine
K ^TMP($J) D ^%ZISC Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRCTRAN 3876 printed Dec 13, 2024@01:49:09 Page 2
RCTRAN ;WASH-ISC@ALTOONA,PA/LDB-Transaction History Report ;1/19/95 4:33 PM
+1 ;;4.5;Accounts Receivable;**104,154,315**;Mar 20, 1995;Build 67
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 NEW AMT,APP,BDATE,BILL,BY,CAT,DIC,DIR,DIRUT,EDATE,FUND,LINE,LN,NODE0,NODE1,NODE2,NODE3,PG,POP,PX2,RCX,RCX1,TDAT,TYP
+5 NEW X,X1,X11,X12,X1A,X2,X3,XFND,XF1,Y,ZTDESC,ZTRTN,ZTSAVE,%ZIS
EN SET X=$$DATE^RCEVUTL1("")
+1 if X<0
QUIT
+2 SET BDATE=+X
SET EDATE=$PIECE(X,"^",2)
TYPE SET DIC="^PRCA(430.3,"
SET DIC(0)="QEMZ"
+1 SET Y=0
WRITE !,"TRANSACTION TYPE: "_$SELECT('$ORDER(TYP("")):"ALL// ",1:"")
+2 READ X:DTIME
IF '$TEST!(X="^")
QUIT
+3 IF ((X="")!(X="ALL"))
IF '$ORDER(TYP(""))
SET (TYP,X)="ALL"
GOTO CAT
+4 IF X=""
GOTO CAT
+5 IF X'="ALL"
DO ^DIC
SET TYP=+Y
+6 IF X["?"
WRITE !!,"Enter 'ALL' for all types of transactions in the AR TRANSACTION TYPE FILE",!
GOTO TYPE
+7 ;I $P($G(^PRCA(430.3,+Y,0)),"^",3)>100 W !!,"This is a STATUS. Enter a transaction type only.",! G TYPE
+8 IF TYP'="ALL"
IF (+TYP>0)
SET TYP(+TYP)=""
GOTO TYPE
+9 if +TYP<0
GOTO TYPE
CAT KILL DIC
SET Y=0
WRITE !,"CATEGORY OF BILL: "_$SELECT('$ORDER(CAT("")):"ALL// ",1:"")
+1 READ X:DTIME
IF '$TEST!(X="^")
QUIT
+2 IF ((X="")!(X="ALL"))
IF '$ORDER(CAT(""))
SET (CAT,X)="ALL"
GOTO DEV
+3 IF X=""
GOTO DEV
+4 IF X'="ALL"
SET DIC="^PRCA(430.2,"
SET DIC(0)="QEMZ"
DO ^DIC
SET CAT=+Y
+5 IF X["?"
WRITE !!,"Enter 'ALL' for all categories of bills.",!
GOTO CAT
+6 IF CAT'="ALL"
IF (+CAT>0)
SET CAT(+CAT)=""
GOTO CAT
+7 if +CAT<0
GOTO CAT
DEV WRITE !!,"This report takes a long time to compile."
+1 WRITE !,"It is recommended that it be queued to print later.",!!
+2 SET %ZIS="AEQ"
DO ^%ZIS
if POP
GOTO EXIT
+3 IF $DATA(IO("Q"))
Begin DoDot:1
+4 SET ZTSAVE("BDATE")=""
SET ZTSAVE("EDATE")=""
SET ZTSAVE("TYP")=""
SET ZTSAVE("CAT")=""
SET ZTRTN="DQ^RCTRAN"
SET ZTDESC="Transaction History Report"
+5 if $ORDER(TYP(""))
SET ZTSAVE("TYP(")=""
+6 if $ORDER(CAT(""))
SET ZTSAVE("CAT(")=""
+7 DO ^%ZTLOAD
DO ^%ZISC
DO EXIT
KILL ZTSAVE,ZTRTN
QUIT
End DoDot:1
QUIT
+8 ;
DQ ;Call to build array of payment transactions
+1 ;
+2 USE IO
+3 DO DT^DICRW
if $EXTRACT(IOST,1,2)'="P-"
WRITE @IOF
SET PG=0
SET LINE=""
SET $PIECE(LINE,"-",79)=""
+4 KILL ^TMP($JOB)
DO TRANS^RCTRAN1
+5 IF '$DATA(^TMP($JOB))
DO HDR^RCTRAN1
WRITE !!,"There is no activity of this type during this time period."
+6 IF $DATA(^TMP($JOB))
DO PRINT
+7 KILL ^TMP($JOB)
DO ^%ZISC
+8 QUIT
+9 ;
PRINT ;Print transactions of type within selected date range
+1 DO HDR^RCTRAN1
+2 SET (AMT("TOT"),RCX)=0
+3 FOR
SET RCX1=RCX
SET RCX=$ORDER(^TMP($JOB,RCX))
if $DATA(DIRUT)!'RCX
QUIT
SET X11=0
FOR
SET X12=X11
SET X11=$ORDER(^TMP($JOB,RCX,X11))
if $DATA(DIRUT)
QUIT
if 'X11
QUIT
SET XFND=""
FOR
SET XFND=$ORDER(^TMP($JOB,RCX,X11,XFND))
if $DATA(DIRUT)!(XFND="")
QUIT
DO FCHK
Begin DoDot:1
+4 SET AMT(X11)=0
SET X2=0
SET PX2=X2
FOR
SET X2=$ORDER(^TMP($JOB,RCX,X11,XFND,X2))
if $DATA(DIRUT)
QUIT
if 'X2
DO SUB^RCTRAN1
if 'X2
QUIT
SET X3=0
FOR
SET AMT(X11,XFND)=0
SET X3=$ORDER(^TMP($JOB,RCX,X11,XFND,X2,X3))
if 'X3!$DATA(DIRUT)
QUIT
Begin DoDot:2
+5 if $$SLH^RCFN01(X2)'=$$SLH^RCFN01(PX2)!'LN
WRITE !,$$SLH^RCFN01(X2)
+6 if RCX'=RCX1!'LN
WRITE ?12,$EXTRACT($PIECE($GET(^PRCA(430.3,+RCX,0)),"^"),1,23)
+7 WRITE ?37,$PIECE($GET(^PRCA(430.2,+X11,0)),"^",2)
+8 SET BILL=$PIECE(^TMP($JOB,RCX,X11,XFND,X2,X3),"^",2)
WRITE ?41,BILL
+9 WRITE ?55,$JUSTIFY(X3,8)
+10 SET AMT=+^TMP($JOB,RCX,X11,XFND,X2,X3)
+11 IF ",2,8,9,10,11,14,19,47,34,35,29,"[(","_TYP_",")
IF AMT'<0
SET AMT=-AMT
+12 IF ",2,8,9,10,11,12,14,19,47,34,35,29,"'[(","_TYP_",")
IF AMT<0
SET AMT=-AMT
+13 IF +CAT=26
IF TYP=1
IF AMT'<0
SET AMT=-AMT
+14 IF +CAT=26
IF TYP=35
IF AMT'<0
SET AMT=-AMT
+15 SET AMT("TOT")=AMT("TOT")+AMT
+16 SET AMT(X11)=AMT(X11)+AMT
+17 SET AMT(X11,XFND)=AMT(X11,XFND)+AMT
+18 if AMT<0
SET AMT=-AMT
WRITE ?64,$JUSTIFY(AMT,11,2)
+19 SET BY=$PIECE(^TMP($JOB,RCX,X11,XFND,X2,X3),"^",3)
if BY
SET BY=$PIECE($GET(^VA(200,+BY,0)),"^",2)
+20 WRITE ?76,BY
+21 IF RCX=45
WRITE !?10,$PIECE($GET(^PRCA(433,+X3,5)),"^",2),!
+22 SET LN=LN+1
+23 IF $ORDER(^TMP($JOB,RCX))!TYP
IF $Y+3>IOSL
Begin DoDot:3
+24 IF $EXTRACT(IOST,1,2)="C-"
SET DIR(0)="E"
KILL DIRUT
DO ^DIR
if $DATA(DIRUT)
QUIT
+25 WRITE @IOF
DO HDR^RCTRAN1
End DoDot:3
End DoDot:2
End DoDot:1
+26 if $DATA(DIRUT)
QUIT
+27 IF $ORDER(^TMP($JOB,RCX))!TYP
IF ($Y+10>IOSL)
Begin DoDot:1
+28 IF $EXTRACT(IOST,1,2)="C-"
SET DIR(0)="E"
KILL DIRUT
DO ^DIR
if $DATA(DIRUT)
QUIT
+29 WRITE @IOF
DO HDR^RCTRAN1
End DoDot:1
+30 if $DATA(DIRUT)
QUIT
+31 if AMT("TOT")<0
SET AMT("TOT")=-AMT("TOT")
if TYP
WRITE !?64,"------------",!,?57,"TOTAL:",?64,$JUSTIFY(AMT("TOT"),12,2)
+32 DO KEY^RCTRAN1
+33 QUIT
+34 ;
FCHK ;Check fund
+1 WRITE !,"FUND: ",XFND
+2 QUIT
+3 ;
EXIT ;Exit routine
+1 KILL ^TMP($JOB)
DO ^%ZISC
QUIT
