PRCPDAP2 ;WISC/RFJ-drug accountability/prime vendor (check items) ;15 Mar 94
;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
Q
;
;
PRINT ; print items on invoice
; prcpferr=1 for errors, do not create repetitive item lists
N X
K X S X(1)="Enter the device which will be used to print the items on the invoice, any errors with the items, and the repetitive item list number if created." D DISPLAY^PRCPUX2(5,60,.X)
S %ZIS="Q" D ^%ZIS Q:POP I $D(IO("Q")) D D ^%ZTLOAD K IO("Q"),ZTSK Q
. S ZTDESC="Prime Vendor Invoice Upload Report",ZTRTN="DQ^PRCPDAP2"
. S ZTSAVE("PRC*")="",ZTSAVE("^TMP($J,")="",ZTSAVE("ZTREQ")="@"
W !!,"<*> please wait <*>"
DQ ; queue starts here
N %,%H,%I,DA,DATA,INVDATA,ITEMDA,LINEITEM,NOW,PAGE,PRCPFLAG,QTY,SCREEN,STCTRL,TOTAL,TOTCOST,UNITCOST,VENDA,VENDATA,WHODATA,X,Y
D NOW^%DTC S Y=% D DD^%DT S NOW=Y,PAGE=1,SCREEN=$$SCRPAUSE^PRCPUREP U IO
S STCTRL="" F S STCTRL=$O(^TMP($J,"PRCPDAPV SET",STCTRL)) Q:STCTRL=""!($G(PRCPFLAG)) D
. D H^PRCPDAP3
. I $G(^TMP($J,"PRCPDAPV SET",STCTRL,"E")) K X S X(1)="THERE ARE ERRORS WITH THIS INVOICE WHICH NEED CORRECTING BEFORE THE REPETITVE ITEM LIST CAN BE CREATED." D DISPLAY^PRCPUX2(1,80,.X)
. S INVDATA=$G(^TMP($J,"PRCPDAPV SET",STCTRL,"IN"))
. W !!,"INVOICE : ",$P(INVDATA,"^",2),?40,"DATE: ",$$DATE($P(INVDATA,"^"))
. W !,"PURCHASE ORDER: ",$P(INVDATA,"^",4),?40,"DATE: ",$$DATE($P(INVDATA,"^",3))
. W !?5,"PRIME VENDOR: ",$P($G(^PRC(440,PRCPVEND,0)),"^")
. W !?5,"TERMS DISCOUNT PERCENT: ",$P(INVDATA,"^",6),?40,"DUE DATE: ",$$DATE($P(INVDATA,"^",7)),?60,"DAYS DUE: ",$P(INVDATA,"^",8)
. W !?5,"TERMS DISCOUNT AMOUNT : ",$J($P(INVDATA,"^",11),0,2),?40,"DUE DATE: ",$$DATE($P(INVDATA,"^",9)),?60,"NET DAYS: ",$P(INVDATA,"^",10),!
. W !?5,"DELIVERY DATE REQUESTED: ",$$DATE($P(INVDATA,"^",12))
. W !?5,"DELIVERED ON DATE : ",$$DATE($P(INVDATA,"^",13))
. I $Y>(IOSL-8) D:SCREEN P^PRCPUREP Q:$G(PRCPFLAG) D H^PRCPDAP3
. W !!?5,"BUYER INFORMATION: "
. S WHODATA=$G(^TMP($J,"PRCPDAPV SET",STCTRL,"BY")) I WHODATA="" W "(SAME AS SHIPPING INFORMATION)"
. E D WHO(WHODATA)
. I $Y>(IOSL-8) D:SCREEN P^PRCPUREP Q:$G(PRCPFLAG) D H^PRCPDAP3
. W !!?5,"SHIPPING INFORMATION: "
. S WHODATA=$G(^TMP($J,"PRCPDAPV SET",STCTRL,"ST")) I WHODATA="" W "(SAME AS BUYER INFORMATION)"
. E D WHO(WHODATA)
. I $Y>(IOSL-8) D:SCREEN P^PRCPUREP Q:$G(PRCPFLAG) D H^PRCPDAP3
. W !!?5,"DISTRIBUTER INFORMATION: "
. S WHODATA=$G(^TMP($J,"PRCPDAPV SET",STCTRL,"DS")) D WHO(WHODATA)
. I $Y>(IOSL-8) D:SCREEN P^PRCPUREP Q:$G(PRCPFLAG) D H^PRCPDAP3
. D LINEITEM^PRCPDAP3
Q
;
;
DATE(DATE) ; convert date
S %=$E(DATE,3,4)_"/"_$E(DATE,5,6)_"/"_$E(DATE,1,2)
I $TR(%,"/")="" S %=""
Q %
;
;
WHO(WHODATA) ; show buyer, shipping, seller address information
W !?8,"NAME: ",$P(WHODATA,"^"),?62,"ID: ",$P(WHODATA,"^",2)
W !?8,"ADDR: ",$P(WHODATA,"^",3)
W !?8,"CITY: ",$P(WHODATA,"^",4),?40,"STATE: ",$P(WHODATA,"^",5),?62,"ZIPCODE: ",$P(WHODATA,"^",6)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPDAP2 3111 printed Sep 23, 2025@19:49:28 Page 2
PRCPDAP2 ;WISC/RFJ-drug accountability/prime vendor (check items) ;15 Mar 94
+1 ;;5.1;IFCAP;;Oct 20, 2000
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
+3 QUIT
+4 ;
+5 ;
PRINT ; print items on invoice
+1 ; prcpferr=1 for errors, do not create repetitive item lists
+2 NEW X
+3 KILL X
SET X(1)="Enter the device which will be used to print the items on the invoice, any errors with the items, and the repetitive item list number if created."
DO DISPLAY^PRCPUX2(5,60,.X)
+4 SET %ZIS="Q"
DO ^%ZIS
if POP
QUIT
IF $DATA(IO("Q"))
Begin DoDot:1
+5 SET ZTDESC="Prime Vendor Invoice Upload Report"
SET ZTRTN="DQ^PRCPDAP2"
+6 SET ZTSAVE("PRC*")=""
SET ZTSAVE("^TMP($J,")=""
SET ZTSAVE("ZTREQ")="@"
End DoDot:1
DO ^%ZTLOAD
KILL IO("Q"),ZTSK
QUIT
+7 WRITE !!,"<*> please wait <*>"
DQ ; queue starts here
+1 NEW %,%H,%I,DA,DATA,INVDATA,ITEMDA,LINEITEM,NOW,PAGE,PRCPFLAG,QTY,SCREEN,STCTRL,TOTAL,TOTCOST,UNITCOST,VENDA,VENDATA,WHODATA,X,Y
+2 DO NOW^%DTC
SET Y=%
DO DD^%DT
SET NOW=Y
SET PAGE=1
SET SCREEN=$$SCRPAUSE^PRCPUREP
USE IO
+3 SET STCTRL=""
FOR
SET STCTRL=$ORDER(^TMP($JOB,"PRCPDAPV SET",STCTRL))
if STCTRL=""!($GET(PRCPFLAG))
QUIT
Begin DoDot:1
+4 DO H^PRCPDAP3
+5 IF $GET(^TMP($JOB,"PRCPDAPV SET",STCTRL,"E"))
KILL X
SET X(1)="THERE ARE ERRORS WITH THIS INVOICE WHICH NEED CORRECTING BEFORE THE REPETITVE ITEM LIST CAN BE CREATED."
DO DISPLAY^PRCPUX2(1,80,.X)
+6 SET INVDATA=$GET(^TMP($JOB,"PRCPDAPV SET",STCTRL,"IN"))
+7 WRITE !!,"INVOICE : ",$PIECE(INVDATA,"^",2),?40,"DATE: ",$$DATE($PIECE(INVDATA,"^"))
+8 WRITE !,"PURCHASE ORDER: ",$PIECE(INVDATA,"^",4),?40,"DATE: ",$$DATE($PIECE(INVDATA,"^",3))
+9 WRITE !?5,"PRIME VENDOR: ",$PIECE($GET(^PRC(440,PRCPVEND,0)),"^")
+10 WRITE !?5,"TERMS DISCOUNT PERCENT: ",$PIECE(INVDATA,"^",6),?40,"DUE DATE: ",$$DATE($PIECE(INVDATA,"^",7)),?60,"DAYS DUE: ",$PIECE(INVDATA,"^",8)
+11 WRITE !?5,"TERMS DISCOUNT AMOUNT : ",$JUSTIFY($PIECE(INVDATA,"^",11),0,2),?40,"DUE DATE: ",$$DATE($PIECE(INVDATA,"^",9)),?60,"NET DAYS: ",$PIECE(INVDATA,"^",10),!
+12 WRITE !?5,"DELIVERY DATE REQUESTED: ",$$DATE($PIECE(INVDATA,"^",12))
+13 WRITE !?5,"DELIVERED ON DATE : ",$$DATE($PIECE(INVDATA,"^",13))
+14 IF $Y>(IOSL-8)
if SCREEN
DO P^PRCPUREP
if $GET(PRCPFLAG)
QUIT
DO H^PRCPDAP3
+15 WRITE !!?5,"BUYER INFORMATION: "
+16 SET WHODATA=$GET(^TMP($JOB,"PRCPDAPV SET",STCTRL,"BY"))
IF WHODATA=""
WRITE "(SAME AS SHIPPING INFORMATION)"
+17 IF '$TEST
DO WHO(WHODATA)
+18 IF $Y>(IOSL-8)
if SCREEN
DO P^PRCPUREP
if $GET(PRCPFLAG)
QUIT
DO H^PRCPDAP3
+19 WRITE !!?5,"SHIPPING INFORMATION: "
+20 SET WHODATA=$GET(^TMP($JOB,"PRCPDAPV SET",STCTRL,"ST"))
IF WHODATA=""
WRITE "(SAME AS BUYER INFORMATION)"
+21 IF '$TEST
DO WHO(WHODATA)
+22 IF $Y>(IOSL-8)
if SCREEN
DO P^PRCPUREP
if $GET(PRCPFLAG)
QUIT
DO H^PRCPDAP3
+23 WRITE !!?5,"DISTRIBUTER INFORMATION: "
+24 SET WHODATA=$GET(^TMP($JOB,"PRCPDAPV SET",STCTRL,"DS"))
DO WHO(WHODATA)
+25 IF $Y>(IOSL-8)
if SCREEN
DO P^PRCPUREP
if $GET(PRCPFLAG)
QUIT
DO H^PRCPDAP3
+26 DO LINEITEM^PRCPDAP3
End DoDot:1
+27 QUIT
+28 ;
+29 ;
DATE(DATE) ; convert date
+1 SET %=$EXTRACT(DATE,3,4)_"/"_$EXTRACT(DATE,5,6)_"/"_$EXTRACT(DATE,1,2)
+2 IF $TRANSLATE(%,"/")=""
SET %=""
+3 QUIT %
+4 ;
+5 ;
WHO(WHODATA) ; show buyer, shipping, seller address information
+1 WRITE !?8,"NAME: ",$PIECE(WHODATA,"^"),?62,"ID: ",$PIECE(WHODATA,"^",2)
+2 WRITE !?8,"ADDR: ",$PIECE(WHODATA,"^",3)
+3 WRITE !?8,"CITY: ",$PIECE(WHODATA,"^",4),?40,"STATE: ",$PIECE(WHODATA,"^",5),?62,"ZIPCODE: ",$PIECE(WHODATA,"^",6)
+4 QUIT
