PRCPOPR ;WISC/RFJ-release distribution order ;27 Sep 93
V ;;5.1;IFCAP;**1,24**;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
Q
;
;
RELEASEL ; release order - called from list manager
S VALMBCK="R"
N %,ITEMDA,PRCPFLAG
;
W !!,"CHECKING ITEMS ON ORDER..."
S (ITEMDA,PRCPFLAG)=0 F S ITEMDA=$O(^PRCP(445.3,ORDERDA,1,ITEMDA)) Q:'ITEMDA I $P($G(^(ITEMDA,0)),"^",2),$$ITEMCHK^PRCPOPER(PRCPPRIM,PRCPSECO,ITEMDA)'="" S PRCPFLAG=1 Q
I PRCPFLAG S VALMSG="ORDER CANNOT BE RELEASED - FIX ALL ERRORS FIRST" D CHECKORD^PRCPOPER Q
W " NO ERRORS FOUND !",!
;
I $$ASKREL(ORDERDA,1)'=1 Q
;
D RELEASE(ORDERDA)
S VALMSG="ORDER HAS BEEN RELEASED (TO PRIMARY) FOR FILLING"
D HDR^PRCPOPL,VARIABLE^PRCPOPU
Q
;
;
RELEASE(ORDERDA) ; release order - update dueouts and dueins, set order status released
N %,ITEMDA,ORDRDATA,PRCPPRIM,PRCPSECO,QUANTITY
S ORDRDATA=$G(^PRCP(445.3,ORDERDA,0)),PRCPPRIM=$P(ORDRDATA,"^",2),PRCPSECO=$P(ORDRDATA,"^",3)
S ITEMDA=0 F S ITEMDA=$O(^PRCP(445.3,ORDERDA,1,ITEMDA)) Q:'ITEMDA S QUANTITY=$P(^(ITEMDA,0),"^",2) I QUANTITY D DUEOUTIN^PRCPOPU(PRCPPRIM,PRCPSECO,ITEMDA,QUANTITY,0)
;
S $P(^PRCP(445.3,ORDERDA,0),"^",6)="R"
;
; if this is a regular order for a supply station secondary, send the
; order to the supply station and set up field 10.
I $P(^PRCP(445.3,ORDERDA,0),"^",8)="R",$P($G(^PRCP(445,PRCPSECO,5)),"^",1)]"" D
. N FLAG,ITEM
. I $P($G(^PRCP(445.3,ORDERDA,2)),"^",1)]"" D EN^DDIOL("Case Cart or IK Orders are not handled by the supply station.") Q ; CC/IK don't go
. S ITEM=0,FLAG=0
. F S ITEM=$O(^PRCP(445.3,ORDERDA,1,ITEM)) Q:+ITEM=0 D I FLAG Q
. . I $P(^PRC(441,ITEM,0),"^",6)'="S" S FLAG=1
. I 'FLAG D EN^DDIOL("Case Cart or IK Orders are not handled by the supply station.") Q
. D BLDSEG^PRCPHLSO(ORDERDA)
. D NOW^%DTC
. S $P(^PRCP(445.3,ORDERDA,0),"^",10)=%
;
Q
;
ASKREL(ORDERDA,%) ; ask to release order, %=defualt
; returns 1 for yes, 2 for no, 0 for ^
S XP="Is this order READY to be RELEASED to "_$$INVNAME^PRCPUX1(+$P($G(^PRCP(445.3,+ORDERDA,0)),"^",2))_" for FILLING",XH="Enter 'YES' to RELEASE this order for filling, 'NO' or '^' to exit."
W !
Q $$YN^PRCPUYN(%)
;
;
; remove piece 10 from file 445.3 for order sent to supply station
REMFLAG I '$D(PRCP("DPTYPE")) S PRCP("DPTYPE")="P"
D ^PRCPUSEL I '$G(PRCP("I")) Q
N DA,DIE,DIR,DR,ORDERDA,PRCPPRIM,PRCPSEC,PRCPSTOP,REFILL,Y
S PRCPPRIM=PRCP("I")
; ask order number
S ORDERDA=$$ORDERSEL^PRCPOPUS(PRCPPRIM,0,"R","")
Q:'ORDERDA
S PRCPSEC=$P(^PRCP(445.3,ORDERDA,0),"^",10)
I PRCPSEC']"" D EN^DDIOL("This order is not a supply station order and has no flag to remove.") QUIT
S DIR(0)="Y"
S DIR("A")="Restrict all processing of this order to GIP"
S DIR("A",1)=" "
S DIR("A",2)="WARNING: RESTRICTIONS MAY COMPROMISE THE INTEGRITY OF INVENTORY DATA !!!"
S DIR("A",3)=" "
S DIR("A",4)="Restrict processing ONLY when a supply station or its interface is"
S DIR("A",5)="down for extended periods of time."
S DIR("B")="NO"
D ^DIR
K DIR
I Y'=1 QUIT
S PRCPSTOP=0
S REFILL=$$REFILL^PRCPOPD(+ORDERDA)
I REFILL D I PRCPSTOP QUIT
. N DA,DIR,DR
. S DIR(0)="Y"
. S DIR("A",1)=" "
. S DIR("A",2)="WARNING: The supply station stocked items in this order!!!"
. S DIR("A",3)=" THE STOCKED QUANTITIES WILL BE LOST IF YOU PROCEED."
. S DIR("A",4)=" "
. S DIR("A")="Are you sure you want to process the order in GIP instead"
. S DIR("?")="Enter 'Y' or 'YES' to process the order in GIP."
. S DIR("?",1)="Enter 'N' or 'NO' to process the order in the supply station."
. D ^DIR
. I $D(DUOUT)!$D(DTOUT) S PRCPSTOP=1 Q
. I Y=0 S PRCPSTOP=1 Q
;
; DELETE FLAG FROM ORDER
I REFILL D MESSAGE^PRCPOPD(+ORDERDA,2)
S DIE="^PRCP(445.3,"
S DA=ORDERDA
S DR="10///@"
D ^DIE
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPOPR 3858 printed Mar 13, 2025@21:19:07 Page 2
PRCPOPR ;WISC/RFJ-release distribution order ;27 Sep 93
V ;;5.1;IFCAP;**1,24**;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 QUIT
+3 ;
+4 ;
RELEASEL ; release order - called from list manager
+1 SET VALMBCK="R"
+2 NEW %,ITEMDA,PRCPFLAG
+3 ;
+4 WRITE !!,"CHECKING ITEMS ON ORDER..."
+5 SET (ITEMDA,PRCPFLAG)=0
FOR
SET ITEMDA=$ORDER(^PRCP(445.3,ORDERDA,1,ITEMDA))
if 'ITEMDA
QUIT
IF $PIECE($GET(^(ITEMDA,0)),"^",2)
IF $$ITEMCHK^PRCPOPER(PRCPPRIM,PRCPSECO,ITEMDA)'=""
SET PRCPFLAG=1
QUIT
+6 IF PRCPFLAG
SET VALMSG="ORDER CANNOT BE RELEASED - FIX ALL ERRORS FIRST"
DO CHECKORD^PRCPOPER
QUIT
+7 WRITE " NO ERRORS FOUND !",!
+8 ;
+9 IF $$ASKREL(ORDERDA,1)'=1
QUIT
+10 ;
+11 DO RELEASE(ORDERDA)
+12 SET VALMSG="ORDER HAS BEEN RELEASED (TO PRIMARY) FOR FILLING"
+13 DO HDR^PRCPOPL
DO VARIABLE^PRCPOPU
+14 QUIT
+15 ;
+16 ;
RELEASE(ORDERDA) ; release order - update dueouts and dueins, set order status released
+1 NEW %,ITEMDA,ORDRDATA,PRCPPRIM,PRCPSECO,QUANTITY
+2 SET ORDRDATA=$GET(^PRCP(445.3,ORDERDA,0))
SET PRCPPRIM=$PIECE(ORDRDATA,"^",2)
SET PRCPSECO=$PIECE(ORDRDATA,"^",3)
+3 SET ITEMDA=0
FOR
SET ITEMDA=$ORDER(^PRCP(445.3,ORDERDA,1,ITEMDA))
if 'ITEMDA
QUIT
SET QUANTITY=$PIECE(^(ITEMDA,0),"^",2)
IF QUANTITY
DO DUEOUTIN^PRCPOPU(PRCPPRIM,PRCPSECO,ITEMDA,QUANTITY,0)
+4 ;
+5 SET $PIECE(^PRCP(445.3,ORDERDA,0),"^",6)="R"
+6 ;
+7 ; if this is a regular order for a supply station secondary, send the
+8 ; order to the supply station and set up field 10.
+9 IF $PIECE(^PRCP(445.3,ORDERDA,0),"^",8)="R"
IF $PIECE($GET(^PRCP(445,PRCPSECO,5)),"^",1)]""
Begin DoDot:1
+10 NEW FLAG,ITEM
+11 ; CC/IK don't go
IF $PIECE($GET(^PRCP(445.3,ORDERDA,2)),"^",1)]""
DO EN^DDIOL("Case Cart or IK Orders are not handled by the supply station.")
QUIT
+12 SET ITEM=0
SET FLAG=0
+13 FOR
SET ITEM=$ORDER(^PRCP(445.3,ORDERDA,1,ITEM))
if +ITEM=0
QUIT
Begin DoDot:2
+14 IF $PIECE(^PRC(441,ITEM,0),"^",6)'="S"
SET FLAG=1
End DoDot:2
IF FLAG
QUIT
+15 IF 'FLAG
DO EN^DDIOL("Case Cart or IK Orders are not handled by the supply station.")
QUIT
+16 DO BLDSEG^PRCPHLSO(ORDERDA)
+17 DO NOW^%DTC
+18 SET $PIECE(^PRCP(445.3,ORDERDA,0),"^",10)=%
End DoDot:1
+19 ;
+20 QUIT
+21 ;
ASKREL(ORDERDA,%) ; ask to release order, %=defualt
+1 ; returns 1 for yes, 2 for no, 0 for ^
+2 SET XP="Is this order READY to be RELEASED to "_$$INVNAME^PRCPUX1(+$PIECE($GET(^PRCP(445.3,+ORDERDA,0)),"^",2))_" for FILLING"
SET XH="Enter 'YES' to RELEASE this order for filling, 'NO' or '^' to exit."
+3 WRITE !
+4 QUIT $$YN^PRCPUYN(%)
+5 ;
+6 ;
+7 ; remove piece 10 from file 445.3 for order sent to supply station
REMFLAG IF '$DATA(PRCP("DPTYPE"))
SET PRCP("DPTYPE")="P"
+1 DO ^PRCPUSEL
IF '$GET(PRCP("I"))
QUIT
+2 NEW DA,DIE,DIR,DR,ORDERDA,PRCPPRIM,PRCPSEC,PRCPSTOP,REFILL,Y
+3 SET PRCPPRIM=PRCP("I")
+4 ; ask order number
+5 SET ORDERDA=$$ORDERSEL^PRCPOPUS(PRCPPRIM,0,"R","")
+6 if 'ORDERDA
QUIT
+7 SET PRCPSEC=$PIECE(^PRCP(445.3,ORDERDA,0),"^",10)
+8 IF PRCPSEC']""
DO EN^DDIOL("This order is not a supply station order and has no flag to remove.")
QUIT
+9 SET DIR(0)="Y"
+10 SET DIR("A")="Restrict all processing of this order to GIP"
+11 SET DIR("A",1)=" "
+12 SET DIR("A",2)="WARNING: RESTRICTIONS MAY COMPROMISE THE INTEGRITY OF INVENTORY DATA !!!"
+13 SET DIR("A",3)=" "
+14 SET DIR("A",4)="Restrict processing ONLY when a supply station or its interface is"
+15 SET DIR("A",5)="down for extended periods of time."
+16 SET DIR("B")="NO"
+17 DO ^DIR
+18 KILL DIR
+19 IF Y'=1
QUIT
+20 SET PRCPSTOP=0
+21 SET REFILL=$$REFILL^PRCPOPD(+ORDERDA)
+22 IF REFILL
Begin DoDot:1
+23 NEW DA,DIR,DR
+24 SET DIR(0)="Y"
+25 SET DIR("A",1)=" "
+26 SET DIR("A",2)="WARNING: The supply station stocked items in this order!!!"
+27 SET DIR("A",3)=" THE STOCKED QUANTITIES WILL BE LOST IF YOU PROCEED."
+28 SET DIR("A",4)=" "
+29 SET DIR("A")="Are you sure you want to process the order in GIP instead"
+30 SET DIR("?")="Enter 'Y' or 'YES' to process the order in GIP."
+31 SET DIR("?",1)="Enter 'N' or 'NO' to process the order in the supply station."
+32 DO ^DIR
+33 IF $DATA(DUOUT)!$DATA(DTOUT)
SET PRCPSTOP=1
QUIT
+34 IF Y=0
SET PRCPSTOP=1
QUIT
End DoDot:1
IF PRCPSTOP
QUIT
+35 ;
+36 ; DELETE FLAG FROM ORDER
+37 IF REFILL
DO MESSAGE^PRCPOPD(+ORDERDA,2)
+38 SET DIE="^PRCP(445.3,"
+39 SET DA=ORDERDA
+40 SET DR="10///@"
+41 DO ^DIE
+42 QUIT
