PRCPWPLM ;WISC/RFJ-whse post issue book (list manager) ;13 Jan 94
;;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")'="W" W !,"ONLY THE WAREHOUSE CAN POST ISSUE BOOKS!" Q
I $$CHECK^PRCPCUT1(PRCP("I")) Q
I '$D(^PRC(442.6,"B",PRC("SITE")_"-I"_$E(PRC("FY"),2))) D Q
. K X S X(1)="Before you can post issue books you need to set up a common numbering series for issue books. The common numbering series should be in the form '460-I4' where 460 is the station number and 4 is the fiscal year."
. S X(2)="For this station and fiscal year, set up the common numbering series: "_PRC("SITE")_"-I"_$E(PRC("FY"),2)
. D DISPLAY^PRCPUX2(5,75,.X)
N PRCPDA,PRCPFERR,PRCPFINL,PRCPFNSN,PRCPFPRI,PRCPIBNM,PRCPINPT,PRCPORD,PRCPPRIM,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(1) Q:PRCPDA<1 D
. L +^PRCS(410,PRCPDA):5 I '$T D SHOWWHO^PRCPULOC(410,PRCPDA,0) Q
. D ADD^PRCPULOC(410,PRCPDA,0,"Post Issue Book")
. I $P($G(^PRCS(410,PRCPDA,9)),"^",3)'="" W !,"*** THIS TRANSACTION NUMBER WAS JUST MADE A 'FINAL' ***" D UNLOCK Q
. S PRCPIBNM=$P(^PRCS(410,PRCPDA,0),"^")
. S PRCPPRIM=$P($G(^PRCS(410,PRCPDA,0)),"^",6)
. ; primary inventory point not attached to issue book
. I '$D(^PRCP(445,+PRCPPRIM,0)) D I 'PRCPPRIM D UNLOCK Q
. . W !,"NOT A VALID PRIMARY INVENTORY POINT ('",$S(PRCPPRIM="":"<<NO ENTRY>>",1:PRCPPRIM),"')."
. . F S PRCPPRIM=+$$TO^PRCPUDPT(PRCP("I")) Q:'PRCPPRIM D Q:PRCPPRIM
. . . S XP=" ARE YOU SURE YOU WANT TO USE THIS INVENTORY POINT FOR DISTRIBUTION",XH="ENTER 'YES' TO USE THIS INVENTORY POINT, 'NO' TO SELECT ANOTHER INVENTORY POINT."
. . . I $$YN^PRCPUYN(1)'=1 S PRCPPRIM=0 Q
. . . S $P(^PRCS(410,PRCPDA,0),"^",6)=PRCPPRIM
. ;
. S PRCPFPRI=$S($P($G(^PRCP(445,PRCPPRIM,0)),"^",16)="N":0,1:1)
. K X S X(1)="Distribution to Primary Inventory Point: "_$P($$INVNAME^PRCPUX1(PRCPPRIM),"-",2,99)_" "_$S('PRCPFPRI:"***NOT UPDATED DURING POSTING***",1:"") D DISPLAY^PRCPUX2(5,75,.X)
. ;
. ; get voucher number
. S PRCPORD=$P($G(^PRCS(410,PRCPDA,445)),"^")
. K X S X(1)="Reference Voucher Number: "_PRCPORD
. I PRCPORD="" K X S X(1)="This is the FIRST time this issue book has been POSTED. The reference voucher number will automatically be generated from the common numbering series when the issue book is posted."
. D DISPLAY^PRCPUX2(5,75,.X)
. D R^PRCPUREP
. S PRCPFNSN=+$G(^DISV(DUZ,"PRCPWPLM","SHOWNSN"))
. K PRCPFINL
. D EN^VALM("PRCP ISSUE BOOK POSTING")
. D UNLOCK
Q
;
;
UNLOCK ; unlock issue book
D CLEAR^PRCPULOC(410,PRCPDA,0)
L -^PRCS(410,PRCPDA)
Q
;
;
INIT ; build array
K ^TMP($J,"PRCPWPLMPOST")
D REBUILD^PRCPWPLB
Q
;
;
HDR ; header
N SPACE
S SPACE=" "
S VALMHDR(1)=$E("ISSUE BOOK: "_PRCPIBNM_" POST TO: "_$E($$INVNAME^PRCPUX1(PRCPPRIM),1,15)_" "_$S('$G(PRCPFPRI):"**NOT UPDATED DURING POSTING**",1:"")_SPACE,1,69)_$S($G(PRCPFINL):"** FINAL **",1:"")
S VALMHDR(2)=$E(" REF#: "_$S($G(PRCPORD)="":"to be generated",1:PRCPORD)_SPACE,1,32)_"UNIT QTY ESTIMATE * * Q U A N T I T Y * *"
S VALMHDR(3)="LINE DESCRIPTION IM# /IS ONHAND UNITCOST ORDERED REMAIN TO POST"
Q
;
;
EXIT ; exit
K ^TMP($J,"PRCPWPLM"),^TMP($J,"PRCPWPLMPOST"),^TMP($J,"PRCPWPLMLIST")
Q
;
;
SELECTIB(FINAL) ; select issue book
; final=1 for screening out ib which are final
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,2)=""O"",$P(^(0),U,4)=5,$P($G(^(3)),U,4)=+PRCPPVNO,$P($G(^(7)),U,6)]"""","_$S($G(FINAL):"'$P($G(^(9)),U,3),",1:"")_"$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[HPRCPWPLM 4109 printed Apr 09, 2024@21:05:16 Page 2
PRCPWPLM ;WISC/RFJ-whse post issue book (list manager) ;13 Jan 94
+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")'="W"
WRITE !,"ONLY THE WAREHOUSE CAN POST ISSUE BOOKS!"
QUIT
+5 IF $$CHECK^PRCPCUT1(PRCP("I"))
QUIT
+6 IF '$DATA(^PRC(442.6,"B",PRC("SITE")_"-I"_$EXTRACT(PRC("FY"),2)))
Begin DoDot:1
+7 KILL X
SET X(1)="Before you can post issue books you need to set up a common numbering series for issue books. The common numbering series should be in the form '460-I4' where 460 is the station number and 4 is the fiscal year."
+8 SET X(2)="For this station and fiscal year, set up the common numbering series: "_PRC("SITE")_"-I"_$EXTRACT(PRC("FY"),2)
+9 DO DISPLAY^PRCPUX2(5,75,.X)
End DoDot:1
QUIT
+10 NEW PRCPDA,PRCPFERR,PRCPFINL,PRCPFNSN,PRCPFPRI,PRCPIBNM,PRCPINPT,PRCPORD,PRCPPRIM,PRCPPVNO,X,Y
+11 SET PRCPINPT=PRCP("I")
+12 SET X=""
WRITE !
DO ESIG^PRCUESIG(DUZ,.X)
IF X'>0
QUIT
+13 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
+14 FOR
SET PRCPDA=$$SELECTIB(1)
if PRCPDA<1
QUIT
Begin DoDot:1
+15 LOCK +^PRCS(410,PRCPDA):5
IF '$TEST
DO SHOWWHO^PRCPULOC(410,PRCPDA,0)
QUIT
+16 DO ADD^PRCPULOC(410,PRCPDA,0,"Post Issue Book")
+17 IF $PIECE($GET(^PRCS(410,PRCPDA,9)),"^",3)'=""
WRITE !,"*** THIS TRANSACTION NUMBER WAS JUST MADE A 'FINAL' ***"
DO UNLOCK
QUIT
+18 SET PRCPIBNM=$PIECE(^PRCS(410,PRCPDA,0),"^")
+19 SET PRCPPRIM=$PIECE($GET(^PRCS(410,PRCPDA,0)),"^",6)
+20 ; primary inventory point not attached to issue book
+21 IF '$DATA(^PRCP(445,+PRCPPRIM,0))
Begin DoDot:2
+22 WRITE !,"NOT A VALID PRIMARY INVENTORY POINT ('",$SELECT(PRCPPRIM="":"<<NO ENTRY>>",1:PRCPPRIM),"')."
+23 FOR
SET PRCPPRIM=+$$TO^PRCPUDPT(PRCP("I"))
if 'PRCPPRIM
QUIT
Begin DoDot:3
+24 SET XP=" ARE YOU SURE YOU WANT TO USE THIS INVENTORY POINT FOR DISTRIBUTION"
SET XH="ENTER 'YES' TO USE THIS INVENTORY POINT, 'NO' TO SELECT ANOTHER INVENTORY POINT."
+25 IF $$YN^PRCPUYN(1)'=1
SET PRCPPRIM=0
QUIT
+26 SET $PIECE(^PRCS(410,PRCPDA,0),"^",6)=PRCPPRIM
End DoDot:3
if PRCPPRIM
QUIT
End DoDot:2
IF 'PRCPPRIM
DO UNLOCK
QUIT
+27 ;
+28 SET PRCPFPRI=$SELECT($PIECE($GET(^PRCP(445,PRCPPRIM,0)),"^",16)="N":0,1:1)
+29 KILL X
SET X(1)="Distribution to Primary Inventory Point: "_$PIECE($$INVNAME^PRCPUX1(PRCPPRIM),"-",2,99)_" "_$SELECT('PRCPFPRI:"***NOT UPDATED DURING POSTING***",1:"")
DO DISPLAY^PRCPUX2(5,75,.X)
+30 ;
+31 ; get voucher number
+32 SET PRCPORD=$PIECE($GET(^PRCS(410,PRCPDA,445)),"^")
+33 KILL X
SET X(1)="Reference Voucher Number: "_PRCPORD
+34 IF PRCPORD=""
KILL X
SET X(1)="This is the FIRST time this issue book has been POSTED. The reference voucher number will automatically be generated from the common numbering series when the issue book is posted."
+35 DO DISPLAY^PRCPUX2(5,75,.X)
+36 DO R^PRCPUREP
+37 SET PRCPFNSN=+$GET(^DISV(DUZ,"PRCPWPLM","SHOWNSN"))
+38 KILL PRCPFINL
+39 DO EN^VALM("PRCP ISSUE BOOK POSTING")
+40 DO UNLOCK
End DoDot:1
+41 QUIT
+42 ;
+43 ;
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,"PRCPWPLMPOST")
+2 DO REBUILD^PRCPWPLB
+3 QUIT
+4 ;
+5 ;
HDR ; header
+1 NEW SPACE
+2 SET SPACE=" "
+3 SET VALMHDR(1)=$EXTRACT("ISSUE BOOK: "_PRCPIBNM_" POST TO: "_$EXTRACT($$INVNAME^PRCPUX1(PRCPPRIM),1,15)_" "_$SELECT('$GET(PRCPFPRI):"**NOT UPDATED DURING POSTING**",1:"")_SPACE,1,69)_$SELECT($GET(PRCPFINL):"** FINAL **",1:"")
+4 SET VALMHDR(2)=$EXTRACT(" REF#: "_$SELECT($GET(PRCPORD)="":"to be generated",1:PRCPORD)_SPACE,1,32)_"UNIT QTY ESTIMATE * * Q U A N T I T Y * *"
+5 SET VALMHDR(3)="LINE DESCRIPTION IM# /IS ONHAND UNITCOST ORDERED REMAIN TO POST"
+6 QUIT
+7 ;
+8 ;
EXIT ; exit
+1 KILL ^TMP($JOB,"PRCPWPLM"),^TMP($JOB,"PRCPWPLMPOST"),^TMP($JOB,"PRCPWPLMLIST")
+2 QUIT
+3 ;
+4 ;
SELECTIB(FINAL) ; select issue book
+1 ; final=1 for screening out ib which are final
+2 NEW %,DIC,I,X,Y,Z
+3 SET DIC="^PRCS(410,"
SET DIC(0)="QEAMZ"
SET DIC("A")="Select TRANSACTION NUMBER: "
+4 SET DIC("S")="I $P(^(0),U,2)=""O"",$P(^(0),U,4)=5,$P($G(^(3)),U,4)=+PRCPPVNO,$P($G(^(7)),U,6)]"""","_$SELECT($GET(FINAL):"'$P($G(^(9)),U,3),",1:"")_"$S('$D(^PRC(443,+Y,0)):1,$P(^(0),U,3)]"""":1,1:0)"
+5 WRITE !
DO ^PRCSDIC
+6 QUIT +Y
