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