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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPOPD 5120 printed Dec 13, 2024@02:14:10 Page 2
PRCPOPD ;WISC/RFJ/DWA-delete distribution order ;27 Sep 93
V ;;5.1;IFCAP;**24,52**;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 QUIT
+3 ;
+4 ;
ORDRDELM ; delete distribution order (ask first)
+1 ; called from protocol
+2 SET VALMBCK="R"
+3 SET XP="Do you want to DELETE the distribution order"
+4 SET XH="Enter 'YES' to delete the order, 'NO' or '^' to retain the order on file."
+5 WRITE !
IF $$YN^PRCPUYN(1)'=1
QUIT
+6 ;
+7 DO VARIABLE^PRCPOPU
+8 NEW ITEMDA,PRCPSTOP,QTY
+9 SET PRCPSTOP=0
+10 ;
+11 ; if order is released or backordered, cancel dueins and dueouts
+12 IF $PIECE(PRCPORD(0),"^",6)'=""
Begin DoDot:1
+13 WRITE !
+14 IF $PIECE(^PRCP(445.3,+ORDERDA,0),"^",10)]""
IF $$REFILL(+ORDERDA)
Begin DoDot:2
+15 NEW DA,DIR,DR
+16 SET DIR(0)="Y"
+17 SET DIR("A",1)="The supply station received items on this order."
+18 SET DIR("A",2)="WARNING: IF YOU DELETE THE ORDER, GIP WILL NOT BE UPDATED."
+19 SET DIR("A",3)=" "
+20 SET DIR("A")="Are you sure you want to delete the order"
+21 SET DIR("?")="Enter 'Y' or 'YES' to delete the current order."
+22 SET DIR("?",1)="Enter 'N' or 'NO' to retain the order and exit deletion."
+23 DO ^DIR
+24 IF $DATA(DUOUT)!$DATA(DTOUT)
SET PRCPSTOP=1
QUIT
+25 IF Y=0
SET PRCPSTOP=1
QUIT
End DoDot:2
IF PRCPSTOP
QUIT
+26 IF $PIECE(PRCPORD(0),"^",2)'=""
WRITE !,"<*> Cancelling DUE-OUTS in ",$PIECE(PRCPORD(0),"^",2)
+27 IF $PIECE(PRCPORD(0),"^",3)'=""
WRITE !,"<*> Cancelling DUE-INS in ",$PIECE(PRCPORD(0),"^",3)
+28 SET ITEMDA=0
+29 FOR
SET ITEMDA=$ORDER(^PRCP(445.3,ORDERDA,1,ITEMDA))
if 'ITEMDA
QUIT
Begin DoDot:2
+30 SET QTY=$PIECE(^PRCP(445.3,ORDERDA,1,ITEMDA,0),"^",2)
+31 IF QTY
DO DUEOUTIN^PRCPOPU(PRCPPRIM,PRCPSECO,ITEMDA,-QTY,0)
End DoDot:2
End DoDot:1
IF PRCPSTOP
QUIT
+32 ;
+33 DO DELORDER(ORDERDA)
+34 ; pause so user can see msg
+35 DO R^PRCPUREP
+36 ; kill valmbck to exit LM
+37 KILL VALMBCK
+38 QUIT
+39 ;
+40 ;
DELORDER(ORDERDA) ; delete distribution order from file 445.3
+1 ; cancel due-ins and due-outs first
+2 IF '$DATA(^PRCP(445.3,+ORDERDA,0))
QUIT
+3 IF $PIECE(^PRCP(445.3,+ORDERDA,0),"^",10)]""
IF $PIECE(^PRCP(445.3,+ORDERDA,0),"^",6)="R"
DO MESSAGE(+ORDERDA,1)
+4 NEW %,DA,DIC,DIK,X,Y
+5 WRITE !!,"DELETING distribution order..."
+6 SET DA=+ORDERDA
SET DIK="^PRCP(445.3,"
DO ^DIK
+7 QUIT
+8 ;
+9 ;
ITEMDELM ; delete an item from a distribution order
+1 DO FULL^VALM1
+2 SET VALMBCK="R"
+3 ;
+4 DO VARIABLE^PRCPOPU
+5 NEW %,ITEMDA,QTY
+6 ;
+7 FOR
SET ITEMDA=+$$ITEMSEL^PRCPOPUS(ORDERDA,PRCPPRIM,0)
if 'ITEMDA
QUIT
Begin DoDot:1
+8 SET XP="Do you want to DELETE the item from the distribution order"
SET XH="Enter 'YES' to delete the item, 'NO' or '^' to retain the item on the order."
+9 IF $$YN^PRCPUYN(1)'=1
QUIT
+10 ;
+11 SET QTY=$PIECE($GET(^PRCP(445.3,ORDERDA,1,ITEMDA,0)),"^",2)
+12 IF 'QTY
DO DELITEM(ORDERDA,ITEMDA)
WRITE !?5,"* * * ITEM DELETED * * *"
QUIT
+13 ;
+14 IF $PIECE(PRCPORD(0),"^",6)'=""
DO DUEOUTIN^PRCPOPU(PRCPPRIM,PRCPSECO,ITEMDA,-QTY,1)
+15 DO DELITEM(ORDERDA,ITEMDA)
+16 WRITE !?5,"* * * ITEM DELETED * * *"
End DoDot:1
+17 DO INIT^PRCPOPL
+18 QUIT
+19 ;
MESSAGE(ORDER,ACTIVITY) ; tell user of items filled by supply station
+1 ;
+2 ; ORDER - ien of file 445.3
+3 ; ACTIVITY: 1- ORDER DELETED, 2 - SUPPLY STATION FLAG REMOVED
+4 ;
+5 NEW ITEM,LN,ORDERNO,PRCPSEC,PRCPXMY,REFILL,XMB,XMDUZ,XMTEXT,XMY
+6 SET ITEM=$GET(^PRCP(445.3,ORDER,0))
IF ITEM']""
QUIT
+7 SET ORDERNO=$PIECE(ITEM,"^",1)
+8 SET PRCPSEC=$PIECE(ITEM,"^",3)
+9 IF '$$REFILL(ORDER)
QUIT
+10 ; quit if no users in inv point
DO GETUSER^PRCPXTRM(PRCPSEC)
if '$ORDER(PRCPXMY(""))
QUIT
+11 SET ITEM=0
+12 ; restrict message to managers
+13 FOR
SET ITEM=$ORDER(PRCPXMY(ITEM))
if ITEM'>0
QUIT
IF PRCPXMY(ITEM)=1
SET XMY(ITEM)=""
+14 KILL ^TMP($JOB,"PRCPSSORDER")
+15 SET XMTEXT="^TMP($J,""PRCPSSORDER"",1,"
+16 SET XMB="PRCP_ORDER_PARTIALLY_LOST"
+17 SET XMB(1)=ORDERNO
+18 SET XMB(2)=$$INVNAME^PRCPUX1(PRCPSEC)
+19 IF ACTIVITY=1
Begin DoDot:1
+20 SET XMB(3)="deleted"
+21 SET XMB(4)="If refilled, enter an emergency or call-in order to update GIP."
End DoDot:1
+22 IF ACTIVITY=2
Begin DoDot:1
+23 SET XMB(3)="flagged for completion on GIP"
+24 SET XMB(4)="If refilled, adjust the quantity ordered to the refill amount."
End DoDot:1
+25 SET XMB(5)="If not refilled, adjust the supply station down and the secondary up"
+26 SET XMB(6)=" by the same value for each affected item"
+27 SET XMDUZ="SUPPLY STATION INTERFACE"
+28 SET ITEM=0
SET LN=0
+29 FOR
SET ITEM=$ORDER(^PRCP(445.3,ORDER,1,ITEM))
if '+ITEM
QUIT
Begin DoDot:1
+30 IF $PIECE($GET(^PRCP(445.3,ORDER,1,ITEM,0)),"^",7)>0
Begin DoDot:2
+31 NEW QTY,NAME,PRIMVN
+32 SET LN=LN+1
+33 SET QTY=$PIECE(^PRCP(445.3,ORDER,1,ITEM,0),"^",7)
+34 SET PRIMVN=$PIECE(^PRCP(445.3,ORDER,0),"^",2)_";PRCP(445,"
+35 SET X=$$GETVEN^PRCPUVEN(PRCPSEC,ITEM,PRIMVN,1)
+36 ; pkg multiple (conversion factor)
SET X=$PIECE(X,"^",4)
+37 IF 'X
SET X=1
+38 SET QTY=QTY*X
+39 SET NAME=$PIECE(^PRC(441,ITEM,0),"^",2)
+40 SET ^TMP($JOB,"PRCPSSORDER",1,LN,0)=$EXTRACT(" ",$LENGTH(QTY)+1,8)_QTY_" "_"("_ITEM_") "_NAME
End DoDot:2
End DoDot:1
+41 SET ^TMP($JOB,"PRCPSSORDER",1)=LN
+42 DO EN^XMB
+43 KILL ^TMP($JOB,"PRCPSSORDER")
+44 QUIT
+45 ;
REFILL(ORDER) ;
+1 ;
+2 ; This subroutine will return 1 if the order has any refill activity
+3 ; and 0 if there is none
+4 ;
+5 ; ORDER ien of file 445.3
+6 ;
+7 NEW REFILL
+8 SET ITEM=0
SET REFILL=0
+9 FOR
SET ITEM=$ORDER(^PRCP(445.3,ORDER,1,ITEM))
if '+ITEM!REFILL
QUIT
Begin DoDot:1
+10 IF $PIECE($GET(^PRCP(445.3,ORDER,1,ITEM,0)),"^",7)>0
SET REFILL=1
End DoDot:1
+11 QUIT REFILL
+12 ;
+13 ;
DELITEM(ORDERDA,ITEMDA) ; delete item from distribution order
+1 IF '$DATA(^PRCP(445.3,+ORDERDA,1,+ITEMDA,0))
QUIT
+2 NEW %,DA,DIC,DIK,X,Y
+3 SET DA(1)=+ORDERDA
SET DA=+ITEMDA
SET DIK="^PRCP(445.3,"_ORDERDA_",1,"
DO ^DIK
QUIT
