PRCHRP7 ;WISC/KMB/CR-DELINQUENT PC LISTING ;6/05/98 13:17
;;5.1;IFCAP;**8**;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
STRT ;
N FLAG S FLAG=2
STRT1 ;
S:$G(FLAG)="" FLAG=1
START ;
K ^TMP($J)
N AMT1,END,PNUM,Y,P,USER,VEN,VEND,PC,PC1,STATUS,VPHONE,ADATE,TDATE,Z1,Z2,Z3,QTY,QTYOUT,CP,X,XXZ,EX,QTYORD,QTYPRCD,QTYOUT,ITEM,PART,PARTDATE,STR,YDATE,TAMT,TIMEDATE
N DETAIL1,DETAIL2,DETAIL3,I,PCNAME,ZP,CC,LDESC,CCP,ORDTOT,QTYAMT,QSTATUS
N AMTDSCT,PDATE,PRC,PRCRI,STR1,STR2,STR3,Q,Q1,Q2,Q3
S:$G(FLAG)="" FLAG=0
S PRCF("X")="S" D ^PRCFSITE Q:'$D(PRC("SITE")) Q:$G(X)="^"
W !,"Please enter a device for printing this report",!
S %ZIS("B")="",%ZIS="MQ" D ^%ZIS Q:POP
I $D(IO("Q")) S ZTSAVE("*")="",ZTRTN="DEL^PRCHRP7" D ^%ZTLOAD,^%ZISC K FLAG QUIT
D DEL,^%ZISC K FLAG
Q
;
DEL ;
D NOW^%DTC S TDATE=$P(%,"."),(P,EX)=1
S ZP="" F S ZP=$O(^PRC(442,"F",25,ZP)) Q:ZP="" D
.S Z1=$G(^PRC(442,ZP,0)),Z2=$G(^PRC(442,ZP,1)),Z3=$G(^PRC(442,ZP,23)) S ADATE=$P($G(^PRC(442,ZP,1)),"^",15)
.;Do not mix orders from different stations.
.I $D(PRC("SITE")) Q:$P(Z1,"-")'=PRC("SITE")
.Q:$P(Z1,"^",10)>TDATE
.S QSTATUS=+$P($G(^PRC(442,ZP,7)),"^",2)
.Q:"^22^23^24^25^26^29^32^34^39^44^46^47^"'[("^"_QSTATUS_"^")
.S Y=$P(ADATE,".") D DD^%DT S PDATE=Y
.Q:$G(^PRC(442,ZP,2,0))=""
.S VEN=$P(Z2,"^"),VPHONE=$P($G(^PRC(440,+VEN,0)),"^",10),VEND=$P($G(^PRC(440,+VEN,0)),"^")
.I VEND="SIMPLIFIED",$P($G(^PRC(442,ZP,24)),"^",2)'="" S VEND=$P($G(^PRC(442,ZP,24)),"^",2)
.S STATUS=$P($G(^PRC(442,ZP,7)),"^")
.S STATUS=$P($G(^PRCD(442.3,+STATUS,0)),"^") S:STATUS="" STATUS=0
.S STATUS=$E(STATUS,1,34)
.S PC1=$P(Z3,"^",8) Q:+PC1=0 S PC=$P($G(^PRC(440.5,+PC1,0)),"^") Q:PC=""
.I $G(FLAG)=1 I $P($G(^PRC(440.5,+PC1,0)),"^",9)'=DUZ QUIT
.I $G(FLAG)=2 I $P($G(^PRC(440.5,+PC1,0)),"^",8)'=DUZ QUIT
.S PCNAME=$P($G(^PRC(440.5,PC1,0)),"^",11),PCNAME=$E(PCNAME,1,15)
.S CP=$P(Z1,"^",3),CP=$P(CP," ")
.S USER=$P($G(^PRC(440.5,PC1,0)),"^",8),USER=$P($G(^VA(200,+USER,0)),"^") Q:USER=""
.S PNUM=$P(Z1,"^",1)
.S ITEM=0 F S ITEM=$O(^PRC(442,ZP,2,ITEM)) Q:ITEM="" D
..Q:'$D(^PRC(442,ZP,2,"C",ITEM))
..;
..;Get the orders with partials received.
..I $D(^PRC(442,ZP,2,ITEM))&($D(^PRC(442,ZP,2,ITEM,3))) D
...S DETAIL1=^PRC(442,ZP,2,ITEM,0),QTYORD=$P(DETAIL1,"^",2),QTYAMT=$P(DETAIL1,"^",9)
...S (PART,ORDTOT)=0 F S PART=$O(^PRC(442,ZP,2,ITEM,3,PART)) Q:PART="" D
....S STR=$G(^PRC(442,ZP,2,ITEM,3,PART,0)) Q:STR=""
....S YDATE=$P(STR,"^")
....S Y=$P(YDATE,".") D DD^%DT S PARTDATE=Y
....D DETAIL2
..;
..;Get orders without any partials received.
..I $D(^PRC(442,ZP,2,ITEM))&('$D(^PRC(442,ZP,2,ITEM,3))) D
...S DETAIL1=^PRC(442,ZP,2,ITEM,0),QTYORD=$P(DETAIL1,"^",2),QTYAMT=$P(DETAIL1,"^",9)
...S YDATE=$P(^PRC(442,ZP,0),"^",10)
...S Y=$P(YDATE,".") D DD^%DT S PARTDATE=Y
...D DETAIL2
;
D PRINT
K ^TMP($J)
Q
;
DETAIL2 ; Get common calculations in one place, account for discounts too.
S DETAIL3=$G(^PRC(442,ZP,2,ITEM,2)),QTYPRCD=$P(DETAIL3,"^",8)
S AMTDSCT=$P(DETAIL3,"^",6)
S QTYOUT=QTYORD-QTYPRCD
S ORDTOT=QTYOUT*QTYAMT I AMTDSCT>0 S ORDTOT=ORDTOT-AMTDSCT
S ORDTOT=$J(ORDTOT,0,2)
S LDESC=$G(^PRC(442,ZP,2,ITEM,1,1,0)),LDESC=$E(LDESC,1,40)
S ^TMP($J,USER,PNUM,STATUS,PC,1)=PCNAME_"^"_PNUM_"^"_STATUS_"^"_PDATE
S ^TMP($J,USER,PNUM,STATUS,PC,2,ITEM)=PARTDATE_"^"_ITEM_"^"_QTYORD_"^"_QTYOUT_"^"_ORDTOT_"^"_LDESC
S ^TMP($J,USER,PNUM,STATUS,PC,3)=VEND_"^"_VPHONE
Q
;
PRINT ; Variable AMT1 equals the total amount outstanding by purchase card
; and user.
D NOW^%DTC S Y=% D DD^%DT S TIMEDATE=Y
U IO
I '$D(^TMP($J)) S P=1,Q="" D HEADER W !!!!,?10,"*** NO RECORDS TO PRINT ***" Q
S Q=0 F S Q=$O(^TMP($J,Q)) Q:Q="" Q:EX="^" D
.D HEADER
.S AMT1=0
.S Q1="" F S Q1=$O(^TMP($J,Q,Q1)) Q:Q1="" Q:EX="^" D
..S Q2="" F S Q2=$O(^TMP($J,Q,Q1,Q2)) Q:Q2="" Q:EX="^" D
...S Q3="" F S Q3=$O(^TMP($J,Q,Q1,Q2,Q3)) Q:Q3="" Q:EX="^" D
....S STR1=^TMP($J,Q,Q1,Q2,Q3,1),STR2=^TMP($J,Q,Q1,Q2,Q3,3)
....W !,$P(STR1,"^"),?20,$P(STR1,"^",2),?32,$P(STR1,"^",3),?68,$P(STR1,"^",4),!,$P(STR2,"^"),?45,$P(STR2,"^",2)
....S ITEM="" F S ITEM=$O(^TMP($J,Q,Q1,Q2,Q3,2,ITEM)) Q:ITEM="" Q:EX="^" D
.....S STR3=^TMP($J,Q,Q1,Q2,Q3,2,ITEM) W !,$P(STR3,"^"),?15,$P(STR3,"^",2),?40,$P(STR3,"^",3),?54,$P(STR3,"^",4),!,$P(STR3,"^",5),?30,$P(STR3,"^",6)
.....S AMT1=$P(STR3,"^",5)+$G(AMT1)
.....I (IOSL-$Y)<7 D HOLD Q:EX[U
....W !,"PURCHASE CARD SUBTOTAL: ",$J(AMT1,0,2),!
.I $E(IOST,1,2)="C-",EX'["^" W !,"Press return to continue, '^' to exit: " R XXZ:DTIME S:XXZ["^" EX="^" S:'$T EX=U
QUIT
;
HOLD G HEADER:$E(IOST,1,2)'="C-"!(IO'=IO(0)) W !,"Press return to continue, '^' to exit: " R XXZ:DTIME S:XXZ["^" EX="^" S:'$T EX=U I EX'="^",$G(Q3)'="" D HEADER
QUIT
;
W @IOF
W "DELINQUENT PURCHASE CARD LISTING",?45,TIMEDATE,?70,"PAGE ",P
W !!,"PURCHASE CARD NAME",?20,"PO NUMBER",?32,"STATUS",?67,"PO DATE",!,"VENDOR",?45,"VENDOR PHONE"
W !,"DELIVERY DATE",?15,"LINE ITEM OUTSTANDING",?40,"QTY ORDERED",?54,"QTY OUTSTANDING",!,"AMOUNT OUTSTANDING",?30,"ITEM DESCRIPTION"
W ! F I=1:1:8 W "----------"
W !,?20,"BUYER: ",Q,!
S P=P+1 QUIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHRP7 5195 printed Apr 09, 2024@21:09:18 Page 2
PRCHRP7 ;WISC/KMB/CR-DELINQUENT PC LISTING ;6/05/98 13:17
+1 ;;5.1;IFCAP;**8**;Oct 20, 2000
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
STRT ;
+1 NEW FLAG
SET FLAG=2
STRT1 ;
+1 if $GET(FLAG)=""
SET FLAG=1
START ;
+1 KILL ^TMP($JOB)
+2 NEW AMT1,END,PNUM,Y,P,USER,VEN,VEND,PC,PC1,STATUS,VPHONE,ADATE,TDATE,Z1,Z2,Z3,QTY,QTYOUT,CP,X,XXZ,EX,QTYORD,QTYPRCD,QTYOUT,ITEM,PART,PARTDATE,STR,YDATE,TAMT,TIMEDATE
+3 NEW DETAIL1,DETAIL2,DETAIL3,I,PCNAME,ZP,CC,LDESC,CCP,ORDTOT,QTYAMT,QSTATUS
+4 NEW AMTDSCT,PDATE,PRC,PRCRI,STR1,STR2,STR3,Q,Q1,Q2,Q3
+5 if $GET(FLAG)=""
SET FLAG=0
+6 SET PRCF("X")="S"
DO ^PRCFSITE
if '$DATA(PRC("SITE"))
QUIT
if $GET(X)="^"
QUIT
+7 WRITE !,"Please enter a device for printing this report",!
+8 SET %ZIS("B")=""
SET %ZIS="MQ"
DO ^%ZIS
if POP
QUIT
+9 IF $DATA(IO("Q"))
SET ZTSAVE("*")=""
SET ZTRTN="DEL^PRCHRP7"
DO ^%ZTLOAD
DO ^%ZISC
KILL FLAG
QUIT
+10 DO DEL
DO ^%ZISC
KILL FLAG
+11 QUIT
+12 ;
DEL ;
+1 DO NOW^%DTC
SET TDATE=$PIECE(%,".")
SET (P,EX)=1
+2 SET ZP=""
FOR
SET ZP=$ORDER(^PRC(442,"F",25,ZP))
if ZP=""
QUIT
Begin DoDot:1
+3 SET Z1=$GET(^PRC(442,ZP,0))
SET Z2=$GET(^PRC(442,ZP,1))
SET Z3=$GET(^PRC(442,ZP,23))
SET ADATE=$PIECE($GET(^PRC(442,ZP,1)),"^",15)
+4 ;Do not mix orders from different stations.
+5 IF $DATA(PRC("SITE"))
if $PIECE(Z1,"-")'=PRC("SITE")
QUIT
+6 if $PIECE(Z1,"^",10)>TDATE
QUIT
+7 SET QSTATUS=+$PIECE($GET(^PRC(442,ZP,7)),"^",2)
+8 if "^22^23^24^25^26^29^32^34^39^44^46^47^"'[("^"_QSTATUS_"^")
QUIT
+9 SET Y=$PIECE(ADATE,".")
DO DD^%DT
SET PDATE=Y
+10 if $GET(^PRC(442,ZP,2,0))=""
QUIT
+11 SET VEN=$PIECE(Z2,"^")
SET VPHONE=$PIECE($GET(^PRC(440,+VEN,0)),"^",10)
SET VEND=$PIECE($GET(^PRC(440,+VEN,0)),"^")
+12 IF VEND="SIMPLIFIED"
IF $PIECE($GET(^PRC(442,ZP,24)),"^",2)'=""
SET VEND=$PIECE($GET(^PRC(442,ZP,24)),"^",2)
+13 SET STATUS=$PIECE($GET(^PRC(442,ZP,7)),"^")
+14 SET STATUS=$PIECE($GET(^PRCD(442.3,+STATUS,0)),"^")
if STATUS=""
SET STATUS=0
+15 SET STATUS=$EXTRACT(STATUS,1,34)
+16 SET PC1=$PIECE(Z3,"^",8)
if +PC1=0
QUIT
SET PC=$PIECE($GET(^PRC(440.5,+PC1,0)),"^")
if PC=""
QUIT
+17 IF $GET(FLAG)=1
IF $PIECE($GET(^PRC(440.5,+PC1,0)),"^",9)'=DUZ
QUIT
+18 IF $GET(FLAG)=2
IF $PIECE($GET(^PRC(440.5,+PC1,0)),"^",8)'=DUZ
QUIT
+19 SET PCNAME=$PIECE($GET(^PRC(440.5,PC1,0)),"^",11)
SET PCNAME=$EXTRACT(PCNAME,1,15)
+20 SET CP=$PIECE(Z1,"^",3)
SET CP=$PIECE(CP," ")
+21 SET USER=$PIECE($GET(^PRC(440.5,PC1,0)),"^",8)
SET USER=$PIECE($GET(^VA(200,+USER,0)),"^")
if USER=""
QUIT
+22 SET PNUM=$PIECE(Z1,"^",1)
+23 SET ITEM=0
FOR
SET ITEM=$ORDER(^PRC(442,ZP,2,ITEM))
if ITEM=""
QUIT
Begin DoDot:2
+24 if '$DATA(^PRC(442,ZP,2,"C",ITEM))
QUIT
+25 ;
+26 ;Get the orders with partials received.
+27 IF $DATA(^PRC(442,ZP,2,ITEM))&($DATA(^PRC(442,ZP,2,ITEM,3)))
Begin DoDot:3
+28 SET DETAIL1=^PRC(442,ZP,2,ITEM,0)
SET QTYORD=$PIECE(DETAIL1,"^",2)
SET QTYAMT=$PIECE(DETAIL1,"^",9)
+29 SET (PART,ORDTOT)=0
FOR
SET PART=$ORDER(^PRC(442,ZP,2,ITEM,3,PART))
if PART=""
QUIT
Begin DoDot:4
+30 SET STR=$GET(^PRC(442,ZP,2,ITEM,3,PART,0))
if STR=""
QUIT
+31 SET YDATE=$PIECE(STR,"^")
+32 SET Y=$PIECE(YDATE,".")
DO DD^%DT
SET PARTDATE=Y
+33 DO DETAIL2
End DoDot:4
End DoDot:3
+34 ;
+35 ;Get orders without any partials received.
+36 IF $DATA(^PRC(442,ZP,2,ITEM))&('$DATA(^PRC(442,ZP,2,ITEM,3)))
Begin DoDot:3
+37 SET DETAIL1=^PRC(442,ZP,2,ITEM,0)
SET QTYORD=$PIECE(DETAIL1,"^",2)
SET QTYAMT=$PIECE(DETAIL1,"^",9)
+38 SET YDATE=$PIECE(^PRC(442,ZP,0),"^",10)
+39 SET Y=$PIECE(YDATE,".")
DO DD^%DT
SET PARTDATE=Y
+40 DO DETAIL2
End DoDot:3
End DoDot:2
End DoDot:1
+41 ;
+42 DO PRINT
+43 KILL ^TMP($JOB)
+44 QUIT
+45 ;
DETAIL2 ; Get common calculations in one place, account for discounts too.
+1 SET DETAIL3=$GET(^PRC(442,ZP,2,ITEM,2))
SET QTYPRCD=$PIECE(DETAIL3,"^",8)
+2 SET AMTDSCT=$PIECE(DETAIL3,"^",6)
+3 SET QTYOUT=QTYORD-QTYPRCD
+4 SET ORDTOT=QTYOUT*QTYAMT
IF AMTDSCT>0
SET ORDTOT=ORDTOT-AMTDSCT
+5 SET ORDTOT=$JUSTIFY(ORDTOT,0,2)
+6 SET LDESC=$GET(^PRC(442,ZP,2,ITEM,1,1,0))
SET LDESC=$EXTRACT(LDESC,1,40)
+7 SET ^TMP($JOB,USER,PNUM,STATUS,PC,1)=PCNAME_"^"_PNUM_"^"_STATUS_"^"_PDATE
+8 SET ^TMP($JOB,USER,PNUM,STATUS,PC,2,ITEM)=PARTDATE_"^"_ITEM_"^"_QTYORD_"^"_QTYOUT_"^"_ORDTOT_"^"_LDESC
+9 SET ^TMP($JOB,USER,PNUM,STATUS,PC,3)=VEND_"^"_VPHONE
+10 QUIT
+11 ;
PRINT ; Variable AMT1 equals the total amount outstanding by purchase card
+1 ; and user.
+2 DO NOW^%DTC
SET Y=%
DO DD^%DT
SET TIMEDATE=Y
+3 USE IO
+4 IF '$DATA(^TMP($JOB))
SET P=1
SET Q=""
DO HEADER
WRITE !!!!,?10,"*** NO RECORDS TO PRINT ***"
QUIT
+5 SET Q=0
FOR
SET Q=$ORDER(^TMP($JOB,Q))
if Q=""
QUIT
if EX="^"
QUIT
Begin DoDot:1
+6 DO HEADER
+7 SET AMT1=0
+8 SET Q1=""
FOR
SET Q1=$ORDER(^TMP($JOB,Q,Q1))
if Q1=""
QUIT
if EX="^"
QUIT
Begin DoDot:2
+9 SET Q2=""
FOR
SET Q2=$ORDER(^TMP($JOB,Q,Q1,Q2))
if Q2=""
QUIT
if EX="^"
QUIT
Begin DoDot:3
+10 SET Q3=""
FOR
SET Q3=$ORDER(^TMP($JOB,Q,Q1,Q2,Q3))
if Q3=""
QUIT
if EX="^"
QUIT
Begin DoDot:4
+11 SET STR1=^TMP($JOB,Q,Q1,Q2,Q3,1)
SET STR2=^TMP($JOB,Q,Q1,Q2,Q3,3)
+12 WRITE !,$PIECE(STR1,"^"),?20,$PIECE(STR1,"^",2),?32,$PIECE(STR1,"^",3),?68,$PIECE(STR1,"^",4),!,$PIECE(STR2,"^"),?45,$PIECE(STR2,"^",2)
+13 SET ITEM=""
FOR
SET ITEM=$ORDER(^TMP($JOB,Q,Q1,Q2,Q3,2,ITEM))
if ITEM=""
QUIT
if EX="^"
QUIT
Begin DoDot:5
+14 SET STR3=^TMP($JOB,Q,Q1,Q2,Q3,2,ITEM)
WRITE !,$PIECE(STR3,"^"),?15,$PIECE(STR3,"^",2),?40,$PIECE(STR3,"^",3),?54,$PIECE(STR3,"^",4),!,$PIECE(STR3,"^",5),?30,$PIECE(STR3,"^",6)
+15 SET AMT1=$PIECE(STR3,"^",5)+$GET(AMT1)
+16 IF (IOSL-$Y)<7
DO HOLD
if EX[U
QUIT
End DoDot:5
+17 WRITE !,"PURCHASE CARD SUBTOTAL: ",$JUSTIFY(AMT1,0,2),!
End DoDot:4
End DoDot:3
End DoDot:2
+18 IF $EXTRACT(IOST,1,2)="C-"
IF EX'["^"
WRITE !,"Press return to continue, '^' to exit: "
READ XXZ:DTIME
if XXZ["^"
SET EX="^"
if '$TEST
SET EX=U
End DoDot:1
+19 QUIT
+20 ;
HOLD if $EXTRACT(IOST,1,2)'="C-"!(IO'=IO(0))
GOTO HEADER
WRITE !,"Press return to continue, '^' to exit: "
READ XXZ:DTIME
if XXZ["^"
SET EX="^"
if '$TEST
SET EX=U
IF EX'="^"
IF $GET(Q3)'=""
DO HEADER
+1 QUIT
+2 ;
+1 WRITE @IOF
+2 WRITE "DELINQUENT PURCHASE CARD LISTING",?45,TIMEDATE,?70,"PAGE ",P
+3 WRITE !!,"PURCHASE CARD NAME",?20,"PO NUMBER",?32,"STATUS",?67,"PO DATE",!,"VENDOR",?45,"VENDOR PHONE"
+4 WRITE !,"DELIVERY DATE",?15,"LINE ITEM OUTSTANDING",?40,"QTY ORDERED",?54,"QTY OUTSTANDING",!,"AMOUNT OUTSTANDING",?30,"ITEM DESCRIPTION"
+5 WRITE !
FOR I=1:1:8
WRITE "----------"
+6 WRITE !,?20,"BUYER: ",Q,!
+7 SET P=P+1
QUIT
