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 Apr 09, 2024@21:09 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
