RCTRAN1 ;WASH-ISC@ALTOONA,PA/LDB-Transaction History Report ;11/14/94 5:25 PM
;;4.5;Accounts Receivable;**104,310**;Mar 20, 1995;Build 14
;Per VA Directive 6402, this routine should not be modified.
;
;Subroutines Called by RCTRAN
;
TRANS ;Find transactions of selected type for selected date range
S CAT("X")=CAT D DT^DICRW
S BDATE(1)=BDATE,BDATE=(BDATE-1)+.999999999
S EDATE(1)=EDATE,EDATE=$S('EDATE:9999999,1:EDATE+.99999999)
S RCX=0 F S RCX=$O(^PRCA(433,RCX)) Q:'RCX I $D(^PRCA(433,RCX,0)),+$G(^(1)) D
.S NODE0=^(0),NODE1=^(1),NODE2=$G(^(2)),NODE3=$G(^(3))
.S TDAT=$S($P(NODE1,"^",9):$P(NODE1,"^",9),1:+NODE1)
.S BILL=$P(NODE0,"^",2) Q:'BILL
.S CAT=$P($G(^PRCA(430,+BILL,0)),"^",2) Q:'CAT
.I ($D(TYP(+$P(NODE1,"^",2)))!'TYP),($D(CAT(+CAT))!'CAT("X")),TDAT>BDATE,TDAT<EDATE D
..S APP=$P($G(^PRCA(430,+BILL,11)),"^",17)
..I APP="",",5,4,3,18,25,"[(","_CAT_",") S APP="2431"
..I APP="",",9,6,7,8,21,22,23,26,45,"[(","_CAT_",") S APP="5014" ;PRCA*4.5*310/DRF added category 47 for FEE REIMB INS
..I APP="",",14,12,19,20,1,10,2,"[(","_CAT_",") S APP="0160"
..I CAT=26 S APP="5014"
..I APP="" S APP="NO FUND W/BILL"
..S BILL=$P($G(^PRCA(430,+BILL,0)),"^")
..I ",12,13,14,"[(","_TYP_",") D Q
...F I=5:1:8 S AMT=$P(NODE2,"^",I) I AMT S APP=$S(I=8:1435,I=7:3220,1:"0869") D SET
..I ",2,34,"[(","_TYP_",") D Q
...F I=1:1:5 I $P(NODE3,"^",I) S AMT=+$P(NODE3,"^",I),APP=$S(I=1:APP,I=2:1435,I=3:3220,1:"0869") D SET
..S AMT=+$P(NODE1,"^",5)
..D SET
Q
;
SET S ^TMP($J,+$P(NODE1,"^",2),+CAT,APP,TDAT,RCX)=AMT_"^"_BILL_"^"_$P(NODE0,"^",9)
Q
;
SUB ;Sub-total categories
I RCX'=45 S:AMT(X11)<0 AMT(X11)=-AMT(X11) W !?64,"-----------",!?64,$J(AMT(X11),11,2),!
Q
;
KEY ;Key to category abbreviations
W !!?30,"CATEGORY ABBREVIATIONS",!!
W !,"C - C (MEANS TEST), CE - CURRENT EMPLOYEE, CP - CRIME OF PER. VIO."
W !,"E - EX-EMPLOYEE"
W !,"F1 - FEDERAL AGENGIES-REIMB., F2 - FEDERAL AGENCIES-REFUND"
W !,"FR - FEE BASIS REIMBURSABLE HEALTH INSURANCE" ;PRCA*4.5*310/DRF - Added FEE REIMB INS
W !,"H - EMERGENCY HUMANITARIAN"
W !,"I - INELIGIBLE HOSP., IA - INTERAGENCY, M - MILITARY, MC - MEDICARN"
W !,"NA - NO-FAULT AUTO ACC."
W !,"PN - RX CO-PAY NSC, PS - RX CO-PAY SC, PP - PREPAY"
W !,"RI - REIMBURSIBLE HEALTH INSURANCE"
W !,"SA - SHARING AGREEMENTS, TF - TORT FEASOR, V - VENDOR, WC - WORKMAN'S COMP."
Q
HDR ;;Heading
S PG=PG+1
W !?30,"HISTORY OF TRANSACTIONS",?70,"PAGE ",?75,PG
W !,LINE
W !,"Date",?12,"Trans.",?37,"Cat",?44,"Bill#",?57,"Trans#",?66,"Amount",?75,"BY"
W !,LINE
S LN=0
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRCTRAN1 2607 printed Oct 16, 2024@17:50 Page 2
RCTRAN1 ;WASH-ISC@ALTOONA,PA/LDB-Transaction History Report ;11/14/94 5:25 PM
+1 ;;4.5;Accounts Receivable;**104,310**;Mar 20, 1995;Build 14
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ;Subroutines Called by RCTRAN
+5 ;
TRANS ;Find transactions of selected type for selected date range
+1 SET CAT("X")=CAT
DO DT^DICRW
+2 SET BDATE(1)=BDATE
SET BDATE=(BDATE-1)+.999999999
+3 SET EDATE(1)=EDATE
SET EDATE=$SELECT('EDATE:9999999,1:EDATE+.99999999)
+4 SET RCX=0
FOR
SET RCX=$ORDER(^PRCA(433,RCX))
if 'RCX
QUIT
IF $DATA(^PRCA(433,RCX,0))
IF +$GET(^(1))
Begin DoDot:1
+5 SET NODE0=^(0)
SET NODE1=^(1)
SET NODE2=$GET(^(2))
SET NODE3=$GET(^(3))
+6 SET TDAT=$SELECT($PIECE(NODE1,"^",9):$PIECE(NODE1,"^",9),1:+NODE1)
+7 SET BILL=$PIECE(NODE0,"^",2)
if 'BILL
QUIT
+8 SET CAT=$PIECE($GET(^PRCA(430,+BILL,0)),"^",2)
if 'CAT
QUIT
+9 IF ($DATA(TYP(+$PIECE(NODE1,"^",2)))!'TYP)
IF ($DATA(CAT(+CAT))!'CAT("X"))
IF TDAT>BDATE
IF TDAT<EDATE
Begin DoDot:2
+10 SET APP=$PIECE($GET(^PRCA(430,+BILL,11)),"^",17)
+11 IF APP=""
IF ",5,4,3,18,25,"[(","_CAT_",")
SET APP="2431"
+12 ;PRCA*4.5*310/DRF added category 47 for FEE REIMB INS
IF APP=""
IF ",9,6,7,8,21,22,23,26,45,"[(","_CAT_",")
SET APP="5014"
+13 IF APP=""
IF ",14,12,19,20,1,10,2,"[(","_CAT_",")
SET APP="0160"
+14 IF CAT=26
SET APP="5014"
+15 IF APP=""
SET APP="NO FUND W/BILL"
+16 SET BILL=$PIECE($GET(^PRCA(430,+BILL,0)),"^")
+17 IF ",12,13,14,"[(","_TYP_",")
Begin DoDot:3
+18 FOR I=5:1:8
SET AMT=$PIECE(NODE2,"^",I)
IF AMT
SET APP=$SELECT(I=8:1435,I=7:3220,1:"0869")
DO SET
End DoDot:3
QUIT
+19 IF ",2,34,"[(","_TYP_",")
Begin DoDot:3
+20 FOR I=1:1:5
IF $PIECE(NODE3,"^",I)
SET AMT=+$PIECE(NODE3,"^",I)
SET APP=$SELECT(I=1:APP,I=2:1435,I=3:3220,1:"0869")
DO SET
End DoDot:3
QUIT
+21 SET AMT=+$PIECE(NODE1,"^",5)
+22 DO SET
End DoDot:2
End DoDot:1
+23 QUIT
+24 ;
SET SET ^TMP($JOB,+$PIECE(NODE1,"^",2),+CAT,APP,TDAT,RCX)=AMT_"^"_BILL_"^"_$PIECE(NODE0,"^",9)
+1 QUIT
+2 ;
SUB ;Sub-total categories
+1 IF RCX'=45
if AMT(X11)<0
SET AMT(X11)=-AMT(X11)
WRITE !?64,"-----------",!?64,$JUSTIFY(AMT(X11),11,2),!
+2 QUIT
+3 ;
KEY ;Key to category abbreviations
+1 WRITE !!?30,"CATEGORY ABBREVIATIONS",!!
+2 WRITE !,"C - C (MEANS TEST), CE - CURRENT EMPLOYEE, CP - CRIME OF PER. VIO."
+3 WRITE !,"E - EX-EMPLOYEE"
+4 WRITE !,"F1 - FEDERAL AGENGIES-REIMB., F2 - FEDERAL AGENCIES-REFUND"
+5 ;PRCA*4.5*310/DRF - Added FEE REIMB INS
WRITE !,"FR - FEE BASIS REIMBURSABLE HEALTH INSURANCE"
+6 WRITE !,"H - EMERGENCY HUMANITARIAN"
+7 WRITE !,"I - INELIGIBLE HOSP., IA - INTERAGENCY, M - MILITARY, MC - MEDICARN"
+8 WRITE !,"NA - NO-FAULT AUTO ACC."
+9 WRITE !,"PN - RX CO-PAY NSC, PS - RX CO-PAY SC, PP - PREPAY"
+10 WRITE !,"RI - REIMBURSIBLE HEALTH INSURANCE"
+11 WRITE !,"SA - SHARING AGREEMENTS, TF - TORT FEASOR, V - VENDOR, WC - WORKMAN'S COMP."
+12 QUIT
HDR ;;Heading
+1 SET PG=PG+1
+2 WRITE !?30,"HISTORY OF TRANSACTIONS",?70,"PAGE ",?75,PG
+3 WRITE !,LINE
+4 WRITE !,"Date",?12,"Trans.",?37,"Cat",?44,"Bill#",?57,"Trans#",?66,"Amount",?75,"BY"
+5 WRITE !,LINE
+6 SET LN=0
+7 QUIT
