- PRCPBAL3 ;WISC/RFJ/DWA-release,print the pick ticket for barcode orders ;04 Dec 92
- ;;5.1;IFCAP;**47**;Oct 20, 2000
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- Q
- ;
- ;
- RELEASE ; release orders in ^tmp($j,"prcpbal3",orderda)
- N ITEMDA,ORDERDA,PRCPFLAG,PRCPORD,PRCPPAT,PRCPPRIM,PRCPSECO
- S ORDERDA=0 F S ORDERDA=$O(^TMP($J,"PRCPBAL3",ORDERDA)) Q:'ORDERDA D
- . L +^PRCP(445.3,ORDERDA):2 Q:'$T
- . D VARIABLE^PRCPOPU
- . I PRCPORD(0)="" L -^PRCP(445.3,ORDERDA) Q
- . W !,"Order # ",$P(PRCPORD(0),"^")
- . I $P(PRCPORD(0),"^",6)'="" W ?20,"Already released" L -^PRCP(445.3,ORDERDA) Q
- . ; check for items
- . 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 W ?20,"NOT RELEASED, errors found with ordered items." K ^TMP($J,"PRCPBAL3",ORDERDA) L -^PRCP(445.3,ORDERDA) Q
- . D RELEASE^PRCPOPR(ORDERDA)
- . L -^PRCP(445.3,ORDERDA)
- . W ?20,"Released !"
- Q
- ;
- ;
- PICKTICK ; print picking tickets in ^tmp($j,"prcpbal3",orderda)
- ;
- DEVICE ;
- K X S X(1)="Enter the DEVICE which will be used to print the picking tickets." D DISPLAY^PRCPUX2(2,40,.X)
- W ! S %ZIS="Q" D ^%ZIS Q:POP
- I IO=IO(0) W !,"YOU CANNOT SELECT YOUR CURRENT DEVICE FOR PRINTING PICKING TICKETS." G DEVICE
- I $D(IO("Q")) D D ^%ZTLOAD K IO("Q"),ZTSK Q
- . S ZTDESC="Print Picking Tickets",ZTRTN="DQ^PRCPBAL3"
- . S ZTSAVE("^TMP($J,""PRCPBAL3"",")="",ZTSAVE("ZTREQ")="@"
- ;
- DQ ; print picking tickets for orders in ^tmp($j,"prcpbal3",orderda)
- N ORDERDA,PRCPORD,PRCPPAT,PRCPPRIM,PRCPSECO,X
- S ORDERDA=0 F S ORDERDA=$O(^TMP($J,"PRCPBAL3",ORDERDA)) Q:'ORDERDA D
- . L +^PRCP(445.3,ORDERDA)
- . D VARIABLE^PRCPOPU
- . I PRCPORD(0)="" L -^PRCP(445.3,ORDERDA) Q
- . U IO(0) W !,"Order # ",$P(PRCPORD(0),"^")
- . I $P(PRCPORD(0),"^",6)'="R" W ?20,"Not released" L -^PRCP(445.3,ORDERDA) Q
- . D BUILD^PRCPOPT(ORDERDA)
- . D DQ^PRCPOPT1
- . L -^PRCP(445.3,ORDERDA)
- . U IO(0) W ?20,"Printed !"
- D Q^PRCPOPT
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPBAL3 2100 printed Feb 18, 2025@23:39:23 Page 2
- PRCPBAL3 ;WISC/RFJ/DWA-release,print the pick ticket for barcode orders ;04 Dec 92
- +1 ;;5.1;IFCAP;**47**;Oct 20, 2000
- +2 ;Per VHA Directive 10-93-142, this routine should not be modified.
- +3 QUIT
- +4 ;
- +5 ;
- RELEASE ; release orders in ^tmp($j,"prcpbal3",orderda)
- +1 NEW ITEMDA,ORDERDA,PRCPFLAG,PRCPORD,PRCPPAT,PRCPPRIM,PRCPSECO
- +2 SET ORDERDA=0
- FOR
- SET ORDERDA=$ORDER(^TMP($JOB,"PRCPBAL3",ORDERDA))
- if 'ORDERDA
- QUIT
- Begin DoDot:1
- +3 LOCK +^PRCP(445.3,ORDERDA):2
- if '$TEST
- QUIT
- +4 DO VARIABLE^PRCPOPU
- +5 IF PRCPORD(0)=""
- LOCK -^PRCP(445.3,ORDERDA)
- QUIT
- +6 WRITE !,"Order # ",$PIECE(PRCPORD(0),"^")
- +7 IF $PIECE(PRCPORD(0),"^",6)'=""
- WRITE ?20,"Already released"
- LOCK -^PRCP(445.3,ORDERDA)
- QUIT
- +8 ; check for items
- +9 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
- +10 IF PRCPFLAG
- WRITE ?20,"NOT RELEASED, errors found with ordered items."
- KILL ^TMP($JOB,"PRCPBAL3",ORDERDA)
- LOCK -^PRCP(445.3,ORDERDA)
- QUIT
- +11 DO RELEASE^PRCPOPR(ORDERDA)
- +12 LOCK -^PRCP(445.3,ORDERDA)
- +13 WRITE ?20,"Released !"
- End DoDot:1
- +14 QUIT
- +15 ;
- +16 ;
- PICKTICK ; print picking tickets in ^tmp($j,"prcpbal3",orderda)
- +1 ;
- DEVICE ;
- +1 KILL X
- SET X(1)="Enter the DEVICE which will be used to print the picking tickets."
- DO DISPLAY^PRCPUX2(2,40,.X)
- +2 WRITE !
- SET %ZIS="Q"
- DO ^%ZIS
- if POP
- QUIT
- +3 IF IO=IO(0)
- WRITE !,"YOU CANNOT SELECT YOUR CURRENT DEVICE FOR PRINTING PICKING TICKETS."
- GOTO DEVICE
- +4 IF $DATA(IO("Q"))
- Begin DoDot:1
- +5 SET ZTDESC="Print Picking Tickets"
- SET ZTRTN="DQ^PRCPBAL3"
- +6 SET ZTSAVE("^TMP($J,""PRCPBAL3"",")=""
- SET ZTSAVE("ZTREQ")="@"
- End DoDot:1
- DO ^%ZTLOAD
- KILL IO("Q"),ZTSK
- QUIT
- +7 ;
- DQ ; print picking tickets for orders in ^tmp($j,"prcpbal3",orderda)
- +1 NEW ORDERDA,PRCPORD,PRCPPAT,PRCPPRIM,PRCPSECO,X
- +2 SET ORDERDA=0
- FOR
- SET ORDERDA=$ORDER(^TMP($JOB,"PRCPBAL3",ORDERDA))
- if 'ORDERDA
- QUIT
- Begin DoDot:1
- +3 LOCK +^PRCP(445.3,ORDERDA)
- +4 DO VARIABLE^PRCPOPU
- +5 IF PRCPORD(0)=""
- LOCK -^PRCP(445.3,ORDERDA)
- QUIT
- +6 USE IO(0)
- WRITE !,"Order # ",$PIECE(PRCPORD(0),"^")
- +7 IF $PIECE(PRCPORD(0),"^",6)'="R"
- WRITE ?20,"Not released"
- LOCK -^PRCP(445.3,ORDERDA)
- QUIT
- +8 DO BUILD^PRCPOPT(ORDERDA)
- +9 DO DQ^PRCPOPT1
- +10 LOCK -^PRCP(445.3,ORDERDA)
- +11 USE IO(0)
- WRITE ?20,"Printed !"
- End DoDot:1
- +12 DO Q^PRCPOPT
- +13 QUIT