- 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 Apr 23, 2025@18:24:40 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
