PRCPOPR.m

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 ---PRCPOPR   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