PRCHRP10 ;WISC/KMB/CR HISTORY OF PURCHASE CARD TRANSACTIONS ;6/26/98 11:21
;;5.1;IFCAP;**8**;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
STR1 S FLAG=0
STR2 S:$G(FLAG)="" FLAG=1
START ;
N AMT,AMT1,ARR,BOC,CC,CP,CSTATUS,DIR,EDATE,EX,F1,F2,FDATE,GTOT,I,LINE1
N LINE2,LINE3,LINE4,LSTATUS,P,PAT,PC,POSTATUS,QSTATUS,STATUS,TDATE,TOT
N USER,VEND,X,XXZ,Y,ZP,ZTR,HDATE,PRC
K ^TMP($J),^TMP("CANC",$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 want 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(0)="S^P:Paid;U:Unpaid;B:Both",DIR("A")="STATUS" D ^DIR K DIR Q:Y["^" S STATUS=Y
S:STATUS["P" STATUS="P" S:STATUS["U" STATUS="U" S:STATUS["B" STATUS=""
S %ZIS("B")="",%ZIS="MQ" D ^%ZIS Q:POP
I $D(IO("Q")) S ZTRTN="DETAIL^PRCHRP10",ZTSAVE("*")="" D ^%ZTLOAD,^%ZISC K FLAG Q
D DETAIL,^%ZISC K FLAG Q
DETAIL ;
D NOW^%DTC S Y=$P(%,".") D DD^%DT S HDATE=Y
U IO S U="^",P=1,(EX,POSTATUS,ZP)=""
F I=24,29,32,34,37,38,40,41,50,51 S ARR(I)=""
F S ZP=$O(^PRC(442,"F",25,ZP)) Q:ZP="" D
.S PC=$P($G(^PRC(442,ZP,23)),"^",8) Q:PC=""
.I $G(FLAG)=1 I ($P($G(^PRC(440.5,+PC,0)),"^",10)'=DUZ)&($P($G(^PRC(440.5,+PC,0)),"^",9)'=DUZ) Q
.I $G(FLAG)=0 I $P($G(^PRC(440.5,+PC,0)),"^",8)'=DUZ QUIT
.S CSTATUS=$P($G(^PRC(442,ZP,7)),"^"),CSTATUS=$P($G(^PRCD(442.3,+CSTATUS,0)),"^",2)
.I STATUS="U" Q:$D(ARR(CSTATUS))
.I STATUS="P" Q:'$D(ARR(CSTATUS))
.S F1=$G(^PRC(442,ZP,0)),F2=$G(^PRC(442,ZP,1)),LINE3=$G(^PRC(442,ZP,2,1,1,1,0)),POSTATUS=$P($G(^PRC(442,ZP,7)),"^"),POSTATUS=$P($G(^PRCD(442.3,+POSTATUS,0)),"^",1)
.;Do not mix data from different stations
.I $D(PRC("SITE")) Q:$P(F1,"-",1)'=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($G(^PRC(440.5,PC,0)),"^",8),USER=$E($P($G(^VA(200,+USER,0)),"^"),1,20),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,20)
.S PAT=$P(F1,"^")
.S LINE1=CP_"^"_PAT_"^"_TDATE_"^"_USER_"^"_VEND
.S CC=$P(F1,"^",5),BOC=$P($G(^PRC(442,ZP,2,1,0)),"^",4),BOC=$E(BOC,1,40)
.S LSTATUS=POSTATUS_"^"_CSTATUS
.S LINE2=AMT_"^"_CC_"^"_BOC
.S CP=+CP,^TMP($J,CP,ZP,1)=LINE1,^TMP($J,CP,ZP,2)=LINE2,^TMP($J,CP,ZP,3)=LINE3,^TMP($J,CP,ZP,4)=LSTATUS
;
WRITE ;
I '$D(^TMP($J)) S P=1 S:STATUS["P" STATUS="P" S:STATUS["U" STATUS="U" S:STATUS["B" STATUS="" D HEADER W !!!!,?10,"*** NO RECORDS TO PRINT ***" Q
S (GTOT,TOT,CP,ZP)="" F S CP=$O(^TMP($J,CP)) Q:CP="" Q:EX="^" D
.S TOT=0 F S ZP=$O(^TMP($J,CP,ZP)) Q:ZP="" Q:EX="^" D
..D:P=1 HEADER
..S LINE1=^TMP($J,CP,ZP,1) W !,$P(LINE1,"^"),?6,$P(LINE1,"^",2),?19,$P(LINE1,"^",3),?36,$P(LINE1,"^",4),?58,$P(LINE1,"^",5)
..S AMT1=$P(^TMP($J,CP,ZP,2),"^",1) W !,?3,$J(AMT1,0,2),?18,$P(^TMP($J,CP,ZP,2),"^",2),?36,$P(^TMP($J,CP,ZP,2),"^",3)
..W !,^TMP($J,CP,ZP,3),!
..S LINE4=^TMP($J,CP,ZP,4) I +$P(LINE4,"^",2)'=45 W $P(LINE4,"^",1),!
..I +$P(LINE4,"^",2)=45 S AMT1=0,^TMP("CANC",$J)=1 W $P(LINE4,"^",1),!
..I (IOSL-$Y)<6 D HOLD Q:EX="^"
..S TOT=TOT+AMT1,GTOT=GTOT+AMT1
.I EX'="^" W !,?30,"CONTROL POINT ",$P(LINE1,"^")," SUBTOTAL: ",$J(TOT,0,2),! S TOT=0
I GTOT'=0,EX'="^" W ?30,"TOTAL: ",$J(GTOT,0,2) W:$D(^TMP("CANC",$J)) !?30,"(EXCLUDES Cancelled Orders)"
K ^TMP($J),^TMP("CANC",$J)
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="^" D:EX'="^" HEADER Q
;
W @IOF
W !,"HISTORY OF PURCHASE CARD TRANSACTIONS REPORT - " W $S(STATUS="U":"UNPAID",STATUS="P":"PAID",1:"ALL")
W ?56,HDATE,?70,"PAGE ",P
W !,"FCP",?6,"PO NUMBER",?19,"PURCHASE DATE",?36,"BUYER",?58,"VENDOR"
W !,?3,"AMOUNT",?18,"COST CENTER",?36,"BUDGET OBJECT CODE",!,"FIRST LINE ITEM DESCRIPTION",!,"STATUS"
W ! F I=1:1:10 W "--------"
S P=P+1 Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHRP10 4259 printed Dec 13, 2024@02:10:17 Page 2
PRCHRP10 ;WISC/KMB/CR HISTORY OF PURCHASE CARD TRANSACTIONS ;6/26/98 11:21
+1 ;;5.1;IFCAP;**8**;Oct 20, 2000
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
STR1 SET FLAG=0
STR2 if $GET(FLAG)=""
SET FLAG=1
START ;
+1 NEW AMT,AMT1,ARR,BOC,CC,CP,CSTATUS,DIR,EDATE,EX,F1,F2,FDATE,GTOT,I,LINE1
+2 NEW LINE2,LINE3,LINE4,LSTATUS,P,PAT,PC,POSTATUS,QSTATUS,STATUS,TDATE,TOT
+3 NEW USER,VEND,X,XXZ,Y,ZP,ZTR,HDATE,PRC
+4 KILL ^TMP($JOB),^TMP("CANC",$JOB)
+5 WRITE @IOF
+6 SET PRCF("X")="S"
DO ^PRCFSITE
if '$DATA(PRC("SITE"))
QUIT
if $GET(X)="^"
QUIT
+7 SET DIR("A")="Enter beginning date"
SET DIR("?")="Enter the first date for which you wish to see records"
+8 SET DIR(0)="D^^"
DO ^DIR
KILL DIR
if +Y<1
QUIT
SET FDATE=+Y
WRITE " ",Y(0)
+9 SET DIR("A")="Enter ending date"
SET DIR("?")="Enter the last date for which you want to see records"
+10 SET DIR(0)="D^^"
DO ^DIR
KILL DIR
if +Y<1
QUIT
SET EDATE=+Y
WRITE " ",Y(0)
+11 IF EDATE<FDATE
WRITE !,"Date range is incorrect."
GOTO START
+12 SET DIR(0)="S^P:Paid;U:Unpaid;B:Both"
SET DIR("A")="STATUS"
DO ^DIR
KILL DIR
if Y["^"
QUIT
SET STATUS=Y
+13 if STATUS["P"
SET STATUS="P"
if STATUS["U"
SET STATUS="U"
if STATUS["B"
SET STATUS=""
+14 SET %ZIS("B")=""
SET %ZIS="MQ"
DO ^%ZIS
if POP
QUIT
+15 IF $DATA(IO("Q"))
SET ZTRTN="DETAIL^PRCHRP10"
SET ZTSAVE("*")=""
DO ^%ZTLOAD
DO ^%ZISC
KILL FLAG
QUIT
+16 DO DETAIL
DO ^%ZISC
KILL FLAG
QUIT
DETAIL ;
+1 DO NOW^%DTC
SET Y=$PIECE(%,".")
DO DD^%DT
SET HDATE=Y
+2 USE IO
SET U="^"
SET P=1
SET (EX,POSTATUS,ZP)=""
+3 FOR I=24,29,32,34,37,38,40,41,50,51
SET ARR(I)=""
+4 FOR
SET ZP=$ORDER(^PRC(442,"F",25,ZP))
if ZP=""
QUIT
Begin DoDot:1
+5 SET PC=$PIECE($GET(^PRC(442,ZP,23)),"^",8)
if PC=""
QUIT
+6 IF $GET(FLAG)=1
IF ($PIECE($GET(^PRC(440.5,+PC,0)),"^",10)'=DUZ)&($PIECE($GET(^PRC(440.5,+PC,0)),"^",9)'=DUZ)
QUIT
+7 IF $GET(FLAG)=0
IF $PIECE($GET(^PRC(440.5,+PC,0)),"^",8)'=DUZ
QUIT
+8 SET CSTATUS=$PIECE($GET(^PRC(442,ZP,7)),"^")
SET CSTATUS=$PIECE($GET(^PRCD(442.3,+CSTATUS,0)),"^",2)
+9 IF STATUS="U"
if $DATA(ARR(CSTATUS))
QUIT
+10 IF STATUS="P"
if '$DATA(ARR(CSTATUS))
QUIT
+11 SET F1=$GET(^PRC(442,ZP,0))
SET F2=$GET(^PRC(442,ZP,1))
SET LINE3=$GET(^PRC(442,ZP,2,1,1,1,0))
SET POSTATUS=$PIECE($GET(^PRC(442,ZP,7)),"^")
SET POSTATUS=$PIECE($GET(^PRCD(442.3,+POSTATUS,0)),"^",1)
+12 ;Do not mix data from different stations
+13 IF $DATA(PRC("SITE"))
if $PIECE(F1,"-",1)'=PRC("SITE")
QUIT
+14 SET Y=$PIECE(F2,"^",15)
SET CP=$PIECE(F1,"^",3)
SET CP=$PIECE(CP," ")
+15 if CP=""
QUIT
if Y<FDATE
QUIT
if Y>EDATE
QUIT
+16 DO DD^%DT
SET TDATE=Y
+17 SET USER=$PIECE($GET(^PRC(440.5,PC,0)),"^",8)
SET USER=$EXTRACT($PIECE($GET(^VA(200,+USER,0)),"^"),1,20)
SET VEND=$PIECE(F2,"^")
SET VEND=$PIECE($GET(^PRC(440,+VEND,0)),"^")
SET AMT=$PIECE(F1,"^",15)
+18 IF VEND="SIMPLIFIED"
IF $PIECE($GET(^PRC(442,ZP,24)),"^",2)'=""
SET VEND=$PIECE($GET(^PRC(442,ZP,24)),"^",2)
+19 SET VEND=$EXTRACT(VEND,1,20)
+20 SET PAT=$PIECE(F1,"^")
+21 SET LINE1=CP_"^"_PAT_"^"_TDATE_"^"_USER_"^"_VEND
+22 SET CC=$PIECE(F1,"^",5)
SET BOC=$PIECE($GET(^PRC(442,ZP,2,1,0)),"^",4)
SET BOC=$EXTRACT(BOC,1,40)
+23 SET LSTATUS=POSTATUS_"^"_CSTATUS
+24 SET LINE2=AMT_"^"_CC_"^"_BOC
+25 SET CP=+CP
SET ^TMP($JOB,CP,ZP,1)=LINE1
SET ^TMP($JOB,CP,ZP,2)=LINE2
SET ^TMP($JOB,CP,ZP,3)=LINE3
SET ^TMP($JOB,CP,ZP,4)=LSTATUS
End DoDot:1
+26 ;
WRITE ;
+1 IF '$DATA(^TMP($JOB))
SET P=1
if STATUS["P"
SET STATUS="P"
if STATUS["U"
SET STATUS="U"
if STATUS["B"
SET STATUS=""
DO HEADER
WRITE !!!!,?10,"*** NO RECORDS TO PRINT ***"
QUIT
+2 SET (GTOT,TOT,CP,ZP)=""
FOR
SET CP=$ORDER(^TMP($JOB,CP))
if CP=""
QUIT
if EX="^"
QUIT
Begin DoDot:1
+3 SET TOT=0
FOR
SET ZP=$ORDER(^TMP($JOB,CP,ZP))
if ZP=""
QUIT
if EX="^"
QUIT
Begin DoDot:2
+4 if P=1
DO HEADER
+5 SET LINE1=^TMP($JOB,CP,ZP,1)
WRITE !,$PIECE(LINE1,"^"),?6,$PIECE(LINE1,"^",2),?19,$PIECE(LINE1,"^",3),?36,$PIECE(LINE1,"^",4),?58,$PIECE(LINE1,"^",5)
+6 SET AMT1=$PIECE(^TMP($JOB,CP,ZP,2),"^",1)
WRITE !,?3,$JUSTIFY(AMT1,0,2),?18,$PIECE(^TMP($JOB,CP,ZP,2),"^",2),?36,$PIECE(^TMP($JOB,CP,ZP,2),"^",3)
+7 WRITE !,^TMP($JOB,CP,ZP,3),!
+8 SET LINE4=^TMP($JOB,CP,ZP,4)
IF +$PIECE(LINE4,"^",2)'=45
WRITE $PIECE(LINE4,"^",1),!
+9 IF +$PIECE(LINE4,"^",2)=45
SET AMT1=0
SET ^TMP("CANC",$JOB)=1
WRITE $PIECE(LINE4,"^",1),!
+10 IF (IOSL-$Y)<6
DO HOLD
if EX="^"
QUIT
+11 SET TOT=TOT+AMT1
SET GTOT=GTOT+AMT1
End DoDot:2
+12 IF EX'="^"
WRITE !,?30,"CONTROL POINT ",$PIECE(LINE1,"^")," SUBTOTAL: ",$JUSTIFY(TOT,0,2),!
SET TOT=0
End DoDot:1
+13 IF GTOT'=0
IF EX'="^"
WRITE ?30,"TOTAL: ",$JUSTIFY(GTOT,0,2)
if $DATA(^TMP("CANC",$JOB))
WRITE !?30,"(EXCLUDES Cancelled Orders)"
+14 KILL ^TMP($JOB),^TMP("CANC",$JOB)
+15 QUIT
+16 ;
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="^"
if EX'="^"
DO HEADER
QUIT
+1 ;
+1 WRITE @IOF
+2 WRITE !,"HISTORY OF PURCHASE CARD TRANSACTIONS REPORT - "
WRITE $SELECT(STATUS="U":"UNPAID",STATUS="P":"PAID",1:"ALL")
+3 WRITE ?56,HDATE,?70,"PAGE ",P
+4 WRITE !,"FCP",?6,"PO NUMBER",?19,"PURCHASE DATE",?36,"BUYER",?58,"VENDOR"
+5 WRITE !,?3,"AMOUNT",?18,"COST CENTER",?36,"BUDGET OBJECT CODE",!,"FIRST LINE ITEM DESCRIPTION",!,"STATUS"
+6 WRITE !
FOR I=1:1:10
WRITE "--------"
+7 SET P=P+1
QUIT
