PRCAREPC ;SF-ISC/NYB-CATEGORY LIST-BILLS ;8/26/93 8:43 AM
V ;;4.5;Accounts Receivable;**72,94,63**;Mar 20, 1995
;;Per VHA Directive 10-93-142, this routine should not be modified.
EN N BN,BN0,BN7,CBAL,DBP,DBP1,DEB,DEBT,DP1,FL,III
N NCT,NCT2,NDE,PBAL,RCDOJ,SCT,SCT2,STAB
N STOT,STOT2,TFLG,TOT,TOT2
I CAT="ALL" S CNO=0 F S CNO=$O(^PRCA(430.2,"AC",CNO)) Q:CNO="" D
.S CAT=0 S CAT=$O(^PRCA(430.2,"AC",CNO,CAT)) Q:CAT="" D
..S ^TMP($J,"PRCAT",CAT)=""
..Q
.Q
I ST="ALL" S ST=0 F S ST=($O(^PRCA(430.3,"AC",ST))) Q:ST="" D
.Q:ST<100!(ST=107)
.S ^TMP($J,"PRCAST",$O(^PRCA(430.3,"AC",ST,0)))=""
.Q
S (CAT,TFLG)=0 F S CAT=$O(^TMP($J,"PRCAT",CAT)) Q:CAT=""!($G(OT)="^") D
.S ST=0 F S ST=$O(^TMP($J,"PRCAST",ST)) Q:ST=""!($G(OT)="^") D
..S ^TMP($J,"PRCASC",ST,CAT)=1
..Q
.Q
S ST=0 F S ST=$O(^TMP($J,"PRCASC",ST)) Q:ST="" D
.S (NCT,PRCAE,TOT,TOT2)=0 F S PRCAE=$O(^PRCA(430,"AC",ST,PRCAE)),X="" Q:'PRCAE D
..N DEB
..Q:'$O(^TMP($J,"PRCASC",0))
..S BN0=$G(^PRCA(430,PRCAE,0))
..S BN=$P($G(BN0),"^")
..S RCDOJ=$$REFST^RCRCUTL(PRCAE)
..I RCDOJ S BN=BN_"r"
..S CT4=$P($G(BN0),"^",2)
..S CAT=+$O(^TMP($J,"PRCASC",ST,(CT4-1)))
..I +$G(CAT)'>0 Q
..I $G(CT4)'=CAT Q
..S DEBT=$P($G(BN0),"^",9)
..I $G(DEBT) D
...S DEB=$P($G(^RCD(340,DEBT,0)),"^") Q:'DEB
...S DEB="^"_$P(DEB,";",2)_+DEB_",0)"
...S DEB=$G(@DEB),DEB=$P(DEB,"^")
...Q
..S DBP=$P($G(BN0),"^",10)
..I DT1'="",DBP<DT1 Q
..I DT2'="",DBP>DT2 Q
..I '$G(DBP) S DBP="**NONE**"
..S ST2=$G(^PRCA(430.3,ST,0))
..S STAB=$P($G(ST2),"^",2),ST2=$P($G(ST2),"^")
..S CAT2=$P($G(^PRCA(430.2,CT4,0)),"^")
..S BN7=$G(^PRCA(430,PRCAE,7))
..S PBAL=+$P($G(BN7),"^")
..S CBAL=0 F X=1:1:5 S CBAL=CBAL+$P($G(BN7),"^",X)
..S ^TMP($J,"PRCACS",CAT2,STAB,DBP,BN)=BN_"^"_$G(DEB)_"^"_PBAL_"^"_CBAL
..Q
.Q
K ^TMP($J,"PRCAT"),^TMP($J,"PRCASC"),^TMP($J,"PRCAST")
WRITE ;Write out report.
I '$D(^TMP($J,"PRCACS")) D HDR1 I $E(IOST)'="C" W @IOF Q
S (FL,NCT,SCT,STOT,STOT2,TOT,TOT2)=0
S CAT="" F S CAT=$O(^TMP($J,"PRCACS",CAT)) G:CAT=""!($G(OT)="^") ENQ D
.I 'FL D HDR
.I FL,$E(IOST)="C" D TOP Q:$G(OT)="^" D HDR S FL=0
.I FL,$E(IOST)="P" W @IOF D HDR S FL=0
.S STAB="" F S STAB=$O(^TMP($J,"PRCACS",CAT,STAB)) Q:STAB=""!($G(OT)="^") D
..I FL,$E(IOST)="C" D TOP Q:$G(OT)="^" D HDR
..I FL,$E(IOST)="P" W @IOF D HDR
..S DBP=0 F S DBP=$O(^TMP($J,"PRCACS",CAT,STAB,DBP)) Q:DBP=""!($G(OT)="^") S BN=0 F S BN=$O(^TMP($J,"PRCACS",CAT,STAB,DBP,BN)) Q:BN=""!($G(OT)="^") D
...S NDE=$G(^TMP($J,"PRCACS",CAT,STAB,DBP,BN))
...S Y=DBP D DD^%DT S DBP1=Y
...S DEB=$P($G(NDE),"^",2)
...S PBAL=$P($G(NDE),"^",3),CBAL=$P($G(NDE),"^",4)
...S STOT=STOT+PBAL,SCT=SCT+1
...S STOT2=STOT2+CBAL
...W !,BN,?14,$E(DEB,1,15),?32,DBP1,?46,STAB,?51,$J(PBAL,9,2),?65,$J(CBAL,9,2)
...I $E(IOST)="C",$Y+5>IOSL D TOP Q:$G(OT)="^" D HDR
...I $E(IOST)="P",$Y+5>IOSL W @IOF D HDR
...S FL=1
...Q
..D SUB
..Q
.D TOT
.W !!,"( r - Bill is Currently Referred )",!
.Q
ENQ K ^TMP($J),DIC,DIC(0)
Q
TOP ;Press return to continue prompt.
N DTOUT,DUOUT,DIRUT,DIR,DIROUT,Y
Q:$G(OT)="^"
S DIR(0)="E" D ^DIR I +Y=0 S OT="^"
TOPQ Q
HDR ;Header of the report.
I $E(IOST)="C" W @IOF
W "CATEGORY LISTING FOR BILLS REPORT",?45," ",SDT," Page: "_PAGE
W !,"Sort Criteria for Date Prepared: "_SC1_" to "_SC2
W !,?32,"Date",?52,"Princpal",?68,"Current"
W !,"Bill No.",?14,"Debtor",?32,"Preprd",?43,"Status"
W ?52,"Balance",?68,"Balance"
S X="",$P(X,"-",IOM-1)="" W !,X,!
W !,?7,"CATEGORY: "_$G(CAT),!!
S PAGE=PAGE+1
HDRQ Q
HDR1 ;Header if there is nothing to print.
I $E(IOST)="C" W @IOF
W "CATEGORY LISTING FOR BILLS REPORT",?45," ",SDT," Page: "_PAGE
W !,"Sort Criteria for Date Prepared: "_SC1_" to "_SC2
W !,?32,"Date",?52,"Princpal",?68,"Current"
W !,"Bill No.",?14,"Debtor",?32,"Preprd",?43,"Status"
W ?52,"Balance",?68,"Balance"
S X="",$P(X,"-",IOM-1)="" W !,X,!
W !!,"****NO RECORDS TO PRINT****",!!
HDR1Q Q
SUB ;Calculates the subtotals
D SUB1 Q:$G(OT)="^"
S (STOT,STOT2,SCT)=0
SUBQ Q
SUB1 I $G(Y)="^" S OT="^"
I $G(SCT)>0 W !?50,"----------",?64,"----------",!?41,"SUBTOTAL:"
I W ?50,$J(STOT,10,2),?64,$J(STOT2,10,2),!?41,"SUBCOUNT:"
I W ?50,$J(SCT,10),?64,$J(SCT,10)
S NCT=NCT+SCT,TOT=TOT+STOT,TOT2=TOT2+STOT2
SUB1Q Q
TOT ;Calculates the totals.
W !?50,"----------",?64,"----------"
W !?44,"TOTAL:",?50,$J(TOT,10,2),?64,$J(TOT2,10,2)
I $G(NCT)>0 W !?44,"COUNT:",?50,$J(NCT,10),?64,$J(NCT,10)
S (NCT,TOT,TOT2)=0
S TFLG=1
TOTQ Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCAREPC 4933 printed Apr 09, 2024@20:46:22 Page 2
PRCAREPC ;SF-ISC/NYB-CATEGORY LIST-BILLS ;8/26/93 8:43 AM
V ;;4.5;Accounts Receivable;**72,94,63**;Mar 20, 1995
+1 ;;Per VHA Directive 10-93-142, this routine should not be modified.
EN NEW BN,BN0,BN7,CBAL,DBP,DBP1,DEB,DEBT,DP1,FL,III
+1 NEW NCT,NCT2,NDE,PBAL,RCDOJ,SCT,SCT2,STAB
+2 NEW STOT,STOT2,TFLG,TOT,TOT2
+3 IF CAT="ALL"
SET CNO=0
FOR
SET CNO=$ORDER(^PRCA(430.2,"AC",CNO))
if CNO=""
QUIT
Begin DoDot:1
+4 SET CAT=0
SET CAT=$ORDER(^PRCA(430.2,"AC",CNO,CAT))
if CAT=""
QUIT
Begin DoDot:2
+5 SET ^TMP($JOB,"PRCAT",CAT)=""
+6 QUIT
End DoDot:2
+7 QUIT
End DoDot:1
+8 IF ST="ALL"
SET ST=0
FOR
SET ST=($ORDER(^PRCA(430.3,"AC",ST)))
if ST=""
QUIT
Begin DoDot:1
+9 if ST<100!(ST=107)
QUIT
+10 SET ^TMP($JOB,"PRCAST",$ORDER(^PRCA(430.3,"AC",ST,0)))=""
+11 QUIT
End DoDot:1
+12 SET (CAT,TFLG)=0
FOR
SET CAT=$ORDER(^TMP($JOB,"PRCAT",CAT))
if CAT=""!($GET(OT)="^")
QUIT
Begin DoDot:1
+13 SET ST=0
FOR
SET ST=$ORDER(^TMP($JOB,"PRCAST",ST))
if ST=""!($GET(OT)="^")
QUIT
Begin DoDot:2
+14 SET ^TMP($JOB,"PRCASC",ST,CAT)=1
+15 QUIT
End DoDot:2
+16 QUIT
End DoDot:1
+17 SET ST=0
FOR
SET ST=$ORDER(^TMP($JOB,"PRCASC",ST))
if ST=""
QUIT
Begin DoDot:1
+18 SET (NCT,PRCAE,TOT,TOT2)=0
FOR
SET PRCAE=$ORDER(^PRCA(430,"AC",ST,PRCAE))
SET X=""
if 'PRCAE
QUIT
Begin DoDot:2
+19 NEW DEB
+20 if '$ORDER(^TMP($JOB,"PRCASC",0))
QUIT
+21 SET BN0=$GET(^PRCA(430,PRCAE,0))
+22 SET BN=$PIECE($GET(BN0),"^")
+23 SET RCDOJ=$$REFST^RCRCUTL(PRCAE)
+24 IF RCDOJ
SET BN=BN_"r"
+25 SET CT4=$PIECE($GET(BN0),"^",2)
+26 SET CAT=+$ORDER(^TMP($JOB,"PRCASC",ST,(CT4-1)))
+27 IF +$GET(CAT)'>0
QUIT
+28 IF $GET(CT4)'=CAT
QUIT
+29 SET DEBT=$PIECE($GET(BN0),"^",9)
+30 IF $GET(DEBT)
Begin DoDot:3
+31 SET DEB=$PIECE($GET(^RCD(340,DEBT,0)),"^")
if 'DEB
QUIT
+32 SET DEB="^"_$PIECE(DEB,";",2)_+DEB_",0)"
+33 SET DEB=$GET(@DEB)
SET DEB=$PIECE(DEB,"^")
+34 QUIT
End DoDot:3
+35 SET DBP=$PIECE($GET(BN0),"^",10)
+36 IF DT1'=""
IF DBP<DT1
QUIT
+37 IF DT2'=""
IF DBP>DT2
QUIT
+38 IF '$GET(DBP)
SET DBP="**NONE**"
+39 SET ST2=$GET(^PRCA(430.3,ST,0))
+40 SET STAB=$PIECE($GET(ST2),"^",2)
SET ST2=$PIECE($GET(ST2),"^")
+41 SET CAT2=$PIECE($GET(^PRCA(430.2,CT4,0)),"^")
+42 SET BN7=$GET(^PRCA(430,PRCAE,7))
+43 SET PBAL=+$PIECE($GET(BN7),"^")
+44 SET CBAL=0
FOR X=1:1:5
SET CBAL=CBAL+$PIECE($GET(BN7),"^",X)
+45 SET ^TMP($JOB,"PRCACS",CAT2,STAB,DBP,BN)=BN_"^"_$GET(DEB)_"^"_PBAL_"^"_CBAL
+46 QUIT
End DoDot:2
+47 QUIT
End DoDot:1
+48 KILL ^TMP($JOB,"PRCAT"),^TMP($JOB,"PRCASC"),^TMP($JOB,"PRCAST")
WRITE ;Write out report.
+1 IF '$DATA(^TMP($JOB,"PRCACS"))
DO HDR1
IF $EXTRACT(IOST)'="C"
WRITE @IOF
QUIT
+2 SET (FL,NCT,SCT,STOT,STOT2,TOT,TOT2)=0
+3 SET CAT=""
FOR
SET CAT=$ORDER(^TMP($JOB,"PRCACS",CAT))
if CAT=""!($GET(OT)="^")
GOTO ENQ
Begin DoDot:1
+4 IF 'FL
DO HDR
+5 IF FL
IF $EXTRACT(IOST)="C"
DO TOP
if $GET(OT)="^"
QUIT
DO HDR
SET FL=0
+6 IF FL
IF $EXTRACT(IOST)="P"
WRITE @IOF
DO HDR
SET FL=0
+7 SET STAB=""
FOR
SET STAB=$ORDER(^TMP($JOB,"PRCACS",CAT,STAB))
if STAB=""!($GET(OT)="^")
QUIT
Begin DoDot:2
+8 IF FL
IF $EXTRACT(IOST)="C"
DO TOP
if $GET(OT)="^"
QUIT
DO HDR
+9 IF FL
IF $EXTRACT(IOST)="P"
WRITE @IOF
DO HDR
+10 SET DBP=0
FOR
SET DBP=$ORDER(^TMP($JOB,"PRCACS",CAT,STAB,DBP))
if DBP=""!($GET(OT)="^")
QUIT
SET BN=0
FOR
SET BN=$ORDER(^TMP($JOB,"PRCACS",CAT,STAB,DBP,BN))
if BN=""!($GET(OT)="^")
QUIT
Begin DoDot:3
+11 SET NDE=$GET(^TMP($JOB,"PRCACS",CAT,STAB,DBP,BN))
+12 SET Y=DBP
DO DD^%DT
SET DBP1=Y
+13 SET DEB=$PIECE($GET(NDE),"^",2)
+14 SET PBAL=$PIECE($GET(NDE),"^",3)
SET CBAL=$PIECE($GET(NDE),"^",4)
+15 SET STOT=STOT+PBAL
SET SCT=SCT+1
+16 SET STOT2=STOT2+CBAL
+17 WRITE !,BN,?14,$EXTRACT(DEB,1,15),?32,DBP1,?46,STAB,?51,$JUSTIFY(PBAL,9,2),?65,$JUSTIFY(CBAL,9,2)
+18 IF $EXTRACT(IOST)="C"
IF $Y+5>IOSL
DO TOP
if $GET(OT)="^"
QUIT
DO HDR
+19 IF $EXTRACT(IOST)="P"
IF $Y+5>IOSL
WRITE @IOF
DO HDR
+20 SET FL=1
+21 QUIT
End DoDot:3
+22 DO SUB
+23 QUIT
End DoDot:2
+24 DO TOT
+25 WRITE !!,"( r - Bill is Currently Referred )",!
+26 QUIT
End DoDot:1
ENQ KILL ^TMP($JOB),DIC,DIC(0)
+1 QUIT
TOP ;Press return to continue prompt.
+1 NEW DTOUT,DUOUT,DIRUT,DIR,DIROUT,Y
+2 if $GET(OT)="^"
QUIT
+3 SET DIR(0)="E"
DO ^DIR
IF +Y=0
SET OT="^"
TOPQ QUIT
HDR ;Header of the report.
+1 IF $EXTRACT(IOST)="C"
WRITE @IOF
+2 WRITE "CATEGORY LISTING FOR BILLS REPORT",?45," ",SDT," Page: "_PAGE
+3 WRITE !,"Sort Criteria for Date Prepared: "_SC1_" to "_SC2
+4 WRITE !,?32,"Date",?52,"Princpal",?68,"Current"
+5 WRITE !,"Bill No.",?14,"Debtor",?32,"Preprd",?43,"Status"
+6 WRITE ?52,"Balance",?68,"Balance"
+7 SET X=""
SET $PIECE(X,"-",IOM-1)=""
WRITE !,X,!
+8 WRITE !,?7,"CATEGORY: "_$GET(CAT),!!
+9 SET PAGE=PAGE+1
HDRQ QUIT
HDR1 ;Header if there is nothing to print.
+1 IF $EXTRACT(IOST)="C"
WRITE @IOF
+2 WRITE "CATEGORY LISTING FOR BILLS REPORT",?45," ",SDT," Page: "_PAGE
+3 WRITE !,"Sort Criteria for Date Prepared: "_SC1_" to "_SC2
+4 WRITE !,?32,"Date",?52,"Princpal",?68,"Current"
+5 WRITE !,"Bill No.",?14,"Debtor",?32,"Preprd",?43,"Status"
+6 WRITE ?52,"Balance",?68,"Balance"
+7 SET X=""
SET $PIECE(X,"-",IOM-1)=""
WRITE !,X,!
+8 WRITE !!,"****NO RECORDS TO PRINT****",!!
HDR1Q QUIT
SUB ;Calculates the subtotals
+1 DO SUB1
if $GET(OT)="^"
QUIT
+2 SET (STOT,STOT2,SCT)=0
SUBQ QUIT
SUB1 IF $GET(Y)="^"
SET OT="^"
+1 IF $GET(SCT)>0
WRITE !?50,"----------",?64,"----------",!?41,"SUBTOTAL:"
+2 IF $TEST
WRITE ?50,$JUSTIFY(STOT,10,2),?64,$JUSTIFY(STOT2,10,2),!?41,"SUBCOUNT:"
+3 IF $TEST
WRITE ?50,$JUSTIFY(SCT,10),?64,$JUSTIFY(SCT,10)
+4 SET NCT=NCT+SCT
SET TOT=TOT+STOT
SET TOT2=TOT2+STOT2
SUB1Q QUIT
TOT ;Calculates the totals.
+1 WRITE !?50,"----------",?64,"----------"
+2 WRITE !?44,"TOTAL:",?50,$JUSTIFY(TOT,10,2),?64,$JUSTIFY(TOT2,10,2)
+3 IF $GET(NCT)>0
WRITE !?44,"COUNT:",?50,$JUSTIFY(NCT,10),?64,$JUSTIFY(NCT,10)
+4 SET (NCT,TOT,TOT2)=0
+5 SET TFLG=1
TOTQ QUIT
