source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCSOUT.m@ 619

Last change on this file since 619 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 2.8 KB
Line 
1PRCSOUT ;WISC/KMB-OUTSTANDING APPROVED REQUESTS REPORT ;1-24-94 13:06
2 ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4START ;
5 N PAGE,XDA,I,J,LL,OUT,OUT1,LOOP,LOOP1,LOOP2,TODAY,TODAY1 S (OUT,OUT1,I)=1,(LOOP1,LOOP2,PAGE)=0
6 S (OUT,OUT1,I)=1,(LOOP1,LOOP2,PAGE)=0
7 W @IOF D EN1^PRCSUT G W1:'$D(PRC("SITE")),EXIT:Y<0
8PROCESS ;
9 W @IOF D NOW^%DTC S TODAY=$P(%,"."),Y=% D DD^%DT S TODAY1=Y
10 W !,"Processing entries...",!
11 S LOOP=PRC("SITE")_"-"_PRC("FY")_"-"_PRC("QTR")_"-"_$P(PRC("CP")," "),LOOP1=LOOP_"-0000"
12 F I=0:1 S LOOP1=$O(^PRCS(410,"B",LOOP1)) Q:$P(LOOP1,"-",1,4)'=LOOP D
13 .S LOOP2=0 F S LOOP2=$O(^PRCS(410,"B",LOOP1,LOOP2)) Q:LOOP2="" S XDA=LOOP2 D
14 ..N ZEROTH,FIRST,SECOND,THIRD,FOURTH,FIFTH,SIXTH
15 ..S FIFTH=$P($G(^PRCS(410,XDA,1)),"^",4) Q:FIFTH>TODAY
16 ..S FIRST=$P($G(^PRCS(410,XDA,7)),"^",5) Q:FIRST=""
17 ..Q:$P($G(^PRCS(410,XDA,0)),"^",2)'["O"
18 ..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)
19 ..S SIXTH=$P($G(^PRCS(410,XDA,4)),"^",5)
20 ..S ^TMP($J,I)=FIRST_"*"_SECOND_"*"_THIRD_"*"_FOURTH_"*"_FIFTH_"*"_SIXTH_"*"_ZEROTH_"*"_XDA
21 I '$D(^TMP($J)) U IO(0) W !,"No outstanding transactions found for this quarter.",! G START
22WRITE ;
23 S %ZIS("B")="HOME",%ZIS="MQ" D ^%ZIS G EXIT:POP
24 S ZTSAVE("PRC*")="",ZTSAVE("OUT")="",ZTSAVE("I")="",ZTSAVE("TODAY1")="",ZTSAVE("PAGE")=""
25 I IO'=IO(0) S OUT1=0
26 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
27 D WRITE1 D ^%ZISC,EXIT,WRITE2 G START
28WRITE1 ;
29 U IO D HEADER F K=1:1:I-1 I $G(^TMP($J,K))'="" D
30 .Q:OUT=U D:IOSL-($Y#IOSL)<6 HOLD Q:OUT=U
31 .W !,?2,$P(^TMP($J,K),"*",7)
32 .S D0=$P(^TMP($J,K),"*",8) D:D0'="" STATUS^PRCSES W ?22,$E(X,1,25)
33 .W ?50,$E($P(^TMP($J,K),"*",3),1,30)
34 .W ! S Y=$P(^TMP($J,K),"*") D DD^%DT W Y
35 .S Y=$P(^TMP($J,K),"*",2) D DD^%DT W ?15,Y
36 .W ?35,$P(^TMP($J,K),"*",6)
37 .S Y=$P(^TMP($J,K),"*",4) D DD^%DT W ?50,Y
38 .S Y=$P(^TMP($J,K),"*",5) D DD^%DT W ?65,Y
39 I $D(ZTSK) D KILL^%ZTLOAD K ZTSK
40 Q
41WRITE2 ;
42 U IO(0) W !!,"------------------",!,"End of processing",! H 2 Q
43W1 W !!,"You are not an authorized control point user.",!,"Please contact your control point official." R I:5 G EXIT
44HEADER ;
45 S PAGE=PAGE+1
46 I PAGE'=1 W @IOF
47 W !,"OUTSTANDING APPROVED REQUEST REPORT - CP ",$P(PRC("CP")," "),?49,TODAY1,?72,"PAGE ",PAGE
48 W !!,"TRANSACTION NUMBER",?22,"TRANSACTION STATUS",?50,"VENDOR"
49 W !,"DATE SIGNED",?15,"EST. DEL. DATE",?35,"PO #",?50,"DATE OBL.",?65,"DATE REQ."
50 S LL="",$P(LL,"-",IOM)="-" W !,LL S LL="" Q
51HOLD ;
52 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
53EXIT K ^TMP($J),PRCS Q
Note: See TracBrowser for help on using the repository browser.