source: FOIAVistA/tag/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCPOPD.m@ 636

PRCPOPD ;WISC/RFJ/DWA-delete distribution order ;27 Sep 93
V ;;5.1;IFCAP;**24,52**;Oct 20, 2000
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 Q
 ;
 ;
ORDRDELM ;  delete distribution order (ask first)
 ;  called from protocol
 S VALMBCK="R"
 S XP="Do you want to DELETE the distribution order"
 S XH="Enter 'YES' to delete the order, 'NO' or '^' to retain the order on file."
 W ! I $$YN^PRCPUYN(1)'=1 Q
 ;
 D VARIABLE^PRCPOPU
 N ITEMDA,PRCPSTOP,QTY
 S PRCPSTOP=0
 ;
 ;  if order is released or backordered, cancel dueins and dueouts
 I $P(PRCPORD(0),"^",6)'="" D  I PRCPSTOP QUIT
 .   W !
 . I $P(^PRCP(445.3,+ORDERDA,0),"^",10)]"",$$REFILL(+ORDERDA) D  I PRCPSTOP QUIT
 . . N DA,DIR,DR
 . . S DIR(0)="Y"
 . . S DIR("A",1)="The supply station received items on this order."
 . . S DIR("A",2)="WARNING: IF YOU DELETE THE ORDER, GIP WILL NOT BE UPDATED."
 . . S DIR("A",3)=" "
 . . S DIR("A")="Are you sure you want to delete the order"
 . . S DIR("?")="Enter 'Y' or 'YES' to delete the current order."
 . . S DIR("?",1)="Enter 'N' or 'NO' to retain the order and exit deletion."
 . . D ^DIR
 . . I $D(DUOUT)!$D(DTOUT) S PRCPSTOP=1 Q
 . . I Y=0 S PRCPSTOP=1 Q
 . I $P(PRCPORD(0),"^",2)'="" W !,"<*> Cancelling DUE-OUTS in ",$P(PRCPORD(0),"^",2)
 . I $P(PRCPORD(0),"^",3)'="" W !,"<*> Cancelling DUE-INS  in ",$P(PRCPORD(0),"^",3)
 . S ITEMDA=0
 . F  S ITEMDA=$O(^PRCP(445.3,ORDERDA,1,ITEMDA)) Q:'ITEMDA  D
 . . S QTY=$P(^PRCP(445.3,ORDERDA,1,ITEMDA,0),"^",2)
 . . I QTY D DUEOUTIN^PRCPOPU(PRCPPRIM,PRCPSECO,ITEMDA,-QTY,0)
 ;
 D DELORDER(ORDERDA)
 ;  pause so user can see msg
 D R^PRCPUREP
 ;  kill valmbck to exit LM
 K VALMBCK
 Q
 ;
 ;
DELORDER(ORDERDA)         ;  delete distribution order from file 445.3
 ;  cancel due-ins and due-outs first
 I '$D(^PRCP(445.3,+ORDERDA,0)) Q
 I $P(^PRCP(445.3,+ORDERDA,0),"^",10)]"",$P(^PRCP(445.3,+ORDERDA,0),"^",6)="R" D MESSAGE(+ORDERDA,1)
 N %,DA,DIC,DIK,X,Y
 W !!,"DELETING distribution order..."
 S DA=+ORDERDA,DIK="^PRCP(445.3," D ^DIK
 Q
 ;
 ;
ITEMDELM ;  delete an item from a distribution order
 D FULL^VALM1
 S VALMBCK="R"
 ;
 D VARIABLE^PRCPOPU
 N %,ITEMDA,QTY
 ;
 F  S ITEMDA=+$$ITEMSEL^PRCPOPUS(ORDERDA,PRCPPRIM,0) Q:'ITEMDA  D
 .   S XP="Do you want to DELETE the item from the distribution order",XH="Enter 'YES' to delete the item, 'NO' or '^' to retain the item on the order."
 .   I $$YN^PRCPUYN(1)'=1 Q
 .   ;
 .   S QTY=$P($G(^PRCP(445.3,ORDERDA,1,ITEMDA,0)),"^",2)
 .   I 'QTY D DELITEM(ORDERDA,ITEMDA) W !?5,"* * * ITEM DELETED * * *" Q
 .   ;
 .   I $P(PRCPORD(0),"^",6)'="" D DUEOUTIN^PRCPOPU(PRCPPRIM,PRCPSECO,ITEMDA,-QTY,1)
 .   D DELITEM(ORDERDA,ITEMDA)
 .   W !?5,"* * * ITEM DELETED * * *"
 D INIT^PRCPOPL
 Q
 ;
MESSAGE(ORDER,ACTIVITY) ; tell user of items filled by supply station
 ; 
 ; ORDER - ien of file 445.3 
 ; ACTIVITY:  1- ORDER DELETED, 2 - SUPPLY STATION FLAG REMOVED
 ;
 N ITEM,LN,ORDERNO,PRCPSEC,PRCPXMY,REFILL,XMB,XMDUZ,XMTEXT,XMY
 S ITEM=$G(^PRCP(445.3,ORDER,0)) I ITEM']"" QUIT
 S ORDERNO=$P(ITEM,"^",1)
 S PRCPSEC=$P(ITEM,"^",3)
 I '$$REFILL(ORDER) QUIT
 D GETUSER^PRCPXTRM(PRCPSEC) Q:'$O(PRCPXMY(""))  ; quit if no users in inv point
 S ITEM=0
 ; restrict message to managers
 F  S ITEM=$O(PRCPXMY(ITEM)) Q:ITEM'>0  I PRCPXMY(ITEM)=1 S XMY(ITEM)=""
 K ^TMP($J,"PRCPSSORDER")
 S XMTEXT="^TMP($J,""PRCPSSORDER"",1,"
 S XMB="PRCP_ORDER_PARTIALLY_LOST"
 S XMB(1)=ORDERNO
 S XMB(2)=$$INVNAME^PRCPUX1(PRCPSEC)
 I ACTIVITY=1 D
 . S XMB(3)="deleted"
 . S XMB(4)="If refilled, enter an emergency or call-in order to update GIP."
 I ACTIVITY=2 D
 . S XMB(3)="flagged for completion on GIP"
 . S XMB(4)="If refilled, adjust the quantity ordered to the refill amount."
 S XMB(5)="If not refilled, adjust the supply station down and the secondary up"
 S XMB(6)="                 by the same value for each affected item"
 S XMDUZ="SUPPLY STATION INTERFACE"
 S ITEM=0,LN=0
 F  S ITEM=$O(^PRCP(445.3,ORDER,1,ITEM)) Q:'+ITEM  D
 . I $P($G(^PRCP(445.3,ORDER,1,ITEM,0)),"^",7)>0 D
 . . N QTY,NAME,PRIMVN
 . . S LN=LN+1
 . . S QTY=$P(^PRCP(445.3,ORDER,1,ITEM,0),"^",7)
 . . S PRIMVN=$P(^PRCP(445.3,ORDER,0),"^",2)_";PRCP(445,"
 . . S X=$$GETVEN^PRCPUVEN(PRCPSEC,ITEM,PRIMVN,1)
 . . S X=$P(X,"^",4) ; pkg multiple (conversion factor)
 . . I 'X S X=1
 . . S QTY=QTY*X
 . . S NAME=$P(^PRC(441,ITEM,0),"^",2)
 . . S ^TMP($J,"PRCPSSORDER",1,LN,0)=$E("        ",$L(QTY)+1,8)_QTY_"  "_"("_ITEM_") "_NAME
 S ^TMP($J,"PRCPSSORDER",1)=LN
 D EN^XMB
 K ^TMP($J,"PRCPSSORDER")
 Q
 ;
REFILL(ORDER) ;
 ;
 ; This subroutine will return 1 if the order has any refill activity
 ; and 0 if there is none
 ;
 ; ORDER  ien of file 445.3
 ;
 N REFILL
 S ITEM=0,REFILL=0
 F  S ITEM=$O(^PRCP(445.3,ORDER,1,ITEM)) Q:'+ITEM!REFILL  D
 . I $P($G(^PRCP(445.3,ORDER,1,ITEM,0)),"^",7)>0 S REFILL=1
 QUIT REFILL
 ;
 ;
DELITEM(ORDERDA,ITEMDA)     ;  delete item from distribution order
 I '$D(^PRCP(445.3,+ORDERDA,1,+ITEMDA,0)) Q
 N %,DA,DIC,DIK,X,Y
 S DA(1)=+ORDERDA,DA=+ITEMDA,DIK="^PRCP(445.3,"_ORDERDA_",1," D ^DIK Q