source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHCS2.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.5 KB
Line 
1PRCHCS2 ;WISC/RHD-BUILD LOG CODE SHEET DATA ;12/1/93 09:51
2V ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4COM ;S PRCHCOM=$S($D(^PRC(441.2,+$P(PRCH2,U,3),0)):$P(^(0),U,4),1:"") Q
5 S PRCHCOM=$P($G(^PRC(441.2,+$P(PRCH2,U,3),0)),U,4) Q
6NOM S X=$S(PRCHCOM=1:$E($P(PRCHI0,U,2),1,20),PRCHCOM=8:$E($P(PRCHI0,U,2),1,13),1:$E($P(PRCHI0,U,2),1,16)) Q:PRCHCOM'=8
7 I PRCHDIET="" W $C(7),!!,"WARNING--DIETETICS COST PERIOD MISSING--WILL BE SET TO 'N'!!" S PRCHDIET="N"
8 S Y=X,PRCFLN=13 D RBF^PRCFU S PRCHZ=Y_PRCHDIET_$S($P(PRCH4,U,12):$P(PRCH4,U,12),1:" "),Y=$P(PRCH4,U,13),PRCFLN=5 D LBF^PRCFU S X=PRCHZ_Y K Y,PRCHZ Q
9MAX S X="",PRCHCS("MAX")=$P(PRCHIV0,U,9) Q:'PRCHCS("MAX") S:$P(PRCH0,U,2)>PRCHCS("MAX") X=1 Q
10MAND S X="",PRCHCS("MAND")="" Q:'$P(PRCHI0,U,8) Q:$D(^PRC(440,"AC","S",+$P(PRCHI0,U,8)))
11 S PRCHCS("MAND")=$S($D(^PRC(440,+$P(PRCHI0,U,8),2)):$P(^(2),U,2),1:PRCHCS("MAND"))
12M2 I PRCHCS("MAND"),$P(PRCH4,U,10),PRCHCS("MAND")'=$P(PRCH4,U,10) W $C(7),!!,"NOTE: Possible Source deviation on line/item "_$P(PRCH0,U,1),!
13 Q
14DOCID ;SET DOCUMENT IDENTIFIER TO COMMON NO.(PAT) OR REQUISITION NO. IF SOURCE 1 (DEPOT)
15 S X="" Q:'$D(^PRC(442,PRCHPO,18)) S X=^(18),X=$P(X,U,3)
16 Q
17AMT ;SET X=AMOUNT ORDERED INCLUDING TERM & TRADE DISCOUNTS, AND SHIPPING/HANDLING CHARGES.
18 S X=$P(PRCH2,U,1)-$P(PRCH2,U,6)
19 S X=X-(X*PRCHS("T")) I PRCHEST S X=X+PRCHEST
20 S:X<0 X=0 S X=+$J(X,0,2)
21 Q
22B500 ;POSTED ACQUISITIONS TRX# 630,500,504
23 S PRCHTP(1,1)="S X=PRCHPO;5.1",PRCHTP(1,2)="D DOCID^PRCHCS2;344",PRCHTP(1,3)="7;306"
24 S PRCHTP(2,1)=".01;300",PRCHTP(2,2)="2;302",PRCHTP(2,3)="S X=$P(PRCHDIC1(2,0),U,13),X=$P(X,""-"",2)_$P(X,""-"",3)_$P(X,""-"",4);308",PRCHTP(2,4)="39;341"
25 S PRCHTP(2,5)="S X=$S($P(PRCH4,U,10)=1:"""",1:+PRCH2) D:X AMT^PRCHCS2;301",PRCHTP(2,6)="35;347",PRCHTP(2,7)="36;348",PRCHTP(2,8)="3;303"
26 S PRCHTP(2,9)="S Y=$E($P(PRCHI0,U,2),1,15),PRCFLN=15 D RBF^PRCFU S X=Y K Y;310",PRCHTP(2,10)="D MAX^PRCHCS2;349",PRCHTP(2,11)="D MAND^PRCHCS2;359" Q
27 Q
28B100 ;DLA ACQUISITIONS TRX# 100
29 S PRCHTP(1,1)="S X=PRCHPO;5.1",PRCHTP(1,2)="71;313",PRCHTP(1,3)="72;312",PRCHTP(1,4)="80;350",PRCHTP(1,5)="72.4;311",PRCHTP(1,6)=".1;306.2"
30 S PRCHTP(1,7)="73;351",PRCHTP(1,8)="S X=$P($P(^PRC(442,PRCHPO,0),U,1),""-"",2);367",PRCHTP(1,9)="102;344",PRCHTP(1,10)="74;352",PRCHTP(1,11)="75;353",PRCHTP(1,12)="76;354",PRCHTP(1,13)="77;355"
31 S PRCHTP(1,14)="78;356",PRCHTP(1,15)="7;358",PRCHTP(1,16)="79;357"
32 S PRCHTP(2,1)=".01;300",PRCHTP(2,2)="2;302",PRCHTP(2,3)="30;366",PRCHTP(2,4)="S X=$P(PRCHDIC1(2,0),U,13),X=$P(X,""-"",1)_$P(X,""-"",2)_$P(X,""-"",3)_$E($P(X,""-"",4),1,4);307"
33 S PRCHTP(2,5)="3;303"
34 Q
35B501 ;UNPOSTED ACQUISITION--SOURCE 1 (DEPOT) TRX# 501,505,510,514,515
36 S PRCHTP(1,1)="S X=PRCHPO;5.1",PRCHTP(1,2)="D DOCID^PRCHCS2;344",PRCHTP(1,3)="7;306",PRCHTP(1,4)="70;330"
37 S PRCHTP(2,1)=".01;300",PRCHTP(2,2)="2;302",PRCHTP(2,3)="S X=$P(PRCHDIC1(2,0),U,13),X=$P(X,""-"",2)_$P(X,""-"",3)_$P(X,""-"",4);308",PRCHTP(2,4)="39;341"
38 S PRCHTP(2,5)="35;347",PRCHTP(2,6)="36;348"
39 Q
40B700 ;UNPOSTED ACQUISITION--SOURCE 3 (GSA) TRX# 700
41 S PRCHTP(1,1)="S X=PRCHPO;5.1",PRCHTP(1,2)="102;344",PRCHTP(1,3)="7;306",PRCHTP(1,4)="70;330",PRCHTP(1,5)="S X=""G"";340"
42 S PRCHTP(2,1)=".01;300",PRCHTP(2,2)="2;302",PRCHTP(2,3)="S X=$P(PRCHDIC1(2,0),U,13),X=$P(X,""-"",2)_$P(X,""-"",3)_$P(X,""-"",4);308",PRCHTP(2,4)="39;341",PRCHTP(2,5)="D AMT^PRCHCS2;301"
43 S PRCHTP(2,6)="S X=$S($P(PRCH4,U,1)]"""":""*""_$P(PRCH4,U,1),1:$E($P(PRCHI0,U,2),1,9));310.6",PRCHTP(2,7)="3;303"
44 S PRCHTP(2,8)="8;364",PRCHTP(2,9)="35;347",PRCHTP(2,10)="36;348",PRCHTP(2,11)="D COM^PRCHCS2 S X=PRCHCOM;336"
45 Q
Note: See TracBrowser for help on using the repository browser.