- 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 Mar 13, 2025@21:21:37 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
