source: FOIAVistA/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHHI7.m@ 1119

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

initial load of FOIAVistA 6/30/08 version

File size: 2.4 KB
Line 
1PRCHHI7 ;WISC/TGH-IFCAP SEGMENT DL -(IT) ;8/12/92 10:00 AM
2V ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;;
5DL(A,VAR1,NUM,DLCNT) ;Prism delivery Order Line
6 N A2,A3,DAT,DESCLN,SKU,X,Y,I0,I2,I4,ITEM,KEPNUM,PRCHNSN,PRCHDIFF,PRCHQTY,PRCHJUDT
7 S (ITEM,ITEMCNT)=0,TOTAL=$P($G(^PRC(442,VAR1,2,0)),U,4)+7
8 S A2=2,A3="DE"
9 D NOW^%DTC S X=$P(%,".") D JD^PRCFDLN S DAT=$E(X,1,3)+1700_$E(Y,1,3)
10 F S ITEM=$O(^PRC(442,VAR1,2,ITEM)) K PRCHTP1 Q:ITEM'>0 D
11 .S DLCNT=DLCNT+1
12 .S I0=$G(^PRC(442,VAR1,2,ITEM,0))
13 .S DESCLN=$G(^PRC(442,VAR1,2,ITEM,1,0)),DESCLN=$P(DESCLN,U,4)
14 .S I2=$G(^PRC(442,VAR1,2,ITEM,2))
15 .S I4=$G(^PRC(442,VAR1,2,ITEM,4))
16 .;
17 .S PRCHTP1(0,20)="|DL"
18 .S PRCHTP1(0,2)=$P(I0,U,13) ;NSN
19 .S PRCHTP1(0,1)=$P(I0,U) ;ITEM LINE NO.
20 .S PRCHTP1(1,8)=$P(I2,U,2) ;CONTRACT #
21 .S PRCHTP1(0,11)=$P(A,U,10) ;DEL DATE
22 .S PRCHTP1(1,1)=$P(I0,U,2)\1 ;QTY ORDERED
23 .S SKU=$P(I0,U,16) I SKU]"" S SKU=$G(^PRCD(420.5,SKU,0))
24 .S PRCHTP1(0,3)=$P(SKU,U)
25 .S PRCHTP1(1,10)=DESCLN
26 .D
27 ..N I,J S (I,J)=""
28 ..;S $P(^PRCF(423,PRCFA("CSDA"),52,0),U,3,4)=$P(^PRC(442,VAR1,2,0),U,3,4)
29 ..;F S I=$O(PRCHTP1(I)) Q:I="" F S J=$O(PRCHTP1(I,J)) Q:J="" D
30 ..; WAS 3.'s $P(^PRCF(423,PRCFA("CSDA"),52,ITEM,I),U,J)=PRCHTP1(I,J)
31 ..;REMOVE DASHES FROM NSN & FORMAT UPTO 20 CHARS W TRAILING SPACES
32 ..S PRCHNSN=$TR($P(I0,U,13),"-")
33 ..I $D(PRCHNSN) S PRCHNSN=PRCHNSN_" ",PRCHNSN=$E(PRCHNSN,1,20)
34 ..;
35 ..;LINE ITEM NUMBER FORMAT UPTO 3 CHARS W LEADING ZEROS
36 ..S PRCHLINU=$P(I0,U),PRCHLINE="00"_PRCHLINU
37 ..I $D(PRCHLINU) S PRCHLINE=$E(PRCHLINE,$L(PRCHLINE)-2,99)
38 ..;
39 ..;REQUESTED DEL DATE FORMAT UPTO 7 CHARS W JULIAN DATE
40 ..S X=$P(A,U,10) D JD^PRCFDLN S PRCHJUDT=$E(X,1,3)+1700_$E(Y,1,3)
41 ..;
42 ..;QTY ORDERED FORMATTED UPTO 9 CHARS W LEADING ZEROS & 2 DEC. IMPLIED
43 ..S PRCHQTY=$TR($J($P(I0,U,2),0,2),".")
44 ..S PRCHQTY="000000000"_PRCHQTY
45 ..S PRCHQTY=$E(PRCHQTY,$L(PRCHQTY)-8,99)
46 ..;
47 ..S NUM=NUM+1
48 ..S ^TMP($J,"STRING",NUM)="DL"_"^^^"_PRCHNSN_"^"_PRCHLINE_"^"_$P(I2,U,2)_"^^"_PRCHJUDT_"^"_PRCHQTY_"^^^^"_$P(SKU,U)_"^^^^^|"
49 ..S KEPNUM=NUM D CO^PRCHHI9(A2,A3,VAR1,ITEM,.NUM)
50 ..;
51 ..;#DE SEGMENT (DESCR. COUNT) FORMATTED UPTO 3 CHARS W LEADING ZEROS
52 ..;IN DL STRING (3lines above) THE 17Tth piece is set to null
53 ..S PRCHDIFF=NUM-KEPNUM,PRCHDIFF="00"_PRCHDIFF
54 ..S PRCHDIFF=$E(PRCHDIFF,$L(PRCHDIFF)-2,99)
55 ..S $P(^TMP($J,"STRING",KEPNUM),U,17)=PRCHDIFF
56 ..Q
Note: See TracBrowser for help on using the repository browser.