PRCHRP6 ;WISC/KMB/CR FISCAL DAILY REVIEW ;7/09/98 10:34
;;5.1;IFCAP;**8**;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
START ;
N LINE1,LINE2,PONUM,STRING,LIN1,LIN2,AMT,AMT1,FLAG,STATUS,CP,VEND,USER,STATUS,TDATE,EDATE,FDATE,HDATE,DIR,ZP,P,X,Y,F1,F2,LINE3,TOT,XXZ,EX
K ^TMP($J)
W @IOF
S PRCF("X")="S" D ^PRCFSITE Q:'$D(PRC("SITE")) Q:$G(X)="^"
S DIR("A")="Enter beginning date",DIR("?")="Enter the first date for which you wish to see records"
S DIR(0)="D^^" D ^DIR K DIR Q:+Y<1 S FDATE=+Y W " ",Y(0)
S DIR("A")="Enter ending date",DIR("?")="Enter the last date for which you wish to see records"
S DIR(0)="D^^" D ^DIR K DIR Q:+Y<1 S EDATE=+Y W " ",Y(0)
I EDATE<FDATE W !,"Date range is incorrect." G START
S DIR("A")="Do you want to see delivery orders",DIR(0)="Y^^" D ^DIR K DIR Q:Y<0 S FLAG=Y
S %ZIS("B")="",%ZIS="MQ" D ^%ZIS Q:POP
I $D(IO("Q")) S ZTRTN="DETAIL^PRCHRP6",ZTSAVE("*")="" D ^%ZTLOAD,^%ZISC Q
D DETAIL,^%ZISC
Q
;
DETAIL ;
D NOW^%DTC,YX^%DTC S HDATE=Y
S (P,EX)=1
S ZP="" F S ZP=$O(^PRC(442,"F",25,ZP)) Q:ZP="" D DETAIL1
I $G(FLAG)=1 S ZP="" F S ZP=$O(^PRC(442,"F",1,ZP)) Q:ZP="" D DETAIL1
D WRITE
K ^TMP($J)
Q
;
DETAIL1 ;
S F1=$G(^PRC(442,ZP,0)),F2=$G(^PRC(442,ZP,1))
I $D(PRC("SITE")) Q:$P(F1,"-")'=PRC("SITE")
S Y=$P(F2,"^",15),CP=$P(F1,"^",3),CP=+$P(CP," ")
Q:CP="" Q:Y<FDATE Q:Y>EDATE
D DD^%DT S TDATE=Y
S USER=$P(F2,"^",10),USER=$P($G(^VA(200,+USER,0)),"^"),VEND=$P(F2,"^"),VEND=$P($G(^PRC(440,+VEND,0)),"^"),AMT=$P(F1,"^",15)
I VEND="SIMPLIFIED",$P($G(^PRC(442,ZP,24)),"^",2)'="" S VEND=$P($G(^PRC(442,ZP,24)),"^",2)
S VEND=$E(VEND,1,25)
S LINE1=TDATE_"^"_USER_"^"_VEND_"^"_AMT
S PONUM=$P(F1,"^"),STATUS=$P($G(^PRC(442,ZP,7)),"^") Q:STATUS=1 Q:STATUS=45
S:STATUS'="" STATUS=$P($G(^PRCD(442.3,STATUS,0)),"^"),STATUS=$E(STATUS,1,40)
S LINE2=STATUS_"^"_PONUM
S ^TMP($J,CP,ZP,1)=LINE1,^TMP($J,CP,ZP,2)=LINE2
Q
;
WRITE ;
U IO S P=1
S STRING="PURCHASE CARD PO NUMBER" S:FLAG=1 STRING="TRANSACTION PO NUMBER"
I '$D(^TMP($J)) S CP="" D HEADER W !!!!,?10,"*** NO RECORDS TO PRINT ***" Q
S TOT=0,(CP,ZP)="" F S CP=$O(^TMP($J,CP)) Q:EX[U Q:CP="" D
.D HEADER
.F S ZP=$O(^TMP($J,CP,ZP)) Q:EX[U Q:ZP="" D
..S LINE1=^TMP($J,CP,ZP,1),LINE2=^TMP($J,CP,ZP,2) D
...W !,$P(LINE1,"^"),?15,$P(LINE1,"^",2),?40,$P(LINE1,"^",3) S AMT1=$P(LINE1,"^",4) W ?70,$J(AMT1,8,2)
...W !,$P(LINE2,"^"),?45,$P(LINE2,"^",2),!
...S TOT=TOT+AMT1
...I (IOSL-$Y)<5 D HOLD
.I EX'[U W !,?25,"CONTROL POINT ",CP," SUBTOTAL: ",$J(TOT,0,2),! S TOT=0
.I $E(IOST,1,2)'="P-",EX'[U W !,"Press return to continue, '^' to exit: " R XXZ:DTIME S:XXZ[U EX=U S:'$T EX=U W !
Q
;
HOLD G HEADER:$E(IOST,1,2)="P-"!(IO'=IO(0)) W !,"Press return to continue, '^' to exit: " R XXZ:DTIME S:XXZ["^" EX="^" S:'$T EX="^" D:EX'="^" HEADER
Q
;
W @IOF
W !,"FISCAL DAILY REVIEW REPORT",?42,HDATE,?70,"PAGE ",P,!
W !,"PURCHASE DATE",?15,"BUYER",?40,"VENDOR",?72,"AMOUNT"
W !,?3,"STATUS",?45,STRING
W ! F I=1:1:10 W "--------"
W !!,"CONTROL POINT: ",CP,!
S P=P+1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHRP6 3114 printed Dec 13, 2024@02:10:22 Page 2
PRCHRP6 ;WISC/KMB/CR FISCAL DAILY REVIEW ;7/09/98 10:34
+1 ;;5.1;IFCAP;**8**;Oct 20, 2000
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
START ;
+1 NEW LINE1,LINE2,PONUM,STRING,LIN1,LIN2,AMT,AMT1,FLAG,STATUS,CP,VEND,USER,STATUS,TDATE,EDATE,FDATE,HDATE,DIR,ZP,P,X,Y,F1,F2,LINE3,TOT,XXZ,EX
+2 KILL ^TMP($JOB)
+3 WRITE @IOF
+4 SET PRCF("X")="S"
DO ^PRCFSITE
if '$DATA(PRC("SITE"))
QUIT
if $GET(X)="^"
QUIT
+5 SET DIR("A")="Enter beginning date"
SET DIR("?")="Enter the first date for which you wish to see records"
+6 SET DIR(0)="D^^"
DO ^DIR
KILL DIR
if +Y<1
QUIT
SET FDATE=+Y
WRITE " ",Y(0)
+7 SET DIR("A")="Enter ending date"
SET DIR("?")="Enter the last date for which you wish to see records"
+8 SET DIR(0)="D^^"
DO ^DIR
KILL DIR
if +Y<1
QUIT
SET EDATE=+Y
WRITE " ",Y(0)
+9 IF EDATE<FDATE
WRITE !,"Date range is incorrect."
GOTO START
+10 SET DIR("A")="Do you want to see delivery orders"
SET DIR(0)="Y^^"
DO ^DIR
KILL DIR
if Y<0
QUIT
SET FLAG=Y
+11 SET %ZIS("B")=""
SET %ZIS="MQ"
DO ^%ZIS
if POP
QUIT
+12 IF $DATA(IO("Q"))
SET ZTRTN="DETAIL^PRCHRP6"
SET ZTSAVE("*")=""
DO ^%ZTLOAD
DO ^%ZISC
QUIT
+13 DO DETAIL
DO ^%ZISC
+14 QUIT
+15 ;
DETAIL ;
+1 DO NOW^%DTC
DO YX^%DTC
SET HDATE=Y
+2 SET (P,EX)=1
+3 SET ZP=""
FOR
SET ZP=$ORDER(^PRC(442,"F",25,ZP))
if ZP=""
QUIT
DO DETAIL1
+4 IF $GET(FLAG)=1
SET ZP=""
FOR
SET ZP=$ORDER(^PRC(442,"F",1,ZP))
if ZP=""
QUIT
DO DETAIL1
+5 DO WRITE
+6 KILL ^TMP($JOB)
+7 QUIT
+8 ;
DETAIL1 ;
+1 SET F1=$GET(^PRC(442,ZP,0))
SET F2=$GET(^PRC(442,ZP,1))
+2 IF $DATA(PRC("SITE"))
if $PIECE(F1,"-")'=PRC("SITE")
QUIT
+3 SET Y=$PIECE(F2,"^",15)
SET CP=$PIECE(F1,"^",3)
SET CP=+$PIECE(CP," ")
+4 if CP=""
QUIT
if Y<FDATE
QUIT
if Y>EDATE
QUIT
+5 DO DD^%DT
SET TDATE=Y
+6 SET USER=$PIECE(F2,"^",10)
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)
+7 IF VEND="SIMPLIFIED"
IF $PIECE($GET(^PRC(442,ZP,24)),"^",2)'=""
SET VEND=$PIECE($GET(^PRC(442,ZP,24)),"^",2)
+8 SET VEND=$EXTRACT(VEND,1,25)
+9 SET LINE1=TDATE_"^"_USER_"^"_VEND_"^"_AMT
+10 SET PONUM=$PIECE(F1,"^")
SET STATUS=$PIECE($GET(^PRC(442,ZP,7)),"^")
if STATUS=1
QUIT
if STATUS=45
QUIT
+11 if STATUS'=""
SET STATUS=$PIECE($GET(^PRCD(442.3,STATUS,0)),"^")
SET STATUS=$EXTRACT(STATUS,1,40)
+12 SET LINE2=STATUS_"^"_PONUM
+13 SET ^TMP($JOB,CP,ZP,1)=LINE1
SET ^TMP($JOB,CP,ZP,2)=LINE2
+14 QUIT
+15 ;
WRITE ;
+1 USE IO
SET P=1
+2 SET STRING="PURCHASE CARD PO NUMBER"
if FLAG=1
SET STRING="TRANSACTION PO NUMBER"
+3 IF '$DATA(^TMP($JOB))
SET CP=""
DO HEADER
WRITE !!!!,?10,"*** NO RECORDS TO PRINT ***"
QUIT
+4 SET TOT=0
SET (CP,ZP)=""
FOR
SET CP=$ORDER(^TMP($JOB,CP))
if EX[U
QUIT
if CP=""
QUIT
Begin DoDot:1
+5 DO HEADER
+6 FOR
SET ZP=$ORDER(^TMP($JOB,CP,ZP))
if EX[U
QUIT
if ZP=""
QUIT
Begin DoDot:2
+7 SET LINE1=^TMP($JOB,CP,ZP,1)
SET LINE2=^TMP($JOB,CP,ZP,2)
Begin DoDot:3
+8 WRITE !,$PIECE(LINE1,"^"),?15,$PIECE(LINE1,"^",2),?40,$PIECE(LINE1,"^",3)
SET AMT1=$PIECE(LINE1,"^",4)
WRITE ?70,$JUSTIFY(AMT1,8,2)
+9 WRITE !,$PIECE(LINE2,"^"),?45,$PIECE(LINE2,"^",2),!
+10 SET TOT=TOT+AMT1
+11 IF (IOSL-$Y)<5
DO HOLD
End DoDot:3
End DoDot:2
+12 IF EX'[U
WRITE !,?25,"CONTROL POINT ",CP," SUBTOTAL: ",$JUSTIFY(TOT,0,2),!
SET TOT=0
+13 IF $EXTRACT(IOST,1,2)'="P-"
IF EX'[U
WRITE !,"Press return to continue, '^' to exit: "
READ XXZ:DTIME
if XXZ[U
SET EX=U
if '$TEST
SET EX=U
WRITE !
End DoDot:1
+14 QUIT
+15 ;
HOLD if $EXTRACT(IOST,1,2)="P-"!(IO'=IO(0))
GOTO HEADER
WRITE !,"Press return to continue, '^' to exit: "
READ XXZ:DTIME
if XXZ["^"
SET EX="^"
if '$TEST
SET EX="^"
if EX'="^"
DO HEADER
+1 QUIT
+2 ;
+1 WRITE @IOF
+2 WRITE !,"FISCAL DAILY REVIEW REPORT",?42,HDATE,?70,"PAGE ",P,!
+3 WRITE !,"PURCHASE DATE",?15,"BUYER",?40,"VENDOR",?72,"AMOUNT"
+4 WRITE !,?3,"STATUS",?45,STRING
+5 WRITE !
FOR I=1:1:10
WRITE "--------"
+6 WRITE !!,"CONTROL POINT: ",CP,!
+7 SET P=P+1
+8 QUIT
