- 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 Mar 13, 2025@21:15:09 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
