Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PRCSOUT

PRCSOUT.m

Go to the documentation of this file.
  1. PRCSOUT ;WISC/KMB-OUTSTANDING APPROVED REQUESTS REPORT ;1-24-94 13:06
  1. ;;5.1;IFCAP;;Oct 20, 2000
  1. ;Per VHA Directive 10-93-142, this routine should not be modified.
  1. START ;
  1. N PAGE,XDA,I,J,LL,OUT,OUT1,LOOP,LOOP1,LOOP2,TODAY,TODAY1 S (OUT,OUT1,I)=1,(LOOP1,LOOP2,PAGE)=0
  1. S (OUT,OUT1,I)=1,(LOOP1,LOOP2,PAGE)=0
  1. W @IOF D EN1^PRCSUT G W1:'$D(PRC("SITE")),EXIT:Y<0
  1. PROCESS ;
  1. W @IOF D NOW^%DTC S TODAY=$P(%,"."),Y=% D DD^%DT S TODAY1=Y
  1. W !,"Processing entries...",!
  1. S LOOP=PRC("SITE")_"-"_PRC("FY")_"-"_PRC("QTR")_"-"_$P(PRC("CP")," "),LOOP1=LOOP_"-0000"
  1. F I=0:1 S LOOP1=$O(^PRCS(410,"B",LOOP1)) Q:$P(LOOP1,"-",1,4)'=LOOP D
  1. .S LOOP2=0 F S LOOP2=$O(^PRCS(410,"B",LOOP1,LOOP2)) Q:LOOP2="" S XDA=LOOP2 D
  1. ..N ZEROTH,FIRST,SECOND,THIRD,FOURTH,FIFTH,SIXTH
  1. ..S FIFTH=$P($G(^PRCS(410,XDA,1)),"^",4) Q:FIFTH>TODAY
  1. ..S FIRST=$P($G(^PRCS(410,XDA,7)),"^",5) Q:FIRST=""
  1. ..Q:$P($G(^PRCS(410,XDA,0)),"^",2)'["O"
  1. ..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)
  1. ..S SIXTH=$P($G(^PRCS(410,XDA,4)),"^",5)
  1. ..S ^TMP($J,I)=FIRST_"*"_SECOND_"*"_THIRD_"*"_FOURTH_"*"_FIFTH_"*"_SIXTH_"*"_ZEROTH_"*"_XDA
  1. I '$D(^TMP($J)) U IO(0) W !,"No outstanding transactions found for this quarter.",! G START
  1. WRITE ;
  1. S %ZIS("B")="HOME",%ZIS="MQ" D ^%ZIS G EXIT:POP
  1. S ZTSAVE("PRC*")="",ZTSAVE("OUT")="",ZTSAVE("I")="",ZTSAVE("TODAY1")="",ZTSAVE("PAGE")=""
  1. I IO'=IO(0) S OUT1=0
  1. 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
  1. D WRITE1 D ^%ZISC,EXIT,WRITE2 G START
  1. WRITE1 ;
  1. U IO D HEADER F K=1:1:I-1 I $G(^TMP($J,K))'="" D
  1. .Q:OUT=U D:IOSL-($Y#IOSL)<6 HOLD Q:OUT=U
  1. .W !,?2,$P(^TMP($J,K),"*",7)
  1. .S D0=$P(^TMP($J,K),"*",8) D:D0'="" STATUS^PRCSES W ?22,$E(X,1,25)
  1. .W ?50,$E($P(^TMP($J,K),"*",3),1,30)
  1. .W ! S Y=$P(^TMP($J,K),"*") D DD^%DT W Y
  1. .S Y=$P(^TMP($J,K),"*",2) D DD^%DT W ?15,Y
  1. .W ?35,$P(^TMP($J,K),"*",6)
  1. .S Y=$P(^TMP($J,K),"*",4) D DD^%DT W ?50,Y
  1. .S Y=$P(^TMP($J,K),"*",5) D DD^%DT W ?65,Y
  1. I $D(ZTSK) D KILL^%ZTLOAD K ZTSK
  1. Q
  1. WRITE2 ;
  1. U IO(0) W !!,"------------------",!,"End of processing",! H 2 Q
  1. W1 W !!,"You are not an authorized control point user.",!,"Please contact your control point official." R I:5 G EXIT
  1. S PAGE=PAGE+1
  1. I PAGE'=1 W @IOF
  1. W !,"OUTSTANDING APPROVED REQUEST REPORT - CP ",$P(PRC("CP")," "),?49,TODAY1,?72,"PAGE ",PAGE
  1. W !!,"TRANSACTION NUMBER",?22,"TRANSACTION STATUS",?50,"VENDOR"
  1. W !,"DATE SIGNED",?15,"EST. DEL. DATE",?35,"PO #",?50,"DATE OBL.",?65,"DATE REQ."
  1. S LL="",$P(LL,"-",IOM)="-" W !,LL S LL="" Q
  1. HOLD ;
  1. 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
  1. EXIT K ^TMP($J),PRCS Q