source: FOIAVistA/tag/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCPOPUS.m@ 1470

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

initial load of FOIAVistA 6/30/08 version

File size: 5.6 KB
Line 
1PRCPOPUS ;WISC/RFJ-utility: distribution order selection ; 5/5/99 10:25am
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 ;
7ADDNEW(ORDER,PRCPPRIM,PRCPSECO) ; add new distribution order number ORDER
8 ; returns distribution order
9 N %,%DT,C,D0,DA,DD,DI,DIC,DIE,DLAYGO,DQ,DR,X,Y
10 S DIC="^PRCP(445.3,",DIC("DR")="1////"_(+PRCPPRIM)_";2////"_(+PRCPSECO)_";3///TODAY;3.5////R;4////"_DUZ,DIC(0)="LZ",DLAYGO=445.3,X=+ORDER,PRCPPRIV=1 D FILE^DICN K PRCPPRIV
11 Q $S(+Y>0:+Y,1:0)
12 ;
13 ;
14NEWORDER(PRCPPRIM) ; get next order number for primary
15 ; called from 445.3,.01 input transform when entering 'new'.
16 ; returns variable x = new order
17 I '$D(^PRCP(445,+PRCPPRIM,0)) K X Q
18 N END,FLAG,Z
19 L +^PRCP(445.3,"ANXT",PRCPPRIM)
20 S (END,X)=+$G(^PRCP(445.3,"ANXT",PRCPPRIM))
21 F S X=X+1 Q:X=END S:X>999999 X=1 Q:'$D(^PRCP(445.3,"B",X)) D Q:'$G(FLAG)
22 . K FLAG S Z=0 F S Z=$O(^PRCP(445.3,"B",X,Z)) Q:'Z I $D(^PRCP(445.3,"AC",PRCPPRIM,Z)) S FLAG=1 Q
23 S ^PRCP(445.3,"ANXT",PRCPPRIM)=X
24 L -^PRCP(445.3,"ANXT",PRCPPRIM)
25 I X=END W !!?10,"YOU NEED TO DELETE SOME OF THE OLD ORDERS FIRST!" K X
26 Q
27 ;
28 ;
29ORDERSEL(PRCPPRIM,PRCPSECO,PRCPSTAT,ADDNEW) ; select distribution order
30 ; prcpprim=primary inventory point screen
31 ; prcpseco=secondary inventory point screen
32 ; prcpstat=status for screen (set to * to eliminate screen on status)
33 ; addnew=1 to add new orders
34 ; returns selected distribution order da number
35 ; returns variable prcpfnew if its a newly created order
36 N %,%H,%I,C,D0,DA,DG,DI,DQ,DIC,DIE,DLAYGO,DR,ORDERDA,PRCPNEW,PRCPPRIV,SCREEN,STATUS,X,Y
37 K PRCPFNEW
38 S DIC(0)="AEQM",DIC="^PRCP(445.3,"
39 S DIC("A")="Select DISTRIBUTION ORDER: "
40 S PRCPPRIV=1
41 ;
42 ; set up screen
43 I PRCPPRIM S DIC("S")="I $P(^(0),U,2)="_PRCPPRIM
44 I PRCPSECO S DIC("S")=$S($G(DIC("S"))="":"I ",1:DIC("S")_",")_"$P(^(0),U,3)="_PRCPSECO
45 I PRCPSTAT'="*" D
46 . S DIC("S")=DIC("S")_" S %=$P(^(0),U,6)"
47 . I PRCPSTAT="" S DIC("S")=DIC("S")_" I %=""""" Q
48 . S SCREEN=""
49 . F %=1:1 S STATUS=$P(PRCPSTAT,"!",%) Q:STATUS="" S SCREEN=SCREEN_$S(SCREEN="":"",1:"!")_"(%="_$C(34)_STATUS_$C(34)_")"
50 . S DIC("S")=DIC("S")_" I "_SCREEN
51 ;
52 ; adding new entries allowed
53 I ADDNEW S DIC(0)="AEQML",DLAYGO=445.3,DIC("DR")="1////"_PRCPPRIM_$S(PRCPSECO:";2////"_PRCPSECO,1:"")
54 ;
55 D ^DIC I Y'>0 Q 0
56 S ORDERDA=+Y
57 I $P(Y,"^",3) S PRCPFNEW=1
58 I $G(PRCPFNEW) S $P(^PRCP(445.3,ORDERDA,0),"^",4,5)=DT_"^"_DUZ,$P(^(0),"^",8)="R"
59 Q ORDERDA
60 ;
61 ;
62TYPE(ORDERDA) ; ask order type for orderda
63 ; returns 1 if unsuccessful
64 I '$D(^PRCP(445.3,+ORDERDA,0)) Q 1
65 I $P(^PRCP(445.3,+ORDERDA,0),"^",6)="P" Q 0
66 N %,D,D0,DA,DDH,DI,DIC,DIE,DIR,DQ,DR,DZ,ORD,PRCPEXIT,PRCPPRIV,PRCPSEC,X,Y
67 ; if this is a regular order for a supply station secondary, don't prompt
68 ; if this is an emergency or call-in order for a supply station secondary, allow all selections but regular.
69 S ORD=0,PRCPEXIT=0
70 S PRCPSEC=$P($G(^PRCP(445.3,ORDERDA,0)),"^",3)
71 I $P($G(^PRCP(445,PRCPSEC,5)),"^",1)]"",$D(^PRCP(445.3,ORDERDA,1)) D G TYPEQ:PRCPEXIT
72 . S ORD=$P($G(^PRCP(445.3,ORDERDA,0)),"^",8)
73 . I ORD="R" D Q
74 . . D EN^DDIOL("This is a regular order on a supply station secondary.")
75 . . D EN^DDIOL("Its 'TYPE OF ORDER' cannot be edited to CALL_IN or EMERGENCY.")
76 . . S PRCPEXIT=1
77 . S DIR("A")="TYPE OF ORDER"
78 . S DIR("A",1)="This order is for a supply station secondary."
79 . S DIR("A",2)="The order type cannot be changed to regular."
80 . S DIR(0)="SB^C:CALL-IN;E:EMERGENCY"
81 . S DIR("B")="CALL-IN" I ORD="E" S DIR("B")="EMERGENCY"
82 . D ^DIR
83 . I $D(DUOUT)!$D(DTOUT) S PRCPEXIT=1 Q
84 . S ORD=0 I Y="E"!(Y="C") S ORD=Y
85 S (DIE,DIC)="^PRCP(445.3,",DA=ORDERDA,DR="3.5"
86 I ORD'=0 S DR=DR_"///^S X=ORD"
87 S PRCPPRIV=1 D ^DIE
88 I $D(Y) Q 1
89TYPEQ Q 0
90 ;
91 ;
92REMARKS(ORDERDA) ; ask remarks for orderda
93 ; returns 1 if unsuccessful
94 I '$D(^PRCP(445.3,+ORDERDA,0)) Q 1
95 I $P(^PRCP(445.3,+ORDERDA,0),"^",6)="P" Q 0
96 N %,D,D0,DA,DDH,DI,DIC,DIE,DQ,DR,DZ,PRCPPRIV,X,Y
97 S (DIE,DIC)="^PRCP(445.3,",DA=ORDERDA,DR="8",PRCPPRIV=1 D ^DIE
98 I $D(Y) Q 1
99 Q 0
100 ;
101 ;
102ITEMSEL(ORDERDA,PRCPPRIM,PRCPADD) ; select item from distribution order
103 ; returns item number selected
104 N %,C,DA,DDC,DG,DIC,DLAYGO,I,PRCPSET,X,Y
105 I '$D(^PRCP(445.3,ORDERDA,0)) Q 0
106 S:'$D(^PRCP(445.3,ORDERDA,1,0)) ^(0)="^445.37PI^^"
107 S DIC="^PRCP(445.3,"_ORDERDA_",1,",DIC(0)="QEAMZO"
108 I PRCPADD S DIC(0)="QEALMZO"
109 S (PRCPSET,DIC("S"))="I $D(^PRCP(445,PRCPPRIM,1,+Y,0))"
110 ; if this is a regular order for a supply station secondary, restrict
111 ; item selection to items stocked in the supply station (i.e. items
112 ; with non-zero normal levels)
113 I PRCPADD,$P($G(^PRCP(445,$P(^PRCP(445.3,ORDERDA,0),"^",3),5)),"^",1)]"",$P(^PRCP(445.3,ORDERDA,0),"^",8)="R" D
114 . S PRCPSEC=$P(^PRCP(445.3,ORDERDA,0),"^",3)
115 . S U="^"
116 . S (PRCPSET,DIC("S"))=PRCPSET_",$D(^PRCP(445,PRCPSEC,1,+Y,0)),$P(^PRCP(445,PRCPSEC,1,+Y,0),U,9)>0"
117 S DA(1)=ORDERDA
118 S DLAYGO=445.3
119 W ! D ^DIC
120 Q $S(+Y>0:+Y,1:0)
121 ;
122 ;
123ITEMEDIT(ORDERDA,ITEMDA,ASKCOST) ; edit item on distribution order
124 N D,D0,DA,DI,DIC,DIE,DQ,DR,X,Y
125 I '$D(^PRCP(445.3,ORDERDA,1,ITEMDA,0)) Q
126 S (DIC,DIE)="^PRCP(445.3,"_ORDERDA_",1,",DA(1)=ORDERDA,DA=ITEMDA,DR="1;"_$S(ASKCOST:"2;",1:"") D ^DIE
127 Q
128 ;
129 ;
130ITEMADD(ORDERDA,ITEMDA,QTY) ; automatically add items to distribution order
131 ; return item number added or 0 if unsuccessful
132 N %,D0,DA,DD,DI,DIC,DIE,DLAYGO,DQ,DR,PRCPPRIM,PRCPPRIV,UNITCOST,X,Y
133 I '$D(^PRCP(445.3,ORDERDA)) Q 0
134 I 'ITEMDA Q 0
135 S PRCPPRIM=+$P($G(^PRCP(445.3,ORDERDA,0)),"^",2),UNITCOST=+$P($G(^PRCP(445,PRCPPRIM,1,ITEMDA,0)),"^",22)
136 I 'PRCPPRIM,'QTY Q 0
137 I '$D(^PRCP(445.3,ORDERDA,1,0)) S ^(0)="^445.37PI^^"
138 S DIC("DR")="1///"_QTY_";2///"_UNITCOST
139 S DIC="^PRCP(445.3,"_ORDERDA_",1,",DA(1)=ORDERDA,DIC(0)="LZ",DLAYGO=445.3,(DINUM,X)=ITEMDA,PRCPPRIV=1 D FILE^DICN
140 I Y<0 Q 0
141 Q +Y
Note: See TracBrowser for help on using the repository browser.