source: FOIAVistA/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCPUITM.m@ 1420

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

initial load of FOIAVistA 6/30/08 version
File size: 6.5 KB
Line 
1PRCPUITM ;WISC/RFJ-select items utility ;10 Dec 91
2V ;;5.1;IFCAP;**1**;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 Q
5 ;
6 ;
7ITEM(INVPT,ADDNEW,SCREEN,DEFAULT) ; select item in inventory point
8 ; addnew=1 to add new items
9 ; screen=additional screen
10 ; default=default item master number
11 ; return itemda; 0 no item selected; ^ for ^ entered or timeout
12 ;
13 I '$D(^PRCP(445,+INVPT,0)) Q 0
14 N %,C,DA,DG,DISYS,DIC,DTOUT,DUOUT,I,PRCPSET,PRCPX,TYPE,X,Y
15 S DIC="^PRCP(445,"_INVPT_",1,"
16 S DIC(0)="QEAM"_$S(ADDNEW:"L",1:"")
17 S DIC("A")="Select "_$P($$INVNAME^PRCPUX1(INVPT),"-",2,99)_" ITEM: "
18 S TYPE=$P($G(^PRCP(445,INVPT,0)),"^",3)
19 S PRCPSET="I 0"
20 ;
21 ; whse screen
22 I TYPE="W" S PRCPSET="I $$PURCHASE^PRCPU441(+Y),'$$INACTIVE^PRCPU441(+Y),$$MANDSRCE^PRCPU441(+Y)=$O(^PRC(440,""AC"",""S"",0))"_$G(SCREEN)
23 ;
24 ; primary screen
25 I TYPE="P" S PRCPSET="I '$$INACTIVE^PRCPU441(+Y)"_$G(SCREEN)
26 ;
27 ; secondary screen
28 I TYPE="S" S PRCPSET="I '$$INACTIVE^PRCPU441(+Y),$O(^PRCP(445,""AB"","_INVPT_",0))"_$G(SCREEN)_" F PRCPX=0:0 S PRCPX=$O(^PRCP(445,""AB"","_INVPT_",PRCPX)) Q:'PRCPX I $D(^PRCP(445,PRCPX,1,+Y,0)) Q"
29 ;
30 S:'$D(^PRCP(445,INVPT,1,0)) ^(0)="^445.01IP^^"
31 S DIC("S")=PRCPSET
32 S DIC("W")="W ?10,$E($$DESCR^PRCPUX1("_INVPT_",+Y),1,20),?35,""NSN: "",$$NSN^PRCPUX1(+Y)"
33 S DA(1)=INVPT
34 I DEFAULT S DIC("B")=$$DESCR^PRCPUX1(INVPT,DEFAULT) I DIC("B")="" K DIC("B")
35 D ^DIC
36 Q $S($G(DUOUT):"^",$G(DTOUT):"^",Y<1:0,1:+Y)
37 ;
38 ;
39MASTITEM(SCREEN) ; select item from master item file
40 ; screen=optional screen
41 ; return itemda; 0 no item selected; ^ for ^ entered or timeout
42 ;
43 N %,DDH,DIC,DTOUT,DUOUT,PRCPSET,X,Y
44 I $G(SCREEN)'="" S DIC("S")=SCREEN,PRCPSET=SCREEN
45 S DIC="^PRC(441,",DIC(0)="QEAM" D ^DIC
46 Q $S($G(DUOUT):"^",$G(DTOUT):"^",Y<1:0,1:+Y)
47 ;
48 ;
49GETITEM(INVPT,ITEMDA) ; get data for item in invpt
50 ; return data in prcpdata array
51 K PRCPDATA
52 I '$D(^PRCP(445,+INVPT,1,+ITEMDA,0)) Q
53 N %,D0,DA,DIC,DIQ,DIQ2,DR
54 S DIC="^PRCP(445,"
55 S DR=1,DR(445.01)=".01:99"
56 S DA=INVPT,DA(445.01)=ITEMDA
57 S DIQ="PRCPDATA",DIQ(0)="E"
58 D EN^DIQ1
59 Q
60 ;
61 ;
62DELETE(PRCPINPT,ITEMDA) ; check for deleting item from inventory point
63 I $G(^PRCP(445,+PRCPINPT,1,+ITEMDA,0))="" Q
64 N %,%H,%I,DATA,DIC,DISTR,DISYS,DUEIN,DUEOUT,INACTIVE,OUTORD,SITE,STRING,TYPE,X,Y
65 S DATA=^PRCP(445,PRCPINPT,1,ITEMDA,0)
66 I $P(DATA,"^",7) W !!,"QUANTITY ON HAND (",$P(DATA,"^",7),") NEEDS TO BE ADJUSTED TO ZERO." Q
67 I $P(DATA,"^",19) W !!,"QUANTITY NON-ISSUABLE (",$P(DATA,"^",19),") NEEDS TO BE ADJUSTED TO ZERO." Q
68 S INACTIVE=$P(^PRCP(445,PRCPINPT,0),"^",13)
69 I INACTIVE D NOW^%DTC S X1=X,X2=-(INACTIVE*30+1) D C^%DTC I $O(^PRCP(445,PRCPINPT,1,ITEMDA,2,$E(X,1,5)-.1))!($O(^PRCP(445,PRCPINPT,1,ITEMDA,3,X))) D Q
70 . W !!,"ITEM HAS HAD ACTIVITY DURING THE LAST ",INACTIVE," MONTHS."
71 S DUEIN=$$GETIN^PRCPUDUE(PRCPINPT,ITEMDA)
72 I DUEIN W !,"ITEM HAS DUE-INS: ",DUEIN
73 S DUEOUT=$$GETOUT^PRCPUDUE(PRCPINPT,ITEMDA)
74 I DUEOUT W !,"ITEM HAS DUE-OUTS: ",DUEOUT
75 W !,"Checking to see if this item is on an outstanding order...."
76 S OUTORD=$$ORDCHK(ITEMDA,PRCPINPT,"RCE","") I OUTORD D Q
77 . W !,"This item cannot be deleted. You must first post, delete, or"
78 . W !,"remove the item from the following order(s):"
79 . D LISTOO(ITEMDA,PRCPINPT)
80 S %=$$INVNAME^PRCPUX1(PRCPINPT),SITE=$P(%,"-")
81 S XP="ARE YOU SURE YOU WANT TO DELETE THIS ITEM"
82 S XP(1)=" FROM THE "_%_" INVENTORY POINT"
83 S XH="Enter 'YES' to DELETE this item from the inventory point."
84 I $$YN^PRCPUYN(2)'=1 Q
85 W !!?5,"--Deleting Item from Inventory Point ..."
86 D DELITEM(PRCPINPT,ITEMDA)
87 I $P($G(^PRCP(445,PRCPINPT,0)),"^",3)="W" D
88 . D DELETE^PRCPSMS0(ITEMDA)
89 . I STRING("ID")="" W !," WARNING--UNABLE TO CREATE ISMS CODE SHEET!" Q
90 . K ^TMP($J,"STRING") S ^TMP($J,"STRING",1)=STRING("ID") D CODESHT^PRCPSMGO(SITE,"IVD","")
91 W !!,"Checking Distribution Points (you will have the option to delete the item",!,"from the distribution points if the distribution point is NOT keeping a",!,"perpetual inventory) ..."
92 S DISTR="" F S DISTR=$O(^PRCP(445,PRCPINPT,2,DISTR)) Q:'DISTR I $P($G(^PRCP(445,DISTR,0)),"^",6)="Y",$D(^PRCP(445,DISTR,1,ITEMDA,0)) W !!,"DISTRIBUTION POINT: ",$P($$INVNAME^PRCPUX1(DISTR),"-",2,99) D
93 . S XP=" OK TO DELETE ITEM FROM THIS DISTRIBUTION POINT",XH=" Enter 'YES' to DELETE the item from the distribution point, '^' to exit."
94 . S %=$$YN^PRCPUYN(2) I '% S DISTR=999999 Q
95 . I %=2 Q
96 . W !!?5,"--Deleting Item from Distribution Point ..." D DELITEM(DISTR,ITEMDA) Q
97 Q
98 ;
99 ;
100DELITEM(PRCPINPT,DA) ; delete item da from inventory point
101 N %,DIC,DIK,ITEM,X,Y
102 S ITEM=DA
103 I $P($G(^PRCP(445,PRCPINPT,5)),"^",1)]"",$P($G(^PRCP(445,PRCPINPT,1,ITEM,0)),"^",9)>0 D BLDSEG^PRCPHLFM(2,ITEM,PRCPINPT) ; send to supply station
104 S DA(1)=PRCPINPT,DIK="^PRCP(445,"_DA(1)_",1," D ^DIK
105 Q
106 ;
107ORDCHK(ITEMDA,PRCPINPT,ORDTYP,ORDSTA) ; is the item on any outstanding orders
108 ; ITEMDA = DA of item to be deleted, 0 if search is for any order
109 ; for that inventory point.
110 ; PRCPINT = DA of inventory point in the search
111 ; ORDTYP = search for regular, emergency and/or call-in
112 ; ORDSTA = Status of the outstanding order, if search is limited
113 ; returns 0 if no outstanding order is found, 1 it it is
114 ;
115 N ORD,OUTORD,TYPE,XREF
116 I '$D(ORDSTA) S ORDSTA=""
117 S TYPE=$P($G(^PRCP(445,PRCPINPT,0)),"^",3)
118 S XREF=""
119 I TYPE="S" S XREF="AD"
120 I TYPE="P" S XREF="AC"
121 S OUTORD=0
122 I XREF]"" D
123 . S ORD=0
124 . F S ORD=$O(^PRCP(445.3,XREF,PRCPINPT,ORD)) Q:+ORD'>0!OUTORD D
125 . . I 'ITEMDA,$P(^PRCP(445.3,ORD,0),"^",6)'="P",ORDTYP[($P(^PRCP(445.3,ORD,0),"^",8)) D
126 . . . I ORDSTA="" S OUTORD=1
127 . . . I ORDSTA]"",$P(^PRCP(445.3,ORD,0),"^",6)[ORDSTA S OUTORD=1
128 . . I ITEMDA,$P(^PRCP(445.3,ORD,0),"^",6)'="P",$D(^PRCP(445.3,ORD,1,ITEMDA)),ORDTYP[($P(^PRCP(445.3,ORD,0),"^",8)) D
129 . . . I ORDSTA="" S OUTORD=1
130 . . . I ORDSTA]"",$P(^PRCP(445.3,ORD,0),"^",6)[ORDSTA S OUTORD=1
131 Q (OUTORD)
132 ;
133LISTOO(ITEM,PRCPINPT,ORDSTA) ; list outstanding orders for this item
134 ; ITEM = DA of item to be deleted
135 ; PRCPINT = DA of inventory point housing the item
136 ; ORDSTA = Status of the outstanding order, if search is limited
137 ;
138 N ORD,OUTORD,TYPE,XREF
139 I '$D(ORDSTA) S ORDSTA=""
140 S TYPE=$P($G(^PRCP(445,PRCPINPT,0)),"^",3)
141 S XREF=""
142 I TYPE="S" S XREF="AD"
143 I TYPE="P" S XREF="AC"
144 S OUTORD=0
145 I XREF]"" D
146 . S ORD=0
147 . F S ORD=$O(^PRCP(445.3,XREF,PRCPINPT,ORD)) Q:+ORD'>0 D
148 . . I $P(^PRCP(445.3,ORD,0),"^",6)'="P",$D(^PRCP(445.3,ORD,1,ITEM)) D
149 . . . S OUTORD=$P(^PRCP(445.3,ORD,0),"^",1)
150 . . . I ORDSTA]"",$P(^PRCP(445.3,ORD,0),"^",6)[ORDSTA W !?5,OUTORD
151 . . . I ORDSTA="" W !?5,OUTORD
152 Q ; (OUTORD)
Note: See TracBrowser for help on using the repository browser.