source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHHI6.m@ 1710

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

initial load of WorldVistAEHR

File size: 2.2 KB
RevLine 
[613]1PRCHHI6 ;WISC/TGH-IFCAP SEGMENT IT ;6/19/92 11:20 AM
2V ;;5.1;IFCAP;;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 ITEM SEGMENT FOR
6 ;;EACH ITEM IN THE P.O. TRANSACTION.
7IT(VAR1,NUM) ;ITEMS INFORMATION SEGMENT
8 N B,DC,DIS,I,I0,I2,I4,ITEM,LI,LIN,MPN,N,N1,N1L,N2,N2L,N3,N3L
9 N NDC,NL,NSN,PDA,RP,TD,UP,UPN
10 S (ITEM,ITEMCNT)=0,TOTAL=$P($G(^PRC(442,VAR1,2,0)),U,4)+7
11 F S ITEM=$O(^PRC(442,VAR1,2,ITEM)) Q:ITEM'>0 D
12 .K PRCHTP1
13 .S I0=$G(^PRC(442,VAR1,2,ITEM,0))
14 .S I2=$G(^PRC(442,VAR1,2,ITEM,2))
15 .S I4=$G(^PRC(442,VAR1,2,ITEM,4))
16 .S PRCHTP1(0,20)="|IT"
17 .S PRCHTP1(0,1)=$P(I0,U)
18 .S PRCHTP1(0,2)=$P(I0,U,13)
19 .S PRCHTP1(1,5)=$P(I0,U,4)
20 .S RP=$P(I0,U,5)
21 .S NSN=$P(I0,U,13),NSN=$TR(NSN,"-")
22 .S MPN="" S:RP'="" MPN=$G(^PRC(441,RP,3))
23 .S PRCHTP1(1,13)=$P(MPN,U,5)
24 .S N=$P(I0,U,15) I N]"" S N1=$P(N,"-"),N2=$P(N,"-",2),N3=$P(N,"-",3),N1="000000"_N1,N1L=$L(N1),N1=$E(N1,N1L-5,N1L),N2="0000"_N2,N2L=$L(N2),N2=$E(N2,N2L-3,N2L),N3="00"_N3,N3L=$L(N3),N3=$E(N3,N3L-1,N3L),N=N1_N2_N3
25 .S PRCHTP1(1,14)=N,NDC=N
26 .S PRCHTP1(1,1)=$P(I0,U,2)\1
27 .S UP=$P(I0,U,3),UPN="" S:UP'="" UPN=$G(^PRCD(420.5,UP,0))
28 .S UNIT=$P(UPN,U)
29 .S PRCHTP1(1,2)=UNIT
30 .S LIN=$P(I0,U),(DIS,TD)=0 F S DIS=$O(^PRC(442,VAR1,3,DIS)) G:DIS'>0 IT3 S DC=$G(^PRC(442,VAR1,3,DIS,0)),LI=$P(DC,U,6) Q:LIN=LI
31 .S PDA=$P(DC,U,2) I $E(PDA,1)'="$" S TD=1,N=$P(PDA,"."),N1=$P(PDA,".",2),N="00"_N,NL=$L(N),N=$E(N,NL-1,NL),N1=N1_"00",N1=$E(N1,1,2),N=N_N1,B=B_N_"^^" G IT3
32 .S TD=1,PDA=$E(PDA,2,99),N=$P(PDA,"."),N1=$P(PDA,".",2),N="0000000"_N,NL=$L(N),N=$E(N,NL-6,NL),N1=N1_"00",N1=$E(N1,1,2),N=N_N1,B=B_"^"_N_"^"
33IT3 .S PRCHTP1(0,3)=$P(MPN,U,8)
34 .S PRCHTP1(1,6)=$S($P(I4,U,15)]"":$P(I4,U,15),1:"N")
35 .S PRCHTP1(1,7)=$S($P(I4,U,16)]"":$P(I4,U,16),1:"N")
36 .S PRCHTP1(1,20)=0
37 .D
38 ..N I,J S (I,J)=""
39 ..;S $P(^PRCF(423,PRCFA("CSDA"),52,0),U,3,4)=$P(^PRC(442,VAR1,2,0),U,3,4)
40 ..F S I=$O(PRCHTP1(I)) Q:I="" F S J=$O(PRCHTP1(I,J)) Q:J="" D
41 ...;S $P(^PRCF(423,PRCFA("CSDA"),52,ITEM,I),U,J)=PRCHTP1(I,J) Q
42 ..S NUM=NUM+1
43 ..S ^TMP($J,"STRING",NUM)="IT"_"^"_$P(I0,U)_"^"_NSN_"^^^"_$P(MPN,U,5)_"^"_NDC_"^"_$P(I0,U,2)_"^"_UNIT_"^^^^^"_$P(MPN,U,8)_"^^"_$P(I0,U,4)_"^Y^N^^^0^|"
Note: See TracBrowser for help on using the repository browser.