source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCPPOLM.m@ 623

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

initial load of WorldVistAEHR

File size: 3.6 KB
Line 
1PRCPPOLM ;WISC/RFJ-receive purchase order (list manager) ; 6/13/01 5:52pm
2 ;;5.1;IFCAP;**34,87**;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 "PW"'[PRCP("DPTYPE") W !,"YOU MUST BE A WAREHOUSE OR PRIMARY INVENTORY POINT TO USE THIS OPTION." Q
6 I $$CHECK^PRCPCUT1(PRCP("I")) Q
7 N %,PRCPFCOS,PRCPFLAG,PRCPINPT,PRCPORDN,PRCPORDR,PRCPPARD,PRCPPART,PRCPTYPE,PRCPVEND,PRCPVENN,PRCPM,X,Y
8 S X="" W ! D ESIG^PRCUESIG(DUZ,.X) I X'>0 Q
9AUTH S PRCPINPT=PRCP("I"),PRCPTYPE=PRCP("DPTYPE")
10 S:$G(PRCHAUTH) PRCPORDR=PRCHPO
11 D:$G(PRCHAUTH) I '$G(PRCHAUTH) F S PRCPORDR=$$SELECTPO^PRCPPOU1(PRCPINPT) Q:PRCPORDR<1 D
12 . S PRCPORDN=$P($G(^PRC(442,PRCPORDR,0)),"^") I PRCPORDN="" W !,"ERROR - INVALID OR MISSING PURCHASE ORDER NUMBER !" Q
13 . S PRCPVEND=+$G(^PRC(442,PRCPORDR,1)),PRCPVENN=$P($G(^PRC(440,PRCPVEND,0)),"^")
14 . I PRCPVEND="" W !,"ERROR - INVALID OR MISSING VENDOR ON THIS PURCHASE ORDER !" Q
15 . L +^PRC(442,PRCPORDR):5 I '$T D SHOWWHO^PRCPULOC(442,PRCPORDR,0) Q
16 . I $G(PRCHAUTH) S PRCPPART=PRCHRPT G JMP
17 . ;I '$D(^PRC(442,PRCPORDR,11,0)) G JMP ; functionality modified 9/15/05 T.Holloway.
18 . ; if level 11 does not exist the old code would jump over the part that creates PRCPPART.
19 . ; PRCPPART is a required variable later in the application and items without it should not continue.
20 . ; 7 lines of code are added to detect and handle the situation. T.Holloway
21 . I '$D(^PRC(442,PRCPORDR,11,0)) D D UNLOCK Q
22 . . S PRCPM=$P($G(^PRC(442,PRCPORDR,0)),U,2),PRCPM=$P(^PRCD(442.5,PRCPM,0),U,2)
23 . . I (PRCPM="PC")&($P($G(^PRC(442,PRCPORDR,23)),U,15)="N") D
24 . . . W !!,"Sorry, this Purchase Card order has been marked 'No Receiving Required'"
25 . . . W !,"and has been Reconciled as COMPLETE ORDER RECEIVED: YES."
26 . . . W !,"It may not be received into inventory in this status."
27 . . E W !!,"No Partial on file, further processing not allowed."
28 . S FINALREC=""
29 . S FINALREC=$P($G(^PRC(442,PRCPORDR,11,0)),"^",4)
30 . I FINALREC'="" D
31 . . I $P($G(^PRC(442,PRCPORDR,11,FINALREC,0)),"^",16)="" D
32 . . .;; show partials not received yet
33 . . . W !!,"PARTIALS NOT YET RECEIVED:"
34 . K FINALREC
35 . S %=0 F S %=$O(^PRC(442,PRCPORDR,11,%)) Q:'% I $P($G(^(%,0)),"^",16)="" S Y=$P(^(0),"^") D DD^%DT W !?5,"PARTIAL #: ",%,?28,"DATE: ",Y I $P($G(^PRC(442,PRCPORDR,11,%,0)),"^",9)="F" W ?55,"FINAL RECEIPT"
36 . S PRCPPART=$$PARTIAL^PRCPPOU1(PRCPORDR) I PRCPPART<0 D UNLOCK Q
37 . S PRCPPARD=$P($G(^PRC(442,PRCPORDR,11,PRCPPART,0)),"^") I 'PRCPPARD W !,"ERROR - CANNOT FIND PARTIAL DATE FOR THIS PARTIAL !" D UNLOCK Q
38JMP . D EN^VALM("PRCP PURCHASE ORDER RECEIPT")
39 . D UNLOCK
40 Q
41 ;
42 ;
43UNLOCK ; unlock po
44 D CLEAR^PRCPULOC(442,PRCPORDR,0)
45 L -^PRC(442,PRCPORDR)
46 Q
47 ;
48 ;
49HDR ; build header
50 N DATA,FLAG,SPACE,Y
51 S DATA=$G(^PRC(442,PRCPORDR,11,PRCPPART,0)),FLAG=$S($P(DATA,"^",9)="F":"FINAL ",1:""),FLAG=FLAG_$S($P(DATA,"^",10)="Y":"OVERAGE",1:"")
52 S Y=$P(DATA,"^") D DD^%DT
53 S SPACE=" "
54 S VALMHDR(1)=$E("INVENTORY: "_$$INVNAME^PRCPUX1(PRCPINPT)_SPACE,1,30)_$E(" PO: "_PRCPORDN_SPACE,1,20)_$E("VENDOR: "_PRCPVENN_SPACE,1,22)_"#"_PRCPVEND
55 S VALMHDR(2)=$E("PARTIAL: "_PRCPPART_SPACE,1,14)_$E("DATE: "_Y_SPACE,1,19)_$E("LINECNT: "_$P(DATA,"^",14)_SPACE,1,14)_$E("TOTAL AMT: "_$P(DATA,"^",12)_SPACE,1,25)_FLAG
56 S VALMHDR(3)="LINE DESCRIPTION IM# POQTY CONV RECQTY AVGCOST UNITCOST TOTCOST"
57 Q
58 ;
59 ;
60INIT ; build array
61 ; clean up before entry
62 K ^TMP($J,"PRCPPOLMCOS")
63 D REBUILD^PRCPPOLB
64 Q
65 ;
66 ;
67EXIT ; exit
68 K ^TMP($J,"PRCPPOLM"),^TMP($J,"PRCPPOLMCOS"),^TMP($J,"PRCPPOLMREC")
69 Q
Note: See TracBrowser for help on using the repository browser.