- 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 Jan 18, 2025@02:50:23 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