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