- 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 Mar 13, 2025@21:11:37 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
