Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PRCPOPD

PRCPOPD.m

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