- 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 Feb 18, 2025@23:39:47 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
