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

Last change on this file since 619 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 3.3 KB
Line 
1PRCHCS7 ;WISC/RHD-BUILD LOG CODE SHEET DATA ;12/1/93 09:53
2V ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4STK S PRCHSRC=$P(PRCH4,U,10) I PRCHSRC'=1,PRCHCOM=1 D DRG K Y Q
5 S X=$P(PRCH0,U,13),X=$P(X,"-",2)_$P(X,"-",3)_$P(X,"-",4) Q
6DRG ;DRUG FOR CODE SHEET
7 S X=$P(PRCH0,U,15),X=$P(X,"-",1)_$P(X,"-",2)_$P(X,"-",3) G:PRCHN("SFC")=2 SDRG
8 I X="" S Y="",PRCFLN=12 D RZF^PRCFU S X=Y
9 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
10SDRG S Y="DRUG D"_X,PRCFLN=21 D RZF^PRCFU S X=Y Q
11NOM2 I PRCHCOM'=1!(PRCHN("SC")=1)!(PRCHN("SC")="A") S X=$E($P(PRCHI0,U,2),1,21) Q
12 D DRG Q
13RAMT ;SET X=AMOUNT RECEIVED INCLUDING TERM & TRADE DISCOUNTS, AND (IF FIRST PARTIAL), SHIPPING/HANDLING CHARGES.
14 ;SET PRCHQTY=QTY.RECEIVED
15 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)
16 S X=X-(X*PRCHS("T")) I PRCHEST S X=X+PRCHEST
17 S:X<0 X=0 S X=+$J(X,0,2)
18 K Y Q
19B710 ;UNPOSTED RECEIPTS (EXCEPT FOR DEPOT)
20 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"
21 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"
22 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"
23 S PRCHTP(2,10)="S X="""" I PRCHEMG=""Y"",$P(PRCH4,U,10)=2,""1,2""[PRCHCOM S X=""*"";383"
24 Q
25B632 ;POSTED RECEIPTS (EXCEPT FOR DEPOT)
26 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"
27 W !,"'QUANTITY' fields on the code sheets for those items.",!
28 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"
29 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"
30 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"
31 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"
32 S PRCHTP(2,6)="D RAMT^PRCHCS7;301",PRCHTP(2,7)="39.5;342",PRCHTP(2,8)="S X=PRCHQTY;302"
33 Q
34B551 ;POSTED DEPOT RECEIPT CODE SHEET (RELEASE)
35 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"
36 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"
37 Q
38B552 ;UNPOSTED DEPOT RECEIPT CODE SHEETS (RELEASE)
39 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"
40 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"
41 Q
42CMDTY S X="" I PRCHCOM=8,$D(^PRC(442,PRCHPO,17)),$E(^(17),1,2)=11 S X=$P(PRCHRD,".",1)
43 Q
Note: See TracBrowser for help on using the repository browser.