source: FOIAVistA/tag/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCPWPPL.m@ 1569

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

initial load of FOIAVistA 6/30/08 version

File size: 2.4 KB
Line 
1PRCPWPPL ;WISC/RFJ-primary receive issue book (list manager) ;20 Jan 93
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")'="P" W !,"ONLY THE PRIMARY CAN RECEIVE ISSUE BOOKS!" Q
6 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
7 I $$CHECK^PRCPCUT1(PRCP("I")) Q
8 N PRCPDA,PRCPFINL,PRCPIBNM,PRCPINPT,PRCPWHSE,PRCPPVNO,X,Y
9 S PRCPINPT=PRCP("I")
10 S X="" W ! D ESIG^PRCUESIG(DUZ,.X) I X'>0 Q
11 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
12 F S PRCPDA=$$SELECTIB Q:PRCPDA<1 D
13 . L +^PRCS(410,PRCPDA):5 I '$T D SHOWWHO^PRCPULOC(410,PRCPDA,0) Q
14 . D ADD^PRCPULOC(410,PRCPDA,0,"Receive Issue Book")
15 . S PRCPIBNM=$P(^PRCS(410,PRCPDA,0),"^")
16 . S PRCPWHSE=0 F S PRCPWHSE=$O(^PRCP(445,"AC","W",PRCPWHSE)) Q:'PRCPWHSE I +$G(^PRCP(445,PRCPWHSE,0))=+PRCPIBNM Q
17 . I 'PRCPWHSE W !,"THERE IS NOT A WAREHOUSE DESIGNATED FOR STATION '",+PRCPIBNM,"'." D UNLOCK Q
18 . I $P($G(^PRCS(410,PRCPDA,9)),"^",3) S PRCPFINL=1
19 . D EN^VALM("PRCP ISSUE BOOK RECEIVING")
20 . D UNLOCK
21 Q
22 ;
23 ;
24UNLOCK ; unlock issue book
25 D CLEAR^PRCPULOC(410,PRCPDA,0)
26 L -^PRCS(410,PRCPDA)
27 Q
28 ;
29 ;
30INIT ; build array
31 K ^TMP($J,"PRCPWPPLPOST")
32 D REBUILD^PRCPWPPB
33 Q
34 ;
35 ;
36HDR ; header
37 N SPACE
38 S SPACE=" "
39 S VALMHDR(1)=$E("ISSUE BOOK: "_PRCPIBNM_" FROM: "_$E($$INVNAME^PRCPUX1(PRCPWHSE),1,15)_SPACE,1,69)_$S($G(PRCPFINL):"** FINAL **",1:"")
40 S VALMHDR(2)="LINE DESCRIPTION IM# NSN ** Q U A N T I T Y (in U/R) **"
41 S VALMHDR(3)=" UNIT CONV UNIT UNIT/IS UNIT/REC WHSE PRIM *TO*"
42 S VALMHDR(4)=" /IS FACT /REC AVGCOST UNITCOST ORDERED POSTED REC'D RECEIVE"
43 Q
44 ;
45 ;
46EXIT ; exit
47 K ^TMP($J,"PRCPWPPL"),^TMP($J,"PRCPWPPLPOST"),^TMP($J,"PRCPWPPLLIST")
48 Q
49 ;
50 ;
51SELECTIB() ; select issue book
52 N %,DIC,I,X,Y,Z
53 S DIC="^PRCS(410,",DIC(0)="QEAMZ",DIC("A")="Select TRANSACTION NUMBER: "
54 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)"
55 W ! D ^PRCSDIC
56 Q +Y
Note: See TracBrowser for help on using the repository browser.