source: FOIAVistA/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCPOPU.m@ 1607

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

initial load of FOIAVistA 6/30/08 version

File size: 1.5 KB
Line 
1PRCPOPU ;WISC/RFJ,DWA-distibution order utilities ;27 Sep 93
2 ;;5.1;IFCAP;**27**;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 Q
5 ;
6 ;
7VARIABLE ; set up order variables for orderda
8 N DFN,VADM,VAERR
9 S PRCPORD(0)=$G(^PRCP(445.3,ORDERDA,0)),PRCPORD(2)=$G(^PRCP(445.3,ORDERDA,2))
10 S PRCPPRIM=+$P(PRCPORD(0),"^",2),PRCPSECO=+$P(PRCPORD(0),"^",3),PRCPPAT=+$P(PRCPORD(2),"^")
11 S $P(PRCPORD(0),"^",2)=$$INVNAME^PRCPUX1(PRCPPRIM)
12 S $P(PRCPORD(0),"^",3)=$$INVNAME^PRCPUX1(PRCPSECO)
13 S DFN=PRCPPAT I $$VERSION^XPDUTL("DG") D DEM^VADPT
14 S $P(PRCPORD(2),"^")=$G(VADM(1))
15 Q
16 ;
17 ;
18DUEOUTIN(PRCPPRIM,PRCPSECO,ITEMDA,QTY,PRINT) ;
19 ; update the primary prcpprim itemda dueouts by qty (- to subtract);
20 ; update the secondary prcpseco itemda dueins by qty*conv
21 ; print=1 to display message
22 N %
23 ;
24 I PRINT W !!,"<*> Updating DUE-OUTS in primary ",$$INVNAME^PRCPUX1(PRCPPRIM),?60," by ",QTY
25 D SETOUT^PRCPUDUE(PRCPPRIM,ITEMDA,QTY)
26 ;
27 S QTY=QTY*$P($$GETVEN^PRCPUVEN(PRCPSECO,ITEMDA,PRCPPRIM_";PRCP(445,",1),"^",4)
28 I PRINT W !,"<*> Updating DUE-INS in secondary ",$$INVNAME^PRCPUX1(PRCPSECO),?60," by ",QTY
29 D SETIN^PRCPUDUE(PRCPSECO,ITEMDA,QTY)
30 Q
31 ;
32 ;
33STATUS(ORDERDA) ; return status of order
34 N %
35 S %=$P($G(^PRCP(445.3,+ORDERDA,0)),"^",6) I %'="" S %=$P($P($P(^DD(445.3,5,0),"^",3),%_":",2),";")
36 I %="" S %="<< NOT RELEASED >>"
37 Q %
38 ;
39 ;
40TYPE(ORDERDA) ; return type of order
41 N %
42 S %=$P($G(^PRCP(445.3,+ORDERDA,0)),"^",8) I %'="" S %=$P($P($P(^DD(445.3,3.5,0),"^",3),%_":",2),";")
43 I %="" S %="<< NO TYPE >>"
44 Q %
Note: See TracBrowser for help on using the repository browser.