- 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 Jan 18, 2025@02:42:19 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