PRCHCS7 ;WISC/RHD-BUILD LOG CODE SHEET DATA ;12/1/93 09:53
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
STK S PRCHSRC=$P(PRCH4,U,10) I PRCHSRC'=1,PRCHCOM=1 D DRG K Y Q
S X=$P(PRCH0,U,13),X=$P(X,"-",2)_$P(X,"-",3)_$P(X,"-",4) Q
DRG ;DRUG FOR CODE SHEET
S X=$P(PRCH0,U,15),X=$P(X,"-",1)_$P(X,"-",2)_$P(X,"-",3) G:PRCHN("SFC")=2 SDRG
I X="" S Y="",PRCFLN=12 D RZF^PRCFU S X=Y
S:$L(X)<11 X="0"_X S Y=$S($P(PRCH4,U,11)]"":$P(PRCH4,U,11),1:"D")_X,PRCFLN=13 D:$L(X)<13 RBF^PRCFU S X=Y Q
SDRG S Y="DRUG D"_X,PRCFLN=21 D RZF^PRCFU S X=Y Q
NOM2 I PRCHCOM'=1!(PRCHN("SC")=1)!(PRCHN("SC")="A") S X=$E($P(PRCHI0,U,2),1,21) Q
D DRG Q
RAMT ;SET X=AMOUNT RECEIVED INCLUDING TERM & TRADE DISCOUNTS, AND (IF FIRST PARTIAL), SHIPPING/HANDLING CHARGES.
;SET PRCHQTY=QTY.RECEIVED
S X="",PRCHQTY="",Y=$O(^PRC(442,PRCHPO,2,"AB",PRCHRD,PRCHLI,0)) Q:'$D(^PRC(442,PRCHPO,2,PRCHLI,3,+Y,0)) S X=$P(^(0),U,3)-$P(^(0),U,5),PRCHQTY=+$P(^(0),U,2)
S X=X-(X*PRCHS("T")) I PRCHEST S X=X+PRCHEST
S:X<0 X=0 S X=+$J(X,0,2)
K Y Q
B710 ;UNPOSTED RECEIPTS (EXCEPT FOR DEPOT)
S PRCHTP(1,1)="S X=PRCHPO;5.1",PRCHTP(1,2)="101;346",PRCHTP(1,3)="102;344",PRCHTP(1,4)="S X=PRCHN(""FMO"");305",PRCHTP(1,5)="70;330"
S PRCHTP(2,1)=".01;300",PRCHTP(2,2)="D COM^PRCHCS2,STK^PRCHCS7;307",PRCHTP(2,3)="39;341",PRCHTP(2,4)="D NOM^PRCHCS2;310.5",PRCHTP(2,5)="3;303"
S PRCHTP(2,6)="D RAMT^PRCHCS7;301",PRCHTP(2,7)="S X=PRCHQTY;302",PRCHTP(2,8)="S X=PRCHCOM;336",PRCHTP(2,9)="D CMDTY^PRCHCS7;306.1"
S PRCHTP(2,10)="S X="""" I PRCHEMG=""Y"",$P(PRCH4,U,10)=2,""1,2""[PRCHCOM S X=""*"";383"
Q
B632 ;POSTED RECEIPTS (EXCEPT FOR DEPOT)
W !!!,$C(7),$C(7),"WARNING!!!",!,"If the Unit of Receipt into the Warehouse is not the same as the Unit of Issue",!,"from the Warehouse on any items, you will need to edit the 'UNIT OF ISSUE' and"
W !,"'QUANTITY' fields on the code sheets for those items.",!
S PRCHTP(1,1)="S X=PRCHPO;5.1",PRCHTP(1,2)="S X=1 I $D(^PRC(442,PRCHPO,17)),$P(^(17),U,14)]"""" S X=$P(^(17),U,14);340"
S PRCHTP(1,3)="S X="""" I ""01""[PRCHN(""SC""),$D(^PRC(442,PRCHPO,18)) S X=$P(^(18),U,3);344",PRCHTP(1,4)="S X=PRCHCMI;343",PRCHTP(1,5)="D DOCID^PRCHCS2;377"
S PRCHTP(1,6)="107;345",PRCHTP(1,7)="101;346",PRCHTP(1,8)="S X=+$P(^PRC(442,PRCHPO,1),U,15),X=$E(X,3)+$E(X,4) S:$L(X)=2 X=$E(X,2,2);304",PRCHTP(1,9)="S X=PRCHRD;306.1"
S PRCHTP(2,1)=".01;300",PRCHTP(2,2)="S X=$P(PRCHDIC1(2,0),U,13),X=$P(X,""-"",2)_$P(X,""-"",3)_$P(X,""-"",4);308",PRCHTP(2,3)="39;341",PRCHTP(2,4)="D COM^PRCHCS2,NOM2^PRCHCS7;309",PRCHTP(2,5)="3;303"
S PRCHTP(2,6)="D RAMT^PRCHCS7;301",PRCHTP(2,7)="39.5;342",PRCHTP(2,8)="S X=PRCHQTY;302"
Q
B551 ;POSTED DEPOT RECEIPT CODE SHEET (RELEASE)
S PRCHTP(1,1)="S X=PRCHPO;5.1",PRCHTP(1,2)="107;345",PRCHTP(1,3)=".09;368",PRCHTP(1,4)="D DOCID^PRCHCS2;369"
S PRCHTP(1,5)="S X=+$P(^PRC(442,PRCHPO,1),U,15),X=$E(X,3)+$E(X,4);304",PRCHTP(1,6)="S X=""R"";370",PRCHTP(1,7)="102;344"
Q
B552 ;UNPOSTED DEPOT RECEIPT CODE SHEETS (RELEASE)
S PRCHTP(1,1)="S X=PRCHPO;5.1",PRCHTP(1,2)="107;345",PRCHTP(1,3)=".09;368",PRCHTP(1,4)="D DOCID^PRCHCS2;369",PRCHTP(1,5)="70;330"
S PRCHTP(1,6)="S X=""R"";370",PRCHTP(1,7)="102;344",PRCHTP(1,8)="S X=PRCHN(""FMO"");305",PRCHTP(1,9)="S X=$S($D(^PRC(442,PRCHPO,11,PRCHRPT,1)):$P(^(1),U,2),1:"""");333"
Q
CMDTY S X="" I PRCHCOM=8,$D(^PRC(442,PRCHPO,17)),$E(^(17),1,2)=11 S X=$P(PRCHRD,".",1)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHCS7 3417 printed Sep 23, 2025@19:42:28 Page 2
PRCHCS7 ;WISC/RHD-BUILD LOG CODE SHEET DATA ;12/1/93 09:53
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
STK SET PRCHSRC=$PIECE(PRCH4,U,10)
IF PRCHSRC'=1
IF PRCHCOM=1
DO DRG
KILL Y
QUIT
+1 SET X=$PIECE(PRCH0,U,13)
SET X=$PIECE(X,"-",2)_$PIECE(X,"-",3)_$PIECE(X,"-",4)
QUIT
DRG ;DRUG FOR CODE SHEET
+1 SET X=$PIECE(PRCH0,U,15)
SET X=$PIECE(X,"-",1)_$PIECE(X,"-",2)_$PIECE(X,"-",3)
if PRCHN("SFC")=2
GOTO SDRG
+2 IF X=""
SET Y=""
SET PRCFLN=12
DO RZF^PRCFU
SET X=Y
+3 if $LENGTH(X)<11
SET X="0"_X
SET Y=$SELECT($PIECE(PRCH4,U,11)]"":$PIECE(PRCH4,U,11),1:"D")_X
SET PRCFLN=13
if $LENGTH(X)<13
DO RBF^PRCFU
SET X=Y
QUIT
SDRG SET Y="DRUG D"_X
SET PRCFLN=21
DO RZF^PRCFU
SET X=Y
QUIT
NOM2 IF PRCHCOM'=1!(PRCHN("SC")=1)!(PRCHN("SC")="A")
SET X=$EXTRACT($PIECE(PRCHI0,U,2),1,21)
QUIT
+1 DO DRG
QUIT
RAMT ;SET X=AMOUNT RECEIVED INCLUDING TERM & TRADE DISCOUNTS, AND (IF FIRST PARTIAL), SHIPPING/HANDLING CHARGES.
+1 ;SET PRCHQTY=QTY.RECEIVED
+2 SET X=""
SET PRCHQTY=""
SET Y=$ORDER(^PRC(442,PRCHPO,2,"AB",PRCHRD,PRCHLI,0))
if '$DATA(^PRC(442,PRCHPO,2,PRCHLI,3,+Y,0))
QUIT
SET X=$PIECE(^(0),U,3)-$PIECE(^(0),U,5)
SET PRCHQTY=+$PIECE(^(0),U,2)
+3 SET X=X-(X*PRCHS("T"))
IF PRCHEST
SET X=X+PRCHEST
+4 if X<0
SET X=0
SET X=+$JUSTIFY(X,0,2)
+5 KILL Y
QUIT
B710 ;UNPOSTED RECEIPTS (EXCEPT FOR DEPOT)
+1 SET PRCHTP(1,1)="S X=PRCHPO;5.1"
SET PRCHTP(1,2)="101;346"
SET PRCHTP(1,3)="102;344"
SET PRCHTP(1,4)="S X=PRCHN(""FMO"");305"
SET PRCHTP(1,5)="70;330"
+2 SET PRCHTP(2,1)=".01;300"
SET PRCHTP(2,2)="D COM^PRCHCS2,STK^PRCHCS7;307"
SET PRCHTP(2,3)="39;341"
SET PRCHTP(2,4)="D NOM^PRCHCS2;310.5"
SET PRCHTP(2,5)="3;303"
+3 SET PRCHTP(2,6)="D RAMT^PRCHCS7;301"
SET PRCHTP(2,7)="S X=PRCHQTY;302"
SET PRCHTP(2,8)="S X=PRCHCOM;336"
SET PRCHTP(2,9)="D CMDTY^PRCHCS7;306.1"
+4 SET PRCHTP(2,10)="S X="""" I PRCHEMG=""Y"",$P(PRCH4,U,10)=2,""1,2""[PRCHCOM S X=""*"";383"
+5 QUIT
B632 ;POSTED RECEIPTS (EXCEPT FOR DEPOT)
+1 WRITE !!!,$CHAR(7),$CHAR(7),"WARNING!!!",!,"If the Unit of Receipt into the Warehouse is not the same as the Unit of Issue",!,"from the Warehouse on any items, you will need to edit the 'UNIT OF ISSUE' and"
+2 WRITE !,"'QUANTITY' fields on the code sheets for those items.",!
+3 SET PRCHTP(1,1)="S X=PRCHPO;5.1"
SET PRCHTP(1,2)="S X=1 I $D(^PRC(442,PRCHPO,17)),$P(^(17),U,14)]"""" S X=$P(^(17),U,14);340"
+4 SET PRCHTP(1,3)="S X="""" I ""01""[PRCHN(""SC""),$D(^PRC(442,PRCHPO,18)) S X=$P(^(18),U,3);344"
SET PRCHTP(1,4)="S X=PRCHCMI;343"
SET PRCHTP(1,5)="D DOCID^PRCHCS2;377"
+5 SET PRCHTP(1,6)="107;345"
SET PRCHTP(1,7)="101;346"
SET PRCHTP(1,8)="S X=+$P(^PRC(442,PRCHPO,1),U,15),X=$E(X,3)+$E(X,4) S:$L(X)=2 X=$E(X,2,2);304"
SET PRCHTP(1,9)="S X=PRCHRD;306.1"
+6 SET PRCHTP(2,1)=".01;300"
SET PRCHTP(2,2)="S X=$P(PRCHDIC1(2,0),U,13),X=$P(X,""-"",2)_$P(X,""-"",3)_$P(X,""-"",4);308"
SET PRCHTP(2,3)="39;341"
SET PRCHTP(2,4)="D COM^PRCHCS2,NOM2^PRCHCS7;309"
SET PRCHTP(2,5)="3;303"
+7 SET PRCHTP(2,6)="D RAMT^PRCHCS7;301"
SET PRCHTP(2,7)="39.5;342"
SET PRCHTP(2,8)="S X=PRCHQTY;302"
+8 QUIT
B551 ;POSTED DEPOT RECEIPT CODE SHEET (RELEASE)
+1 SET PRCHTP(1,1)="S X=PRCHPO;5.1"
SET PRCHTP(1,2)="107;345"
SET PRCHTP(1,3)=".09;368"
SET PRCHTP(1,4)="D DOCID^PRCHCS2;369"
+2 SET PRCHTP(1,5)="S X=+$P(^PRC(442,PRCHPO,1),U,15),X=$E(X,3)+$E(X,4);304"
SET PRCHTP(1,6)="S X=""R"";370"
SET PRCHTP(1,7)="102;344"
+3 QUIT
B552 ;UNPOSTED DEPOT RECEIPT CODE SHEETS (RELEASE)
+1 SET PRCHTP(1,1)="S X=PRCHPO;5.1"
SET PRCHTP(1,2)="107;345"
SET PRCHTP(1,3)=".09;368"
SET PRCHTP(1,4)="D DOCID^PRCHCS2;369"
SET PRCHTP(1,5)="70;330"
+2 SET PRCHTP(1,6)="S X=""R"";370"
SET PRCHTP(1,7)="102;344"
SET PRCHTP(1,8)="S X=PRCHN(""FMO"");305"
SET PRCHTP(1,9)="S X=$S($D(^PRC(442,PRCHPO,11,PRCHRPT,1)):$P(^(1),U,2),1:"""");333"
+3 QUIT
CMDTY SET X=""
IF PRCHCOM=8
IF $DATA(^PRC(442,PRCHPO,17))
IF $EXTRACT(^(17),1,2)=11
SET X=$PIECE(PRCHRD,".",1)
+1 QUIT
