- 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 Apr 23, 2025@18:32:30 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
