PRCHDPO ;WOIFO/CR - DELINQUENT DELIVERY LISTING PA OPTION ; 2/20/01 12:55 PM
;;5.1;IFCAP;**8,133**;Oct 20, 2000;Build 5
;Per VHA Directive 2004-038, this routine should not be modified.
A1 ;
D CLEAN
TYPE K Y,SELECT S SELECTW="" W !!
S DIR("?")=" ",DIR("?",1)="Enter the Supply Employee code desired."
S DIR("?",2)="Enter multiple codes if needed, ex. 1,3 or 2-4"
S DIR("?",3)="Normal run has been for 6-ALL"
S DIR(0)="L^1:6:0"
S DIR("A",1)="Supply Employee type selection: ",DIR("A",2)="",DIR("A",3)="1:WAREHOUSE",DIR("A",4)="2:PPM ACCOUNTABLE OFFICER"
S DIR("A",5)="3:PURCHASING AGENT",DIR("A",6)="4:MANAGER",DIR("A",7)="5:PURCHASE CARD HOLDER"
S DIR("A",8)="6:ALL OF THE ABOVE",DIR("A",9)=""
S DIR("A")="By Type of Supply Employee: ",DIR("B")="6" D ^DIR
Q:$D(DIRUT)!($D(DTOUT))
S SELECT=Y I SELECT[6 S SELECTW="<All Supply Employee types>",SELECT="6,"
E F I=1:1 S X=$P(SELECT,",",I) Q:X="" I X>0 S:SELECTW'="" SELECTW=SELECTW_"," S SELECTW=SELECTW_$P("WAREHOUSE,PPM ACCT OFFICER,PURCHASING AGENT,MANAGER,PURCHASE CARD HOLDER",",",X)
W !!,"SELECTED: ",$E(SELECT,1,($L(SELECT)-1))," / ",SELECTW,!
K DR,DIR,X,Y,DIRUT,DTOUT
DATE S DIR("A")="START WITH DELIVERY DATE",DIR(0)="D^^" D ^DIR K DIR Q:Y["^"!(Y<1)
S FDATE=+Y W " ",Y(0)
;
S DIR("A")="GO TO DELIVERY DATE",DIR(0)="D^^" D ^DIR K DIR Q:Y["^"!(Y<1)
S EDATE=+Y W " ",Y(0)
I EDATE<FDATE W !,$C(7),"Less than 'FROM' value.",! K EDATE,FDATE G DATE
;
S %ZIS("B")="",%ZIS="MQ" D ^%ZIS Q:POP
I $D(IO("Q")) S ZTRTN="STAT^PRCHDPO",ZTSAVE("*")="" D ^%ZTLOAD,^%ZISC Q
D STAT
D ^%ZISC
Q
;
FRMDT ; Make the current date for the header easier to read.
D NOW^%DTC S Y=% D DD^%DT
S X1=$P(Y,"@",1),X2=$P(X1,",",1)_","_$P(X1,", ",2)
S X3=$P($P(Y,"@",2),":",1,2)
S DATE=X2_" "_X3
Q
;
FRMDT1 ; Compress the delivery date display.
S X1=$P(Y,",",1)_","_$P(Y,", ",2)
Q
;
STAT ; Gather all the statistics
S (GTOT,AMT1)=0,(VENTOT,SUBUSER)="",P=1
S I="" F S I=$O(^PRC(442,"B",I)) Q:I="" D
.S ZP="" F S ZP=$O(^PRC(442,"B",I,ZP)) Q:ZP="" D
..S ZP0=$G(^PRC(442,ZP,0)),DELDT=$P(ZP0,"^",10)
..S PONUM=$P(ZP0,"^",1),MOP=$P(ZP0,"^",2)
..; Check all possible methods of processing
..Q:"^1^2^3^4^7^8^9^21^22^23^25^26^"'[("^"_MOP_"^")
..S ZP1=$G(^PRC(442,ZP,1))
..Q:ZP1=""
..Q:DELDT<FDATE
..Q:DELDT>EDATE
..S Y=DELDT D DD^%DT,FRMDT1 S DELDT=X1 ; Show a human-readable date
..S VENPTR=$P(ZP1,"^",1)
..Q:VENPTR=""!(VENPTR=0)!(VENPTR'>0)
..S VENDOR=$P(^PRC(440,VENPTR,0),"^",1)
..S PHONE=$P($G(^PRC(440,VENPTR,0)),"^",10)
..S PRCHPA=+$P(ZP1,"^",10) Q:PRCHPA=""!(PRCHPA=0)
..I $D(^VA(200,PRCHPA,0)) S USER=$P(^VA(200,PRCHPA,0),"^")_">"_PRCHPA
..I SELECT'[6 Q:+$G(^VA(200,PRCHPA,400))=0&(SELECT'[5) Q:+$G(^VA(200,PRCHPA,400))>0&(SELECT'[+$G(^VA(200,PRCHPA,400)))
..S:$D(^PRC(442,ZP,7)) ZP7=^PRC(442,ZP,7)
..S SUPT=+$P(ZP7,"^",1)
..S PRCSTAT=$P($G(^PRCD(442.3,SUPT,0)),"^")
..S SUPORD=$P(ZP7,"^",2)
..Q:"^20^21^22^23^24^25^26^27^28^29^32^34^39^44^46^47^"'[("^"_SUPORD_"^")
..S TOTAMT=$P(ZP0,"^",15),LIQAMT=$P(ZP0,"^",17)
..I LIQAMT<0,(TOTAMT-LIQAMT)>TOTAMT S COSOUT=0
..E S COSOUT=TOTAMT-LIQAMT I COSOUT<0 S COSOUT=0
..S ^TMP($J,USER,VENDOR,PONUM)=PONUM_"^"_PRCSTAT_"^"_COSOUT_"^"_VENDOR_"^"_PHONE_"^"_DELDT
;
PRINT ; Let's print the outstanding orders and dollar amounts.
;
U IO
D FRMDT
S (P,EX)=1,(TOT,AMT1)=0
I '$D(^TMP($J)) S P=1,(Q,Q1)="" D HEADER W !!!!,?10,"*** NO RECORDS TO PRINT ***" Q
S Q="" F S Q=$O(^TMP($J,Q)) Q:Q="" Q:EX="^" D
.D HEADER S (VENTOT,SUBUSER)=""
.S Q1="" F S Q1=$O(^TMP($J,Q,Q1)) Q:Q1="" Q:EX="^" D
..W:Q1]"" !,?18,"VENDOR: ",Q1
..S Q2="" F S Q2=$O(^TMP($J,Q,Q1,Q2)) Q:Q2="" Q:EX="^" D
...S AMT1=0
...S STR3=^TMP($J,Q,Q1,Q2)
...W !,$P(STR3,"^",1),?15,$P(STR3,"^",2),?60,$J($P(STR3,"^",3),10,2)
...W !,?3,$P(STR3,"^",6),?17,$P(STR3,"^",5)
...I (IOSL-$Y)<8 D HOLD Q:EX="^"
...S AMT1=$P(STR3,"^",3),TOT=AMT1+$G(TOT),VENTOT(USER,VENPTR)=TOT
..W !,?60,"----------"
..W !,"SUBTOTAL",?60,$J(VENTOT(USER,VENPTR),10,2),!
..S GTOT=$G(GTOT)+VENTOT(USER,VENPTR),SUBUSER(USER)=VENTOT(USER,VENPTR)+$G(SUBUSER(USER))
..S TOT=0
.I $E(IOST,1,2)="C-",EX'["^" W !,"Press return to continue, '^' to exit: " R XXZ:DTIME S:XXZ="^" EX="^" S:'$T EX="^"
.I $G(Q2)="" D
..W ?60,"----------"
..W !,"SUBTOTAL",?60,$J(SUBUSER(USER),10,2) S SUBUSER(USER)=""
..; This is the subtotal for the user including all the vendors used.
W !,?60,"----------"
W !,"TOTAL",?55,$J(GTOT,15,2)
D CLEAN
Q
;
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="^" I EX'="^",$G(Q2)'="" D HEADER
Q
;
W @IOF
W !,"DELINQUENT PURCHASE ORDERS",?42,DATE,?68,"PAGE ",P,!
W "** FOR SUPPLY EMPLOYEE: ",SELECTW,!
W !,"PO NUMBER",?15,"SUPPLY STATUS",?63,"COST",!
W ?3,"DELIVERY",?17,"PHONE",?60,"OUTSTANDING",!
W ?3,"DATE",?17,"NUMBER",?45,"(QTY*UNIT COST FOR ITEMS NOT REC'D)",!
F I=1:1:10 W "--------"
W !!,?15,"PA/PPM/AUTHORIZED BUYER: ",$P(Q,">"),!
S P=P+1
Q
;
CLEAN K AMT1,COSOUT,DATE,DELDT,EDATE,FDATE,PRCHPA,PRCSTAT,Q,Q1,Q2,^TMP($J)
K SUPT,TOT,TOTAMT,VENDOR,VENPTR,VENTOT,X,X1,X2,X3,XXZ,Y,ZP,ZP0,ZP1,ZP7
K EX,ENTOT,GTOT,I,LIQAMT,MOP,P,PHONE,PONUM,STR3,SUBUSER,SUPORD,USER
K SELECT,SELECTW
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHDPO 5323 printed Apr 09, 2024@21:20:28 Page 2
PRCHDPO ;WOIFO/CR - DELINQUENT DELIVERY LISTING PA OPTION ; 2/20/01 12:55 PM
+1 ;;5.1;IFCAP;**8,133**;Oct 20, 2000;Build 5
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
A1 ;
+1 DO CLEAN
TYPE KILL Y,SELECT
SET SELECTW=""
WRITE !!
+1 SET DIR("?")=" "
SET DIR("?",1)="Enter the Supply Employee code desired."
+2 SET DIR("?",2)="Enter multiple codes if needed, ex. 1,3 or 2-4"
+3 SET DIR("?",3)="Normal run has been for 6-ALL"
+4 SET DIR(0)="L^1:6:0"
+5 SET DIR("A",1)="Supply Employee type selection: "
SET DIR("A",2)=""
SET DIR("A",3)="1:WAREHOUSE"
SET DIR("A",4)="2:PPM ACCOUNTABLE OFFICER"
+6 SET DIR("A",5)="3:PURCHASING AGENT"
SET DIR("A",6)="4:MANAGER"
SET DIR("A",7)="5:PURCHASE CARD HOLDER"
+7 SET DIR("A",8)="6:ALL OF THE ABOVE"
SET DIR("A",9)=""
+8 SET DIR("A")="By Type of Supply Employee: "
SET DIR("B")="6"
DO ^DIR
+9 if $DATA(DIRUT)!($DATA(DTOUT))
QUIT
+10 SET SELECT=Y
IF SELECT[6
SET SELECTW="<All Supply Employee types>"
SET SELECT="6,"
+11 IF '$TEST
FOR I=1:1
SET X=$PIECE(SELECT,",",I)
if X=""
QUIT
IF X>0
if SELECTW'=""
SET SELECTW=SELECTW_","
SET SELECTW=SELECTW_$PIECE("WAREHOUSE,PPM ACCT OFFICER,PURCHASING AGENT,MANAGER,PURCHASE CARD HOLDER",",",X)
+12 WRITE !!,"SELECTED: ",$EXTRACT(SELECT,1,($LENGTH(SELECT)-1))," / ",SELECTW,!
+13 KILL DR,DIR,X,Y,DIRUT,DTOUT
DATE SET DIR("A")="START WITH DELIVERY DATE"
SET DIR(0)="D^^"
DO ^DIR
KILL DIR
if Y["^"!(Y<1)
QUIT
+1 SET FDATE=+Y
WRITE " ",Y(0)
+2 ;
+3 SET DIR("A")="GO TO DELIVERY DATE"
SET DIR(0)="D^^"
DO ^DIR
KILL DIR
if Y["^"!(Y<1)
QUIT
+4 SET EDATE=+Y
WRITE " ",Y(0)
+5 IF EDATE<FDATE
WRITE !,$CHAR(7),"Less than 'FROM' value.",!
KILL EDATE,FDATE
GOTO DATE
+6 ;
+7 SET %ZIS("B")=""
SET %ZIS="MQ"
DO ^%ZIS
if POP
QUIT
+8 IF $DATA(IO("Q"))
SET ZTRTN="STAT^PRCHDPO"
SET ZTSAVE("*")=""
DO ^%ZTLOAD
DO ^%ZISC
QUIT
+9 DO STAT
+10 DO ^%ZISC
+11 QUIT
+12 ;
FRMDT ; Make the current date for the header easier to read.
+1 DO NOW^%DTC
SET Y=%
DO DD^%DT
+2 SET X1=$PIECE(Y,"@",1)
SET X2=$PIECE(X1,",",1)_","_$PIECE(X1,", ",2)
+3 SET X3=$PIECE($PIECE(Y,"@",2),":",1,2)
+4 SET DATE=X2_" "_X3
+5 QUIT
+6 ;
FRMDT1 ; Compress the delivery date display.
+1 SET X1=$PIECE(Y,",",1)_","_$PIECE(Y,", ",2)
+2 QUIT
+3 ;
STAT ; Gather all the statistics
+1 SET (GTOT,AMT1)=0
SET (VENTOT,SUBUSER)=""
SET P=1
+2 SET I=""
FOR
SET I=$ORDER(^PRC(442,"B",I))
if I=""
QUIT
Begin DoDot:1
+3 SET ZP=""
FOR
SET ZP=$ORDER(^PRC(442,"B",I,ZP))
if ZP=""
QUIT
Begin DoDot:2
+4 SET ZP0=$GET(^PRC(442,ZP,0))
SET DELDT=$PIECE(ZP0,"^",10)
+5 SET PONUM=$PIECE(ZP0,"^",1)
SET MOP=$PIECE(ZP0,"^",2)
+6 ; Check all possible methods of processing
+7 if "^1^2^3^4^7^8^9^21^22^23^25^26^"'[("^"_MOP_"^")
QUIT
+8 SET ZP1=$GET(^PRC(442,ZP,1))
+9 if ZP1=""
QUIT
+10 if DELDT<FDATE
QUIT
+11 if DELDT>EDATE
QUIT
+12 ; Show a human-readable date
SET Y=DELDT
DO DD^%DT
DO FRMDT1
SET DELDT=X1
+13 SET VENPTR=$PIECE(ZP1,"^",1)
+14 if VENPTR=""!(VENPTR=0)!(VENPTR'>0)
QUIT
+15 SET VENDOR=$PIECE(^PRC(440,VENPTR,0),"^",1)
+16 SET PHONE=$PIECE($GET(^PRC(440,VENPTR,0)),"^",10)
+17 SET PRCHPA=+$PIECE(ZP1,"^",10)
if PRCHPA=""!(PRCHPA=0)
QUIT
+18 IF $DATA(^VA(200,PRCHPA,0))
SET USER=$PIECE(^VA(200,PRCHPA,0),"^")_">"_PRCHPA
+19 IF SELECT'[6
if +$GET(^VA(200,PRCHPA,400))=0&(SELECT'[5)
QUIT
if +$GET(^VA(200,PRCHPA,400))>0&(SELECT'[+$GET(^VA(200,PRCHPA,400)))
QUIT
+20 if $DATA(^PRC(442,ZP,7))
SET ZP7=^PRC(442,ZP,7)
+21 SET SUPT=+$PIECE(ZP7,"^",1)
+22 SET PRCSTAT=$PIECE($GET(^PRCD(442.3,SUPT,0)),"^")
+23 SET SUPORD=$PIECE(ZP7,"^",2)
+24 if "^20^21^22^23^24^25^26^27^28^29^32^34^39^44^46^47^"'[("^"_SUPORD_"^")
QUIT
+25 SET TOTAMT=$PIECE(ZP0,"^",15)
SET LIQAMT=$PIECE(ZP0,"^",17)
+26 IF LIQAMT<0
IF (TOTAMT-LIQAMT)>TOTAMT
SET COSOUT=0
+27 IF '$TEST
SET COSOUT=TOTAMT-LIQAMT
IF COSOUT<0
SET COSOUT=0
+28 SET ^TMP($JOB,USER,VENDOR,PONUM)=PONUM_"^"_PRCSTAT_"^"_COSOUT_"^"_VENDOR_"^"_PHONE_"^"_DELDT
End DoDot:2
End DoDot:1
+29 ;
PRINT ; Let's print the outstanding orders and dollar amounts.
+1 ;
+2 USE IO
+3 DO FRMDT
+4 SET (P,EX)=1
SET (TOT,AMT1)=0
+5 IF '$DATA(^TMP($JOB))
SET P=1
SET (Q,Q1)=""
DO HEADER
WRITE !!!!,?10,"*** NO RECORDS TO PRINT ***"
QUIT
+6 SET Q=""
FOR
SET Q=$ORDER(^TMP($JOB,Q))
if Q=""
QUIT
if EX="^"
QUIT
Begin DoDot:1
+7 DO HEADER
SET (VENTOT,SUBUSER)=""
+8 SET Q1=""
FOR
SET Q1=$ORDER(^TMP($JOB,Q,Q1))
if Q1=""
QUIT
if EX="^"
QUIT
Begin DoDot:2
+9 if Q1]""
WRITE !,?18,"VENDOR: ",Q1
+10 SET Q2=""
FOR
SET Q2=$ORDER(^TMP($JOB,Q,Q1,Q2))
if Q2=""
QUIT
if EX="^"
QUIT
Begin DoDot:3
+11 SET AMT1=0
+12 SET STR3=^TMP($JOB,Q,Q1,Q2)
+13 WRITE !,$PIECE(STR3,"^",1),?15,$PIECE(STR3,"^",2),?60,$JUSTIFY($PIECE(STR3,"^",3),10,2)
+14 WRITE !,?3,$PIECE(STR3,"^",6),?17,$PIECE(STR3,"^",5)
+15 IF (IOSL-$Y)<8
DO HOLD
if EX="^"
QUIT
+16 SET AMT1=$PIECE(STR3,"^",3)
SET TOT=AMT1+$GET(TOT)
SET VENTOT(USER,VENPTR)=TOT
End DoDot:3
+17 WRITE !,?60,"----------"
+18 WRITE !,"SUBTOTAL",?60,$JUSTIFY(VENTOT(USER,VENPTR),10,2),!
+19 SET GTOT=$GET(GTOT)+VENTOT(USER,VENPTR)
SET SUBUSER(USER)=VENTOT(USER,VENPTR)+$GET(SUBUSER(USER))
+20 SET TOT=0
End DoDot:2
+21 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="^"
+22 IF $GET(Q2)=""
Begin DoDot:2
+23 WRITE ?60,"----------"
+24 WRITE !,"SUBTOTAL",?60,$JUSTIFY(SUBUSER(USER),10,2)
SET SUBUSER(USER)=""
+25 ; This is the subtotal for the user including all the vendors used.
End DoDot:2
End DoDot:1
+26 WRITE !,?60,"----------"
+27 WRITE !,"TOTAL",?55,$JUSTIFY(GTOT,15,2)
+28 DO CLEAN
+29 QUIT
+30 ;
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="^"
IF EX'="^"
IF $GET(Q2)'=""
DO HEADER
+1 QUIT
+2 ;
+1 WRITE @IOF
+2 WRITE !,"DELINQUENT PURCHASE ORDERS",?42,DATE,?68,"PAGE ",P,!
+3 WRITE "** FOR SUPPLY EMPLOYEE: ",SELECTW,!
+4 WRITE !,"PO NUMBER",?15,"SUPPLY STATUS",?63,"COST",!
+5 WRITE ?3,"DELIVERY",?17,"PHONE",?60,"OUTSTANDING",!
+6 WRITE ?3,"DATE",?17,"NUMBER",?45,"(QTY*UNIT COST FOR ITEMS NOT REC'D)",!
+7 FOR I=1:1:10
WRITE "--------"
+8 WRITE !!,?15,"PA/PPM/AUTHORIZED BUYER: ",$PIECE(Q,">"),!
+9 SET P=P+1
+10 QUIT
+11 ;
CLEAN KILL AMT1,COSOUT,DATE,DELDT,EDATE,FDATE,PRCHPA,PRCSTAT,Q,Q1,Q2,^TMP($JOB)
+1 KILL SUPT,TOT,TOTAMT,VENDOR,VENPTR,VENTOT,X,X1,X2,X3,XXZ,Y,ZP,ZP0,ZP1,ZP7
+2 KILL EX,ENTOT,GTOT,I,LIQAMT,MOP,P,PHONE,PONUM,STR3,SUBUSER,SUPORD,USER
+3 KILL SELECT,SELECTW
+4 QUIT
