PRCPOPU ;WISC/RFJ,DWA-distibution order utilities ;27 Sep 93
;;5.1;IFCAP;**27**;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
Q
;
;
VARIABLE ; set up order variables for orderda
N DFN,VADM,VAERR
S PRCPORD(0)=$G(^PRCP(445.3,ORDERDA,0)),PRCPORD(2)=$G(^PRCP(445.3,ORDERDA,2))
S PRCPPRIM=+$P(PRCPORD(0),"^",2),PRCPSECO=+$P(PRCPORD(0),"^",3),PRCPPAT=+$P(PRCPORD(2),"^")
S $P(PRCPORD(0),"^",2)=$$INVNAME^PRCPUX1(PRCPPRIM)
S $P(PRCPORD(0),"^",3)=$$INVNAME^PRCPUX1(PRCPSECO)
S DFN=PRCPPAT I $$VERSION^XPDUTL("DG") D DEM^VADPT
S $P(PRCPORD(2),"^")=$G(VADM(1))
Q
;
;
DUEOUTIN(PRCPPRIM,PRCPSECO,ITEMDA,QTY,PRINT) ;
; update the primary prcpprim itemda dueouts by qty (- to subtract);
; update the secondary prcpseco itemda dueins by qty*conv
; print=1 to display message
N %
;
I PRINT W !!,"<*> Updating DUE-OUTS in primary ",$$INVNAME^PRCPUX1(PRCPPRIM),?60," by ",QTY
D SETOUT^PRCPUDUE(PRCPPRIM,ITEMDA,QTY)
;
S QTY=QTY*$P($$GETVEN^PRCPUVEN(PRCPSECO,ITEMDA,PRCPPRIM_";PRCP(445,",1),"^",4)
I PRINT W !,"<*> Updating DUE-INS in secondary ",$$INVNAME^PRCPUX1(PRCPSECO),?60," by ",QTY
D SETIN^PRCPUDUE(PRCPSECO,ITEMDA,QTY)
Q
;
;
STATUS(ORDERDA) ; return status of order
N %
S %=$P($G(^PRCP(445.3,+ORDERDA,0)),"^",6) I %'="" S %=$P($P($P(^DD(445.3,5,0),"^",3),%_":",2),";")
I %="" S %="<< NOT RELEASED >>"
Q %
;
;
TYPE(ORDERDA) ; return type of order
N %
S %=$P($G(^PRCP(445.3,+ORDERDA,0)),"^",8) I %'="" S %=$P($P($P(^DD(445.3,3.5,0),"^",3),%_":",2),";")
I %="" S %="<< NO TYPE >>"
Q %
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPOPU 1630 printed Oct 16, 2024@18:15:07 Page 2
PRCPOPU ;WISC/RFJ,DWA-distibution order utilities ;27 Sep 93
+1 ;;5.1;IFCAP;**27**;Oct 20, 2000
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
+3 QUIT
+4 ;
+5 ;
VARIABLE ; set up order variables for orderda
+1 NEW DFN,VADM,VAERR
+2 SET PRCPORD(0)=$GET(^PRCP(445.3,ORDERDA,0))
SET PRCPORD(2)=$GET(^PRCP(445.3,ORDERDA,2))
+3 SET PRCPPRIM=+$PIECE(PRCPORD(0),"^",2)
SET PRCPSECO=+$PIECE(PRCPORD(0),"^",3)
SET PRCPPAT=+$PIECE(PRCPORD(2),"^")
+4 SET $PIECE(PRCPORD(0),"^",2)=$$INVNAME^PRCPUX1(PRCPPRIM)
+5 SET $PIECE(PRCPORD(0),"^",3)=$$INVNAME^PRCPUX1(PRCPSECO)
+6 SET DFN=PRCPPAT
IF $$VERSION^XPDUTL("DG")
DO DEM^VADPT
+7 SET $PIECE(PRCPORD(2),"^")=$GET(VADM(1))
+8 QUIT
+9 ;
+10 ;
DUEOUTIN(PRCPPRIM,PRCPSECO,ITEMDA,QTY,PRINT) ;
+1 ; update the primary prcpprim itemda dueouts by qty (- to subtract);
+2 ; update the secondary prcpseco itemda dueins by qty*conv
+3 ; print=1 to display message
+4 NEW %
+5 ;
+6 IF PRINT
WRITE !!,"<*> Updating DUE-OUTS in primary ",$$INVNAME^PRCPUX1(PRCPPRIM),?60," by ",QTY
+7 DO SETOUT^PRCPUDUE(PRCPPRIM,ITEMDA,QTY)
+8 ;
+9 SET QTY=QTY*$PIECE($$GETVEN^PRCPUVEN(PRCPSECO,ITEMDA,PRCPPRIM_";PRCP(445,",1),"^",4)
+10 IF PRINT
WRITE !,"<*> Updating DUE-INS in secondary ",$$INVNAME^PRCPUX1(PRCPSECO),?60," by ",QTY
+11 DO SETIN^PRCPUDUE(PRCPSECO,ITEMDA,QTY)
+12 QUIT
+13 ;
+14 ;
STATUS(ORDERDA) ; return status of order
+1 NEW %
+2 SET %=$PIECE($GET(^PRCP(445.3,+ORDERDA,0)),"^",6)
IF %'=""
SET %=$PIECE($PIECE($PIECE(^DD(445.3,5,0),"^",3),%_":",2),";")
+3 IF %=""
SET %="<< NOT RELEASED >>"
+4 QUIT %
+5 ;
+6 ;
TYPE(ORDERDA) ; return type of order
+1 NEW %
+2 SET %=$PIECE($GET(^PRCP(445.3,+ORDERDA,0)),"^",8)
IF %'=""
SET %=$PIECE($PIECE($PIECE(^DD(445.3,3.5,0),"^",3),%_":",2),";")
+3 IF %=""
SET %="<< NO TYPE >>"
+4 QUIT %
