source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCPAWO0.m@ 1154

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

initial load of WorldVistAEHR
File size: 3.3 KB
Line 
1PRCPAWO0 ;WISC/RFJ-adjust inventory level - other adjustment ;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 3 other adjustment
8OTHER ; other adjustment
9 ; select item from the inventory point and ask for input.
10 N DATA,ITEMDA,ITEMDATA,ORDERNO,PRCPAWN0,PRCPID,QTY,REASON,REASONCD,VALUE,VOUCHER
11 K ^TMP($J,"PRCPAWO0")
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,"PRCPAWO0","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,"PRCPAWO0","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),99998) I QTY["^" Q
25 . S VALUE=$$VALUE^PRCPAWU0(-99999.99,99999.99," INVENTORY","") I VALUE["^" Q
26 . I 'QTY,'VALUE W !!?10,">> EITHER QUANTITY OR VALUE NEEDS TO BE ENTERED FOR AN ADJUSTMENT <<" Q
27 . I '$D(VOUCHER) W ! S VOUCHER=$$VOUCHER^PRCPAWU0 I VOUCHER=""!(VOUCHER="^") Q
28 . W ! S REASONCD=$$REASON I 'REASONCD Q
29 . W ! S REASON=$$REASON^PRCPAWU0(REASONCD) I REASON["^" Q
30 . S ^TMP($J,"PRCPAWO0","PROCESS",ITEMDA)=QTY_"^^"_VALUE_"^^"_VOUCHER_"^"_(+REASONCD)_"^"_REASON
31 ;
32 I ITEMDA["^" D Q Q
33 I '$O(^TMP($J,"PRCPAWO0","PROCESS",0)) W !!?10,">> NO ITEMS HAVE BEEN SELECTED <<" D Q Q
34 ; get whse fcp data
35 N PRCPWBFY,PRCPWFCP,PRCPWSTA
36 D SVDATA^PRCPSFIU(PRCP("I"))
37 S XP="READY TO PROCESS INVENTORY ADJUSTMENTS",XH="Enter YES to PROCESS the INVENTORY adjustments, NO to exit."
38 W !! I $$YN^PRCPUYN(1)'=1 D Q Q
39 ;
40 ; process inventory adjustments
41 S ORDERNO=$$ORDERNO^PRCPUTRX(PRCP("I"))
42 S ITEMDA=0 F S ITEMDA=$O(^TMP($J,"PRCPAWO0","PROCESS",ITEMDA)) Q:'ITEMDA S DATA=^(ITEMDA) I DATA'="" D
43 . K PRCPAWN0
44 . S PRCPAWN0("QTY")=$P(DATA,"^"),PRCPAWN0("INVVAL")=$P(DATA,"^",3),PRCPAWN0("SELVAL")=0,PRCPAWN0("REF")=$P(DATA,"^",5),PRCPAWN0("REASON")="0:"_$P(DATA,"^",7),PRCPAWN0("REASONCODE")=$P(DATA,"^",6),PRCPAWN0("2237PO")=PRC("SITE")
45 . D ITEM^PRCPUUIW(PRCP("I"),ITEMDA,"A",ORDERNO,.PRCPAWN0)
46 . K PRCPAWN0
47 ;
48 ; create fms sv document
49 D SV^PRCPSFSV(PRCP("I"),"A"_ORDERNO,"","")
50 ; create log or isms code sheets
51 D CODESHTS^PRCPAWC0(PRCP("I"),"A"_ORDERNO)
52 ; print form
53 D PRINFORM^PRCPAWR0("A"_ORDERNO)
54Q K ^TMP($J,"PRCPAWO0")
55 Q
56 ;
57 ;
58REASON() ; enter reason text
59 N DIR,REASON,X,Y
60 S REASON=$G(^DISV(+$G(DUZ),"PRCPAWO0","REASON"))
61 S DIR(0)="SO^1:Transfer of stock to another VAMC Warehouse;2:Sale of stock to OGA;3:Transfer of excess stock to GSA;4:Adjustment of stock valuation;5:Writeoff damaged stock;6:Transfer Transportation expense to stock;7:Inventory Refund"
62 S DIR("A")=" Select TYPE of ADJUSTMENT"
63 I REASON'="" S DIR("B")=REASON
64 W ! D ^DIR K DIR I Y'=1,Y'=2,Y'=3,Y'=4,Y'=5,Y'=6,Y'=7 Q 0
65 S DIR("A",1)=" >> Enter the reason text which will appear on the transaction register. <<"
66 D ^DIR
67 I Y'["^" S ^DISV(DUZ,"PRCPAWO0","REASON")=Y
68 Q Y_":"_Y(0)
Note: See TracBrowser for help on using the repository browser.