source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCPAWN0.m@ 1710

Last change on this file since 1710 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 2.4 KB
RevLine 
[613]1PRCPAWN0 ;WISC/RFJ-adjust inventory level to or from non-issuable ;11 Mar 94
2 ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 Q
5 ;
6 ;
7 ; called from prcpawa0 for type 2 non-issuable adjustment
8NONISSUE ; move quantity to or from non-issuable
9 ; select item from the inventory point and ask for input.
10 N DATA,ITEMDA,ITEMDATA,ORDERNO,PRCPAWN0,PRCPID,QTY,REASON,VOUCHER
11 K ^TMP($J,"PRCPAWN0")
12 F D Q:'ITEMDA W !!!!!
13 . W !!," >> Select an item number from the ",PRCP("IN")," inventory point. <<"
14 . S ITEMDA=$$ITEM^PRCPUITM(PRCP("I"),0,"","") I 'ITEMDA Q
15 . D SHOWDATA^PRCPAWA0(PRCP("I"),ITEMDA)
16 . ;
17 . ; item already selected
18 . I $D(^TMP($J,"PRCPAWN0","PROCESS",ITEMDA)) S XP=" THIS ITEM WAS PREVIOUSLY SELECTED DURING THIS SELECTION PROCESS.",XP(1)=" OK TO REMOVE THIS ADJUSTMENT SO YOU CAN ENTER A NEW ONE" W !! I $$YN^PRCPUYN(1)'=1 Q
19 . K ^TMP($J,"PRCPAWN0","PROCESS",ITEMDA)
20 . ;
21 . ; enter adjustment
22 . S ITEMDATA=$G(^PRCP(445,PRCP("I"),1,ITEMDA,0)) I ITEMDATA="" Q
23 . W !!,"**************** E N T E R A D J U S T M E N T D A T A ****************",!
24 . S QTY=$$QTY^PRCPAWU0(-$P(ITEMDATA,"^",7),+$P(ITEMDATA,"^",19)) I QTY["^" Q
25 . I QTY=0 W !!?5,">> THE QUANTITY MOVED TO OR FROM NON-ISSUABLE CANNOT EQUAL 0. <<" Q
26 . I '$D(VOUCHER) W ! S VOUCHER=$$VOUCHER^PRCPAWU0 I VOUCHER="" Q
27 . W ! S REASON=$$REASON^PRCPAWU0($S(QTY<0:"TO ",1:"FROM ")_"non-issuable") I REASON["^" Q
28 . S ^TMP($J,"PRCPAWN0","PROCESS",ITEMDA)=QTY_"^^^^"_VOUCHER_"^"_REASON
29 ;
30 I ITEMDA["^" D Q Q
31 I '$O(^TMP($J,"PRCPAWN0","PROCESS",0)) W !!?10,">> NO ITEMS HAVE BEEN SELECTED <<" D Q Q
32 S XP="READY TO PROCESS NON-ISSUABLE ADJUSTMENTS",XH="Enter YES to PROCESS the NON-ISSUABLE adjustments, NO to exit."
33 W !! I $$YN^PRCPUYN(1)'=1 D Q Q
34 ;
35 ; process non-issuable adjustments
36 S ORDERNO=$$ORDERNO^PRCPUTRX(PRCP("I"))
37 S ITEMDA=0 F S ITEMDA=$O(^TMP($J,"PRCPAWN0","PROCESS",ITEMDA)) Q:'ITEMDA S DATA=^(ITEMDA) I DATA'="" D
38 . K PRCPAWN0
39 . S PRCPAWN0("QTY")=$P(DATA,"^"),(PRCPAWN0("INVVAL"),PRCPAWN0("SELVAL"))=0,PRCPAWN0("REF")=$P(DATA,"^",5),PRCPAWN0("REASON")="0:"_$P(DATA,"^",6),PRCPAWN0("ISSUE")=$S(QTY<0:"N",1:"I"),PRCPAWN0("2237PO")=PRC("SITE")
40 . D ITEM^PRCPUUIW(PRCP("I"),ITEMDA,"A",ORDERNO,.PRCPAWN0)
41 . K PRCPAWN0
42 ;
43 ; create log or isms code sheets
44 D CODESHTS^PRCPAWC0(PRCP("I"),"A"_ORDERNO)
45 ; print form
46 D PRINFORM^PRCPAWR0("A"_ORDERNO)
47Q K ^TMP($J,"PRCPAWN0")
48 Q
Note: See TracBrowser for help on using the repository browser.