PRCPOPU.m

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 ---PRCPOPU   1630     printed  Apr 09, 2024@21:10:36                                                                                                                                                                                                     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 %