- 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 Feb 18, 2025@23:40:50 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