PRCHRP2 ;WISC/KMB/CR UNPAID PC TRANSACTION BY FCP ;6/05/98 11:15
;;5.1;IFCAP;**62**;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
START ;
N BDATE,EDATE,PODATE,PC1,ARR,XXZ,EX,CP,VEND,USER,STATUS,TDATE,EDATE,FDATE,DIR,ZP,P,X,Y,F1,F2,LINE3,TOT,PCNUM,ZTR,ZTR1
N AMT,AMT1,LINE1,LINE2,LSTATUS,PRCST,PRCSJ,ZIP,BOC,CC,CCREC,PP,QSTATUS
K ^TMP($J)
;
W @IOF,!!,"Detailed Report of Unpaid PC Transactions by FCP"
;
DATE S DIR(0)="D",DIR("A")="P.O. DATE (BEGIN RANGE) ",DIR("B")="T-30"
D ^DIR Q:$D(DIRUT) S BDATE=Y
;
S DIR("A")="P.O. DATE (END RANGE) ",DIR("B")="T"
D ^DIR Q:$D(DIRUT) S EDATE=Y
;
I BDATE'<EDATE,BDATE'=EDATE D G DATE
. W !,"Please enter a valid date range",!
;
W !,"Please select a device for printing this report.",!
;
S %ZIS("B")="",%ZIS="MQ" D ^%ZIS Q:POP
;
;Queue the report
I $D(IO("Q")) D Q
. S ZTRTN="DETAIL^PRCHRP2"
. S ZTSAVE("BDATE")=""
. S ZTSAVE("EDATE")=""
. D ^%ZTLOAD,^%ZISC Q
;
D DETAIL,^%ZISC Q
;
DETAIL ;
F ZTR=1,24,29,32,34,37,38,40,41,45,50,51 S ARR(ZTR)=""
U IO S U="^",(P,EX)=1,ZP="" F S ZP=$O(^PRC(442,"F",25,ZP)) Q:ZP="" D
.S ZTR1=+$P($G(^PRC(442,ZP,7)),"^",2) Q:ZTR1=""
.Q:$D(ARR(ZTR1))
.S F1=$G(^PRC(442,ZP,0)),F2=$G(^PRC(442,ZP,1)),LINE3=$G(^PRC(442,ZP,2,1,1,1,0))
.S (PODATE,Y)=$P(F2,"^",15)
.I PODATE<BDATE!(PODATE>EDATE) Q
.S STATUS=+$P($G(^PRC(442,ZP,7)),"^",1),LSTATUS=$P($G(^PRCD(442.3,STATUS,0)),"^",1)
.S PCNUM=$P(F1,"^"),CP=$P(F1,"^",3),CP=$P(CP," ")
.S ZTR1=+$P($G(^PRC(442,ZP,7)),"^",2) Q:$D(ARR(ZTR1))
.Q:CP=""
.S PC1=$P($G(^PRC(442,ZP,23)),"^",8) Q:PC1=""
.D DD^%DT S TDATE=Y
.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,ZP,24)),"^",2)'="" S VEND=$P($G(^PRC(442,ZP,24)),"^",2)
.S LINE1=CP_"^"_PCNUM_"^"_USER_"^"_VEND
.S CC=$P(F1,"^",5),BOC=$P($G(^PRC(442,ZP,2,1,0)),"^",4),BOC=$E(BOC,1,20)
.S LINE2=AMT_"^"_TDATE_"^"_CC_"^"_$E(BOC,1,30)
.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 D HEADER W !!!!,?10,"*** NO RECORDS TO PRINT ***" Q
S (TOT,CP,ZP)="" F S CP=$O(^TMP($J,CP)) Q:EX[U Q:CP="" D
.F S ZP=$O(^TMP($J,CP,ZP)) Q:EX[U Q:ZP="" D
..D:P=1 HEADER I (IOSL-$Y)<6 D HOLD Q:EX[U
..S LINE1=^TMP($J,CP,ZP,1) W !,$P(LINE1,"^"),?6,$P(LINE1,"^",2),?25,$P(LINE1,"^",3),?50,$P(LINE1,"^",4)
..S AMT1=$P(^TMP($J,CP,ZP,2),"^",1) W !,?3,$J(AMT1,0,2),?20,$P(^TMP($J,CP,ZP,2),"^",2),?36,$P(^TMP($J,CP,ZP,2),"^",3),?50,$P(^TMP($J,CP,ZP,2),"^",4)
..W !,^TMP($J,CP,ZP,3),!,^TMP($J,CP,ZP,4),!
..S TOT=TOT+AMT1
.I EX'[U W !,?40,"CONTROL POINT ",CP," SUBTOTAL: ",$J(TOT,0,2),! S TOT=0
QUIT
;
HOLD G HEADER:$E(IOST)="P"!(IO'=IO(0)) W !,"Press return to continue, '^' to exit: " R XXZ:DTIME S:XXZ["^" EX=U S:'$T EX=U D:EX'=U HEADER Q
;
W @IOF
W !,"DETAILED REPORT OF UNPAID PURCHASE CARD TRANSACTIONS BY FCP",?65,"PAGE: ",P
W !,"FCP",?6,"PC NUMBER",?25,"BUYER",?50,"VENDOR"
W !,?3,"AMOUNT",?20,"PURCHASE DATE",?36,"COST CENTER",?50,"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[HPRCHRP2 3297 printed Apr 09, 2024@21:01:16 Page 2
PRCHRP2 ;WISC/KMB/CR UNPAID PC TRANSACTION BY FCP ;6/05/98 11:15
+1 ;;5.1;IFCAP;**62**;Oct 20, 2000
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
START ;
+1 NEW BDATE,EDATE,PODATE,PC1,ARR,XXZ,EX,CP,VEND,USER,STATUS,TDATE,EDATE,FDATE,DIR,ZP,P,X,Y,F1,F2,LINE3,TOT,PCNUM,ZTR,ZTR1
+2 NEW AMT,AMT1,LINE1,LINE2,LSTATUS,PRCST,PRCSJ,ZIP,BOC,CC,CCREC,PP,QSTATUS
+3 KILL ^TMP($JOB)
+4 ;
+5 WRITE @IOF,!!,"Detailed Report of Unpaid PC Transactions by FCP"
+6 ;
DATE SET DIR(0)="D"
SET DIR("A")="P.O. DATE (BEGIN RANGE) "
SET DIR("B")="T-30"
+1 DO ^DIR
if $DATA(DIRUT)
QUIT
SET BDATE=Y
+2 ;
+3 SET DIR("A")="P.O. DATE (END RANGE) "
SET DIR("B")="T"
+4 DO ^DIR
if $DATA(DIRUT)
QUIT
SET EDATE=Y
+5 ;
+6 IF BDATE'<EDATE
IF BDATE'=EDATE
Begin DoDot:1
+7 WRITE !,"Please enter a valid date range",!
End DoDot:1
GOTO DATE
+8 ;
+9 WRITE !,"Please select a device for printing this report.",!
+10 ;
+11 SET %ZIS("B")=""
SET %ZIS="MQ"
DO ^%ZIS
if POP
QUIT
+12 ;
+13 ;Queue the report
+14 IF $DATA(IO("Q"))
Begin DoDot:1
+15 SET ZTRTN="DETAIL^PRCHRP2"
+16 SET ZTSAVE("BDATE")=""
+17 SET ZTSAVE("EDATE")=""
+18 DO ^%ZTLOAD
DO ^%ZISC
QUIT
End DoDot:1
QUIT
+19 ;
+20 DO DETAIL
DO ^%ZISC
QUIT
+21 ;
DETAIL ;
+1 FOR ZTR=1,24,29,32,34,37,38,40,41,45,50,51
SET ARR(ZTR)=""
+2 USE IO
SET U="^"
SET (P,EX)=1
SET ZP=""
FOR
SET ZP=$ORDER(^PRC(442,"F",25,ZP))
if ZP=""
QUIT
Begin DoDot:1
+3 SET ZTR1=+$PIECE($GET(^PRC(442,ZP,7)),"^",2)
if ZTR1=""
QUIT
+4 if $DATA(ARR(ZTR1))
QUIT
+5 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))
+6 SET (PODATE,Y)=$PIECE(F2,"^",15)
+7 IF PODATE<BDATE!(PODATE>EDATE)
QUIT
+8 SET STATUS=+$PIECE($GET(^PRC(442,ZP,7)),"^",1)
SET LSTATUS=$PIECE($GET(^PRCD(442.3,STATUS,0)),"^",1)
+9 SET PCNUM=$PIECE(F1,"^")
SET CP=$PIECE(F1,"^",3)
SET CP=$PIECE(CP," ")
+10 SET ZTR1=+$PIECE($GET(^PRC(442,ZP,7)),"^",2)
if $DATA(ARR(ZTR1))
QUIT
+11 if CP=""
QUIT
+12 SET PC1=$PIECE($GET(^PRC(442,ZP,23)),"^",8)
if PC1=""
QUIT
+13 DO DD^%DT
SET TDATE=Y
+14 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)
+15 IF VEND="SIMPLIFIED"
IF $PIECE($GET(^PRC(442,ZP,24)),"^",2)'=""
SET VEND=$PIECE($GET(^PRC(442,ZP,24)),"^",2)
+16 SET LINE1=CP_"^"_PCNUM_"^"_USER_"^"_VEND
+17 SET CC=$PIECE(F1,"^",5)
SET BOC=$PIECE($GET(^PRC(442,ZP,2,1,0)),"^",4)
SET BOC=$EXTRACT(BOC,1,20)
+18 SET LINE2=AMT_"^"_TDATE_"^"_CC_"^"_$EXTRACT(BOC,1,30)
+19 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
+20 ;
WRITE ;
+1 IF '$DATA(^TMP($JOB))
SET P=1
DO HEADER
WRITE !!!!,?10,"*** NO RECORDS TO PRINT ***"
QUIT
+2 SET (TOT,CP,ZP)=""
FOR
SET CP=$ORDER(^TMP($JOB,CP))
if EX[U
QUIT
if CP=""
QUIT
Begin DoDot:1
+3 FOR
SET ZP=$ORDER(^TMP($JOB,CP,ZP))
if EX[U
QUIT
if ZP=""
QUIT
Begin DoDot:2
+4 if P=1
DO HEADER
IF (IOSL-$Y)<6
DO HOLD
if EX[U
QUIT
+5 SET LINE1=^TMP($JOB,CP,ZP,1)
WRITE !,$PIECE(LINE1,"^"),?6,$PIECE(LINE1,"^",2),?25,$PIECE(LINE1,"^",3),?50,$PIECE(LINE1,"^",4)
+6 SET AMT1=$PIECE(^TMP($JOB,CP,ZP,2),"^",1)
WRITE !,?3,$JUSTIFY(AMT1,0,2),?20,$PIECE(^TMP($JOB,CP,ZP,2),"^",2),?36,$PIECE(^TMP($JOB,CP,ZP,2),"^",3),?50,$PIECE(^TMP($JOB,CP,ZP,2),"^",4)
+7 WRITE !,^TMP($JOB,CP,ZP,3),!,^TMP($JOB,CP,ZP,4),!
+8 SET TOT=TOT+AMT1
End DoDot:2
+9 IF EX'[U
WRITE !,?40,"CONTROL POINT ",CP," SUBTOTAL: ",$JUSTIFY(TOT,0,2),!
SET TOT=0
End DoDot:1
+10 QUIT
+11 ;
HOLD if $EXTRACT(IOST)="P"!(IO'=IO(0))
GOTO HEADER
WRITE !,"Press return to continue, '^' to exit: "
READ XXZ:DTIME
if XXZ["^"
SET EX=U
if '$TEST
SET EX=U
if EX'=U
DO HEADER
QUIT
+1 ;
+1 WRITE @IOF
+2 WRITE !,"DETAILED REPORT OF UNPAID PURCHASE CARD TRANSACTIONS BY FCP",?65,"PAGE: ",P
+3 WRITE !,"FCP",?6,"PC NUMBER",?25,"BUYER",?50,"VENDOR"
+4 WRITE !,?3,"AMOUNT",?20,"PURCHASE DATE",?36,"COST CENTER",?50,"BUDGET OBJECT CODE",!,"FIRST LINE ITEM DESCRIPTION",!,"STATUS"
+5 WRITE !
FOR I=1:1:10
WRITE "--------"
+6 SET P=P+1
QUIT
