- 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 Feb 18, 2025@23:40:45 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 %