PRCPWPP0 ;WISC/RFJ,DWA-primary receive issue book (options) ;20 Jan 94
;;5.1;IFCAP;**4**;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
Q
;
;
EEITEMS ; called from protocol file to enter/edit invpt items
D FULL^VALM1
D EN^PRCPEILM
D REBUILD^PRCPWPPB
S VALMBCK="R"
Q
;
;
REMAIN ; set qty to receive to remaining (outstanding) qty
D FULL^VALM1
S VALMBCK="R"
N DATA,ITEMDA,LINEDA,QTY,X
K X S X(1)="This option will set the QUANTITY TO RECEIVE equal to the difference between the QUANTITY ORDERED and the QUANTITY PRIMARY REC'D."
D DISPLAY^PRCPUX2(5,75,.X)
S XP="Do you want to set the QUANTITY TO RECEIVE",XH="Enter YES to set the QUANTITY TO RECEIVE, NO or ^ to return to the list."
I $$YN^PRCPUYN(1)'=1 Q
S LINEDA=0 F S LINEDA=$O(^TMP($J,"PRCPWPPLLIST",LINEDA)) Q:'LINEDA S DATA=^(LINEDA) D
. S ITEMDA=+$P(DATA,"^"),QTY=+$P(DATA,"^",2)
. I '$D(^PRCP(445,PRCPINPT,1,ITEMDA,0)) S QTY=0
. S ^TMP($J,"PRCPWPPLPOST",LINEDA)=QTY
D REBUILD^PRCPWPPB
S VALMSG="QTY TO RECEIVE now set to remaining"
Q
;
;
ENTER ; enter quantity to post
D FULL^VALM1
S VALMBCK="R"
N DATA,DIR,ITEMDA,INVDATA,LINEDA,ONHAND,QTYOUT,QTYPST,QTYREC,STATUS,QUIT,X,Y
S QUIT=0
F W ! S LINEDA=$$LINEITEM Q:LINEDA<1 D
. S DATA=$G(^PRCS(410,PRCPDA,"IT",LINEDA,0)) I DATA="" W !,"CANNOT FIND LINE ITEM." Q
. S ITEMDA=+$P(DATA,"^",5),STATUS=$P(DATA,"^",14),INVDATA=$G(^PRCP(445,PRCPINPT,1,ITEMDA,0))
. I INVDATA="" W !,"ITEM (#",ITEMDA,") NOT STORED IN THE INVENTORY POINT." Q
. I STATUS'="" W !,"ITEM IS CANCELLED",$S(STATUS["S":" AND SUBSTITUTED WITH LINE #(S): "_$P(STATUS,",",2,99),1:"") Q
. S ONHAND=+$P(INVDATA,"^",7),QTYOUT=+$P($G(^TMP($J,"PRCPWPPLLIST",LINEDA)),"^",2),QTYPST=+$P($G(^TMP($J,"PRCPWPPLLIST",LINEDA)),"^",3)
. W !!,ITEMDA,?5,$E($$DESCR^PRCPUX1(PRCPINPT,ITEMDA),1,30)," ",$$NSN^PRCPUX1(ITEMDA)," U/I: ",$$UNIT^PRCPUX1(PRCPINPT,ITEMDA,"/")
. W !?5,"AVERAGE COST : ",$J(+$P(INVDATA,"^",22),0,2)
. W !?5,"LAST COST : ",$J(+$P(INVDATA,"^",15),0,2)
. W !
. W !?5,"QTY ON-HAND : ",ONHAND
. W !?5,"QTY ORDERED : ",+$P(DATA,"^",2)
. W !?5,"QTY POSTED : ",+$P(DATA,"^",12)
. W !?5,"QTY RECEIVED : ",+$P(DATA,"^",13)
. W !?5,"QTY OUTSTANDING: ",QTYOUT
. W !?5,"QTY TO RECEIVE : ",+$G(^TMP($J,"PRCPWPPLPOST",LINEDA))
. S DIR(0)="NA^0:"_QTYPST_":0",DIR("A")=" QUANTITY TO RECEIVE: ",DIR("B")=QTYPST
. S DIR("A",1)="Enter the quantity of this item to receive from 0 to "_QTYPST_"."
. W ! D ^DIR K DIR
. I Y!(Y=0) S ^TMP($J,"PRCPWPPLPOST",LINEDA)=+Y
. K X S X(1)="QUANTITY TO RECEIVE: "_+$G(^TMP($J,"PRCPWPPLPOST",LINEDA)),QTYREC=$TR($P(X(1),":",2)," ")
. I QTYREC>QTYOUT D
. . W !!
. . W !,?15,"*****************WARNING*********************"
. . W !,?15,"** Quantity RECEIVED greater than ORDERED. **"
. . W !,?15,"** Is that what you want to do? **"
. . W !,?15,"*********************************************",!!
. . S DIR(0)="E" D ^DIR
. . I 'Y S QUIT=1 K QTYREC,X(1)
. . Q
. D:'QUIT DISPLAY^PRCPUX2(3,32,.X)
D:'QUIT REBUILD^PRCPWPPB
Q
;
;
LINEITEM() ; select line item for issue book
N DA,DIC,X,Y
S DIC="^PRCS(410,"_PRCPDA_",""IT"",",DA(1)=PRCPDA,DIC(0)="QEAMZ",DIC("A")="Select LINE ITEM Number: "
S DIC("W")="S PRCPNODE=13 D DICW^PRCPWPL0 K PRCPNODE"
D ^DIC
Q +Y
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPWPP0 3457 printed Sep 23, 2025@19:52:51 Page 2
PRCPWPP0 ;WISC/RFJ,DWA-primary receive issue book (options) ;20 Jan 94
+1 ;;5.1;IFCAP;**4**;Oct 20, 2000
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
+3 QUIT
+4 ;
+5 ;
EEITEMS ; called from protocol file to enter/edit invpt items
+1 DO FULL^VALM1
+2 DO EN^PRCPEILM
+3 DO REBUILD^PRCPWPPB
+4 SET VALMBCK="R"
+5 QUIT
+6 ;
+7 ;
REMAIN ; set qty to receive to remaining (outstanding) qty
+1 DO FULL^VALM1
+2 SET VALMBCK="R"
+3 NEW DATA,ITEMDA,LINEDA,QTY,X
+4 KILL X
SET X(1)="This option will set the QUANTITY TO RECEIVE equal to the difference between the QUANTITY ORDERED and the QUANTITY PRIMARY REC'D."
+5 DO DISPLAY^PRCPUX2(5,75,.X)
+6 SET XP="Do you want to set the QUANTITY TO RECEIVE"
SET XH="Enter YES to set the QUANTITY TO RECEIVE, NO or ^ to return to the list."
+7 IF $$YN^PRCPUYN(1)'=1
QUIT
+8 SET LINEDA=0
FOR
SET LINEDA=$ORDER(^TMP($JOB,"PRCPWPPLLIST",LINEDA))
if 'LINEDA
QUIT
SET DATA=^(LINEDA)
Begin DoDot:1
+9 SET ITEMDA=+$PIECE(DATA,"^")
SET QTY=+$PIECE(DATA,"^",2)
+10 IF '$DATA(^PRCP(445,PRCPINPT,1,ITEMDA,0))
SET QTY=0
+11 SET ^TMP($JOB,"PRCPWPPLPOST",LINEDA)=QTY
End DoDot:1
+12 DO REBUILD^PRCPWPPB
+13 SET VALMSG="QTY TO RECEIVE now set to remaining"
+14 QUIT
+15 ;
+16 ;
ENTER ; enter quantity to post
+1 DO FULL^VALM1
+2 SET VALMBCK="R"
+3 NEW DATA,DIR,ITEMDA,INVDATA,LINEDA,ONHAND,QTYOUT,QTYPST,QTYREC,STATUS,QUIT,X,Y
+4 SET QUIT=0
+5 FOR
WRITE !
SET LINEDA=$$LINEITEM
if LINEDA<1
QUIT
Begin DoDot:1
+6 SET DATA=$GET(^PRCS(410,PRCPDA,"IT",LINEDA,0))
IF DATA=""
WRITE !,"CANNOT FIND LINE ITEM."
QUIT
+7 SET ITEMDA=+$PIECE(DATA,"^",5)
SET STATUS=$PIECE(DATA,"^",14)
SET INVDATA=$GET(^PRCP(445,PRCPINPT,1,ITEMDA,0))
+8 IF INVDATA=""
WRITE !,"ITEM (#",ITEMDA,") NOT STORED IN THE INVENTORY POINT."
QUIT
+9 IF STATUS'=""
WRITE !,"ITEM IS CANCELLED",$SELECT(STATUS["S":" AND SUBSTITUTED WITH LINE #(S): "_$PIECE(STATUS,",",2,99),1:"")
QUIT
+10 SET ONHAND=+$PIECE(INVDATA,"^",7)
SET QTYOUT=+$PIECE($GET(^TMP($JOB,"PRCPWPPLLIST",LINEDA)),"^",2)
SET QTYPST=+$PIECE($GET(^TMP($JOB,"PRCPWPPLLIST",LINEDA)),"^",3)
+11 WRITE !!,ITEMDA,?5,$EXTRACT($$DESCR^PRCPUX1(PRCPINPT,ITEMDA),1,30)," ",$$NSN^PRCPUX1(ITEMDA)," U/I: ",$$UNIT^PRCPUX1(PRCPINPT,ITEMDA,"/")
+12 WRITE !?5,"AVERAGE COST : ",$JUSTIFY(+$PIECE(INVDATA,"^",22),0,2)
+13 WRITE !?5,"LAST COST : ",$JUSTIFY(+$PIECE(INVDATA,"^",15),0,2)
+14 WRITE !
+15 WRITE !?5,"QTY ON-HAND : ",ONHAND
+16 WRITE !?5,"QTY ORDERED : ",+$PIECE(DATA,"^",2)
+17 WRITE !?5,"QTY POSTED : ",+$PIECE(DATA,"^",12)
+18 WRITE !?5,"QTY RECEIVED : ",+$PIECE(DATA,"^",13)
+19 WRITE !?5,"QTY OUTSTANDING: ",QTYOUT
+20 WRITE !?5,"QTY TO RECEIVE : ",+$GET(^TMP($JOB,"PRCPWPPLPOST",LINEDA))
+21 SET DIR(0)="NA^0:"_QTYPST_":0"
SET DIR("A")=" QUANTITY TO RECEIVE: "
SET DIR("B")=QTYPST
+22 SET DIR("A",1)="Enter the quantity of this item to receive from 0 to "_QTYPST_"."
+23 WRITE !
DO ^DIR
KILL DIR
+24 IF Y!(Y=0)
SET ^TMP($JOB,"PRCPWPPLPOST",LINEDA)=+Y
+25 KILL X
SET X(1)="QUANTITY TO RECEIVE: "_+$GET(^TMP($JOB,"PRCPWPPLPOST",LINEDA))
SET QTYREC=$TRANSLATE($PIECE(X(1),":",2)," ")
+26 IF QTYREC>QTYOUT
Begin DoDot:2
+27 WRITE !!
+28 WRITE !,?15,"*****************WARNING*********************"
+29 WRITE !,?15,"** Quantity RECEIVED greater than ORDERED. **"
+30 WRITE !,?15,"** Is that what you want to do? **"
+31 WRITE !,?15,"*********************************************",!!
+32 SET DIR(0)="E"
DO ^DIR
+33 IF 'Y
SET QUIT=1
KILL QTYREC,X(1)
+34 QUIT
End DoDot:2
+35 if 'QUIT
DO DISPLAY^PRCPUX2(3,32,.X)
End DoDot:1
+36 if 'QUIT
DO REBUILD^PRCPWPPB
+37 QUIT
+38 ;
+39 ;
LINEITEM() ; select line item for issue book
+1 NEW DA,DIC,X,Y
+2 SET DIC="^PRCS(410,"_PRCPDA_",""IT"","
SET DA(1)=PRCPDA
SET DIC(0)="QEAMZ"
SET DIC("A")="Select LINE ITEM Number: "
+3 SET DIC("W")="S PRCPNODE=13 D DICW^PRCPWPL0 K PRCPNODE"
+4 DO ^DIC
+5 QUIT +Y
