- 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 Jan 18, 2025@03:11:28 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