- PRCE58P1 ;WISC/SAW,LDB/BGJ-CONTROL POINT ACTIVITY 1358 DISPLAY CON'T ;6/17/11 17:51
- V ;;5.1;IFCAP;**158,168**;Oct 20, 2000;Build 3
- ;Per VHA Directive 2004-038, this routine should not be modified.
- ;
- ;PRC*5.1*168 will remove leading zeros when transactions compile into
- ; temp global ^TMP("PRCSR") to insure correct sort for 1358
- ; having more than 999 transactions
- ;
- S Z=$S($D(PRCSPO):PRC("SITE")_"-"_PRCSPO,1:0)
- I I 'Z!('$D(^PRC(424,"AD",Z))) W !,"Daily Record entries have not yet been entered for this request.",!,"The total committed cost of this request is $" W:$D(TRNODE(4)) $J($P(TRNODE(4),U),0,2) W !,L G P
- D HDR1 S PRCSX=0 D OB S (ET,AT,UT)="" D PO1 Q:Z3=U
- W !!,?7,"TOTALS",?29,"$"
- ;Display of dollar amounts staggered if any amount $1 million or more
- D
- . I ET>999999.99!(AT>999999.99)!(CET>999999.99) D Q
- . . W $J(ET,9,2),?51,"$",$J(CET,9,2),?69,"$",$J((PRCSOT-UT),9,2) W !,?40,"$",$J(AT,9,2)
- . W $J(ET,9,2),?40,"$",$J(AT,9,2),?51,"$",$J(CET,9,2),?69,"$",$J((PRCSOT-UT),9,2)
- K PRCSX,PRCSOT,UT,CT,AT,ET,CAT,CET,PRCSR,PRCSX,PRCSXX,J,JJ
- D P
- Q
- OB ;DISPLAY ONLY OBLIGATIONS
- I '$D(^PRC(424,"AD",Z)) G OB1
- S (PRCSOT,X1,UT)="" F S X1=$O(^PRC(424,"AF",Z,X1)) Q:X1'>0 I $D(^PRC(424,X1,0)) S Z1=^(0),PRCSOT=PRCSOT+$P(Z1,U,6) X "I IOSL-$Y<5 D HOLD^PRCE58P0 Q:Z3=U D NEWP^PRCE58P0,HDR1" D DR1
- W !,L Q:$D(PRCSX)
- OB1 W !!,"The following 1358 obligation/adjustment request is ready for processing:"
- S X=$P(TRNODE(0),U,1,2) W !,"TRANSACTION NUMBER: ",$P(X,U),?40,"TYPE: ",$S($P(X,U,2)="O":"OBLIGATION",1:"ADJUSTMENT"),?50,"AMOUNT: $",$J($P(TRNODE(4),U,8),0,2) W !,L G P
- PO1 I $D(TRNODE(10)) S PRCSY=$P(TRNODE(10),U,3) I PRCSY K PO D PO^PRCH58OB(PRCSY,.PO) D:$D(PO(0)) PO11
- Q
- PO11 K ^TMP("PRCSR",$J)
- I IOSL-$Y<15 D HOLD^PRCE58P0 Q:Z3=U D NEWP^PRCE58P0
- D HDR S CET=0 F S PRCSX=$O(^PRC(424,"C",PRCSY,PRCSX)) Q:'PRCSX D
- . I $D(^PRC(424,PRCSX,0)),"^AU^L^"[("^"_$P(^(0),U,3)_"^") S Z1=^(0) I Z1 S ^TMP("PRCSR",$J,+$P($P(Z1,U),"-",3),PRCSX)=Z1 ;PRC*5.1*168 will remove leading zeros in TX#
- S PRCSXX="" F S PRCSXX=$O(^TMP("PRCSR",$J,PRCSXX)) Q:PRCSXX="" S (A,E)=0 D PO12 Q:Z3=U
- K ^TMP("PRCSR",$J) Q
- PO12 S PRCSX=0 F S PRCSX=$O(^TMP("PRCSR",$J,PRCSXX,PRCSX)) Q:PRCSX'>0 S Z1=^TMP("PRCSR",$J,PRCSXX,PRCSX),Y=$P(Z1,U,7) D T X "I IOSL-$Y<3 D HOLD^PRCE58P0 Q:Z3=U D NEWP^PRCE58P0,HDR" D PO2 Q:Z3=U
- K A,E Q
- PO2 W !,Y,?7,$E("0000",1,4-$L(PRCSXX))_PRCSXX,?12,$P(Z1,U,10),?29,"$" ;PRC*5.1*168 will zero pad TX# for print
- S E=$P(Z1,U,12),A=$P(Z1,U,5),UT=UT+$P(Z1,U,4),AT=AT+A,ET=ET+E,CET=CET+E
- ;Display of dollar amounts staggered if any amount $1 million or more
- D
- . I E>999999.99!(A>999999.99)!(CET>999999.99)!(Z1>999999.99) D Q
- . . W $J(E,9,2),?51,"$",$J(CET,9,2) W ! W:$D(PRCSA) ?12,$G(^PRC(424,PRCSX,1)) W ?40,"$",$J(A,9,2),?62,"$",$J($P(Z1,U,4),9,2)
- . W $J(E,9,2),?40,"$",$J(A,9,2),?51,"$",$J(CET,9,2),?62,"$",$J($P(Z1,U,4),9,2) I $D(PRCSA) W !,?12,$G(^PRC(424,PRCSX,1))
- I $D(^PRC(424.1,"C",PRCSX)),$G(PRCSA1)=1 S I=0 F S I=$O(^PRC(424.1,"C",PRCSX,I)) Q:'I I $D(^PRC(424.1,I,0)),$P(^(0),U,11)="P" D Q:Z3=U W !
- . W ! I IOSL-$Y<5 D HOLD^PRCE58P0 Q:Z3=U D NEWP^PRCE58P0,HDR
- . W ! S Y=$P(^PRC(424.1,I,0),U,4) D T W Y,?7,$P($P(^(0),U),"-",3,4) W !,?12,$P(^(0),U,8),?29,"$",$J(($P(^(0),U,3)/-1),9,2)
- . I IOSL-$Y<5 D HOLD^PRCE58P0 Q:Z3=U D NEWP^PRCE58P0,HDR
- . I PRCSA2=1,$D(^PRC(424.1,I,1)) W !,?12,^(1)
- Q
- P W:Z3'=U !!,"VA FORM 4-1358a-ADP (NOV 1987)",! Q
- DR1 S Y=$P(Z1,U,7) D T W !,Y,?7,$P($P(Z1,U),"-",3)
- S DA=$P(Z1,U,15) I DA D NODE^PRCS58OB(DA,.TRNODE) W ?13,$P(TRNODE(0),U)
- W ?36,"$",$J($P(Z1,U,6),9,2) W:$D(PRCSX) ?56,"$",$J(PRCSOT,9,2) Q
- HDR W !,"AUTHORIZATION & ORDER RECORD",?62,"LIQUIDATION RECORD"
- W !!,?30,"AUTH.",?41,"AUTH.",?53,"CUMULATIVE",?74,"UNLIQ",!,"DATE",?7,"SEQ#",?14,"REFERENCE",?30,"AMOUNT",?41,"BALANCE",?53,"AUTH. AMT.",?64,"LIQUID",?74,"BAL" W !,L Q
- HDR1 W !,"ESTIMATED OBLIGATION RECAP",!,"DATE",?7,"REF#",?13,"CPA#",?37,"AMOUNT",?57,"BALANCE" Q
- T S Y=$E(Y,4,5)_"/"_$E(Y,6,7) Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCE58P1 4028 printed Jan 18, 2025@03:02:21 Page 2
- PRCE58P1 ;WISC/SAW,LDB/BGJ-CONTROL POINT ACTIVITY 1358 DISPLAY CON'T ;6/17/11 17:51
- V ;;5.1;IFCAP;**158,168**;Oct 20, 2000;Build 3
- +1 ;Per VHA Directive 2004-038, this routine should not be modified.
- +2 ;
- +3 ;PRC*5.1*168 will remove leading zeros when transactions compile into
- +4 ; temp global ^TMP("PRCSR") to insure correct sort for 1358
- +5 ; having more than 999 transactions
- +6 ;
- +7 SET Z=$SELECT($DATA(PRCSPO):PRC("SITE")_"-"_PRCSPO,1:0)
- I IF 'Z!('$DATA(^PRC(424,"AD",Z)))
- WRITE !,"Daily Record entries have not yet been entered for this request.",!,"The total committed cost of this request is $"
- if $DATA(TRNODE(4))
- WRITE $JUSTIFY($PIECE(TRNODE(4),U),0,2)
- WRITE !,L
- GOTO P
- +1 DO HDR1
- SET PRCSX=0
- DO OB
- SET (ET,AT,UT)=""
- DO PO1
- if Z3=U
- QUIT
- +2 WRITE !!,?7,"TOTALS",?29,"$"
- +3 ;Display of dollar amounts staggered if any amount $1 million or more
- +4 Begin DoDot:1
- +5 IF ET>999999.99!(AT>999999.99)!(CET>999999.99)
- Begin DoDot:2
- +6 WRITE $JUSTIFY(ET,9,2),?51,"$",$JUSTIFY(CET,9,2),?69,"$",$JUSTIFY((PRCSOT-UT),9,2)
- WRITE !,?40,"$",$JUSTIFY(AT,9,2)
- End DoDot:2
- QUIT
- +7 WRITE $JUSTIFY(ET,9,2),?40,"$",$JUSTIFY(AT,9,2),?51,"$",$JUSTIFY(CET,9,2),?69,"$",$JUSTIFY((PRCSOT-UT),9,2)
- End DoDot:1
- +8 KILL PRCSX,PRCSOT,UT,CT,AT,ET,CAT,CET,PRCSR,PRCSX,PRCSXX,J,JJ
- +9 DO P
- +10 QUIT
- OB ;DISPLAY ONLY OBLIGATIONS
- +1 IF '$DATA(^PRC(424,"AD",Z))
- GOTO OB1
- +2 SET (PRCSOT,X1,UT)=""
- FOR
- SET X1=$ORDER(^PRC(424,"AF",Z,X1))
- if X1'>0
- QUIT
- IF $DATA(^PRC(424,X1,0))
- SET Z1=^(0)
- SET PRCSOT=PRCSOT+$PIECE(Z1,U,6)
- XECUTE "I IOSL-$Y<5 D HOLD^PRCE58P0 Q:Z3=U D NEWP^PRCE58P0,HDR1"
- DO DR1
- +3 WRITE !,L
- if $DATA(PRCSX)
- QUIT
- OB1 WRITE !!,"The following 1358 obligation/adjustment request is ready for processing:"
- +1 SET X=$PIECE(TRNODE(0),U,1,2)
- WRITE !,"TRANSACTION NUMBER: ",$PIECE(X,U),?40,"TYPE: ",$SELECT($PIECE(X,U,2)="O":"OBLIGATION",1:"ADJUSTMENT"),?50,"AMOUNT: $",$JUSTIFY($PIECE(TRNODE(4),U,8),0,2)
- WRITE !,L
- GOTO P
- PO1 IF $DATA(TRNODE(10))
- SET PRCSY=$PIECE(TRNODE(10),U,3)
- IF PRCSY
- KILL PO
- DO PO^PRCH58OB(PRCSY,.PO)
- if $DATA(PO(0))
- DO PO11
- +1 QUIT
- PO11 KILL ^TMP("PRCSR",$JOB)
- +1 IF IOSL-$Y<15
- DO HOLD^PRCE58P0
- if Z3=U
- QUIT
- DO NEWP^PRCE58P0
- +2 DO HDR
- SET CET=0
- FOR
- SET PRCSX=$ORDER(^PRC(424,"C",PRCSY,PRCSX))
- if 'PRCSX
- QUIT
- Begin DoDot:1
- +3 ;PRC*5.1*168 will remove leading zeros in TX#
- IF $DATA(^PRC(424,PRCSX,0))
- IF "^AU^L^"[("^"_$PIECE(^(0),U,3)_"^")
- SET Z1=^(0)
- IF Z1
- SET ^TMP("PRCSR",$JOB,+$PIECE($PIECE(Z1,U),"-",3),PRCSX)=Z1
- End DoDot:1
- +4 SET PRCSXX=""
- FOR
- SET PRCSXX=$ORDER(^TMP("PRCSR",$JOB,PRCSXX))
- if PRCSXX=""
- QUIT
- SET (A,E)=0
- DO PO12
- if Z3=U
- QUIT
- +5 KILL ^TMP("PRCSR",$JOB)
- QUIT
- PO12 SET PRCSX=0
- FOR
- SET PRCSX=$ORDER(^TMP("PRCSR",$JOB,PRCSXX,PRCSX))
- if PRCSX'>0
- QUIT
- SET Z1=^TMP("PRCSR",$JOB,PRCSXX,PRCSX)
- SET Y=$PIECE(Z1,U,7)
- DO T
- XECUTE "I IOSL-$Y<3 D HOLD^PRCE58P0 Q:Z3=U D NEWP^PRCE58P0,HDR"
- DO PO2
- if Z3=U
- QUIT
- +1 KILL A,E
- QUIT
- PO2 ;PRC*5.1*168 will zero pad TX# for print
- WRITE !,Y,?7,$EXTRACT("0000",1,4-$LENGTH(PRCSXX))_PRCSXX,?12,$PIECE(Z1,U,10),?29,"$"
- +1 SET E=$PIECE(Z1,U,12)
- SET A=$PIECE(Z1,U,5)
- SET UT=UT+$PIECE(Z1,U,4)
- SET AT=AT+A
- SET ET=ET+E
- SET CET=CET+E
- +2 ;Display of dollar amounts staggered if any amount $1 million or more
- +3 Begin DoDot:1
- +4 IF E>999999.99!(A>999999.99)!(CET>999999.99)!(Z1>999999.99)
- Begin DoDot:2
- +5 WRITE $JUSTIFY(E,9,2),?51,"$",$JUSTIFY(CET,9,2)
- WRITE !
- if $DATA(PRCSA)
- WRITE ?12,$GET(^PRC(424,PRCSX,1))
- WRITE ?40,"$",$JUSTIFY(A,9,2),?62,"$",$JUSTIFY($PIECE(Z1,U,4),9,2)
- End DoDot:2
- QUIT
- +6 WRITE $JUSTIFY(E,9,2),?40,"$",$JUSTIFY(A,9,2),?51,"$",$JUSTIFY(CET,9,2),?62,"$",$JUSTIFY($PIECE(Z1,U,4),9,2)
- IF $DATA(PRCSA)
- WRITE !,?12,$GET(^PRC(424,PRCSX,1))
- End DoDot:1
- +7 IF $DATA(^PRC(424.1,"C",PRCSX))
- IF $GET(PRCSA1)=1
- SET I=0
- FOR
- SET I=$ORDER(^PRC(424.1,"C",PRCSX,I))
- if 'I
- QUIT
- IF $DATA(^PRC(424.1,I,0))
- IF $PIECE(^(0),U,11)="P"
- Begin DoDot:1
- +8 WRITE !
- IF IOSL-$Y<5
- DO HOLD^PRCE58P0
- if Z3=U
- QUIT
- DO NEWP^PRCE58P0
- DO HDR
- +9 WRITE !
- SET Y=$PIECE(^PRC(424.1,I,0),U,4)
- DO T
- WRITE Y,?7,$PIECE($PIECE(^(0),U),"-",3,4)
- WRITE !,?12,$PIECE(^(0),U,8),?29,"$",$JUSTIFY(($PIECE(^(0),U,3)/-1),9,2)
- +10 IF IOSL-$Y<5
- DO HOLD^PRCE58P0
- if Z3=U
- QUIT
- DO NEWP^PRCE58P0
- DO HDR
- +11 IF PRCSA2=1
- IF $DATA(^PRC(424.1,I,1))
- WRITE !,?12,^(1)
- End DoDot:1
- if Z3=U
- QUIT
- WRITE !
- +12 QUIT
- P if Z3'=U
- WRITE !!,"VA FORM 4-1358a-ADP (NOV 1987)",!
- QUIT
- DR1 SET Y=$PIECE(Z1,U,7)
- DO T
- WRITE !,Y,?7,$PIECE($PIECE(Z1,U),"-",3)
- +1 SET DA=$PIECE(Z1,U,15)
- IF DA
- DO NODE^PRCS58OB(DA,.TRNODE)
- WRITE ?13,$PIECE(TRNODE(0),U)
- +2 WRITE ?36,"$",$JUSTIFY($PIECE(Z1,U,6),9,2)
- if $DATA(PRCSX)
- WRITE ?56,"$",$JUSTIFY(PRCSOT,9,2)
- QUIT
- HDR WRITE !,"AUTHORIZATION & ORDER RECORD",?62,"LIQUIDATION RECORD"
- +1 WRITE !!,?30,"AUTH.",?41,"AUTH.",?53,"CUMULATIVE",?74,"UNLIQ",!,"DATE",?7,"SEQ#",?14,"REFERENCE",?30,"AMOUNT",?41,"BALANCE",?53,"AUTH. AMT.",?64,"LIQUID",?74,"BAL"
- WRITE !,L
- QUIT
- HDR1 WRITE !,"ESTIMATED OBLIGATION RECAP",!,"DATE",?7,"REF#",?13,"CPA#",?37,"AMOUNT",?57,"BALANCE"
- QUIT
- T SET Y=$EXTRACT(Y,4,5)_"/"_$EXTRACT(Y,6,7)
- QUIT