source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCPOPP.m@ 975

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

initial load of WorldVistAEHR
File size: 5.3 KB
RevLine 
[613]1PRCPOPP ;WISC/RFJ-post distribution order; ; 8/4/99 1:05pm
2V ;;5.1;IFCAP;**1,41**;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 Q
5 ;
6PRCPSS(ORDERDA,PRCPSECO,PRCPPRIM,PRCPSS) ; entry point for supply station
7 ; ORDERDA order to be posted
8 ; PRCPSECO secondary inventory point
9 ; PRCPPRIM primary inventory point
10 ; PRCPSS flag to designate supply station posting (value = 1)
11 G PRCPSS0
12 ;
13POST ; post order
14 ; orderda=order number
15 S VALMBCK="R"
16 N PRCPSS S PRCPSS=0 ; posting is done at GIP
17 ;
18PRCPSS0 N %,CONVFACT,DATA,ITEMDA,ITEMDATA,ORDRDATA,PRCPFLAG,PRCPID,PRCPOH,PRCPOPP,PRCPPORD,PRCPPTDA,PRCPSORD,QTYDUE,QUANTITY,TOTCOST,UNITCOST,XORDERDA,XDT
19 ;
20 ; Check for old orders
21 S XORDERDA=0 F S XORDERDA=$O(^PRCP(445.3,XORDERDA)) Q:'XORDERDA Q:XORDERDA]"A" D
22 . S XDT=$P($G(^PRCP(445.3,XORDERDA,0)),"^",9)
23 . Q:'XDT
24 . I XDT+2<DT D DELORDER^PRCPOPD(XORDERDA)
25 . Q
26 ;
27 I PRCPSS G PRCPSS1 ; checks not valid for supply station posting
28 ;
29 W !!,"CHECKING ITEMS ON ORDER..."
30 S (ITEMDA,PRCPFLAG)=0 F S ITEMDA=$O(^PRCP(445.3,ORDERDA,1,ITEMDA)) Q:'ITEMDA S QUANTITY=$P($G(^(ITEMDA,0)),"^",2) I QUANTITY D I PRCPFLAG Q
31 . I $$ITEMCHK^PRCPOPER(PRCPPRIM,PRCPSECO,ITEMDA)'="" S PRCPFLAG=1 Q
32 I PRCPFLAG S VALMSG="ORDER CANNOT BE POSTED - FIX ALL ERRORS FIRST" D CHECKORD^PRCPOPER Q
33 W " NO ERRORS FOUND !",!
34 ;
35 I $P($G(^PRCP(445.3,ORDERDA,0)),"^",7)="" D Q:$G(PRCPFLAG)
36 . S XP="Do you want to print the picking ticket before posting",XH="Enter YES to print the picking ticket, NO to skip printing it, or ^ to exit."
37 . S %=$$YN^PRCPUYN(1) I %<1 S PRCPFLAG=1 Q
38 . I %'=1 Q
39 . D PICKLM^PRCPOPT
40 ;
41 S XP="Are you sure you want to POST this order to "_$$INVNAME^PRCPUX1(+$P($G(^PRCP(445.3,+ORDERDA,0)),"^",3)),XH="Enter 'YES' to start posting the order to the secondary inventory point",XH(1)="Enter 'NO' or '^' to exit."
42 W ! I $$YN^PRCPUYN(1)'=1 Q
43 ;
44 L +^PRCP(445,PRCPPRIM,1):5
45 I '$T D SHOWWHO^PRCPULOC(445,PRCPPRIM_"-1",0) Q
46 L +^PRCP(445,PRCPSECO,1):5 I '$T D Q
47 . L -^PRCP(445,PRCPPRIM,1)
48 . D SHOWWHO^PRCPULOC(445,PRCPSECO_"-1",0)
49 D ADD^PRCPULOC(445,PRCPPRIM_"-1",0,"Distribution Order Processing")
50 D ADD^PRCPULOC(445,PRCPSECO_"-1",0,"Distribution Order Processing")
51 ;
52 W !,"POSTING DISTRIBUTION ORDER ..."
53 ;
54 ; if patient is on order, add entry
55PRCPSS1 ; use the same transaction register numbers fr the entire order
56 S PRCPPORD=$$ORDERNO^PRCPUTRX(PRCPPRIM)
57 S PRCPSORD=$$ORDERNO^PRCPUTRX(PRCPSECO)
58 ;
59 I $P($G(^PRCP(445.3,ORDERDA,2)),"^") S DATA=^(2) D
60 . S PRCPPTDA=+$P(DATA,"^",3) I $D(^PRCP(446.1,PRCPPTDA,0)) Q
61 . S PRCPPTDA=$$PATIENT^PRCPUPAT(+$P(DATA,"^"),+$P(DATA,"^",2))
62 . I 'PRCPPTDA Q
63 . S $P(^PRCP(445.3,ORDERDA,2),"^",3)=PRCPPTDA
64 . S $P(^PRCP(446.1,PRCPPTDA,0),"^",6)=PRCPSECO
65 ;
66 ; store case carts and instrument kits in
67 ; ^tmp($j,"prcpopccik",itemda)=qty for cc/ik item posting
68 K ^TMP($J,"PRCPOPCCIK")
69 ;
70 ; post order
71 S ITEMDA=0 F S ITEMDA=$O(^PRCP(445.3,ORDERDA,1,ITEMDA)) Q:'ITEMDA S ORDRDATA=$G(^(ITEMDA,0)) D
72 . S (QTYDUE,QUANTITY)=$P(ORDRDATA,"^",2)
73 . S PRCPOH=$P($G(^PRCP(445,PRCPPRIM,1,ITEMDA,0)),"^",7)
74 . I PRCPOH+0=0 S PRCPOH=0
75 . I QUANTITY>PRCPOH S QUANTITY=PRCPOH
76 . I PRCPOH<0 S QUANTITY=0
77 . I PRCPSS S QUANTITY=$P(ORDRDATA,"^",7) ; use qty that was stocked
78 . ;
79 . ; if case cart or instrument kit, set tmp global
80 . I $D(^PRCP(445.7,ITEMDA,0))!($D(^PRCP(445.8,ITEMDA,0))) S:QUANTITY>0 ^TMP($J,"PRCPOPCCIK",ITEMDA)=QUANTITY Q
81 . ;
82 . S ITEMDATA=^PRCP(445,PRCPPRIM,1,ITEMDA,0)
83 . S UNITCOST=+$P(ITEMDATA,"^",22) I 'UNITCOST S UNITCOST=+$P(ITEMDATA,"^",15)
84 . I 'UNITCOST S UNITCOST=+$P(ORDRDATA,"^",3)
85 . S TOTCOST=$J(QUANTITY*UNITCOST,0,2)
86 . ;
87 . ;
88 . I QTYDUE'=0 D
89 . . I 'PRCPSS!(PRCPSS&$D(^PRCP(445,PRCPPRIM,1,ITEMDA))) D
90 . . . ; sell from primary
91 . . . K PRCPOPP
92 . . . S PRCPOPP("QTY")=-QUANTITY,PRCPOPP("DUEOUT")=-QTYDUE,PRCPOPP("INVVAL")=-TOTCOST,PRCPOPP("OTHERPT")=PRCPSECO,PRCPOPP("ORDERDA")=ORDERDA
93 . . . D SALE^PRCPOPPP(PRCPPRIM,ITEMDA,PRCPPORD,.PRCPOPP)
94 . . ;
95 . . I 'PRCPSS!(PRCPSS&$D(^PRCP(445,PRCPSECO,1,ITEMDA))) D
96 . . . ; receipt in secondary
97 . . . S CONVFACT=$P($$GETVEN^PRCPUVEN(PRCPSECO,ITEMDA,PRCPPRIM_";PRCP(445,",1),"^",4)
98 . . . K PRCPOPP
99 . . . S PRCPOPP("QTY")=QUANTITY*CONVFACT,PRCPOPP("DUEIN")=-QTYDUE*CONVFACT,PRCPOPP("INVVAL")=TOTCOST,PRCPOPP("OTHERPT")=PRCPPRIM
100 . . . ; if patient, distribute from secondary to patient
101 . . . I $G(PRCPPTDA) S PRCPOPP("PRCPPTDA")=PRCPPTDA
102 . . . D RECEIPT^PRCPOPPP(PRCPSECO,ITEMDA,PRCPSORD,.PRCPOPP)
103 . . . Q
104 . ;
105 . ; Set quantity posted into item multiple
106 . I 'PRCPSS S $P(^PRCP(445.3,ORDERDA,1,ITEMDA,0),"^",7)=QUANTITY
107 ;
108 ; Set up posted status
109 S $P(^PRCP(445.3,ORDERDA,0),"^",6)="P",$P(^(0),"^",9)=DT
110 ;
111 ; if an item is a cc or ik
112 I $O(^TMP($J,"PRCPOPCCIK",0)) D
113 . ; if interactive, display screen to post items in cc and iks
114 . I 'PRCPSS D EN^VALM("PRCP DIST ORDER CC/IK POSTING")
115 . I PRCPSS D ; mark amount rec'd as 0, so user gets message
116 . . N PRCPAMT
117 . . S DIE="^PRCP(445.3,"_ORDERDA_",1,"
118 . . S DA=PRCPITEM
119 . . S PRCPAMT="@" ; delete entry to invoke bulletin to user
120 . . S DR="6///^S X=PRCPAMT"
121 . . D ^DIE K DIE
122 . . Q
123 . Q
124 ;
125 I 'PRCPSS D
126 . D CLEAR^PRCPULOC(445,PRCPPRIM_"-1",0),CLEAR^PRCPULOC(445,PRCPSECO_"-1",0)
127 . L -^PRCP(445,PRCPPRIM,1),-^PRCP(445,PRCPSECO,1)
128 ;
129 Q
Note: See TracBrowser for help on using the repository browser.