PRCHREC1 ;ID/RSD,SF/TKW/RHD-CONT. OF RECEIVING ;2/9/93 14:53
V ;;5.1;IFCAP;**133,170,188**;Oct 20, 2000;Build 1
;Per VHA Directive 6402, this routine should not be modified.
;
;PRC*5.1*170 For receipt processing to insure the user is returned to
; the quantity query after any erroneous quantity entry.
;
;PRC*5.1*188 Remove the check for fractional quantity entered that
; the fractional warning message will not appear if the
; item has an item multiple or conversion factor that
; would infer a non fractional entry, BUT will not be
; allowed to be received into inventory because the
; quantity is still fractional.
;
EN1 S PRCHRQ3="",DA=PRCHPO,D="C",DIC="^PRC(442,DA,2,",DIC(0)="QZXE" W !!?3,"Item: ",X D IX^DIC Q:Y<0
S PRCHRDY=+$O(^PRC(442,DA,2,"AB",PRCHRD,+Y,0)) S:'$D(^PRC(442,DA,2,+Y,3,PRCHRDY,0)) PRCHRDY=0 S:PRCHRDY PRCHRQ3=$P(^(0),U,2),$P(^(0),U,2)=0,$P(^(0),U,3)=0 ;PRC*5.1*170
S PRCHRIT=Y,PRCHRQ1=$P(Y(0),U,2),$P(^PRC(442,DA,2,+Y,2),U,8)=$P(^PRC(442,DA,2,+Y,2),U,8)-PRCHRQ3,PRCHRQ2=$P(^(2),U,8),PRCHRAM=$P(^(2),U,1),PRCHRDA=+$P(^(2),U,6) D WP^PRCHREC2
W !,"UNIT OF PRCH: ",$P($G(^PRCD(420.5,+$P(Y(0),U,3),0)),U,1)," QTY ORDERED: ",PRCHRQ1," PREVIOUSLY RECEIVED: ",PRCHRQ2,!
I $D(^TMP("PRCHREC4",$J)) W !
F I=0:0 S I=$O(^TMP("PRCHREC4",$J,+$P(^PRC(442,DA,2,+PRCHRIT,0),U,1),I)) Q:'I S X=^(I) W ?10,"Delv.Location: ",$P($G(^PRCS(410.8,+X,0)),U,1),?56,"Delv.Qty.:"_$J(+$P(X,U,2),4),!
N PRCCKER,PRCHITIN,PRCHITRQ ;PRC*5.1*188
S PRCHITRQ=$P(^PRC(442,DA,2,+PRCHRIT,0),U,11) I PRCHITRQ'="" S PRCHITIN=$P($G(^PRCS(410,PRCHITRQ,0)),U,6)
ENQTY W !?3,"QTY BEING RECEIVED: ",PRCHRQ3 W:PRCHRQ3]"" "// "
S PRCHRTP=0,PRCCKER=0 R PRCHRQ:DTIME I PRCHRDY G DEL1^PRCHREC2:PRCHRQ="@" S:PRCHRQ3&((PRCHRQ="")!(PRCHRQ["^")) PRCHRQ=PRCHRQ3
I PRCHRQ=""!(PRCHRQ["^") Q ;PRC*5.1*170
I PRCHRQ'=+PRCHRQ!(PRCHRQ<0)!(PRCHRQ?.E1"."3N.N) G HLP ;PRC*5.1*170
I $P(PRCHRQ,".",2)>0 D
. W !,"This appears to be an inventory item that will have PURCHASE ORDER RECEIVING TO"
. W !,"INVENTORY. You CANNOT enter a fractional quantity as it WILL NOT be allowed to"
. W !,"be received into Inventory. Please OK the fractional amount is for a non"
. W !,"inventory receipt.",!
. W $C(7) S %A="Receiving a fractional quantity, is this a non-inventory item receipt",%B="",%=2 D ^PRCFYN I %'=1 S PRCCKER=1
I PRCCKER=1 G ENQTY ;PRC*5.1*170
I PRCHRQ>(PRCHRQ1-PRCHRQ2) W $C(7) S %A=" You are receiving an overage, do you want to continue",%B="",%=2 D ^PRCFYN G ENQTY:%'=1 S PRCHROV="" ;PRC*5.1*170
;
EN3 I PRCHRQ'=PRCHRQ1 S PRCHRAM=$P(^PRC(442,PRCHPO,2,+PRCHRIT,0),U,9),PRCHRAM=$J(PRCHRAM*PRCHRQ,0,2),PRCHRDA=PRCHRDA/PRCHRQ1*PRCHRQ
K DIC I 'PRCHRDY S DA(2)=PRCHPO,DA(1)=+PRCHRIT,DIC="^PRC(442,DA(2),2,DA(1),3,",DIC(0)="LX",DLAYGO=442,X=PRCHRD S:'$D(@(DIC_"0)")) ^(0)="^442.08DA^^0" D ^DIC K DIC,DA,DLAYGO Q:Y<0 S PRCHRDY=+Y
S $P(^(2),U,8)=$P(^PRC(442,PRCHPO,2,+PRCHRIT,2),U,8)+PRCHRQ,$P(^PRC(442,PRCHPO,2,+PRCHRIT,3,PRCHRDY,0),U,2,3)=PRCHRQ_U_+PRCHRAM,$P(^(0),U,5)=PRCHRDA
W:'PRCHRTP ?35,"AMOUNT: ",PRCHRAM
D:$P(PRC("PARAM"),U,7)=2 ^PRCHREC7 Q
;
LI R !!!,"LINE ITEM: ",X:DTIME G 2^PRCHREC:X=""!(X["^"),HLP1:$E(X)="?",LI1:"Aa"[$E(X),COM:"Cc"[$E(X)
S X1="" F I=1:1 S Y=$P(X,",",I) Q:Y="" S:Y'[":"&(Y?1N.N) X1=X1_Y_",",Y="" I Y]"" K:Y'[":"!($P(Y,":",1)'?1N.N)!($P(Y,":",2)'?1N.N) X Q:'$D(X) S X1=X1_+Y_":1:"_$P(Y,":",2)_","
G:'$D(X) 2^PRCHREC S X=$E(X1,1,$L(X1)-1) X "F PRCHX="_X_" S X=PRCHX D EN1"
G LI
;
LI1 S PRCHX=0 F I=0:0 S PRCHX=$O(^PRC(442,PRCHPO,2,"C",PRCHX)) Q:PRCHX=""!(PRCHX'>0) S X=PRCHX D EN1
G LI
;
COM S %A=" Complete P.O. as is",%B="",%=1 D ^PRCFYN G:$D(PRCHIMP)&(%'=1) 2^PRCHREC G:%'=1 LI
;
COM1 ;ENTRY POINT FOR AUTOMATIC GENERATION OF PROOF OF ORDER FOR GUARANTEED DELIVERY P.O.S
S I=0 F S I=$O(^PRC(442,PRCHPO,2,"C",I)) Q:I=""!(I'>0) S PRCHRIT=+$O(^(I,0))_"^"_I,PRCHRQ1=$P(^PRC(442,PRCHPO,2,+PRCHRIT,0),U,2),PRCHRQ2=$P(^(2),U,8),PRCHRAM=$P(^(2),U,1),PRCHRDA=$P(^(2),U,6) D COM2
G 2^PRCHREC
;
COM2 Q:$O(^PRC(442,PRCHPO,2,"AB",PRCHRD,+PRCHRIT,0))&($D(^PRC(442,PRCHPO,2,+PRCHRIT,3,+$O(^(0)),0))) S PRCHRTP=1,PRCHRQ=PRCHRQ1-PRCHRQ2,PRCHRDY=0 S:PRCHRQ<0 PRCHRQ=0 D EN3
Q
;
HLP W !?3,"Enter a number between .01 and 99999" W:PRCHRDY " or '@' to delete" W "."
G ENQTY ;PRC*5.1*170
;
HLP1 W !?3,"Enter a Line Item number in the following format: 1,2,3,4 or 1:4 .",!?3,"You may also enter 'C' to complete P.O. as is, or 'A' to see all items."
S X="??",D="C",DA=PRCHPO,DIC="^PRC(442,DA,2,",DIC(0)="QEM",DIC("S")="I '$D(^PRC(442,DA,2,""AB"",+Y))" D IX^DIC K DIC
G LI
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHREC1 4666 printed Mar 13, 2025@21:14:58 Page 2
PRCHREC1 ;ID/RSD,SF/TKW/RHD-CONT. OF RECEIVING ;2/9/93 14:53
V ;;5.1;IFCAP;**133,170,188**;Oct 20, 2000;Build 1
+1 ;Per VHA Directive 6402, this routine should not be modified.
+2 ;
+3 ;PRC*5.1*170 For receipt processing to insure the user is returned to
+4 ; the quantity query after any erroneous quantity entry.
+5 ;
+6 ;PRC*5.1*188 Remove the check for fractional quantity entered that
+7 ; the fractional warning message will not appear if the
+8 ; item has an item multiple or conversion factor that
+9 ; would infer a non fractional entry, BUT will not be
+10 ; allowed to be received into inventory because the
+11 ; quantity is still fractional.
+12 ;
EN1 SET PRCHRQ3=""
SET DA=PRCHPO
SET D="C"
SET DIC="^PRC(442,DA,2,"
SET DIC(0)="QZXE"
WRITE !!?3,"Item: ",X
DO IX^DIC
if Y<0
QUIT
+1 ;PRC*5.1*170
SET PRCHRDY=+$ORDER(^PRC(442,DA,2,"AB",PRCHRD,+Y,0))
if '$DATA(^PRC(442,DA,2,+Y,3,PRCHRDY,0))
SET PRCHRDY=0
if PRCHRDY
SET PRCHRQ3=$PIECE(^(0),U,2)
SET $PIECE(^(0),U,2)=0
SET $PIECE(^(0),U,3)=0
+2 SET PRCHRIT=Y
SET PRCHRQ1=$PIECE(Y(0),U,2)
SET $PIECE(^PRC(442,DA,2,+Y,2),U,8)=$PIECE(^PRC(442,DA,2,+Y,2),U,8)-PRCHRQ3
SET PRCHRQ2=$PIECE(^(2),U,8)
SET PRCHRAM=$PIECE(^(2),U,1)
SET PRCHRDA=+$PIECE(^(2),U,6)
DO WP^PRCHREC2
+3 WRITE !,"UNIT OF PRCH: ",$PIECE($GET(^PRCD(420.5,+$PIECE(Y(0),U,3),0)),U,1)," QTY ORDERED: ",PRCHRQ1," PREVIOUSLY RECEIVED: ",PRCHRQ2,!
+4 IF $DATA(^TMP("PRCHREC4",$JOB))
WRITE !
+5 FOR I=0:0
SET I=$ORDER(^TMP("PRCHREC4",$JOB,+$PIECE(^PRC(442,DA,2,+PRCHRIT,0),U,1),I))
if 'I
QUIT
SET X=^(I)
WRITE ?10,"Delv.Location: ",$PIECE($GET(^PRCS(410.8,+X,0)),U,1),?56,"Delv.Qty.:"_$JUSTIFY(+$PIECE(X,U,2),4),!
+6 ;PRC*5.1*188
NEW PRCCKER,PRCHITIN,PRCHITRQ
+7 SET PRCHITRQ=$PIECE(^PRC(442,DA,2,+PRCHRIT,0),U,11)
IF PRCHITRQ'=""
SET PRCHITIN=$PIECE($GET(^PRCS(410,PRCHITRQ,0)),U,6)
ENQTY WRITE !?3,"QTY BEING RECEIVED: ",PRCHRQ3
if PRCHRQ3]""
WRITE "// "
+1 SET PRCHRTP=0
SET PRCCKER=0
READ PRCHRQ:DTIME
IF PRCHRDY
if PRCHRQ="@"
GOTO DEL1^PRCHREC2
if PRCHRQ3&((PRCHRQ="")!(PRCHRQ["^"))
SET PRCHRQ=PRCHRQ3
+2 ;PRC*5.1*170
IF PRCHRQ=""!(PRCHRQ["^")
QUIT
+3 ;PRC*5.1*170
IF PRCHRQ'=+PRCHRQ!(PRCHRQ<0)!(PRCHRQ?.E1"."3N.N)
GOTO HLP
+4 IF $PIECE(PRCHRQ,".",2)>0
Begin DoDot:1
+5 WRITE !,"This appears to be an inventory item that will have PURCHASE ORDER RECEIVING TO"
+6 WRITE !,"INVENTORY. You CANNOT enter a fractional quantity as it WILL NOT be allowed to"
+7 WRITE !,"be received into Inventory. Please OK the fractional amount is for a non"
+8 WRITE !,"inventory receipt.",!
+9 WRITE $CHAR(7)
SET %A="Receiving a fractional quantity, is this a non-inventory item receipt"
SET %B=""
SET %=2
DO ^PRCFYN
IF %'=1
SET PRCCKER=1
End DoDot:1
+10 ;PRC*5.1*170
IF PRCCKER=1
GOTO ENQTY
+11 ;PRC*5.1*170
IF PRCHRQ>(PRCHRQ1-PRCHRQ2)
WRITE $CHAR(7)
SET %A=" You are receiving an overage, do you want to continue"
SET %B=""
SET %=2
DO ^PRCFYN
if %'=1
GOTO ENQTY
SET PRCHROV=""
+12 ;
EN3 IF PRCHRQ'=PRCHRQ1
SET PRCHRAM=$PIECE(^PRC(442,PRCHPO,2,+PRCHRIT,0),U,9)
SET PRCHRAM=$JUSTIFY(PRCHRAM*PRCHRQ,0,2)
SET PRCHRDA=PRCHRDA/PRCHRQ1*PRCHRQ
+1 KILL DIC
IF 'PRCHRDY
SET DA(2)=PRCHPO
SET DA(1)=+PRCHRIT
SET DIC="^PRC(442,DA(2),2,DA(1),3,"
SET DIC(0)="LX"
SET DLAYGO=442
SET X=PRCHRD
if '$DATA(@(DIC_"0)"))
SET ^(0)="^442.08DA^^0"
DO ^DIC
KILL DIC,DA,DLAYGO
if Y<0
QUIT
SET PRCHRDY=+Y
+2 SET $PIECE(^(2),U,8)=$PIECE(^PRC(442,PRCHPO,2,+PRCHRIT,2),U,8)+PRCHRQ
SET $PIECE(^PRC(442,PRCHPO,2,+PRCHRIT,3,PRCHRDY,0),U,2,3)=PRCHRQ_U_+PRCHRAM
SET $PIECE(^(0),U,5)=PRCHRDA
+3 if 'PRCHRTP
WRITE ?35,"AMOUNT: ",PRCHRAM
+4 if $PIECE(PRC("PARAM"),U,7)=2
DO ^PRCHREC7
QUIT
+5 ;
LI READ !!!,"LINE ITEM: ",X:DTIME
if X=""!(X["^")
GOTO 2^PRCHREC
if $EXTRACT(X)="?"
GOTO HLP1
if "Aa"[$EXTRACT(X)
GOTO LI1
if "Cc"[$EXTRACT(X)
GOTO COM
+1 SET X1=""
FOR I=1:1
SET Y=$PIECE(X,",",I)
if Y=""
QUIT
if Y'["
SET X1=X1_Y_","
SET Y=""
IF Y]""
if Y'["
KILL X
if '$DATA(X)
QUIT
SET X1=X1_+Y_":1:"_$PIECE(Y,":",2)_","
+2 if '$DATA(X)
GOTO 2^PRCHREC
SET X=$EXTRACT(X1,1,$LENGTH(X1)-1)
XECUTE "F PRCHX="_X_" S X=PRCHX D EN1"
+3 GOTO LI
+4 ;
LI1 SET PRCHX=0
FOR I=0:0
SET PRCHX=$ORDER(^PRC(442,PRCHPO,2,"C",PRCHX))
if PRCHX=""!(PRCHX'>0)
QUIT
SET X=PRCHX
DO EN1
+1 GOTO LI
+2 ;
COM SET %A=" Complete P.O. as is"
SET %B=""
SET %=1
DO ^PRCFYN
if $DATA(PRCHIMP)&(%'=1)
GOTO 2^PRCHREC
if %'=1
GOTO LI
+1 ;
COM1 ;ENTRY POINT FOR AUTOMATIC GENERATION OF PROOF OF ORDER FOR GUARANTEED DELIVERY P.O.S
+1 SET I=0
FOR
SET I=$ORDER(^PRC(442,PRCHPO,2,"C",I))
if I=""!(I'>0)
QUIT
SET PRCHRIT=+$ORDER(^(I,0))_"^"_I
SET PRCHRQ1=$PIECE(^PRC(442,PRCHPO,2,+PRCHRIT,0),U,2)
SET PRCHRQ2=$PIECE(^(2),U,8)
SET PRCHRAM=$PIECE(^(2),U,1)
SET PRCHRDA=$PIECE(^(2),U,6)
DO COM2
+2 GOTO 2^PRCHREC
+3 ;
COM2 if $ORDER(^PRC(442,PRCHPO,2,"AB",PRCHRD,+PRCHRIT,0))&($DATA(^PRC(442,PRCHPO,2,+PRCHRIT,3,+$ORDER(^(0)),0)))
QUIT
SET PRCHRTP=1
SET PRCHRQ=PRCHRQ1-PRCHRQ2
SET PRCHRDY=0
if PRCHRQ<0
SET PRCHRQ=0
DO EN3
+1 QUIT
+2 ;
HLP WRITE !?3,"Enter a number between .01 and 99999"
if PRCHRDY
WRITE " or '@' to delete"
WRITE "."
+1 ;PRC*5.1*170
GOTO ENQTY
+2 ;
HLP1 WRITE !?3,"Enter a Line Item number in the following format: 1,2,3,4 or 1:4 .",!?3,"You may also enter 'C' to complete P.O. as is, or 'A' to see all items."
+1 SET X="??"
SET D="C"
SET DA=PRCHPO
SET DIC="^PRC(442,DA,2,"
SET DIC(0)="QEM"
SET DIC("S")="I '$D(^PRC(442,DA,2,""AB"",+Y))"
DO IX^DIC
KILL DIC
+2 GOTO LI
