source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHCS7.m@ 1800

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