PRCSD111 ;WISC/SAW-CONTROL POINT ACTIVITY 1358 DISPLAY CON'T ;3-19-91/15:34
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
S Z=$S($D(PRCSPO):PRC("SITE")_"-"_PRCSPO,1:0)
I 'Z!('$D(^PRC(424,"AC",Z))) W !,"Daily Record entries have not yet been entered for this request.",!,"The total committed cost of this request is $" W:$D(^PRCS(410,DA,4)) $J($P(^(4),U),0,2) W !,L G P
D HDR1 S PRCSX=0 D OB S (ET,AT,UT,CT)="" D PO1 W !!,?7,"TOTALS",?26,"$",$J(ET,9,2),?38,$J(AT,9,2),?70,"$",$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,"AC",Z)) G OB1
S (PRCSOT,X1,UT)="" F I=1:1 S X1=$O(^PRC(424,"AF",Z,X1)) Q:X1'>0 I $D(^PRC(424,X1,0)) S Z1=$P(^(0),U,3,6),PRCSOT=PRCSOT+$P(^(0),U,5) X "I IOSL-$Y<5 D HOLD^PRCSD11 Q:Z3=U D NEWP^PRCSD11,HDR1" D DR1
W !,L Q:$D(PRCSX)
OB1 W !!,"The following 1358 obligation/adjustment request is ready for processing:"
S X=$P(^PRCS(410,DA,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(^(4),U,8),0,2) W !,L G P
PO1 I $D(^PRCS(410,DA,10)) S PRCSY=$P(^(10),U,3) I PRCSY,$D(^PRC(442,PRCSY,0)) D PO11
Q
PO11 K ^TMP("PRCSR",$J) D HDR F J=1:1 S PRCSX=$O(^PRC(424,"AD",PRCSY,PRCSX)) Q:PRCSX'>0 I $D(^PRC(424,PRCSX,0)),"SF"[$P(^(0),U,4) S Z1=$P(^(0),U,6,10) I Z1 S ^TMP("PRCSR",$J,$S($P(Z1,U,2)]"":$P(Z1,U,2),1:"NONE"),PRCSX)=Z1
S PRCSXX="" F J=1:1 S PRCSXX=$O(^TMP("PRCSR",$J,PRCSXX)) Q:PRCSXX="" D PO12
K ^TMP("PRCSR",$J) Q
PO12 S (CAT,CET)="",PRCSX=0 F JJ=1:1 S PRCSX=$O(^TMP("PRCSR",$J,PRCSXX,PRCSX)) Q:PRCSX'>0 S Z1=^TMP("PRCSR",$J,PRCSXX,PRCSX),Y=$P(Z1,U) D T X "I IOSL-$Y<3 D HOLD^PRCSD11 Q:Z3=U D NEWP^PRCSD11,HDR" D PO2
S CT=$S(CAT:CT+CAT,1:CT+CET) W !?47,"$",$J(CT,9,2) K A,E,CAT,CET
Q
PO2 W !,Y,?7,$P($P(^PRC(424,PRCSX,0),U),"-",3),?12,$P(Z1,U,2),?26,"$"
S E=$P(Z1,U,5),A=$P(Z1,U,3),UT=UT+$P(Z1,U,4),AT=AT+A,ET=ET+E,CAT=CAT+A,CET=CET+E
I '$D(Z1) S Z1=^TMP("PRCSR",$J,PRCSXX,PRCSX)
;the naked reference below refers to ^PRC(424,PRCSX,0)
W $J(E,9,2),?38,$J(A,9,2),?59,"$",$J($P(Z1,U,4),9,2) I $D(PRCSA) W !,?15,$P(^(0),U,14)
Q
P W:Z3'=U !!,"VA FORM 4-1358a-ADP (NOV 1987)",! Q
DR1 I '$D(Z1) S Z1=^TMP("PRCSR",$J,PRCSXX,PRCSX)
;the naked reference below refers to ^PRC(424,PRCSX,0)
S Y=$P(Z1,U,4) D T W !,Y,?7,$P($P(^(0),U),"-",3),?13,$S($D(^PRCS(410,+$P(Z1,U,1),0)):$P(^(0),U,1),1:""),?36,"$",$J($P(Z1,U,3),9,2) W:$D(PRCSX) ?56,"$",$J(PRCSOT,9,2) Q
HDR W !,"AUTHORIZATION & ORDER RECORD",?59,"LIQUIDATION RECORD"
W !,?28,"INDIVIDUAL/DAILY",!,"DATE",?7,"SEQ#",?14,"REFERENCE",?28,"ESTIMATED",?39,"ACTUAL",?47,"CUMULATIVE",?60,"LIQUID",?71,"UNLIQ 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 ;_"/"_$E(Y,2,3)_$S(Y[".":" "_$E($P(Y,".",2)_"0000",1,2)_":"_$E($P(Y,".",2)_"0000",3,4),1:"") Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCSD111 2975 printed Oct 16, 2024@18:18:05 Page 2
PRCSD111 ;WISC/SAW-CONTROL POINT ACTIVITY 1358 DISPLAY CON'T ;3-19-91/15:34
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 SET Z=$SELECT($DATA(PRCSPO):PRC("SITE")_"-"_PRCSPO,1:0)
+3 IF 'Z!('$DATA(^PRC(424,"AC",Z)))
WRITE !,"Daily Record entries have not yet been entered for this request.",!,"The total committed cost of this request is $"
if $DATA(^PRCS(410,DA,4))
WRITE $JUSTIFY($PIECE(^(4),U),0,2)
WRITE !,L
GOTO P
+4 DO HDR1
SET PRCSX=0
DO OB
SET (ET,AT,UT,CT)=""
DO PO1
WRITE !!,?7,"TOTALS",?26,"$",$JUSTIFY(ET,9,2),?38,$JUSTIFY(AT,9,2),?70,"$",$JUSTIFY((PRCSOT-UT),9,2)
KILL PRCSX,PRCSOT,UT,CT,AT,ET,CAT,CET,PRCSR,PRCSX,PRCSXX,J,JJ
DO P
QUIT
OB ;DISPLAY ONLY OBLIGATIONS
+1 IF '$DATA(^PRC(424,"AC",Z))
GOTO OB1
+2 SET (PRCSOT,X1,UT)=""
FOR I=1:1
SET X1=$ORDER(^PRC(424,"AF",Z,X1))
if X1'>0
QUIT
IF $DATA(^PRC(424,X1,0))
SET Z1=$PIECE(^(0),U,3,6)
SET PRCSOT=PRCSOT+$PIECE(^(0),U,5)
XECUTE "I IOSL-$Y<5 D HOLD^PRCSD11 Q:Z3=U D NEWP^PRCSD11,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(^PRCS(410,DA,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(^(4),U,8),0,2)
WRITE !,L
GOTO P
PO1 IF $DATA(^PRCS(410,DA,10))
SET PRCSY=$PIECE(^(10),U,3)
IF PRCSY
IF $DATA(^PRC(442,PRCSY,0))
DO PO11
+1 QUIT
PO11 KILL ^TMP("PRCSR",$JOB)
DO HDR
FOR J=1:1
SET PRCSX=$ORDER(^PRC(424,"AD",PRCSY,PRCSX))
if PRCSX'>0
QUIT
IF $DATA(^PRC(424,PRCSX,0))
IF "SF"[$PIECE(^(0),U,4)
SET Z1=$PIECE(^(0),U,6,10)
IF Z1
SET ^TMP("PRCSR",$JOB,$SELECT($PIECE(Z1,U,2)]"":$PIECE(Z1,U,2),1:"NONE"),PRCSX)=Z1
+1 SET PRCSXX=""
FOR J=1:1
SET PRCSXX=$ORDER(^TMP("PRCSR",$JOB,PRCSXX))
if PRCSXX=""
QUIT
DO PO12
+2 KILL ^TMP("PRCSR",$JOB)
QUIT
PO12 SET (CAT,CET)=""
SET PRCSX=0
FOR JJ=1:1
SET PRCSX=$ORDER(^TMP("PRCSR",$JOB,PRCSXX,PRCSX))
if PRCSX'>0
QUIT
SET Z1=^TMP("PRCSR",$JOB,PRCSXX,PRCSX)
SET Y=$PIECE(Z1,U)
DO T
XECUTE "I IOSL-$Y<3 D HOLD^PRCSD11 Q:Z3=U D NEWP^PRCSD11,HDR"
DO PO2
+1 SET CT=$SELECT(CAT:CT+CAT,1:CT+CET)
WRITE !?47,"$",$JUSTIFY(CT,9,2)
KILL A,E,CAT,CET
+2 QUIT
PO2 WRITE !,Y,?7,$PIECE($PIECE(^PRC(424,PRCSX,0),U),"-",3),?12,$PIECE(Z1,U,2),?26,"$"
+1 SET E=$PIECE(Z1,U,5)
SET A=$PIECE(Z1,U,3)
SET UT=UT+$PIECE(Z1,U,4)
SET AT=AT+A
SET ET=ET+E
SET CAT=CAT+A
SET CET=CET+E
+2 IF '$DATA(Z1)
SET Z1=^TMP("PRCSR",$JOB,PRCSXX,PRCSX)
+3 ;the naked reference below refers to ^PRC(424,PRCSX,0)
+4 WRITE $JUSTIFY(E,9,2),?38,$JUSTIFY(A,9,2),?59,"$",$JUSTIFY($PIECE(Z1,U,4),9,2)
IF $DATA(PRCSA)
WRITE !,?15,$PIECE(^(0),U,14)
+5 QUIT
P if Z3'=U
WRITE !!,"VA FORM 4-1358a-ADP (NOV 1987)",!
QUIT
DR1 IF '$DATA(Z1)
SET Z1=^TMP("PRCSR",$JOB,PRCSXX,PRCSX)
+1 ;the naked reference below refers to ^PRC(424,PRCSX,0)
+2 SET Y=$PIECE(Z1,U,4)
DO T
WRITE !,Y,?7,$PIECE($PIECE(^(0),U),"-",3),?13,$SELECT($DATA(^PRCS(410,+$PIECE(Z1,U,1),0)):$PIECE(^(0),U,1),1:""),?36,"$",$JUSTIFY($PIECE(Z1,U,3),9,2)
if $DATA(PRCSX)
WRITE ?56,"$",$JUSTIFY(PRCSOT,9,2)
QUIT
HDR WRITE !,"AUTHORIZATION & ORDER RECORD",?59,"LIQUIDATION RECORD"
+1 WRITE !,?28,"INDIVIDUAL/DAILY",!,"DATE",?7,"SEQ#",?14,"REFERENCE",?28,"ESTIMATED",?39,"ACTUAL",?47,"CUMULATIVE",?60,"LIQUID",?71,"UNLIQ BAL"
WRITE !,L
QUIT
HDR1 WRITE !,"ESTIMATED OBLIGATION RECAP",!,"DATE",?7,"REF#",?13,"CPA#",?37,"AMOUNT",?57,"BALANCE"
QUIT
T ;_"/"_$E(Y,2,3)_$S(Y[".":" "_$E($P(Y,".",2)_"0000",1,2)_":"_$E($P(Y,".",2)_"0000",3,4),1:"") Q
SET Y=$EXTRACT(Y,4,5)_"/"_$EXTRACT(Y,6,7)
QUIT
