PRCSP1A2 ;WISC/KMB-PPM STATUS OF TRANSACTIONS ; 7/10/01 2:16pm
;;5.1;IFCAP;**31**;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
START ;
N ARRAY,ENTRY,ENTRY1,TEST,P,P1,PP,A,B,D0,I,PRCZ,Z1,%
D EN1^PRCSUT G W2:'$D(PRC("SITE")),EXIT:Y<0 S PRCZ=Z
S (A,Z1,P1)=1,(P,PP)=0 D NOW^%DTC S Y=% D DD^%DT S YY=Y
S P1=PRCZ F S P1=$O(^PRCS(410,"B",P1)) Q:$P(P1,"-",1,4)'=PRCZ D
.S PP=$O(^PRCS(410,"B",P1,0)) Q:PP="" I $P($G(^PRCS(410,PP,0)),"^",2)="O" S D0=PP D STATUS^PRCSES Q:X?.3N D
..I (X["PPM")!(X["Sig.")!(X["Prop.")!(X["Imprest") S ARRAY(A)=PP_"^"_X,A=A+1
I $G(ARRAY(1))="" W !!,"No transactions found.",!! G START
S %ZIS("B")="HOME",%ZIS="MQ" D ^%ZIS Q:POP
I $D(IO("Q")) S ZTRTN="PROCESS^PRCSP1A2",ZTDESC="PPM STATUS OF TRANSACTIONS",ZTSAVE("YY")="",ZTSAVE("P")="",ZTSAVE("PRC*")="",ZTSAVE("ARRAY*")="",ZTSAVE("A")="",ZTSAVE("Z1")="" D ^%ZTLOAD G START
D PROCESS,END G START
PROCESS ;
U IO S B=A-1 D HDR F I=1:1:B D WRITE I IOSL-($Y#IOSL)<6 D HOLD Q:Z1[U
D ^%ZISC Q
WRITE S PP=$P(ARRAY(I),"^"),TEST=$P(ARRAY(I),"^",2) D
.W !,$P($G(^PRCS(410,PP,0)),"^"),?20,$P($G(^(4)),"^",5),?30,"$",$P($G(^(4)),"^") I $P($G(^(4)),"^",3)'="" W ?42,"$",$P($G(^(4)),"^",3)
.S Y=$P($G(^PRCS(410,PP,1)),"^",4) X:Y ^DD("DD") W ?56,Y
.S Y=$P($G(^PRCS(410,PP,4)),"^",4) X:Y ^DD("DD") W ?68,Y
.S ENTRY=$P($G(^PRCS(410,PP,7)),"^"),ENTRY1=$P($G(^PRCS(410,PP,11)),"^",2)
.W:ENTRY'="" !,$P($G(^VA(200,ENTRY,0)),"^")
.W:ENTRY1'="" ?40,$P($G(^VA(200,ENTRY1,0)),"^")
.W !,?30,$P(ARRAY(I),"^",2),!
Q
;
END U IO(0) W !!,"END OF REPORT",!!
K ARRAY
Q
HOLD G HDR:IOSL'=24 W !,"Press return to continue, '^' to exit: " R Z1:10 S:'$T Z1=U D:Z1'=U HDR Q
HDR S P=P+1 W @IOF,"PPM TRANSACTION STATUS REPORT - CP ",$P(PRC("CP")," "),?50,YY,?73," PAGE ",P,!
W !,?20,"PO/OBL#",?30,"COMM.",?42,"OBLIG.",!,"2237#",?30,"(EST) COST",?42,"(ACT) COST",?56,"DATE REQ.",?68,"DATE OBL."
W !,"REQUESTOR",?40,"ORIGINATOR OF REQUEST"
W !,?30,"STATUS" S L="",$P(L,"-",IOM-1)="-" W !,L S L=" " Q
W2 ;
W !,"You are not an authorized control point user.",!,"Contact your control point official." R XXZ:5 G EXIT
EXIT K %ZIS,L,POP,ZTDESC,ZTRTN,ZTSAVE,YY,Y,X,Z,XXZ,PRC Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCSP1A2 2205 printed Sep 23, 2025@19:54:10 Page 2
PRCSP1A2 ;WISC/KMB-PPM STATUS OF TRANSACTIONS ; 7/10/01 2:16pm
+1 ;;5.1;IFCAP;**31**;Oct 20, 2000
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
START ;
+1 NEW ARRAY,ENTRY,ENTRY1,TEST,P,P1,PP,A,B,D0,I,PRCZ,Z1,%
+2 DO EN1^PRCSUT
if '$DATA(PRC("SITE"))
GOTO W2
if Y<0
GOTO EXIT
SET PRCZ=Z
+3 SET (A,Z1,P1)=1
SET (P,PP)=0
DO NOW^%DTC
SET Y=%
DO DD^%DT
SET YY=Y
+4 SET P1=PRCZ
FOR
SET P1=$ORDER(^PRCS(410,"B",P1))
if $PIECE(P1,"-",1,4)'=PRCZ
QUIT
Begin DoDot:1
+5 SET PP=$ORDER(^PRCS(410,"B",P1,0))
if PP=""
QUIT
IF $PIECE($GET(^PRCS(410,PP,0)),"^",2)="O"
SET D0=PP
DO STATUS^PRCSES
if X?.3N
QUIT
Begin DoDot:2
+6 IF (X["PPM")!(X["Sig.")!(X["Prop.")!(X["Imprest")
SET ARRAY(A)=PP_"^"_X
SET A=A+1
End DoDot:2
End DoDot:1
+7 IF $GET(ARRAY(1))=""
WRITE !!,"No transactions found.",!!
GOTO START
+8 SET %ZIS("B")="HOME"
SET %ZIS="MQ"
DO ^%ZIS
if POP
QUIT
+9 IF $DATA(IO("Q"))
SET ZTRTN="PROCESS^PRCSP1A2"
SET ZTDESC="PPM STATUS OF TRANSACTIONS"
SET ZTSAVE("YY")=""
SET ZTSAVE("P")=""
SET ZTSAVE("PRC*")=""
SET ZTSAVE("ARRAY*")=""
SET ZTSAVE("A")=""
SET ZTSAVE("Z1")=""
DO ^%ZTLOAD
GOTO START
+10 DO PROCESS
DO END
GOTO START
PROCESS ;
+1 USE IO
SET B=A-1
DO HDR
FOR I=1:1:B
DO WRITE
IF IOSL-($Y#IOSL)<6
DO HOLD
if Z1[U
QUIT
+2 DO ^%ZISC
QUIT
WRITE SET PP=$PIECE(ARRAY(I),"^")
SET TEST=$PIECE(ARRAY(I),"^",2)
Begin DoDot:1
+1 WRITE !,$PIECE($GET(^PRCS(410,PP,0)),"^"),?20,$PIECE($GET(^(4)),"^",5),?30,"$",$PIECE($GET(^(4)),"^")
IF $PIECE($GET(^(4)),"^",3)'=""
WRITE ?42,"$",$PIECE($GET(^(4)),"^",3)
+2 SET Y=$PIECE($GET(^PRCS(410,PP,1)),"^",4)
if Y
XECUTE ^DD("DD")
WRITE ?56,Y
+3 SET Y=$PIECE($GET(^PRCS(410,PP,4)),"^",4)
if Y
XECUTE ^DD("DD")
WRITE ?68,Y
+4 SET ENTRY=$PIECE($GET(^PRCS(410,PP,7)),"^")
SET ENTRY1=$PIECE($GET(^PRCS(410,PP,11)),"^",2)
+5 if ENTRY'=""
WRITE !,$PIECE($GET(^VA(200,ENTRY,0)),"^")
+6 if ENTRY1'=""
WRITE ?40,$PIECE($GET(^VA(200,ENTRY1,0)),"^")
+7 WRITE !,?30,$PIECE(ARRAY(I),"^",2),!
End DoDot:1
+8 QUIT
+9 ;
END USE IO(0)
WRITE !!,"END OF REPORT",!!
+1 KILL ARRAY
+2 QUIT
HOLD if IOSL'=24
GOTO HDR
WRITE !,"Press return to continue, '^' to exit: "
READ Z1:10
if '$TEST
SET Z1=U
if Z1'=U
DO HDR
QUIT
HDR SET P=P+1
WRITE @IOF,"PPM TRANSACTION STATUS REPORT - CP ",$PIECE(PRC("CP")," "),?50,YY,?73," PAGE ",P,!
+1 WRITE !,?20,"PO/OBL#",?30,"COMM.",?42,"OBLIG.",!,"2237#",?30,"(EST) COST",?42,"(ACT) COST",?56,"DATE REQ.",?68,"DATE OBL."
+2 WRITE !,"REQUESTOR",?40,"ORIGINATOR OF REQUEST"
+3 WRITE !,?30,"STATUS"
SET L=""
SET $PIECE(L,"-",IOM-1)="-"
WRITE !,L
SET L=" "
QUIT
W2 ;
+1 WRITE !,"You are not an authorized control point user.",!,"Contact your control point official."
READ XXZ:5
GOTO EXIT
EXIT KILL %ZIS,L,POP,ZTDESC,ZTRTN,ZTSAVE,YY,Y,X,Z,XXZ,PRC
QUIT
