- PRCHHI6 ;WISC/TGH-IFCAP SEGMENT IT ;6/19/92 11:20 AM
- V ;;5.1;IFCAP;;Oct 20, 2000
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- ;;
- ;;THIS ROUTINE AT THE 'IT' ENTRY POINT CREATES ONE ITEM SEGMENT FOR
- ;;EACH ITEM IN THE P.O. TRANSACTION.
- IT(VAR1,NUM) ;ITEMS INFORMATION SEGMENT
- N B,DC,DIS,I,I0,I2,I4,ITEM,LI,LIN,MPN,N,N1,N1L,N2,N2L,N3,N3L
- N NDC,NL,NSN,PDA,RP,TD,UP,UPN
- S (ITEM,ITEMCNT)=0,TOTAL=$P($G(^PRC(442,VAR1,2,0)),U,4)+7
- F S ITEM=$O(^PRC(442,VAR1,2,ITEM)) Q:ITEM'>0 D
- .K PRCHTP1
- .S I0=$G(^PRC(442,VAR1,2,ITEM,0))
- .S I2=$G(^PRC(442,VAR1,2,ITEM,2))
- .S I4=$G(^PRC(442,VAR1,2,ITEM,4))
- .S PRCHTP1(0,20)="|IT"
- .S PRCHTP1(0,1)=$P(I0,U)
- .S PRCHTP1(0,2)=$P(I0,U,13)
- .S PRCHTP1(1,5)=$P(I0,U,4)
- .S RP=$P(I0,U,5)
- .S NSN=$P(I0,U,13),NSN=$TR(NSN,"-")
- .S MPN="" S:RP'="" MPN=$G(^PRC(441,RP,3))
- .S PRCHTP1(1,13)=$P(MPN,U,5)
- .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
- .S PRCHTP1(1,14)=N,NDC=N
- .S PRCHTP1(1,1)=$P(I0,U,2)\1
- .S UP=$P(I0,U,3),UPN="" S:UP'="" UPN=$G(^PRCD(420.5,UP,0))
- .S UNIT=$P(UPN,U)
- .S PRCHTP1(1,2)=UNIT
- .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
- .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
- .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_"^"
- IT3 .S PRCHTP1(0,3)=$P(MPN,U,8)
- .S PRCHTP1(1,6)=$S($P(I4,U,15)]"":$P(I4,U,15),1:"N")
- .S PRCHTP1(1,7)=$S($P(I4,U,16)]"":$P(I4,U,16),1:"N")
- .S PRCHTP1(1,20)=0
- .D
- ..N I,J S (I,J)=""
- ..;S $P(^PRCF(423,PRCFA("CSDA"),52,0),U,3,4)=$P(^PRC(442,VAR1,2,0),U,3,4)
- ..F S I=$O(PRCHTP1(I)) Q:I="" F S J=$O(PRCHTP1(I,J)) Q:J="" D
- ...;S $P(^PRCF(423,PRCFA("CSDA"),52,ITEM,I),U,J)=PRCHTP1(I,J) Q
- ..S NUM=NUM+1
- ..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^|"
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHHI6 2287 printed Feb 18, 2025@23:34:15 Page 2
- PRCHHI6 ;WISC/TGH-IFCAP SEGMENT IT ;6/19/92 11:20 AM
- V ;;5.1;IFCAP;;Oct 20, 2000
- +1 ;Per VHA Directive 10-93-142, this routine should not be modified.
- +2 ;;
- +3 ;;THIS ROUTINE AT THE 'IT' ENTRY POINT CREATES ONE ITEM SEGMENT FOR
- +4 ;;EACH ITEM IN THE P.O. TRANSACTION.
- IT(VAR1,NUM) ;ITEMS INFORMATION SEGMENT
- +1 NEW B,DC,DIS,I,I0,I2,I4,ITEM,LI,LIN,MPN,N,N1,N1L,N2,N2L,N3,N3L
- +2 NEW NDC,NL,NSN,PDA,RP,TD,UP,UPN
- +3 SET (ITEM,ITEMCNT)=0
- SET TOTAL=$PIECE($GET(^PRC(442,VAR1,2,0)),U,4)+7
- +4 FOR
- SET ITEM=$ORDER(^PRC(442,VAR1,2,ITEM))
- if ITEM'>0
- QUIT
- Begin DoDot:1
- +5 KILL PRCHTP1
- +6 SET I0=$GET(^PRC(442,VAR1,2,ITEM,0))
- +7 SET I2=$GET(^PRC(442,VAR1,2,ITEM,2))
- +8 SET I4=$GET(^PRC(442,VAR1,2,ITEM,4))
- +9 SET PRCHTP1(0,20)="|IT"
- +10 SET PRCHTP1(0,1)=$PIECE(I0,U)
- +11 SET PRCHTP1(0,2)=$PIECE(I0,U,13)
- +12 SET PRCHTP1(1,5)=$PIECE(I0,U,4)
- +13 SET RP=$PIECE(I0,U,5)
- +14 SET NSN=$PIECE(I0,U,13)
- SET NSN=$TRANSLATE(NSN,"-")
- +15 SET MPN=""
- if RP'=""
- SET MPN=$GET(^PRC(441,RP,3))
- +16 SET PRCHTP1(1,13)=$PIECE(MPN,U,5)
- +17 SET N=$PIECE(I0,U,15)
- IF N]""
- SET N1=$PIECE(N,"-")
- SET N2=$PIECE(N,"-",2)
- SET N3=$PIECE(N,"-",3)
- SET N1="000000"_N1
- SET N1L=$LENGTH(N1)
- SET N1=$EXTRACT(N1,N1L-5,N1L)
- SET N2="0000"_N2
- SET N2L=$LENGTH(N2)
- SET N2=$EXTRACT(N2,N2L-3,N2L)
- SET N3="00"_N3
- SET N3L=$LENGTH(N3)
- SET N3=$EXTRACT(N3,N3L-1,N3L)
- SET N=N1_N2_N3
- +18 SET PRCHTP1(1,14)=N
- SET NDC=N
- +19 SET PRCHTP1(1,1)=$PIECE(I0,U,2)\1
- +20 SET UP=$PIECE(I0,U,3)
- SET UPN=""
- if UP'=""
- SET UPN=$GET(^PRCD(420.5,UP,0))
- +21 SET UNIT=$PIECE(UPN,U)
- +22 SET PRCHTP1(1,2)=UNIT
- +23 SET LIN=$PIECE(I0,U)
- SET (DIS,TD)=0
- FOR
- SET DIS=$ORDER(^PRC(442,VAR1,3,DIS))
- if DIS'>0
- GOTO IT3
- SET DC=$GET(^PRC(442,VAR1,3,DIS,0))
- SET LI=$PIECE(DC,U,6)
- if LIN=LI
- QUIT
- +24 SET PDA=$PIECE(DC,U,2)
- IF $EXTRACT(PDA,1)'="$"
- SET TD=1
- SET N=$PIECE(PDA,".")
- SET N1=$PIECE(PDA,".",2)
- SET N="00"_N
- SET NL=$LENGTH(N)
- SET N=$EXTRACT(N,NL-1,NL)
- SET N1=N1_"00"
- SET N1=$EXTRACT(N1,1,2)
- SET N=N_N1
- SET B=B_N_"^^"
- GOTO IT3
- +25 SET TD=1
- SET PDA=$EXTRACT(PDA,2,99)
- SET N=$PIECE(PDA,".")
- SET N1=$PIECE(PDA,".",2)
- SET N="0000000"_N
- SET NL=$LENGTH(N)
- SET N=$EXTRACT(N,NL-6,NL)
- SET N1=N1_"00"
- SET N1=$EXTRACT(N1,1,2)
- SET N=N_N1
- SET B=B_"^"_N_"^"
- IT3 SET PRCHTP1(0,3)=$PIECE(MPN,U,8)
- +1 SET PRCHTP1(1,6)=$SELECT($PIECE(I4,U,15)]"":$PIECE(I4,U,15),1:"N")
- +2 SET PRCHTP1(1,7)=$SELECT($PIECE(I4,U,16)]"":$PIECE(I4,U,16),1:"N")
- +3 SET PRCHTP1(1,20)=0
- +4 Begin DoDot:2
- +5 NEW I,J
- SET (I,J)=""
- +6 ;S $P(^PRCF(423,PRCFA("CSDA"),52,0),U,3,4)=$P(^PRC(442,VAR1,2,0),U,3,4)
- +7 FOR
- SET I=$ORDER(PRCHTP1(I))
- if I=""
- QUIT
- FOR
- SET J=$ORDER(PRCHTP1(I,J))
- if J=""
- QUIT
- Begin DoDot:3
- +8 ;S $P(^PRCF(423,PRCFA("CSDA"),52,ITEM,I),U,J)=PRCHTP1(I,J) Q
- End DoDot:3
- +9 SET NUM=NUM+1
- +10 SET ^TMP($JOB,"STRING",NUM)="IT"_"^"_$PIECE(I0,U)_"^"_NSN_"^^^"_$PIECE(MPN,U,5)_"^"_NDC_"^"_$PIECE(I0,U,2)_"^"_UNIT_"^^^^^"_$PIECE(MPN,U,8)_"^^"_$PIECE(I0,U,4)_"^Y^N^^^0^|"
- End DoDot:2
- End DoDot:1