Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PRCPPOLM

PRCPPOLM.m

Go to the documentation of this file.
  1. PRCPPOLM ;WISC/RFJ-receive purchase order (list manager) ; 6/13/01 5:52pm
  1. ;;5.1;IFCAP;**34,87**;Oct 20, 2000
  1. ;Per VHA Directive 10-93-142, this routine should not be modified.
  1. D ^PRCPUSEL Q:'$G(PRCP("I"))
  1. I "PW"'[PRCP("DPTYPE") W !,"YOU MUST BE A WAREHOUSE OR PRIMARY INVENTORY POINT TO USE THIS OPTION." Q
  1. I $$CHECK^PRCPCUT1(PRCP("I")) Q
  1. N %,PRCPFCOS,PRCPFLAG,PRCPINPT,PRCPORDN,PRCPORDR,PRCPPARD,PRCPPART,PRCPTYPE,PRCPVEND,PRCPVENN,PRCPM,X,Y
  1. S X="" W ! D ESIG^PRCUESIG(DUZ,.X) I X'>0 Q
  1. AUTH S PRCPINPT=PRCP("I"),PRCPTYPE=PRCP("DPTYPE")
  1. S:$G(PRCHAUTH) PRCPORDR=PRCHPO
  1. D:$G(PRCHAUTH) I '$G(PRCHAUTH) F S PRCPORDR=$$SELECTPO^PRCPPOU1(PRCPINPT) Q:PRCPORDR<1 D
  1. . S PRCPORDN=$P($G(^PRC(442,PRCPORDR,0)),"^") I PRCPORDN="" W !,"ERROR - INVALID OR MISSING PURCHASE ORDER NUMBER !" Q
  1. . S PRCPVEND=+$G(^PRC(442,PRCPORDR,1)),PRCPVENN=$P($G(^PRC(440,PRCPVEND,0)),"^")
  1. . I PRCPVEND="" W !,"ERROR - INVALID OR MISSING VENDOR ON THIS PURCHASE ORDER !" Q
  1. . L +^PRC(442,PRCPORDR):5 I '$T D SHOWWHO^PRCPULOC(442,PRCPORDR,0) Q
  1. . I $G(PRCHAUTH) S PRCPPART=PRCHRPT G JMP
  1. . ;I '$D(^PRC(442,PRCPORDR,11,0)) G JMP ; functionality modified 9/15/05 T.Holloway.
  1. . ; if level 11 does not exist the old code would jump over the part that creates PRCPPART.
  1. . ; PRCPPART is a required variable later in the application and items without it should not continue.
  1. . ; 7 lines of code are added to detect and handle the situation. T.Holloway
  1. . I '$D(^PRC(442,PRCPORDR,11,0)) D D UNLOCK Q
  1. . . S PRCPM=$P($G(^PRC(442,PRCPORDR,0)),U,2),PRCPM=$P(^PRCD(442.5,PRCPM,0),U,2)
  1. . . I (PRCPM="PC")&($P($G(^PRC(442,PRCPORDR,23)),U,15)="N") D
  1. . . . W !!,"Sorry, this Purchase Card order has been marked 'No Receiving Required'"
  1. . . . W !,"and has been Reconciled as COMPLETE ORDER RECEIVED: YES."
  1. . . . W !,"It may not be received into inventory in this status."
  1. . . E W !!,"No Partial on file, further processing not allowed."
  1. . S FINALREC=""
  1. . S FINALREC=$P($G(^PRC(442,PRCPORDR,11,0)),"^",4)
  1. . I FINALREC'="" D
  1. . . I $P($G(^PRC(442,PRCPORDR,11,FINALREC,0)),"^",16)="" D
  1. . . .;; show partials not received yet
  1. . . . W !!,"PARTIALS NOT YET RECEIVED:"
  1. . K FINALREC
  1. . 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"
  1. . S PRCPPART=$$PARTIAL^PRCPPOU1(PRCPORDR) I PRCPPART<0 D UNLOCK Q
  1. . S PRCPPARD=$P($G(^PRC(442,PRCPORDR,11,PRCPPART,0)),"^") I 'PRCPPARD W !,"ERROR - CANNOT FIND PARTIAL DATE FOR THIS PARTIAL !" D UNLOCK Q
  1. JMP . D EN^VALM("PRCP PURCHASE ORDER RECEIPT")
  1. . D UNLOCK
  1. Q
  1. ;
  1. ;
  1. UNLOCK ; unlock po
  1. D CLEAR^PRCPULOC(442,PRCPORDR,0)
  1. L -^PRC(442,PRCPORDR)
  1. Q
  1. ;
  1. ;
  1. HDR ; build header
  1. N DATA,FLAG,SPACE,Y
  1. 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:"")
  1. S Y=$P(DATA,"^") D DD^%DT
  1. S SPACE=" "
  1. S VALMHDR(1)=$E("INVENTORY: "_$$INVNAME^PRCPUX1(PRCPINPT)_SPACE,1,30)_$E(" PO: "_PRCPORDN_SPACE,1,20)_$E("VENDOR: "_PRCPVENN_SPACE,1,22)_"#"_PRCPVEND
  1. 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
  1. S VALMHDR(3)="LINE DESCRIPTION IM# POQTY CONV RECQTY AVGCOST UNITCOST TOTCOST"
  1. Q
  1. ;
  1. ;
  1. INIT ; build array
  1. ; clean up before entry
  1. K ^TMP($J,"PRCPPOLMCOS")
  1. D REBUILD^PRCPPOLB
  1. Q
  1. ;
  1. ;
  1. EXIT ; exit
  1. K ^TMP($J,"PRCPPOLM"),^TMP($J,"PRCPPOLMCOS"),^TMP($J,"PRCPPOLMREC")
  1. Q