source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCPWPLM.m@ 1006

Last change on this file since 1006 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 3.9 KB
Line 
1PRCPWPLM ;WISC/RFJ-whse post issue book (list manager) ;13 Jan 94
2 ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 D ^PRCPUSEL Q:'$G(PRCP("I"))
5 I PRCP("DPTYPE")'="W" W !,"ONLY THE WAREHOUSE CAN POST ISSUE BOOKS!" Q
6 I $$CHECK^PRCPCUT1(PRCP("I")) Q
7 I '$D(^PRC(442.6,"B",PRC("SITE")_"-I"_$E(PRC("FY"),2))) D Q
8 . 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."
9 . S X(2)="For this station and fiscal year, set up the common numbering series: "_PRC("SITE")_"-I"_$E(PRC("FY"),2)
10 . D DISPLAY^PRCPUX2(5,75,.X)
11 N PRCPDA,PRCPFERR,PRCPFINL,PRCPFNSN,PRCPFPRI,PRCPIBNM,PRCPINPT,PRCPORD,PRCPPRIM,PRCPPVNO,X,Y
12 S PRCPINPT=PRCP("I")
13 S X="" W ! D ESIG^PRCUESIG(DUZ,.X) I X'>0 Q
14 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
15 F S PRCPDA=$$SELECTIB(1) Q:PRCPDA<1 D
16 . L +^PRCS(410,PRCPDA):5 I '$T D SHOWWHO^PRCPULOC(410,PRCPDA,0) Q
17 . D ADD^PRCPULOC(410,PRCPDA,0,"Post Issue Book")
18 . I $P($G(^PRCS(410,PRCPDA,9)),"^",3)'="" W !,"*** THIS TRANSACTION NUMBER WAS JUST MADE A 'FINAL' ***" D UNLOCK Q
19 . S PRCPIBNM=$P(^PRCS(410,PRCPDA,0),"^")
20 . S PRCPPRIM=$P($G(^PRCS(410,PRCPDA,0)),"^",6)
21 . ; primary inventory point not attached to issue book
22 . I '$D(^PRCP(445,+PRCPPRIM,0)) D I 'PRCPPRIM D UNLOCK Q
23 . . W !,"NOT A VALID PRIMARY INVENTORY POINT ('",$S(PRCPPRIM="":"<<NO ENTRY>>",1:PRCPPRIM),"')."
24 . . F S PRCPPRIM=+$$TO^PRCPUDPT(PRCP("I")) Q:'PRCPPRIM D Q:PRCPPRIM
25 . . . 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."
26 . . . I $$YN^PRCPUYN(1)'=1 S PRCPPRIM=0 Q
27 . . . S $P(^PRCS(410,PRCPDA,0),"^",6)=PRCPPRIM
28 . ;
29 . S PRCPFPRI=$S($P($G(^PRCP(445,PRCPPRIM,0)),"^",16)="N":0,1:1)
30 . 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)
31 . ;
32 . ; get voucher number
33 . S PRCPORD=$P($G(^PRCS(410,PRCPDA,445)),"^")
34 . K X S X(1)="Reference Voucher Number: "_PRCPORD
35 . 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."
36 . D DISPLAY^PRCPUX2(5,75,.X)
37 . D R^PRCPUREP
38 . S PRCPFNSN=+$G(^DISV(DUZ,"PRCPWPLM","SHOWNSN"))
39 . K PRCPFINL
40 . D EN^VALM("PRCP ISSUE BOOK POSTING")
41 . D UNLOCK
42 Q
43 ;
44 ;
45UNLOCK ; unlock issue book
46 D CLEAR^PRCPULOC(410,PRCPDA,0)
47 L -^PRCS(410,PRCPDA)
48 Q
49 ;
50 ;
51INIT ; build array
52 K ^TMP($J,"PRCPWPLMPOST")
53 D REBUILD^PRCPWPLB
54 Q
55 ;
56 ;
57HDR ; header
58 N SPACE
59 S SPACE=" "
60 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:"")
61 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 * *"
62 S VALMHDR(3)="LINE DESCRIPTION IM# /IS ONHAND UNITCOST ORDERED REMAIN TO POST"
63 Q
64 ;
65 ;
66EXIT ; exit
67 K ^TMP($J,"PRCPWPLM"),^TMP($J,"PRCPWPLMPOST"),^TMP($J,"PRCPWPLMLIST")
68 Q
69 ;
70 ;
71SELECTIB(FINAL) ; select issue book
72 ; final=1 for screening out ib which are final
73 N %,DIC,I,X,Y,Z
74 S DIC="^PRCS(410,",DIC(0)="QEAMZ",DIC("A")="Select TRANSACTION NUMBER: "
75 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)"
76 W ! D ^PRCSDIC
77 Q +Y
Note: See TracBrowser for help on using the repository browser.