source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCPOPD.m@ 1259

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

initial load of WorldVistAEHR

File size: 4.9 KB
Line 
1PRCPOPD ;WISC/RFJ/DWA-delete distribution order ;27 Sep 93
2V ;;5.1;IFCAP;**24,52**;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 Q
5 ;
6 ;
7ORDRDELM ; delete distribution order (ask first)
8 ; called from protocol
9 S VALMBCK="R"
10 S XP="Do you want to DELETE the distribution order"
11 S XH="Enter 'YES' to delete the order, 'NO' or '^' to retain the order on file."
12 W ! I $$YN^PRCPUYN(1)'=1 Q
13 ;
14 D VARIABLE^PRCPOPU
15 N ITEMDA,PRCPSTOP,QTY
16 S PRCPSTOP=0
17 ;
18 ; if order is released or backordered, cancel dueins and dueouts
19 I $P(PRCPORD(0),"^",6)'="" D I PRCPSTOP QUIT
20 . W !
21 . I $P(^PRCP(445.3,+ORDERDA,0),"^",10)]"",$$REFILL(+ORDERDA) D I PRCPSTOP QUIT
22 . . N DA,DIR,DR
23 . . S DIR(0)="Y"
24 . . S DIR("A",1)="The supply station received items on this order."
25 . . S DIR("A",2)="WARNING: IF YOU DELETE THE ORDER, GIP WILL NOT BE UPDATED."
26 . . S DIR("A",3)=" "
27 . . S DIR("A")="Are you sure you want to delete the order"
28 . . S DIR("?")="Enter 'Y' or 'YES' to delete the current order."
29 . . S DIR("?",1)="Enter 'N' or 'NO' to retain the order and exit deletion."
30 . . D ^DIR
31 . . I $D(DUOUT)!$D(DTOUT) S PRCPSTOP=1 Q
32 . . I Y=0 S PRCPSTOP=1 Q
33 . I $P(PRCPORD(0),"^",2)'="" W !,"<*> Cancelling DUE-OUTS in ",$P(PRCPORD(0),"^",2)
34 . I $P(PRCPORD(0),"^",3)'="" W !,"<*> Cancelling DUE-INS in ",$P(PRCPORD(0),"^",3)
35 . S ITEMDA=0
36 . F S ITEMDA=$O(^PRCP(445.3,ORDERDA,1,ITEMDA)) Q:'ITEMDA D
37 . . S QTY=$P(^PRCP(445.3,ORDERDA,1,ITEMDA,0),"^",2)
38 . . I QTY D DUEOUTIN^PRCPOPU(PRCPPRIM,PRCPSECO,ITEMDA,-QTY,0)
39 ;
40 D DELORDER(ORDERDA)
41 ; pause so user can see msg
42 D R^PRCPUREP
43 ; kill valmbck to exit LM
44 K VALMBCK
45 Q
46 ;
47 ;
48DELORDER(ORDERDA) ; delete distribution order from file 445.3
49 ; cancel due-ins and due-outs first
50 I '$D(^PRCP(445.3,+ORDERDA,0)) Q
51 I $P(^PRCP(445.3,+ORDERDA,0),"^",10)]"",$P(^PRCP(445.3,+ORDERDA,0),"^",6)="R" D MESSAGE(+ORDERDA,1)
52 N %,DA,DIC,DIK,X,Y
53 W !!,"DELETING distribution order..."
54 S DA=+ORDERDA,DIK="^PRCP(445.3," D ^DIK
55 Q
56 ;
57 ;
58ITEMDELM ; delete an item from a distribution order
59 D FULL^VALM1
60 S VALMBCK="R"
61 ;
62 D VARIABLE^PRCPOPU
63 N %,ITEMDA,QTY
64 ;
65 F S ITEMDA=+$$ITEMSEL^PRCPOPUS(ORDERDA,PRCPPRIM,0) Q:'ITEMDA D
66 . S XP="Do you want to DELETE the item from the distribution order",XH="Enter 'YES' to delete the item, 'NO' or '^' to retain the item on the order."
67 . I $$YN^PRCPUYN(1)'=1 Q
68 . ;
69 . S QTY=$P($G(^PRCP(445.3,ORDERDA,1,ITEMDA,0)),"^",2)
70 . I 'QTY D DELITEM(ORDERDA,ITEMDA) W !?5,"* * * ITEM DELETED * * *" Q
71 . ;
72 . I $P(PRCPORD(0),"^",6)'="" D DUEOUTIN^PRCPOPU(PRCPPRIM,PRCPSECO,ITEMDA,-QTY,1)
73 . D DELITEM(ORDERDA,ITEMDA)
74 . W !?5,"* * * ITEM DELETED * * *"
75 D INIT^PRCPOPL
76 Q
77 ;
78MESSAGE(ORDER,ACTIVITY) ; tell user of items filled by supply station
79 ;
80 ; ORDER - ien of file 445.3
81 ; ACTIVITY: 1- ORDER DELETED, 2 - SUPPLY STATION FLAG REMOVED
82 ;
83 N ITEM,LN,ORDERNO,PRCPSEC,PRCPXMY,REFILL,XMB,XMDUZ,XMTEXT,XMY
84 S ITEM=$G(^PRCP(445.3,ORDER,0)) I ITEM']"" QUIT
85 S ORDERNO=$P(ITEM,"^",1)
86 S PRCPSEC=$P(ITEM,"^",3)
87 I '$$REFILL(ORDER) QUIT
88 D GETUSER^PRCPXTRM(PRCPSEC) Q:'$O(PRCPXMY("")) ; quit if no users in inv point
89 S ITEM=0
90 ; restrict message to managers
91 F S ITEM=$O(PRCPXMY(ITEM)) Q:ITEM'>0 I PRCPXMY(ITEM)=1 S XMY(ITEM)=""
92 K ^TMP($J,"PRCPSSORDER")
93 S XMTEXT="^TMP($J,""PRCPSSORDER"",1,"
94 S XMB="PRCP_ORDER_PARTIALLY_LOST"
95 S XMB(1)=ORDERNO
96 S XMB(2)=$$INVNAME^PRCPUX1(PRCPSEC)
97 I ACTIVITY=1 D
98 . S XMB(3)="deleted"
99 . S XMB(4)="If refilled, enter an emergency or call-in order to update GIP."
100 I ACTIVITY=2 D
101 . S XMB(3)="flagged for completion on GIP"
102 . S XMB(4)="If refilled, adjust the quantity ordered to the refill amount."
103 S XMB(5)="If not refilled, adjust the supply station down and the secondary up"
104 S XMB(6)=" by the same value for each affected item"
105 S XMDUZ="SUPPLY STATION INTERFACE"
106 S ITEM=0,LN=0
107 F S ITEM=$O(^PRCP(445.3,ORDER,1,ITEM)) Q:'+ITEM D
108 . I $P($G(^PRCP(445.3,ORDER,1,ITEM,0)),"^",7)>0 D
109 . . N QTY,NAME,PRIMVN
110 . . S LN=LN+1
111 . . S QTY=$P(^PRCP(445.3,ORDER,1,ITEM,0),"^",7)
112 . . S PRIMVN=$P(^PRCP(445.3,ORDER,0),"^",2)_";PRCP(445,"
113 . . S X=$$GETVEN^PRCPUVEN(PRCPSEC,ITEM,PRIMVN,1)
114 . . S X=$P(X,"^",4) ; pkg multiple (conversion factor)
115 . . I 'X S X=1
116 . . S QTY=QTY*X
117 . . S NAME=$P(^PRC(441,ITEM,0),"^",2)
118 . . S ^TMP($J,"PRCPSSORDER",1,LN,0)=$E(" ",$L(QTY)+1,8)_QTY_" "_"("_ITEM_") "_NAME
119 S ^TMP($J,"PRCPSSORDER",1)=LN
120 D EN^XMB
121 K ^TMP($J,"PRCPSSORDER")
122 Q
123 ;
124REFILL(ORDER) ;
125 ;
126 ; This subroutine will return 1 if the order has any refill activity
127 ; and 0 if there is none
128 ;
129 ; ORDER ien of file 445.3
130 ;
131 N REFILL
132 S ITEM=0,REFILL=0
133 F S ITEM=$O(^PRCP(445.3,ORDER,1,ITEM)) Q:'+ITEM!REFILL D
134 . I $P($G(^PRCP(445.3,ORDER,1,ITEM,0)),"^",7)>0 S REFILL=1
135 QUIT REFILL
136 ;
137 ;
138DELITEM(ORDERDA,ITEMDA) ; delete item from distribution order
139 I '$D(^PRCP(445.3,+ORDERDA,1,+ITEMDA,0)) Q
140 N %,DA,DIC,DIK,X,Y
141 S DA(1)=+ORDERDA,DA=+ITEMDA,DIK="^PRCP(445.3,"_ORDERDA_",1," D ^DIK Q
Note: See TracBrowser for help on using the repository browser.