- 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 Apr 23, 2025@18:31:17 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
