- PRCPPOLB ;WISC/RFJ-receive purchase order (build array) ;06 Jan 94
- ;;5.1;IFCAP;;Oct 20, 2000
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- Q
- ;
- ;
- REBUILD ; called here to rebuild array
- K PRCPDATA,^TMP($J,"PRCPPOLM"),^TMP($J,"PRCPPOLMREC")
- S (PRCPFLAG,PRCPFCOS)=0
- N %,AVGCOST,CONV,INVDATA,ITEMDA,LINE,LINEDA,PODATA,POQTY,POUI,QTYRECVE,TOTCOST,TRANDA,TRANDATA,TRUI,UNITCOST,X
- S TRANDA=+$P(^PRC(442,PRCPORDR,0),"^",12)
- S LINE=0
- S LINEDA=0 F S LINEDA=$O(^PRC(442,PRCPORDR,2,LINEDA)) Q:'LINEDA S PODATA=$G(^(LINEDA,0)) I PODATA'="" D
- . S %=$O(^PRC(442,PRCPORDR,2,LINEDA,3,"AC",PRCPPART,0)) Q:'%
- . S POQTY=+$P($G(^PRC(442,PRCPORDR,2,LINEDA,3,%,0)),"^",2) I 'POQTY Q
- . S ITEMDA=+$P(PODATA,"^",5) I 'ITEMDA,$P(PODATA,"^",13)'="" S ITEMDA=+$O(^PRC(441,"BB",$P(PODATA,"^",13),0))
- . S LINE=LINE+1
- . D SET(LINEDA,LINE,1,80,IORVON,IORVOFF)
- . D SET($$DESCR^PRCPUX1(PRCPINPT,ITEMDA),LINE,6,23)
- . D SET($J(+ITEMDA,6),LINE,24,29)
- . D SET($J(POQTY,8),LINE,30,37)
- . ;
- . ; get outstanding transaction data
- . I 'TRANDA S TRANDA=+$P(PODATA,"^",10)
- . S TRANDATA=$G(^PRCP(445,PRCPINPT,1,ITEMDA,7,TRANDA,0)),TRUI=$$UNITVAL^PRCPUX1($P(TRANDATA,"^",4),$P(TRANDATA,"^",3),"/"),CONV=$P(TRANDATA,"^",5)
- . ; if there is not a due-in established, look up conversion factor
- . ; from procurement source multiple
- . I 'CONV S CONV=$P($$GETVEN^PRCPUVEN(PRCPINPT,ITEMDA,+$P($G(^PRC(442,PRCPORDR,1)),"^")_";PRC(440,",0),"^",4)
- . I 'CONV S CONV="?"
- . S QTYRECVE=POQTY*$S('CONV:1,1:CONV)
- . ;
- . ; get costs
- . S TOTCOST=$J(POQTY*$P(PODATA,"^",9),0,2),UNITCOST=$J(TOTCOST/QTYRECVE,0,2)
- . S INVDATA=$G(^PRCP(445,PRCPINPT,1,ITEMDA,0)),AVGCOST=$P(INVDATA,"^",22)
- . D SET($J(CONV,5),LINE,38,42)
- . D SET($J(QTYRECVE,8),LINE,43,50)
- . D SET($J(AVGCOST,10,2),LINE,51,60)
- . D SET($J(UNITCOST,10,2),LINE,61,70)
- . D SET($J(TOTCOST,10,2),LINE,71,80)
- . ;
- . ; cost to distribution point
- . I '$D(^PRCP(445,PRCPINPT,1,ITEMDA,0)) D
- . . S X=$G(^TMP($J,"PRCPPOLMCOS",LINEDA))
- . . I X="" S ^TMP($J,"PRCPPOLMCOS",LINEDA)=ITEMDA
- . . S %=$$INVNAME^PRCPUX1($P(X,"^",2))
- . . I '$P(X,"^",2) S PRCPFCOS=1,%="<NONE>"
- . . S LINE=LINE+1
- . . I ITEMDA D SET("WARNING: ITEM NOT STORED IN INVENTORY POINT, COST TO: "_%,LINE,6,80)
- . . I 'ITEMDA D SET("WARNING: NO ITEM MASTER NUMBER, COST TO: "_%,LINE,6,80)
- . ;
- . ; check for errors
- . I $P($G(^PRCS(410,TRANDA,0)),"^",6)'=PRCPINPT S LINE=LINE+1,PRCPFLAG=1 D SET("ERROR: INVENTORY POINT NOT TIED TO 2237 ("_$P($G(PRCS(410,TRANDA,0)),"^")_")",LINE,6,80,IORVON,IORVOFF)
- . I $D(^PRCP(445,PRCPINPT,1,ITEMDA,0)),TRANDATA="",QTYRECVE>0 S LINE=LINE+1,PRCPFLAG=1 D SET("ERROR: 2237 ("_$P($G(^PRCS(410,TRANDA,0)),"^")_") NOT ESTABLISHED AS A DUE-IN",LINE,6,80,IORVON,IORVOFF)
- . S POUI=$$UNITVAL^PRCPUX1($P(PODATA,"^",12),$P(PODATA,"^",3),"/")
- . I TRANDATA'="",POUI'=TRUI S LINE=LINE+1,PRCPFLAG=1 D SET("ERROR: PO U/I ("_POUI_") DOES NOT EQUAL DUE-IN U/R ("_TRUI_")",LINE,6,80,IORVON,IORVOFF)
- . I $P(QTYRECVE,".",2) S LINE=LINE+1,PRCPFLAG=1 D SET("ERROR: RECEIVING QUANTITY CANNOT BE A FRACTION",LINE,6,80,IORVON,IORVOFF)
- . I $D(^PRCP(445,PRCPINPT,1,ITEMDA,0)),'CONV S LINE=LINE+1,PRCPFLAG=1 D SET("ERROR: NO CONVERSION FACTOR. EDIT THE DUE-IN OR VENDOR TO SET THE CF",LINE,6,80,IORVON,IORVOFF)
- . I PRCPFLAG S VALMSG="FIX ERRORS BEFORE RECEIVING" Q
- . S ^TMP($J,"PRCPPOLMREC",LINEDA)=ITEMDA_"^"_QTYRECVE_"^"_TOTCOST_"^"_TRANDA_"^"_POUI
- S VALMCNT=LINE
- Q
- ;
- ;
- SET(STRING,LINE,COLUMN,CLREND,ON,OFF) ; set array
- I '$D(@VALMAR@(LINE,0)) D SET^VALM10(LINE,$J("",80))
- D SET^VALM10(LINE,$$SETSTR^VALM1(STRING,@VALMAR@(LINE,0),COLUMN,CLREND))
- I $G(ON)]""!($G(OFF)]"") D CNTRL^VALM10(LINE,COLUMN,$L(STRING),ON,OFF)
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPPOLB 3852 printed Jan 18, 2025@03:15:38 Page 2
- PRCPPOLB ;WISC/RFJ-receive purchase order (build array) ;06 Jan 94
- +1 ;;5.1;IFCAP;;Oct 20, 2000
- +2 ;Per VHA Directive 10-93-142, this routine should not be modified.
- +3 QUIT
- +4 ;
- +5 ;
- REBUILD ; called here to rebuild array
- +1 KILL PRCPDATA,^TMP($JOB,"PRCPPOLM"),^TMP($JOB,"PRCPPOLMREC")
- +2 SET (PRCPFLAG,PRCPFCOS)=0
- +3 NEW %,AVGCOST,CONV,INVDATA,ITEMDA,LINE,LINEDA,PODATA,POQTY,POUI,QTYRECVE,TOTCOST,TRANDA,TRANDATA,TRUI,UNITCOST,X
- +4 SET TRANDA=+$PIECE(^PRC(442,PRCPORDR,0),"^",12)
- +5 SET LINE=0
- +6 SET LINEDA=0
- FOR
- SET LINEDA=$ORDER(^PRC(442,PRCPORDR,2,LINEDA))
- if 'LINEDA
- QUIT
- SET PODATA=$GET(^(LINEDA,0))
- IF PODATA'=""
- Begin DoDot:1
- +7 SET %=$ORDER(^PRC(442,PRCPORDR,2,LINEDA,3,"AC",PRCPPART,0))
- if '%
- QUIT
- +8 SET POQTY=+$PIECE($GET(^PRC(442,PRCPORDR,2,LINEDA,3,%,0)),"^",2)
- IF 'POQTY
- QUIT
- +9 SET ITEMDA=+$PIECE(PODATA,"^",5)
- IF 'ITEMDA
- IF $PIECE(PODATA,"^",13)'=""
- SET ITEMDA=+$ORDER(^PRC(441,"BB",$PIECE(PODATA,"^",13),0))
- +10 SET LINE=LINE+1
- +11 DO SET(LINEDA,LINE,1,80,IORVON,IORVOFF)
- +12 DO SET($$DESCR^PRCPUX1(PRCPINPT,ITEMDA),LINE,6,23)
- +13 DO SET($JUSTIFY(+ITEMDA,6),LINE,24,29)
- +14 DO SET($JUSTIFY(POQTY,8),LINE,30,37)
- +15 ;
- +16 ; get outstanding transaction data
- +17 IF 'TRANDA
- SET TRANDA=+$PIECE(PODATA,"^",10)
- +18 SET TRANDATA=$GET(^PRCP(445,PRCPINPT,1,ITEMDA,7,TRANDA,0))
- SET TRUI=$$UNITVAL^PRCPUX1($PIECE(TRANDATA,"^",4),$PIECE(TRANDATA,"^",3),"/")
- SET CONV=$PIECE(TRANDATA,"^",5)
- +19 ; if there is not a due-in established, look up conversion factor
- +20 ; from procurement source multiple
- +21 IF 'CONV
- SET CONV=$PIECE($$GETVEN^PRCPUVEN(PRCPINPT,ITEMDA,+$PIECE($GET(^PRC(442,PRCPORDR,1)),"^")_";PRC(440,",0),"^",4)
- +22 IF 'CONV
- SET CONV="?"
- +23 SET QTYRECVE=POQTY*$SELECT('CONV:1,1:CONV)
- +24 ;
- +25 ; get costs
- +26 SET TOTCOST=$JUSTIFY(POQTY*$PIECE(PODATA,"^",9),0,2)
- SET UNITCOST=$JUSTIFY(TOTCOST/QTYRECVE,0,2)
- +27 SET INVDATA=$GET(^PRCP(445,PRCPINPT,1,ITEMDA,0))
- SET AVGCOST=$PIECE(INVDATA,"^",22)
- +28 DO SET($JUSTIFY(CONV,5),LINE,38,42)
- +29 DO SET($JUSTIFY(QTYRECVE,8),LINE,43,50)
- +30 DO SET($JUSTIFY(AVGCOST,10,2),LINE,51,60)
- +31 DO SET($JUSTIFY(UNITCOST,10,2),LINE,61,70)
- +32 DO SET($JUSTIFY(TOTCOST,10,2),LINE,71,80)
- +33 ;
- +34 ; cost to distribution point
- +35 IF '$DATA(^PRCP(445,PRCPINPT,1,ITEMDA,0))
- Begin DoDot:2
- +36 SET X=$GET(^TMP($JOB,"PRCPPOLMCOS",LINEDA))
- +37 IF X=""
- SET ^TMP($JOB,"PRCPPOLMCOS",LINEDA)=ITEMDA
- +38 SET %=$$INVNAME^PRCPUX1($PIECE(X,"^",2))
- +39 IF '$PIECE(X,"^",2)
- SET PRCPFCOS=1
- SET %="<NONE>"
- +40 SET LINE=LINE+1
- +41 IF ITEMDA
- DO SET("WARNING: ITEM NOT STORED IN INVENTORY POINT, COST TO: "_%,LINE,6,80)
- +42 IF 'ITEMDA
- DO SET("WARNING: NO ITEM MASTER NUMBER, COST TO: "_%,LINE,6,80)
- End DoDot:2
- +43 ;
- +44 ; check for errors
- +45 IF $PIECE($GET(^PRCS(410,TRANDA,0)),"^",6)'=PRCPINPT
- SET LINE=LINE+1
- SET PRCPFLAG=1
- DO SET("ERROR: INVENTORY POINT NOT TIED TO 2237 ("_$PIECE($GET(PRCS(410,TRANDA,0)),"^")_")",LINE,6,80,IORVON,IORVOFF)
- +46 IF $DATA(^PRCP(445,PRCPINPT,1,ITEMDA,0))
- IF TRANDATA=""
- IF QTYRECVE>0
- SET LINE=LINE+1
- SET PRCPFLAG=1
- DO SET("ERROR: 2237 ("_$PIECE($GET(^PRCS(410,TRANDA,0)),"^")_") NOT ESTABLISHED AS A DUE-IN",LINE,6,80,IORVON,IORVOFF)
- +47 SET POUI=$$UNITVAL^PRCPUX1($PIECE(PODATA,"^",12),$PIECE(PODATA,"^",3),"/")
- +48 IF TRANDATA'=""
- IF POUI'=TRUI
- SET LINE=LINE+1
- SET PRCPFLAG=1
- DO SET("ERROR: PO U/I ("_POUI_") DOES NOT EQUAL DUE-IN U/R ("_TRUI_")",LINE,6,80,IORVON,IORVOFF)
- +49 IF $PIECE(QTYRECVE,".",2)
- SET LINE=LINE+1
- SET PRCPFLAG=1
- DO SET("ERROR: RECEIVING QUANTITY CANNOT BE A FRACTION",LINE,6,80,IORVON,IORVOFF)
- +50 IF $DATA(^PRCP(445,PRCPINPT,1,ITEMDA,0))
- IF 'CONV
- SET LINE=LINE+1
- SET PRCPFLAG=1
- DO SET("ERROR: NO CONVERSION FACTOR. EDIT THE DUE-IN OR VENDOR TO SET THE CF",LINE,6,80,IORVON,IORVOFF)
- +51 IF PRCPFLAG
- SET VALMSG="FIX ERRORS BEFORE RECEIVING"
- QUIT
- +52 SET ^TMP($JOB,"PRCPPOLMREC",LINEDA)=ITEMDA_"^"_QTYRECVE_"^"_TOTCOST_"^"_TRANDA_"^"_POUI
- End DoDot:1
- +53 SET VALMCNT=LINE
- +54 QUIT
- +55 ;
- +56 ;
- SET(STRING,LINE,COLUMN,CLREND,ON,OFF) ; set array
- +1 IF '$DATA(@VALMAR@(LINE,0))
- DO SET^VALM10(LINE,$JUSTIFY("",80))
- +2 DO SET^VALM10(LINE,$$SETSTR^VALM1(STRING,@VALMAR@(LINE,0),COLUMN,CLREND))
- +3 IF $GET(ON)]""!($GET(OFF)]"")
- DO CNTRL^VALM10(LINE,COLUMN,$LENGTH(STRING),ON,OFF)
- +4 QUIT