PRCPWPPL ;WISC/RFJ-primary receive issue book (list manager) ;20 Jan 93
;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
D ^PRCPUSEL Q:'$G(PRCP("I"))
I PRCP("DPTYPE")'="P" W !,"ONLY THE PRIMARY CAN RECEIVE ISSUE BOOKS!" Q
I $P(^PRCP(445,PRCP("I"),0),"^",16)'="N" W !,"BEFORE USING THIS OPTION, THE 'PRIMARY UPDATED BY WAREHOUSE' MUST BE SET TO NO." Q
I $$CHECK^PRCPCUT1(PRCP("I")) Q
N PRCPDA,PRCPFINL,PRCPIBNM,PRCPINPT,PRCPWHSE,PRCPPVNO,X,Y
S PRCPINPT=PRCP("I")
S X="" W ! D ESIG^PRCUESIG(DUZ,.X) I X'>0 Q
S PRCPPVNO=+$O(^PRC(440,"AC","S",0))_";PRC(440," I '$D(^PRC(440,+PRCPPVNO,0)) W !!,"THERE IS NOT A VENDOR IN THE VENDOR FILE (#440) DESIGNATED AS A SUPPLY WHSE." Q
F S PRCPDA=$$SELECTIB Q:PRCPDA<1 D
. L +^PRCS(410,PRCPDA):5 I '$T D SHOWWHO^PRCPULOC(410,PRCPDA,0) Q
. D ADD^PRCPULOC(410,PRCPDA,0,"Receive Issue Book")
. S PRCPIBNM=$P(^PRCS(410,PRCPDA,0),"^")
. S PRCPWHSE=0 F S PRCPWHSE=$O(^PRCP(445,"AC","W",PRCPWHSE)) Q:'PRCPWHSE I +$G(^PRCP(445,PRCPWHSE,0))=+PRCPIBNM Q
. I 'PRCPWHSE W !,"THERE IS NOT A WAREHOUSE DESIGNATED FOR STATION '",+PRCPIBNM,"'." D UNLOCK Q
. I $P($G(^PRCS(410,PRCPDA,9)),"^",3) S PRCPFINL=1
. D EN^VALM("PRCP ISSUE BOOK RECEIVING")
. D UNLOCK
Q
;
;
UNLOCK ; unlock issue book
D CLEAR^PRCPULOC(410,PRCPDA,0)
L -^PRCS(410,PRCPDA)
Q
;
;
INIT ; build array
K ^TMP($J,"PRCPWPPLPOST")
D REBUILD^PRCPWPPB
Q
;
;
HDR ; header
N SPACE
S SPACE=" "
S VALMHDR(1)=$E("ISSUE BOOK: "_PRCPIBNM_" FROM: "_$E($$INVNAME^PRCPUX1(PRCPWHSE),1,15)_SPACE,1,69)_$S($G(PRCPFINL):"** FINAL **",1:"")
S VALMHDR(2)="LINE DESCRIPTION IM# NSN ** Q U A N T I T Y (in U/R) **"
S VALMHDR(3)=" UNIT CONV UNIT UNIT/IS UNIT/REC WHSE PRIM *TO*"
S VALMHDR(4)=" /IS FACT /REC AVGCOST UNITCOST ORDERED POSTED REC'D RECEIVE"
Q
;
;
EXIT ; exit
K ^TMP($J,"PRCPWPPL"),^TMP($J,"PRCPWPPLPOST"),^TMP($J,"PRCPWPPLLIST")
Q
;
;
SELECTIB() ; select issue book
N %,DIC,I,X,Y,Z
S DIC="^PRCS(410,",DIC(0)="QEAMZ",DIC("A")="Select TRANSACTION NUMBER: "
S DIC("S")="I $P(^(0),U,6)=PRCP(""I""),$P(^(0),U,2)=""O"",$P(^(0),U,4)=5,$P($G(^(3)),U,4)=+PRCPPVNO,$P($G(^(7)),U,6)]"""",$S('$D(^PRC(443,+Y,0)):1,$P(^(0),U,3)]"""":1,1:0)"
W ! D ^PRCSDIC
Q +Y
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPWPPL 2464 printed Nov 22, 2024@17:26:54 Page 2
PRCPWPPL ;WISC/RFJ-primary receive issue book (list manager) ;20 Jan 93
+1 ;;5.1;IFCAP;;Oct 20, 2000
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
+3 DO ^PRCPUSEL
if '$GET(PRCP("I"))
QUIT
+4 IF PRCP("DPTYPE")'="P"
WRITE !,"ONLY THE PRIMARY CAN RECEIVE ISSUE BOOKS!"
QUIT
+5 IF $PIECE(^PRCP(445,PRCP("I"),0),"^",16)'="N"
WRITE !,"BEFORE USING THIS OPTION, THE 'PRIMARY UPDATED BY WAREHOUSE' MUST BE SET TO NO."
QUIT
+6 IF $$CHECK^PRCPCUT1(PRCP("I"))
QUIT
+7 NEW PRCPDA,PRCPFINL,PRCPIBNM,PRCPINPT,PRCPWHSE,PRCPPVNO,X,Y
+8 SET PRCPINPT=PRCP("I")
+9 SET X=""
WRITE !
DO ESIG^PRCUESIG(DUZ,.X)
IF X'>0
QUIT
+10 SET PRCPPVNO=+$ORDER(^PRC(440,"AC","S",0))_";PRC(440,"
IF '$DATA(^PRC(440,+PRCPPVNO,0))
WRITE !!,"THERE IS NOT A VENDOR IN THE VENDOR FILE (#440) DESIGNATED AS A SUPPLY WHSE."
QUIT
+11 FOR
SET PRCPDA=$$SELECTIB
if PRCPDA<1
QUIT
Begin DoDot:1
+12 LOCK +^PRCS(410,PRCPDA):5
IF '$TEST
DO SHOWWHO^PRCPULOC(410,PRCPDA,0)
QUIT
+13 DO ADD^PRCPULOC(410,PRCPDA,0,"Receive Issue Book")
+14 SET PRCPIBNM=$PIECE(^PRCS(410,PRCPDA,0),"^")
+15 SET PRCPWHSE=0
FOR
SET PRCPWHSE=$ORDER(^PRCP(445,"AC","W",PRCPWHSE))
if 'PRCPWHSE
QUIT
IF +$GET(^PRCP(445,PRCPWHSE,0))=+PRCPIBNM
QUIT
+16 IF 'PRCPWHSE
WRITE !,"THERE IS NOT A WAREHOUSE DESIGNATED FOR STATION '",+PRCPIBNM,"'."
DO UNLOCK
QUIT
+17 IF $PIECE($GET(^PRCS(410,PRCPDA,9)),"^",3)
SET PRCPFINL=1
+18 DO EN^VALM("PRCP ISSUE BOOK RECEIVING")
+19 DO UNLOCK
End DoDot:1
+20 QUIT
+21 ;
+22 ;
UNLOCK ; unlock issue book
+1 DO CLEAR^PRCPULOC(410,PRCPDA,0)
+2 LOCK -^PRCS(410,PRCPDA)
+3 QUIT
+4 ;
+5 ;
INIT ; build array
+1 KILL ^TMP($JOB,"PRCPWPPLPOST")
+2 DO REBUILD^PRCPWPPB
+3 QUIT
+4 ;
+5 ;
HDR ; header
+1 NEW SPACE
+2 SET SPACE=" "
+3 SET VALMHDR(1)=$EXTRACT("ISSUE BOOK: "_PRCPIBNM_" FROM: "_$EXTRACT($$INVNAME^PRCPUX1(PRCPWHSE),1,15)_SPACE,1,69)_$SELECT($GET(PRCPFINL):"** FINAL **",1:"")
+4 SET VALMHDR(2)="LINE DESCRIPTION IM# NSN ** Q U A N T I T Y (in U/R) **"
+5 SET VALMHDR(3)=" UNIT CONV UNIT UNIT/IS UNIT/REC WHSE PRIM *TO*"
+6 SET VALMHDR(4)=" /IS FACT /REC AVGCOST UNITCOST ORDERED POSTED REC'D RECEIVE"
+7 QUIT
+8 ;
+9 ;
EXIT ; exit
+1 KILL ^TMP($JOB,"PRCPWPPL"),^TMP($JOB,"PRCPWPPLPOST"),^TMP($JOB,"PRCPWPPLLIST")
+2 QUIT
+3 ;
+4 ;
SELECTIB() ; select issue book
+1 NEW %,DIC,I,X,Y,Z
+2 SET DIC="^PRCS(410,"
SET DIC(0)="QEAMZ"
SET DIC("A")="Select TRANSACTION NUMBER: "
+3 SET DIC("S")="I $P(^(0),U,6)=PRCP(""I""),$P(^(0),U,2)=""O"",$P(^(0),U,4)=5,$P($G(^(3)),U,4)=+PRCPPVNO,$P($G(^(7)),U,6)]"""",$S('$D(^PRC(443,+Y,0)):1,$P(^(0),U,3)]"""":1,1:0)"
+4 WRITE !
DO ^PRCSDIC
+5 QUIT +Y
