PRCHRP4 ;WISC/KMB/CR-PC ORDERS READY FOR APPROVAL ;06/11/98 1:50 PM
;;5.1;IFCAP;**25**;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
START ;
N APO,APO1,APO2,LN,PC1,I,LN,X,XX,PO,P,PA,F1,F2,USER,XUSER,F3,YY,Y,PDATE,VEND,RDATE,PC,USER,AMT,XXZ,EX,STATUS,ID,ZIP,AA,Z0,Z1,Z2,Z3,Z4,TIMDATE
K ^TMP($J) W @IOF
S PRCF("X")="S" D ^PRCFSITE Q:'$D(PRC("SITE"))
Q:$G(X)="^"
S %ZIS("B")="",%ZIS="MQ" D ^%ZIS Q:POP
I $D(IO("Q")) S ZTRTN="DETAIL^PRCHRP4",ZTSAVE("PRC*")="" D ^%ZTLOAD,^%ZISC Q
D DETAIL,^%ZISC Q
;
DETAIL ;
S APO=DUZ,CNT=0
S XUSER="" F S XUSER=$O(^PRC(442,"MAPP",XUSER)) Q:XUSER="" D
.S XX="" F S XX=$O(^PRC(442,"MAPP",XUSER,XX)) Q:XX="" D
..;Keep orders from different stations separate
..I $D(PRC("SITE")) Q:$P(^PRC(442,XX,0),"-",1)'=PRC("SITE")
..S (PC,PC1)=$P($G(^PRC(442,XX,23)),"^",8),PC=$P($G(^PRC(440.5,+PC,0)),"^") S:PC="" PC=0
..S F1=$G(^PRC(442,XX,0)),F2=$G(^PRC(442,XX,1)),F3=$G(^PRC(442,XX,2,1,1,1,0))
..;Get the approving official or alternate app. official
..S APO1=$P($G(^PRC(440.5,+PC1,0)),"^",9)
..I APO1'=DUZ S APO2=$P($G(^PRC(440.5,+PC1,0)),"^",10) Q:APO2=""
..S APO=$S(APO1=DUZ:DUZ,APO2=DUZ:DUZ,1:"")
..S:APO'="" APO=$P($G(^VA(200,APO,0)),"^")
..S USER=$P($G(^PRC(440.5,+PC1,0)),"^",8),USER=$P($G(^VA(200,+USER,0)),"^"),VEND=$P(F2,"^"),VEND=$P($G(^PRC(440,+VEND,0)),"^"),AMT=$P(F1,"^",15),VEND=$E(VEND,1,30)
..I VEND="SIMPLIFIED",$P($G(^PRC(442,XX,24)),"^",2)'="" S VEND=$P($G(^PRC(442,XX,24)),"^",2)
..Q:USER=""!(APO="")
..S PO=$P(F1,"^")
..S Y=$P(^PRC(442,XX,23),"^",19) D DD^%DT S RDATE=Y
..S (YY,Y)=$P(F2,"^",15) D DD^%DT S PDATE=Y
..S ^TMP($J,USER,-YY,APO,PC,PO)=PDATE_"^"_RDATE_"^"_PO_"^"_AMT_"^"_VEND
..S ^TMP($J,USER,-YY,APO,PC,PO,1)=$E(F3,1,45),CNT=$G(CNT)+1
;
WRITE ;
U IO S U="^"
S X=DT D NOW^%DTC,YX^%DTC S TIMDATE=Y
I '$D(^TMP($J)) S P=1,Z0="" D HEADER W !!!!,?10,"*** NO RECORDS TO PRINT ***" Q
S (P,EX)=1,Z0=0 F S Z0=$O(^TMP($J,Z0)) Q:EX[U Q:Z0="" D
.D HEADER
.S Z1="" F S Z1=$O(^TMP($J,Z0,Z1)) Q:Z1="" Q:EX[U D
..S Z2="" F S Z2=$O(^TMP($J,Z0,Z1,Z2)) Q:Z2="" Q:EX[U D
...S Z3="" F S Z3=$O(^TMP($J,Z0,Z1,Z2,Z3)) Q:Z3="" Q:EX[U D
....S Z4="" F S Z4=$O(^TMP($J,Z0,Z1,Z2,Z3,Z4)) Q:Z4="" Q:EX[U D
.....I (IOSL-$Y)<6 D HOLD Q:EX[U
.....W ! S LN=^TMP($J,Z0,Z1,Z2,Z3,Z4)
.....W !,$P(LN,"^"),?20,$P(LN,"^",2),?37,$P(LN,"^",3),?55,$J($P(LN,"^",4),0,2)
.....W !,$P(LN,"^",5),?35,^TMP($J,Z0,Z1,Z2,Z3,Z4,1)
.I $E(IOST)'="P",EX'["^" W !,"Press return to continue, '^' to exit: " R XXZ:DTIME S:XXZ["^" EX="^" S:'$T EX=U
W !!,?10,"Total number of orders found: ",CNT
K ^TMP($J),CNT
QUIT
;
HOLD G HEADER:$E(IOST)="P"!(IO'=IO(0)) W !,"Press return to continue, '^' to exit: " R XXZ:DTIME S:XXZ["^" EX="^" S:'$T EX=U D:EX'=U HEADER Q
;
W @IOF
W !,"PURCHASE CARD ORDERS READY FOR APPROVAL",?45,TIMDATE,?70,"PAGE ",P
W !,"PO DATE",?20,"DATE RECONCILED",?37,"PO NUMBER",?55,"$AMT",!,?8,"VENDOR",?35,"DESCRIPTION"
W ! F I=1:1:8 W "----------"
W !,?20,"BUYER: ",Z0
S P=P+1
QUIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHRP4 3072 printed Dec 13, 2024@02:10:20 Page 2
PRCHRP4 ;WISC/KMB/CR-PC ORDERS READY FOR APPROVAL ;06/11/98 1:50 PM
+1 ;;5.1;IFCAP;**25**;Oct 20, 2000
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
START ;
+1 NEW APO,APO1,APO2,LN,PC1,I,LN,X,XX,PO,P,PA,F1,F2,USER,XUSER,F3,YY,Y,PDATE,VEND,RDATE,PC,USER,AMT,XXZ,EX,STATUS,ID,ZIP,AA,Z0,Z1,Z2,Z3,Z4,TIMDATE
+2 KILL ^TMP($JOB)
WRITE @IOF
+3 SET PRCF("X")="S"
DO ^PRCFSITE
if '$DATA(PRC("SITE"))
QUIT
+4 if $GET(X)="^"
QUIT
+5 SET %ZIS("B")=""
SET %ZIS="MQ"
DO ^%ZIS
if POP
QUIT
+6 IF $DATA(IO("Q"))
SET ZTRTN="DETAIL^PRCHRP4"
SET ZTSAVE("PRC*")=""
DO ^%ZTLOAD
DO ^%ZISC
QUIT
+7 DO DETAIL
DO ^%ZISC
QUIT
+8 ;
DETAIL ;
+1 SET APO=DUZ
SET CNT=0
+2 SET XUSER=""
FOR
SET XUSER=$ORDER(^PRC(442,"MAPP",XUSER))
if XUSER=""
QUIT
Begin DoDot:1
+3 SET XX=""
FOR
SET XX=$ORDER(^PRC(442,"MAPP",XUSER,XX))
if XX=""
QUIT
Begin DoDot:2
+4 ;Keep orders from different stations separate
+5 IF $DATA(PRC("SITE"))
if $PIECE(^PRC(442,XX,0),"-",1)'=PRC("SITE")
QUIT
+6 SET (PC,PC1)=$PIECE($GET(^PRC(442,XX,23)),"^",8)
SET PC=$PIECE($GET(^PRC(440.5,+PC,0)),"^")
if PC=""
SET PC=0
+7 SET F1=$GET(^PRC(442,XX,0))
SET F2=$GET(^PRC(442,XX,1))
SET F3=$GET(^PRC(442,XX,2,1,1,1,0))
+8 ;Get the approving official or alternate app. official
+9 SET APO1=$PIECE($GET(^PRC(440.5,+PC1,0)),"^",9)
+10 IF APO1'=DUZ
SET APO2=$PIECE($GET(^PRC(440.5,+PC1,0)),"^",10)
if APO2=""
QUIT
+11 SET APO=$SELECT(APO1=DUZ:DUZ,APO2=DUZ:DUZ,1:"")
+12 if APO'=""
SET APO=$PIECE($GET(^VA(200,APO,0)),"^")
+13 SET USER=$PIECE($GET(^PRC(440.5,+PC1,0)),"^",8)
SET USER=$PIECE($GET(^VA(200,+USER,0)),"^")
SET VEND=$PIECE(F2,"^")
SET VEND=$PIECE($GET(^PRC(440,+VEND,0)),"^")
SET AMT=$PIECE(F1,"^",15)
SET VEND=$EXTRACT(VEND,1,30)
+14 IF VEND="SIMPLIFIED"
IF $PIECE($GET(^PRC(442,XX,24)),"^",2)'=""
SET VEND=$PIECE($GET(^PRC(442,XX,24)),"^",2)
+15 if USER=""!(APO="")
QUIT
+16 SET PO=$PIECE(F1,"^")
+17 SET Y=$PIECE(^PRC(442,XX,23),"^",19)
DO DD^%DT
SET RDATE=Y
+18 SET (YY,Y)=$PIECE(F2,"^",15)
DO DD^%DT
SET PDATE=Y
+19 SET ^TMP($JOB,USER,-YY,APO,PC,PO)=PDATE_"^"_RDATE_"^"_PO_"^"_AMT_"^"_VEND
+20 SET ^TMP($JOB,USER,-YY,APO,PC,PO,1)=$EXTRACT(F3,1,45)
SET CNT=$GET(CNT)+1
End DoDot:2
End DoDot:1
+21 ;
WRITE ;
+1 USE IO
SET U="^"
+2 SET X=DT
DO NOW^%DTC
DO YX^%DTC
SET TIMDATE=Y
+3 IF '$DATA(^TMP($JOB))
SET P=1
SET Z0=""
DO HEADER
WRITE !!!!,?10,"*** NO RECORDS TO PRINT ***"
QUIT
+4 SET (P,EX)=1
SET Z0=0
FOR
SET Z0=$ORDER(^TMP($JOB,Z0))
if EX[U
QUIT
if Z0=""
QUIT
Begin DoDot:1
+5 DO HEADER
+6 SET Z1=""
FOR
SET Z1=$ORDER(^TMP($JOB,Z0,Z1))
if Z1=""
QUIT
if EX[U
QUIT
Begin DoDot:2
+7 SET Z2=""
FOR
SET Z2=$ORDER(^TMP($JOB,Z0,Z1,Z2))
if Z2=""
QUIT
if EX[U
QUIT
Begin DoDot:3
+8 SET Z3=""
FOR
SET Z3=$ORDER(^TMP($JOB,Z0,Z1,Z2,Z3))
if Z3=""
QUIT
if EX[U
QUIT
Begin DoDot:4
+9 SET Z4=""
FOR
SET Z4=$ORDER(^TMP($JOB,Z0,Z1,Z2,Z3,Z4))
if Z4=""
QUIT
if EX[U
QUIT
Begin DoDot:5
+10 IF (IOSL-$Y)<6
DO HOLD
if EX[U
QUIT
+11 WRITE !
SET LN=^TMP($JOB,Z0,Z1,Z2,Z3,Z4)
+12 WRITE !,$PIECE(LN,"^"),?20,$PIECE(LN,"^",2),?37,$PIECE(LN,"^",3),?55,$JUSTIFY($PIECE(LN,"^",4),0,2)
+13 WRITE !,$PIECE(LN,"^",5),?35,^TMP($JOB,Z0,Z1,Z2,Z3,Z4,1)
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
+14 IF $EXTRACT(IOST)'="P"
IF EX'["^"
WRITE !,"Press return to continue, '^' to exit: "
READ XXZ:DTIME
if XXZ["^"
SET EX="^"
if '$TEST
SET EX=U
End DoDot:1
+15 WRITE !!,?10,"Total number of orders found: ",CNT
+16 KILL ^TMP($JOB),CNT
+17 QUIT
+18 ;
HOLD if $EXTRACT(IOST)="P"!(IO'=IO(0))
GOTO HEADER
WRITE !,"Press return to continue, '^' to exit: "
READ XXZ:DTIME
if XXZ["^"
SET EX="^"
if '$TEST
SET EX=U
if EX'=U
DO HEADER
QUIT
+1 ;
+1 WRITE @IOF
+2 WRITE !,"PURCHASE CARD ORDERS READY FOR APPROVAL",?45,TIMDATE,?70,"PAGE ",P
+3 WRITE !,"PO DATE",?20,"DATE RECONCILED",?37,"PO NUMBER",?55,"$AMT",!,?8,"VENDOR",?35,"DESCRIPTION"
+4 WRITE !
FOR I=1:1:8
WRITE "----------"
+5 WRITE !,?20,"BUYER: ",Z0
+6 SET P=P+1
+7 QUIT
