source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCPOPP1.m@ 1608

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

initial load of WorldVistAEHR
File size: 2.9 KB
RevLine 
[613]1PRCPOPP1 ;WISC/RFJ-case cart/instrument kit post utilities ;27 Sep 93
2 ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 Q
5 ;
6 ;
7EDIT ; edit items on list
8 D FULL^VALM1
9 S VALMBCK="R"
10 N CCIKITEM,ITEMDA
11 F W ! S CCIKITEM=+$$ITEMSEL("C") Q:'CCIKITEM D
12 . F W ! S ITEMDA=+$$ITEMSEL("I") Q:'ITEMDA D
13 . . D QTYRETRN
14 D BUILD^PRCPOPPC
15 Q
16 ;
17 ;
18QTYRETRN ; ask for quantity to return to primary
19 N DIR,X,Y
20 S X=$G(^TMP($J,"PRCPOPPC-ITEMS",CCIKITEM,ITEMDA))
21 S DIR(0)="NA^0:"_$P(X,"^")_":0",DIR("A")=" QUANTITY TO RETURN: ",DIR("B")=$P(X,"^",2)
22 S DIR("A",1)=" Quantity Ordered : "_$P(X,"^")
23 S DIR("A",2)=" Quantity Returned: "_$P(X,"^",2)
24 S DIR("A",3)=" Quantity to Post : "_($P(X,"^")-$P(X,"^",2))
25 S DIR("A",4)="Enter the quantity of this item to return to the primary inventory point."
26 W ! D ^DIR
27 I +Y=Y S ^TMP($J,"PRCPOPPC-RETURN",CCIKITEM,ITEMDA)=+Y,$P(^TMP($J,"PRCPOPPC-ITEMS",CCIKITEM,ITEMDA),"^",2)=+Y
28 Q
29 ;
30 ;
31ITEMSEL(V1) ; select items
32 ; v1=C for cc or ik items; v1=I for non cc or ik items
33 ; returns item number
34 N %,DDH,DIC,DTOUT,DUOUT,PRCPSET,X,Y
35 I V1="C" D
36 . S DIC("S")="I $P(^(0),U,6)=""S"",$D(^TMP($J,""PRCPOPPC-ITEMS"",Y))",DIC("A")="Select CASE CART or INSTRUMENT KIT: "
37 I V1="I" D
38 . S DIC("S")="I $P(^(0),U,6)'=""S"",$D(^TMP($J,""PRCPOPPC-ITEMS"",CCIKITEM,Y))",DIC("A")=" Select ITEM: "
39 S PRCPSET="I 1"
40 S DIC="^PRC(441,",DIC(0)="QEAM" D ^DIC
41 Q $S(Y<1:0,1:+Y)
42 ;
43 ;
44REMREUSE ; remove all reusable items from the list and post zero
45 D FULL^VALM1
46 S VALMBCK="R"
47 N %,CCIKITEM,ITEMDA
48 S XP="Do you want to remove ALL reusable items from the list and post ZERO"
49 S XH="Enter 'YES' to remove all REUSABLE items from the list and post zero"
50 S XH(1)="Enter 'NO' or '^' to leave the list as is and return to the main screen."
51 W ! I $$YN^PRCPUYN(2)'=1 Q
52 ; remove reusables from list
53 S CCIKITEM=0 F S CCIKITEM=$O(^TMP($J,"PRCPOPPC-ITEMS",CCIKITEM)) Q:'CCIKITEM S ITEMDA=0 F S ITEMDA=$O(^TMP($J,"PRCPOPPC-ITEMS",CCIKITEM,ITEMDA)) Q:'ITEMDA D
54 . I $$REUSABLE^PRCPU441(ITEMDA) K ^TMP($J,"PRCPOPPC-ITEMS",CCIKITEM,ITEMDA),^TMP($J,"PRCPOPPC-RETURN",CCIKITEM,ITEMDA) S ^TMP($J,"PRCPOPPC-NO",ITEMDA)=""
55 D BUILD^PRCPOPPC
56 Q
57 ;
58 ;
59REMCCIK ; remove cc or ik from list and post zero
60 D FULL^VALM1
61 S VALMBCK="R"
62 N %,CCIKITEM,ITEMDA,PRCPFILE,TYPE
63 W ! S CCIKITEM=+$$ITEMSEL("C") I 'CCIKITEM Q
64 S PRCPFILE=$$FILENUMB^PRCPCUT1(CCIKITEM),TYPE=$S(PRCPFILE=445.7:"CASE CART",1:"INSTRUMENT KIT")
65 S XP="Do you want to remove this "_TYPE_" from the list and post ZERO"
66 S XH="Enter 'YES' to remove "_TYPE_" from the list and post ZERO"
67 S XH(1)="Enter 'NO' or '^' to leave the list as is and return to the main screen."
68 W ! I $$YN^PRCPUYN(2)'=1 Q
69 ; remove cc or ik from list
70 K ^TMP($J,"PRCPOPPC-ITEMS",CCIKITEM),^TMP($J,"PRCPOPPCCIK",CCIKITEM),^TMP($J,"PRCPOPPC-RETURN",CCIKITEM)
71 S ^TMP($J,"PRCPOPPC-NO",CCIKITEM)=""
72 D BUILD^PRCPOPPC
73 Q
Note: See TracBrowser for help on using the repository browser.