PRCSP13 ;BOISE/TKE,WISC/SAW-CPA PRINTS CON'T-TRANSACTION STATUS REPORT ;7/26/13 15:22
V ;;5.1;IFCAP;**174**;Oct 20, 2000;Build 23
;Per VHA Directive 10-93-142, this routine should not be modified.
U IO S U="^",PRCS0=$S($D(^PRCS(410,DA,0)):^(0),1:""),PRCSS=IOSL-2
S PRCSTC=$P(PRCS0,"^",2),PRCSTP="" I PRCSTC'="" S X=$P(^DD(410,1,0),U,3) F I=1:1 S Y=$P(X,";",I) Q:Y="" I $P(Y,":")=PRCSTC S PRCSTP=$P(Y,":",2) Q
S PRCSEX="" D HDR
CA I PRCSTC="CA" D G EX
. I $P($G(^PRCS(410,DA,1)),U,9)>0 D
. . N PRCDATA,PRCIEN S PRCIEN=DA_"," D GETS^DIQ(410,PRCIEN,"104;105","E","PRCDATA")
. . W !,"Cancel By: ",PRCDATA(410,PRCIEN,104,"E"),?49,"Cancel Dt: ",$TR($P(PRCDATA(410,PRCIEN,105,"E"),":",1,2),"@"," ")
. . S PRCSDY=PRCSDY+1
. W ! S PRCSDY=PRCSDY+1 D COM^PRCSP131
C G A:PRCSTC="A",O:PRCSTC="O" S PRCS6=$S($D(^PRCS(410,DA,6)):^(6),1:"")
W !,"Ceiling $ Amount: $",$J(+$P(PRCS6,U),0,2),?41,"Date Allocated: " S Y=$P(PRCS6,U,2) X:Y ^DD("DD") W Y
W !,"Fund Control Point Dist. No.: ",$P(PRCS6,U,3) S PRCS6=$S($D(^PRCS(410,DA,4)):^(4),1:"") W !,"Reference Number: ",$P(PRCS6,U,5) K PRCS6 D ACC S PRCSDY=8 D COM^PRCSP131 G EX
A D VND
S PRCS4=$S($D(^PRCS(410,DA,4)):^(4),1:"") W !,"Purchase Order/Obligation No.: ",$P(PRCS4,U,5),?41,"Adjustment $ Amount: $",$J($P(PRCS4,U,6),0,2)
S Y=$P(PRCS4,U,7) X:Y ^DD("DD") W !,"Date Obl.Adjusted: ",Y K PRCS4
D ACC S X=$S($D(^PRCS(410,DA,11)):$P(^(11),U),1:"") S:$P(X,";") X=$P(X,";",2)_$P(X,";"),X="^"_X_",0)",X=$S($D(@X):$P(^(0),U),1:"") W !,"Sort Group: ",X
S PRCS1=$S($D(^PRCS(410,DA,1)):^(1),1:"") W ?41,"Classification of Request: " S X=$S($D(^PRCS(410.2,+$P(PRCS1,U,5),0)):$E($P(^(0),U),1,22),1:"") W X K PRCS1
S PRCSDY=4 D SUBC^PRCSP132 G EX:PRCSEX[U D:PRCSDY>(PRCSS-4) S G EX:PRCSEX[U
S PRCSDY=PRCSDY+5 D:PRCSDY>(PRCSS-1) S G EX:PRCSEX[U D COM^PRCSP131 G EX
O ;
S D0=DA D STATUS^PRCSES W !,"A&MM Status: ",X I $D(^PRCS(410,DA,10)),$D(^PRC(442,+$P(^(10),U,3),1)),$D(^VA(200,+$P(^(1),U,10),20)) W ?41,"PA/PPM: ",$P(^(20),U,2)
W !,"Temporary Trans. Number: ",$P(PRCS0,U,3) W:'PRCS0 ?41,"Control Point: ",$E($P(^PRCS(410,DA,3),U),1,24)
W !,"Form Type: ",$S($D(^PRCS(410.5,+$P(PRCS0,U,4),0)):$P(^(0),U),1:"") I $P(PRCS0,U,4)=1,$P(PRCS0,U,8) W ?41,"Month of 1358: ",$P("JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC",U,$P(PRCS0,U,8))
S PRCS1=$S($D(^PRCS(410,DA,1)):^(1),1:"") W !,"Date of Request: " S Y=$P(PRCS1,U) X:Y ^DD("DD") W Y W ?41,"Date Required: " S Y=$P(PRCS1,U,4) X:Y ^DD("DD") W Y
S PRCS9=$S($D(^PRCS(410,DA,9)):^(9),1:"") W !,"Est. Delivery Date: " S Y=$P(PRCS9,U,2) X:Y ^DD("DD") W Y W ?41,"Date Received: " S Y=$P(PRCS9,U,3) X:Y ^DD("DD") W Y
D VND S PRCS4=$S($D(^PRCS(410,DA,4)):^(4),1:"")
W !,"Committed (Estimated) Cost: $",$J($P(PRCS4,U),0,2),?41,"Date Committed: " S Y=$P(PRCS4,U,2) X:Y ^DD("DD") W Y
W !,"Obligated (Actual) Cost: $",$J($P(PRCS4,U,3),0,2),?41,"Date Obligated: " S Y=$P(PRCS4,U,4) X:Y ^DD("DD") W Y
W !,"Purchase Order/Obligation No.: ",$P(PRCS4,U,5) K PRCS4
D ACC W !,"Return to Service Comments:" W:$D(^PRCS(410,DA,13,1,0)) $E(^(0),1,80),! W !,"Comments:" W:$D(^PRCS(410,DA,"CO",1,0)) $E(^(0),1,80),! S PRCSDY=20 D ^PRCSP131,^PRCSP133 G EX
VND W !,"Vendor: ",$S($D(^PRCS(410,DA,2)):$E($P(^(2),U),1,30),1:"")
S PRCSVND=$S($D(^PRC(442,+$S($D(^PRCS(410,DA,10)):$P(^(10),U,3),1:""),1)):$P(^(1),U),1:"") I $D(^PRCS(410,DA,3)),$P(^(3),U,4)'=PRCSVND W ?41,"P.O. Vendor: ",$S($D(^PRC(440,+PRCSVND,0)):$E($P(^(0),U),1,20),1:"")
Q
ACC W ?41,"Accounting Data: ",$S($D(^PRCS(410,DA,3)):$P(^(3),U,2),1:"")
S PRCS5=$S($D(^PRCS(410,DA,5)):^(5),1:"") W !,"FMS $ Amount: $",$J($P(PRCS5,U),0,2) S Y=$P(PRCS5,U,2) X:Y ^DD("DD") W ?41,"FMS Date: ",Y W !,"FMS Transaction Code: ",$P(PRCS5,U,3) K PRCS5 Q
HDR W @IOF D NOW^%DTC S Y=% X:Y ^DD("DD") W ?10,PRCSTP," TRANSACTION STATUS DISPLAY ",Y,!!
W "Transaction Number: ",$P(PRCS0,U),?41,"Transaction Type: ",PRCSTP S X="",PRCSDY=3 Q
S Q:$D(ZTQUEUED) G S2:$E(IOST)'="C" F L=PRCSDY:1:PRCSS W !
W !,"Press return to continue or ""^"" to escape" R X:DTIME S:'$T X="^" S PRCSEX=X Q:X[U
S2 D HDR Q
EX D:$D(ZTSK) KILL^%ZTLOAD K ZTSK
EXIT K PRCS0,PRCSTC,PRCSTP,PRCSI,PRCSJ,PRCSEX,DA,PRCSS,PRCSDY,DIWL,DIWR,DIWF,I,J,L,X,Y,Z,^TMP($J) D ^%ZISC Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCSP13 4217 printed Oct 16, 2024@18:18:44 Page 2
PRCSP13 ;BOISE/TKE,WISC/SAW-CPA PRINTS CON'T-TRANSACTION STATUS REPORT ;7/26/13 15:22
V ;;5.1;IFCAP;**174**;Oct 20, 2000;Build 23
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 USE IO
SET U="^"
SET PRCS0=$SELECT($DATA(^PRCS(410,DA,0)):^(0),1:"")
SET PRCSS=IOSL-2
+3 SET PRCSTC=$PIECE(PRCS0,"^",2)
SET PRCSTP=""
IF PRCSTC'=""
SET X=$PIECE(^DD(410,1,0),U,3)
FOR I=1:1
SET Y=$PIECE(X,";",I)
if Y=""
QUIT
IF $PIECE(Y,":")=PRCSTC
SET PRCSTP=$PIECE(Y,":",2)
QUIT
+4 SET PRCSEX=""
DO HDR
CA IF PRCSTC="CA"
Begin DoDot:1
+1 IF $PIECE($GET(^PRCS(410,DA,1)),U,9)>0
Begin DoDot:2
+2 NEW PRCDATA,PRCIEN
SET PRCIEN=DA_","
DO GETS^DIQ(410,PRCIEN,"104;105","E","PRCDATA")
+3 WRITE !,"Cancel By: ",PRCDATA(410,PRCIEN,104,"E"),?49,"Cancel Dt: ",$TRANSLATE($PIECE(PRCDATA(410,PRCIEN,105,"E"),":",1,2),"@"," ")
+4 SET PRCSDY=PRCSDY+1
End DoDot:2
+5 WRITE !
SET PRCSDY=PRCSDY+1
DO COM^PRCSP131
End DoDot:1
GOTO EX
C if PRCSTC="A"
GOTO A
if PRCSTC="O"
GOTO O
SET PRCS6=$SELECT($DATA(^PRCS(410,DA,6)):^(6),1:"")
+1 WRITE !,"Ceiling $ Amount: $",$JUSTIFY(+$PIECE(PRCS6,U),0,2),?41,"Date Allocated: "
SET Y=$PIECE(PRCS6,U,2)
if Y
XECUTE ^DD("DD")
WRITE Y
+2 WRITE !,"Fund Control Point Dist. No.: ",$PIECE(PRCS6,U,3)
SET PRCS6=$SELECT($DATA(^PRCS(410,DA,4)):^(4),1:"")
WRITE !,"Reference Number: ",$PIECE(PRCS6,U,5)
KILL PRCS6
DO ACC
SET PRCSDY=8
DO COM^PRCSP131
GOTO EX
A DO VND
+1 SET PRCS4=$SELECT($DATA(^PRCS(410,DA,4)):^(4),1:"")
WRITE !,"Purchase Order/Obligation No.: ",$PIECE(PRCS4,U,5),?41,"Adjustment $ Amount: $",$JUSTIFY($PIECE(PRCS4,U,6),0,2)
+2 SET Y=$PIECE(PRCS4,U,7)
if Y
XECUTE ^DD("DD")
WRITE !,"Date Obl.Adjusted: ",Y
KILL PRCS4
+3 DO ACC
SET X=$SELECT($DATA(^PRCS(410,DA,11)):$PIECE(^(11),U),1:"")
if $PIECE(X,";")
SET X=$PIECE(X,";",2)_$PIECE(X,";")
SET X="^"_X_",0)"
SET X=$SELECT($DATA(@X):$PIECE(^(0),U),1:"")
WRITE !,"Sort Group: ",X
+4 SET PRCS1=$SELECT($DATA(^PRCS(410,DA,1)):^(1),1:"")
WRITE ?41,"Classification of Request: "
SET X=$SELECT($DATA(^PRCS(410.2,+$PIECE(PRCS1,U,5),0)):$EXTRACT($PIECE(^(0),U),1,22),1:"")
WRITE X
KILL PRCS1
+5 SET PRCSDY=4
DO SUBC^PRCSP132
if PRCSEX[U
GOTO EX
if PRCSDY>(PRCSS-4)
DO S
if PRCSEX[U
GOTO EX
+6 SET PRCSDY=PRCSDY+5
if PRCSDY>(PRCSS-1)
DO S
if PRCSEX[U
GOTO EX
DO COM^PRCSP131
GOTO EX
O ;
+1 SET D0=DA
DO STATUS^PRCSES
WRITE !,"A&MM Status: ",X
IF $DATA(^PRCS(410,DA,10))
IF $DATA(^PRC(442,+$PIECE(^(10),U,3),1))
IF $DATA(^VA(200,+$PIECE(^(1),U,10),20))
WRITE ?41,"PA/PPM: ",$PIECE(^(20),U,2)
+2 WRITE !,"Temporary Trans. Number: ",$PIECE(PRCS0,U,3)
if 'PRCS0
WRITE ?41,"Control Point: ",$EXTRACT($PIECE(^PRCS(410,DA,3),U),1,24)
+3 WRITE !,"Form Type: ",$SELECT($DATA(^PRCS(410.5,+$PIECE(PRCS0,U,4),0)):$PIECE(^(0),U),1:"")
IF $PIECE(PRCS0,U,4)=1
IF $PIECE(PRCS0,U,8)
WRITE ?41,"Month of 1358: ",$PIECE("JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC",U,$PIECE(PRCS0,U,8))
+4 SET PRCS1=$SELECT($DATA(^PRCS(410,DA,1)):^(1),1:"")
WRITE !,"Date of Request: "
SET Y=$PIECE(PRCS1,U)
if Y
XECUTE ^DD("DD")
WRITE Y
WRITE ?41,"Date Required: "
SET Y=$PIECE(PRCS1,U,4)
if Y
XECUTE ^DD("DD")
WRITE Y
+5 SET PRCS9=$SELECT($DATA(^PRCS(410,DA,9)):^(9),1:"")
WRITE !,"Est. Delivery Date: "
SET Y=$PIECE(PRCS9,U,2)
if Y
XECUTE ^DD("DD")
WRITE Y
WRITE ?41,"Date Received: "
SET Y=$PIECE(PRCS9,U,3)
if Y
XECUTE ^DD("DD")
WRITE Y
+6 DO VND
SET PRCS4=$SELECT($DATA(^PRCS(410,DA,4)):^(4),1:"")
+7 WRITE !,"Committed (Estimated) Cost: $",$JUSTIFY($PIECE(PRCS4,U),0,2),?41,"Date Committed: "
SET Y=$PIECE(PRCS4,U,2)
if Y
XECUTE ^DD("DD")
WRITE Y
+8 WRITE !,"Obligated (Actual) Cost: $",$JUSTIFY($PIECE(PRCS4,U,3),0,2),?41,"Date Obligated: "
SET Y=$PIECE(PRCS4,U,4)
if Y
XECUTE ^DD("DD")
WRITE Y
+9 WRITE !,"Purchase Order/Obligation No.: ",$PIECE(PRCS4,U,5)
KILL PRCS4
+10 DO ACC
WRITE !,"Return to Service Comments:"
if $DATA(^PRCS(410,DA,13,1,0))
WRITE $EXTRACT(^(0),1,80),!
WRITE !,"Comments:"
if $DATA(^PRCS(410,DA,"CO",1,0))
WRITE $EXTRACT(^(0),1,80),!
SET PRCSDY=20
DO ^PRCSP131
DO ^PRCSP133
GOTO EX
VND WRITE !,"Vendor: ",$SELECT($DATA(^PRCS(410,DA,2)):$EXTRACT($PIECE(^(2),U),1,30),1:"")
+1 SET PRCSVND=$SELECT($DATA(^PRC(442,+$SELECT($DATA(^PRCS(410,DA,10)):$PIECE(^(10),U,3),1:""),1)):$PIECE(^(1),U),1:"")
IF $DATA(^PRCS(410,DA,3))
IF $PIECE(^(3),U,4)'=PRCSVND
WRITE ?41,"P.O. Vendor: ",$SELECT($DATA(^PRC(440,+PRCSVND,0)):$EXTRACT($PIECE(^(0),U),1,20),1:"")
+2 QUIT
ACC WRITE ?41,"Accounting Data: ",$SELECT($DATA(^PRCS(410,DA,3)):$PIECE(^(3),U,2),1:"")
+1 SET PRCS5=$SELECT($DATA(^PRCS(410,DA,5)):^(5),1:"")
WRITE !,"FMS $ Amount: $",$JUSTIFY($PIECE(PRCS5,U),0,2)
SET Y=$PIECE(PRCS5,U,2)
if Y
XECUTE ^DD("DD")
WRITE ?41,"FMS Date: ",Y
WRITE !,"FMS Transaction Code: ",$PIECE(PRCS5,U,3)
KILL PRCS5
QUIT
HDR WRITE @IOF
DO NOW^%DTC
SET Y=%
if Y
XECUTE ^DD("DD")
WRITE ?10,PRCSTP," TRANSACTION STATUS DISPLAY ",Y,!!
+1 WRITE "Transaction Number: ",$PIECE(PRCS0,U),?41,"Transaction Type: ",PRCSTP
SET X=""
SET PRCSDY=3
QUIT
S if $DATA(ZTQUEUED)
QUIT
if $EXTRACT(IOST)'="C"
GOTO S2
FOR L=PRCSDY:1:PRCSS
WRITE !
+1 WRITE !,"Press return to continue or ""^"" to escape"
READ X:DTIME
if '$TEST
SET X="^"
SET PRCSEX=X
if X[U
QUIT
S2 DO HDR
QUIT
EX if $DATA(ZTSK)
DO KILL^%ZTLOAD
KILL ZTSK
EXIT KILL PRCS0,PRCSTC,PRCSTP,PRCSI,PRCSJ,PRCSEX,DA,PRCSS,PRCSDY,DIWL,DIWR,DIWF,I,J,L,X,Y,Z,^TMP($JOB)
DO ^%ZISC
QUIT
