PRCSOUT ;WISC/KMB-OUTSTANDING APPROVED REQUESTS REPORT ;1-24-94 13:06
;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
START ;
N PAGE,XDA,I,J,LL,OUT,OUT1,LOOP,LOOP1,LOOP2,TODAY,TODAY1 S (OUT,OUT1,I)=1,(LOOP1,LOOP2,PAGE)=0
S (OUT,OUT1,I)=1,(LOOP1,LOOP2,PAGE)=0
W @IOF D EN1^PRCSUT G W1:'$D(PRC("SITE")),EXIT:Y<0
PROCESS ;
W @IOF D NOW^%DTC S TODAY=$P(%,"."),Y=% D DD^%DT S TODAY1=Y
W !,"Processing entries...",!
S LOOP=PRC("SITE")_"-"_PRC("FY")_"-"_PRC("QTR")_"-"_$P(PRC("CP")," "),LOOP1=LOOP_"-0000"
F I=0:1 S LOOP1=$O(^PRCS(410,"B",LOOP1)) Q:$P(LOOP1,"-",1,4)'=LOOP D
.S LOOP2=0 F S LOOP2=$O(^PRCS(410,"B",LOOP1,LOOP2)) Q:LOOP2="" S XDA=LOOP2 D
..N ZEROTH,FIRST,SECOND,THIRD,FOURTH,FIFTH,SIXTH
..S FIFTH=$P($G(^PRCS(410,XDA,1)),"^",4) Q:FIFTH>TODAY
..S FIRST=$P($G(^PRCS(410,XDA,7)),"^",5) Q:FIRST=""
..Q:$P($G(^PRCS(410,XDA,0)),"^",2)'["O"
..S ZEROTH=$P($G(^PRCS(410,XDA,0)),"^"),SECOND=$P($G(^PRCS(410,XDA,9)),"^",2),THIRD=$P($G(^PRCS(410,XDA,2)),"^",1),FOURTH=$P($G(^PRCS(410,XDA,4)),"^",4)
..S SIXTH=$P($G(^PRCS(410,XDA,4)),"^",5)
..S ^TMP($J,I)=FIRST_"*"_SECOND_"*"_THIRD_"*"_FOURTH_"*"_FIFTH_"*"_SIXTH_"*"_ZEROTH_"*"_XDA
I '$D(^TMP($J)) U IO(0) W !,"No outstanding transactions found for this quarter.",! G START
WRITE ;
S %ZIS("B")="HOME",%ZIS="MQ" D ^%ZIS G EXIT:POP
S ZTSAVE("PRC*")="",ZTSAVE("OUT")="",ZTSAVE("I")="",ZTSAVE("TODAY1")="",ZTSAVE("PAGE")=""
I IO'=IO(0) S OUT1=0
I $D(IO("Q")) S ZTDESC="REQUEST REPORT",ZTRTN="WRITE1^PRCSOUT",ZTSAVE("OUT1")="",ZTSAVE("DA")="",ZTSAVE("^TMP($J,")="",ZTSAVE("D0")="" D ^%ZTLOAD D ^%ZISC,EXIT,WRITE2 G START
D WRITE1 D ^%ZISC,EXIT,WRITE2 G START
WRITE1 ;
U IO D HEADER F K=1:1:I-1 I $G(^TMP($J,K))'="" D
.Q:OUT=U D:IOSL-($Y#IOSL)<6 HOLD Q:OUT=U
.W !,?2,$P(^TMP($J,K),"*",7)
.S D0=$P(^TMP($J,K),"*",8) D:D0'="" STATUS^PRCSES W ?22,$E(X,1,25)
.W ?50,$E($P(^TMP($J,K),"*",3),1,30)
.W ! S Y=$P(^TMP($J,K),"*") D DD^%DT W Y
.S Y=$P(^TMP($J,K),"*",2) D DD^%DT W ?15,Y
.W ?35,$P(^TMP($J,K),"*",6)
.S Y=$P(^TMP($J,K),"*",4) D DD^%DT W ?50,Y
.S Y=$P(^TMP($J,K),"*",5) D DD^%DT W ?65,Y
I $D(ZTSK) D KILL^%ZTLOAD K ZTSK
Q
WRITE2 ;
U IO(0) W !!,"------------------",!,"End of processing",! H 2 Q
W1 W !!,"You are not an authorized control point user.",!,"Please contact your control point official." R I:5 G EXIT
S PAGE=PAGE+1
I PAGE'=1 W @IOF
W !,"OUTSTANDING APPROVED REQUEST REPORT - CP ",$P(PRC("CP")," "),?49,TODAY1,?72,"PAGE ",PAGE
W !!,"TRANSACTION NUMBER",?22,"TRANSACTION STATUS",?50,"VENDOR"
W !,"DATE SIGNED",?15,"EST. DEL. DATE",?35,"PO #",?50,"DATE OBL.",?65,"DATE REQ."
S LL="",$P(LL,"-",IOM)="-" W !,LL S LL="" Q
HOLD ;
G HEADER:IO'=IO(0),HEADER:$D(ZTQUEUED) W !,"Press return to continue, uparrow (^) to exit: " R OUT:100 S:'$T OUT=U D:OUT'=U HEADER Q
EXIT K ^TMP($J),PRCS Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCSOUT 2887 printed Nov 22, 2024@17:27:56 Page 2
PRCSOUT ;WISC/KMB-OUTSTANDING APPROVED REQUESTS REPORT ;1-24-94 13:06
+1 ;;5.1;IFCAP;;Oct 20, 2000
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
START ;
+1 NEW PAGE,XDA,I,J,LL,OUT,OUT1,LOOP,LOOP1,LOOP2,TODAY,TODAY1
SET (OUT,OUT1,I)=1
SET (LOOP1,LOOP2,PAGE)=0
+2 SET (OUT,OUT1,I)=1
SET (LOOP1,LOOP2,PAGE)=0
+3 WRITE @IOF
DO EN1^PRCSUT
if '$DATA(PRC("SITE"))
GOTO W1
if Y<0
GOTO EXIT
PROCESS ;
+1 WRITE @IOF
DO NOW^%DTC
SET TODAY=$PIECE(%,".")
SET Y=%
DO DD^%DT
SET TODAY1=Y
+2 WRITE !,"Processing entries...",!
+3 SET LOOP=PRC("SITE")_"-"_PRC("FY")_"-"_PRC("QTR")_"-"_$PIECE(PRC("CP")," ")
SET LOOP1=LOOP_"-0000"
+4 FOR I=0:1
SET LOOP1=$ORDER(^PRCS(410,"B",LOOP1))
if $PIECE(LOOP1,"-",1,4)'=LOOP
QUIT
Begin DoDot:1
+5 SET LOOP2=0
FOR
SET LOOP2=$ORDER(^PRCS(410,"B",LOOP1,LOOP2))
if LOOP2=""
QUIT
SET XDA=LOOP2
Begin DoDot:2
+6 NEW ZEROTH,FIRST,SECOND,THIRD,FOURTH,FIFTH,SIXTH
+7 SET FIFTH=$PIECE($GET(^PRCS(410,XDA,1)),"^",4)
if FIFTH>TODAY
QUIT
+8 SET FIRST=$PIECE($GET(^PRCS(410,XDA,7)),"^",5)
if FIRST=""
QUIT
+9 if $PIECE($GET(^PRCS(410,XDA,0)),"^",2)'["O"
QUIT
+10 SET ZEROTH=$PIECE($GET(^PRCS(410,XDA,0)),"^")
SET SECOND=$PIECE($GET(^PRCS(410,XDA,9)),"^",2)
SET THIRD=$PIECE($GET(^PRCS(410,XDA,2)),"^",1)
SET FOURTH=$PIECE($GET(^PRCS(410,XDA,4)),"^",4)
+11 SET SIXTH=$PIECE($GET(^PRCS(410,XDA,4)),"^",5)
+12 SET ^TMP($JOB,I)=FIRST_"*"_SECOND_"*"_THIRD_"*"_FOURTH_"*"_FIFTH_"*"_SIXTH_"*"_ZEROTH_"*"_XDA
End DoDot:2
End DoDot:1
+13 IF '$DATA(^TMP($JOB))
USE IO(0)
WRITE !,"No outstanding transactions found for this quarter.",!
GOTO START
WRITE ;
+1 SET %ZIS("B")="HOME"
SET %ZIS="MQ"
DO ^%ZIS
if POP
GOTO EXIT
+2 SET ZTSAVE("PRC*")=""
SET ZTSAVE("OUT")=""
SET ZTSAVE("I")=""
SET ZTSAVE("TODAY1")=""
SET ZTSAVE("PAGE")=""
+3 IF IO'=IO(0)
SET OUT1=0
+4 IF $DATA(IO("Q"))
SET ZTDESC="REQUEST REPORT"
SET ZTRTN="WRITE1^PRCSOUT"
SET ZTSAVE("OUT1")=""
SET ZTSAVE("DA")=""
SET ZTSAVE("^TMP($J,")=""
SET ZTSAVE("D0")=""
DO ^%ZTLOAD
DO ^%ZISC
DO EXIT
DO WRITE2
GOTO START
+5 DO WRITE1
DO ^%ZISC
DO EXIT
DO WRITE2
GOTO START
WRITE1 ;
+1 USE IO
DO HEADER
FOR K=1:1:I-1
IF $GET(^TMP($JOB,K))'=""
Begin DoDot:1
+2 if OUT=U
QUIT
if IOSL-($Y#IOSL)<6
DO HOLD
if OUT=U
QUIT
+3 WRITE !,?2,$PIECE(^TMP($JOB,K),"*",7)
+4 SET D0=$PIECE(^TMP($JOB,K),"*",8)
if D0'=""
DO STATUS^PRCSES
WRITE ?22,$EXTRACT(X,1,25)
+5 WRITE ?50,$EXTRACT($PIECE(^TMP($JOB,K),"*",3),1,30)
+6 WRITE !
SET Y=$PIECE(^TMP($JOB,K),"*")
DO DD^%DT
WRITE Y
+7 SET Y=$PIECE(^TMP($JOB,K),"*",2)
DO DD^%DT
WRITE ?15,Y
+8 WRITE ?35,$PIECE(^TMP($JOB,K),"*",6)
+9 SET Y=$PIECE(^TMP($JOB,K),"*",4)
DO DD^%DT
WRITE ?50,Y
+10 SET Y=$PIECE(^TMP($JOB,K),"*",5)
DO DD^%DT
WRITE ?65,Y
End DoDot:1
+11 IF $DATA(ZTSK)
DO KILL^%ZTLOAD
KILL ZTSK
+12 QUIT
WRITE2 ;
+1 USE IO(0)
WRITE !!,"------------------",!,"End of processing",!
HANG 2
QUIT
W1 WRITE !!,"You are not an authorized control point user.",!,"Please contact your control point official."
READ I:5
GOTO EXIT
+1 SET PAGE=PAGE+1
+2 IF PAGE'=1
WRITE @IOF
+3 WRITE !,"OUTSTANDING APPROVED REQUEST REPORT - CP ",$PIECE(PRC("CP")," "),?49,TODAY1,?72,"PAGE ",PAGE
+4 WRITE !!,"TRANSACTION NUMBER",?22,"TRANSACTION STATUS",?50,"VENDOR"
+5 WRITE !,"DATE SIGNED",?15,"EST. DEL. DATE",?35,"PO #",?50,"DATE OBL.",?65,"DATE REQ."
+6 SET LL=""
SET $PIECE(LL,"-",IOM)="-"
WRITE !,LL
SET LL=""
QUIT
HOLD ;
+1 if IO'=IO(0)
GOTO HEADER
if $DATA(ZTQUEUED)
GOTO HEADER
WRITE !,"Press return to continue, uparrow (^) to exit: "
READ OUT:100
if '$TEST
SET OUT=U
if OUT'=U
DO HEADER
QUIT
EXIT KILL ^TMP($JOB),PRCS
QUIT
