source: FOIAVistA/tag/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCOE2.m@ 636

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

initial load of FOIAVistA 6/30/08 version
File size: 5.1 KB
Line 
1PRCOE2 ;WISC/DJM-IFCAP SEGMENTS IT,DE ;12/26/02 18:18
2V ;;5.1;IFCAP;**63**;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;;
5 ;;THIS ROUTINE AT THE 'IT' ENTRY POINT CREATES ONE 'IT' SEGMENTS FOR EACH
6 ;;ITEM IN THE P.O. TRANSACTION. IT ALSO CREATES ALL THE 'DE' SEGMENTS
7 ;;NEEDED FOR EACH 'IT' SEGMENT. THE LAST THING DONE IN THIS ROUTINE IS
8 ;;TO UPDATE THE 'HE' SEGMENT AT FIELD NAME 'LINE COUNT' TO REFLECT THE
9 ;;NUMBER OF 'IT' SEGMENTS IN THIS TRANSACTION.
10 ;;
11 ;;THIS ROUTINE CREATES THE 'COMMENTS' SEGMENT AT THE 'CO' ENTRY POINT.
12 ;;ADDITIONALLY, THE 'HE' SEGMENT AT THE FIELD NAME 'COMMENT COUNT' IS
13 ;;UPDATED TO REFLECT THE NUMBER OF 'CO' SEGMENTS CREATED.
14 ;;
15IT(VAR1,VAR2,TOTAL) ;ITEMS INFORMATION SEGMENT
16 N AZ,B,C,CN,DC,DE,DELDT,DIS,DIWF,DIWL,DIWR,FOBPOINT,FSC,HAZM,I0,I2
17 N I4,INC,INN,ITEM,ITEMCNT,J,LI,LIN,LOT,LPRC,LPRC1,M,MPN,MPNO,N,N1L
18 N NSN,UC,UNIT,UP,UPN,VPN,X,TD,SKU,SKUF,SERNO,SEQU,SCH
19 N SCHX,RP,PDA,OS,OT,IT,ICNT
20 S (ITEM,ITEMCNT)=0
21 S OS=$P($G(^PRC(442,VAR1,7)),"^",1)+0 ; order status
22 S TOTAL=$P($G(^PRC(442,VAR1,2,0)),U,4)+7
23 F S ITEM=$O(^PRC(442,VAR1,2,ITEM)) Q:ITEM'>0 S ITEMCNT=ITEMCNT+1 D Q:VAR2]""
24 .S I0=$G(^PRC(442,VAR1,2,ITEM,0))
25 .S I2=$G(^PRC(442,VAR1,2,ITEM,2))
26 .I I2="" S VAR2="NI2N^"_ITEM Q
27 .S I4=$G(^PRC(442,VAR1,2,ITEM,4))
28 .S NSN=$P(I0,U,13)
29 .S FSC=$P(I2,U,3)
30 .S FSC=$S(FSC]"":$P($G(^PRC(441.2,FSC,0)),U),1:"")
31 .S NSN=$S(NSN]"":NSN,1:FSC)
32 .S B="IT^"_$P(I0,U)_"^"_NSN_"^" ; FIELDS 1, 2, 3
33 .S RP=$P(I0,U,5)
34 .S INN=""
35 .S:RP>0 INN=$G(^PRC(441,RP,0))
36 .S INC=$P(INN,U,12)
37 .I $P(I0,U,13)="",INC="" S INC=77777
38 .S B=B_INC_"^" ; FIELD 4
39 .S VPN=$P(I0,U,6)
40 .S:$E(VPN,1)="#" VPN=$E(VPN,2,99)
41 .S B=B_VPN_"^" ; FIELD 5
42 .;
43IT0 .S MPN=$S(RP>0:$G(^PRC(441,RP,3)),1:"")
44 .I MPN="" S B=B_"^" G IT1 ; FIELD 6 - CONDITION 1
45 .S MPNO=$P(MPN,U,5)
46 .S:$E(MPNO,1)="#" MPNO=$E(MPNO,2,99)
47 .S B=B_MPNO_"^" ; FIELD 6 - CONDITION 2
48 .;
49IT1 .S N=$P(I0,U,15)
50 .I N]"" S N=$TR($P(N,"-",1,3),"-")
51 .S B=B_N_"^" ; FIELD 7 (NDC)
52 .;
53 .S Q=$P(I0,U,2)
54 .I OS=45 S Q=0 ; zero for cancelled orders
55 .I Q="" S VAR2="NQTY^"_$P(I0,U) Q
56 .S Q=Q\1+(Q#1>0)_"00"
57 .S B=B_Q_"^" ; FIELD 8 (quantity)
58 .;
59 .S UP=$P(I0,U,3)
60 .I UP="" S VAR2="NUOP^"_$P(I0,U) Q
61 .S UPN=$G(^PRCD(420.5,UP,0))
62 .I UPN="" S VAR2="NUPN^"_$P(I0,U) Q
63 .S UNIT=$P(UPN,U)
64 .I UNIT="" S VAR2="NUNI^"_$P(I0,U) Q
65 .S B=B_UNIT_"^" ; FIELD 9
66 .;
67 .S UC=$P(I0,U,9)
68 .I UC="" S VAR2="NAUC^"_$P(I0,U) Q
69 .I UC="N/C"!(OS=45) S UC=0 ; no charge or canceled
70 .S UC=$TR($J(UC,11,4)," .","0") ; pad and strip decimal point
71 .;
72IT2 .S B=B_UC_"^^" ; FIELDS 10, 11
73 .S LIN=$P(I0,U)
74 .S (DIS,TD)=0
75 .F S DIS=$O(^PRC(442,VAR1,3,DIS)) G:DIS'>0 IT3 D Q:LIN=LI
76 . .S DC=$G(^PRC(442,VAR1,3,DIS,0))
77 . .S LI=$P(DC,U,6)
78 . .Q
79 .S TD=1
80 .S PDA=$P(DC,U,2)
81 .I $E(PDA,1)'="$" D G IT3
82 . .S N=$TR($J(PDA,5,2)," .","0")
83 . .S B=B_N_"^^" ; FIELDS 12, 13 - CONDITION 1
84 .S PDA=$E(PDA,2,99)
85 .S N=$TR($J(PDA,10,2)," .","0")
86 .S B=B_"^"_N_"^" ; FIELDS 12, 13 - CONDITION 2
87 .;
88IT3 .S:'TD B=B_"^^" ; FIELDS 12, 13 - CONDITION 3
89 .I $P(I0,U,16)>0 D
90 . .S SKU=$P(I0,U,16)
91 . .S SKU=$G(^PRCD(420.5,SKU,0))
92 . .S SKUF=$S($P(I0,U,17)>0:$P(I0,U,17),1:1)
93 . .S SKU=$P(SKU,U)
94 . .S B=B_SKU_"^"_SKUF_"^" ; FIELDS 14, 15 - CONDITION 1
95 .I $P(I0,U,16)'>0 S B=B_UNIT_"^1^" ; FIELDS 14, 15 - CONDITION 2
96 .;
97IT4 .S B=B_"^"_$S($P(I4,U,15)]"":$P(I4,U,15),1:"N")_"^"_$S($P(I4,U,16)]"":$P(I4,U,16),1:"N")_"^" ; FIELDS 16, 17, 18
98 .S CN=$P(I2,U,2)
99 .S OT=$P(^PRC(442,VAR1,1),U,7)
100 .S OT=","_OT_","
101 .S OT=$S(",1,4,6,10,"[OT:"D",1:"")
102 .I OT="D",CN="" S VAR2="NCNO^"_$P(I0,U) Q:VAR2]""
103 .S B=B_CN_"^" ; FIELD 19
104 .S LPRC=$P($G(^PRC(442,VAR1,1)),U,19)
105 .S LPRC1=""
106 .I LPRC>0 S LPRC1=$P($G(^PRC(443.8,LPRC,0)),U)
107 .I LPRC>0 S:LPRC1=10 LPRC1="A"
108 .S B=B_LPRC1_"^" ; FIELD 20
109 .;
110IT5 .S (IT,ICNT)=0
111 .S AZ=$G(^PRC(442,VAR1,2,ITEM,1,0))
112 .G:$P(AZ,U,4)'>0 IT6
113 .S DIWR=70
114 .S DIWL=1
115 .S DIWF=""
116 .S DE=0
117 .K ^UTILITY($J,"W")
118 .F S DE=$O(^PRC(442,VAR1,2,ITEM,1,DE)) Q:DE="" D
119 . .S X=$G(^PRC(442,VAR1,2,ITEM,1,DE,0))
120 . .D DIWP^PRCUTL($G(DA))
121 .S J=$G(^UTILITY($J,"W",1))
122 .G:J="" IT6
123 .I J>900 S J=900
124 .S IT=1
125 .S ICNT=""
126 .F I=1:1:J D
127 . .S N=$G(^UTILITY($J,"W",1,I,0)) S:$L(N)=0 N=" " S N=$TR(N,"^")
128 . .S M="DE^"_$P(I0,U)_"^"_I_"^"_N_"^|" ; DE SEGMENT FIELDS 1, 2, 3, 4, 5
129 . .S ^TMP($J,"STRING",ITEMCNT+6+I)=M
130 . .S TOTAL=TOTAL+1
131 . .S ICNT=ICNT+1
132 .K ^UTILITY($J,"W")
133 .;
134IT6 .S B=B_$S(IT:ICNT,1:0)_"^^" ; FIELDS 21, 22
135 .;
136IT7 .S LOT=$P(I4,U,17)
137 .S SERNO=$P(I4,U,18)
138 .S HAZM=$P(I2,U,14)
139 .S B=B_LOT_"^"_SERNO_"^"_HAZM_"^^" ; FIELDS 23, 24, 25, 26
140 .;
141IT8 .S IT=0
142 .S AZ=$P(^PRC(442,VAR1,0),U)
143 .S SCH=0
144 .S SEQU=0
145 .F S SCH=$O(^PRC(442.8,"AC",AZ,ITEM,SCH)) Q:SCH="" D
146 . .S SCHX=$G(^PRC(442.8,SCH,0))
147 . .Q:SCHX=""
148 . .S SEQU=SEQU+1
149 . .S IT=1
150 . .S X=$P(SCHX,U,3)
151 . .D JD^PRCFDLN
152 . .S DELDT=$E(X,1,3)+1700_$E(Y,1,3)
153 . .S M="SC^"_$P(I0,U)_"^"_SEQU_"^"_($P(SCHX,U,5)*100)_"^"_UNIT_"^"_DELDT_"^|"
154 . .S ^TMP($J,"STRING",ITEMCNT+6+ICNT+SEQU)=M
155 . .S TOTAL=TOTAL+1
156IT9 .S B=B_$S(IT:SEQU,1:0)_"^"_$P(INN,U,15)_"^|" ;FIELDS 27, 28, 29
157 .S ^TMP($J,"STRING",ITEMCNT+6)=B
158 .S ITEMCNT=ITEMCNT+ICNT+SEQU
159 .S B=^TMP($J,"STRING",1) ;ADD 1 TO HE SEGMENT FIELD 12
160 .S $P(B,U,12)=$P(B,U,12)+1
161 .S ^TMP($J,"STRING",1)=B
162 Q
Note: See TracBrowser for help on using the repository browser.