PRCHHI10 ;WISC/TGH-IFCAP SEGMENT DL - ('RC1' Partial's) ;6/19/92 11:25 AM
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
;;
DL(VAR1,PRCHPAR,NUM) ;Prism delivery Order Line
Q:'$D(^PRC(442,VAR1,2,"AB",PRCHPAR))
N A2,A3,DAT,DESCLN,NSN,PART,SKU,X,Y,I0,I2,I4,ITEM,BLANKS,LP,PRCHLINO,PRCHLIFI,PRCHLITM,PRCHDESC,PRCHDESP,PRCHDELE
S (ITEM,ITEMCNT,PART)=0,TOTAL=$P($G(^PRC(442,VAR1,2,0)),U,4)+7
S A2=2,A3="DE"
F S ITEM=$O(^PRC(442,VAR1,2,"AB",PRCHPAR,ITEM)) Q:ITEM="" D
.F S PART=$O(^PRC(442,VAR1,2,"AB",PRCHPAR,ITEM,PART)) Q:PART="" D
..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,3,PART,0))
..S X=$P($P(I4,U),".") D JD^PRCFDLN S DAT=$E(X,1,3)+1700_$E(Y,1,3)
..S PRCHTP1(0,20)="|DL"
..S PRCHTP(1,18)=DAT ;DATE RECEIVED
..S PRCHTP(0,8)=$P(I4,U,2) ;QTY RECEIVED
..S PRCHTP1(0,2)=$P(I0,U,13) ;NSN
..S PRCHTP1(0,1)=$P(I0,U) ;ITEM LINE NO.
..S PRCHTP1(1,8)=$P(I2,U,2) ;CONTRACT #
..S PRCHTP1(1,10)=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 NSN=$P(I0,U,13),NSN=$TR(NSN,"-")
...;AFTER DASHES ARE REMOVED FR NSN, PAD UPTO 20 SPACES W BLANKS
...I $L(NSN)<20 S NSN=NSN_" ",NSN=$E(NSN,1,20)
...;
...;LINE ITEM NUMBER'S FORMAT W LEADING ZEROS UPTO 3 DIGITS
...S PRCHLITM=$P(I0,U),PRCHLINO="00"_PRCHLITM
...S PRCHLINO=$E(PRCHLINO,$L(PRCHLINO)-2,99)
...;
...;#DE SEGMENT (DESCR LINE COUNT) FORMAT UPTO 3 CHARS. W LEADING ZEROS
...S PRCHDESC=$P(I2,U,4),PRCHDELE="00"_PRCHDESC
...I $D(PRCHDESC) S PRCHDESP=$E(PRCHDELE,$L(PRCHDELE)-2,99)
...;
...S ^TMP($J,"STRING",NUM)="DL"_"^"_DAT_"^"_$P(I4,U,2)_"^"_NSN_"^"_PRCHLINO_"^"_$P(I2,U,2)_"^^^^^^^^^^"_"STATUS^PRCHDESP^|"
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHHI10 1997 printed Sep 23, 2025@19:43:51 Page 2
PRCHHI10 ;WISC/TGH-IFCAP SEGMENT DL - ('RC1' Partial's) ;6/19/92 11:25 AM
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 ;;
DL(VAR1,PRCHPAR,NUM) ;Prism delivery Order Line
+1 if '$DATA(^PRC(442,VAR1,2,"AB",PRCHPAR))
QUIT
+2 NEW A2,A3,DAT,DESCLN,NSN,PART,SKU,X,Y,I0,I2,I4,ITEM,BLANKS,LP,PRCHLINO,PRCHLIFI,PRCHLITM,PRCHDESC,PRCHDESP,PRCHDELE
+3 SET (ITEM,ITEMCNT,PART)=0
SET TOTAL=$PIECE($GET(^PRC(442,VAR1,2,0)),U,4)+7
+4 SET A2=2
SET A3="DE"
+5 FOR
SET ITEM=$ORDER(^PRC(442,VAR1,2,"AB",PRCHPAR,ITEM))
if ITEM=""
QUIT
Begin DoDot:1
+6 FOR
SET PART=$ORDER(^PRC(442,VAR1,2,"AB",PRCHPAR,ITEM,PART))
if PART=""
QUIT
Begin DoDot:2
+7 SET I0=$GET(^PRC(442,VAR1,2,ITEM,0))
+8 SET I2=$GET(^PRC(442,VAR1,2,ITEM,2))
+9 SET I4=$GET(^PRC(442,VAR1,2,ITEM,3,PART,0))
+10 SET X=$PIECE($PIECE(I4,U),".")
DO JD^PRCFDLN
SET DAT=$EXTRACT(X,1,3)+1700_$EXTRACT(Y,1,3)
+11 SET PRCHTP1(0,20)="|DL"
+12 ;DATE RECEIVED
SET PRCHTP(1,18)=DAT
+13 ;QTY RECEIVED
SET PRCHTP(0,8)=$PIECE(I4,U,2)
+14 ;NSN
SET PRCHTP1(0,2)=$PIECE(I0,U,13)
+15 ;ITEM LINE NO.
SET PRCHTP1(0,1)=$PIECE(I0,U)
+16 ;CONTRACT #
SET PRCHTP1(1,8)=$PIECE(I2,U,2)
+17 SET PRCHTP1(1,10)=0
+18 Begin DoDot:3
+19 NEW I,J
SET (I,J)=""
+20 ;S $P(^PRCF(423,PRCFA("CSDA"),52,0),U,3,4)=$P(^PRC(442,VAR1,2,0),U,3,4)
+21 FOR
SET I=$ORDER(PRCHTP1(I))
if I=""
QUIT
FOR
SET J=$ORDER(PRCHTP1(I,J))
if J=""
QUIT
Begin DoDot:4
+22 ;S $P(^PRCF(423,PRCFA("CSDA"),52,ITEM,I),U,J)=PRCHTP1(I,J)
+23 QUIT
End DoDot:4
+24 SET NUM=NUM+1
+25 SET NSN=$PIECE(I0,U,13)
SET NSN=$TRANSLATE(NSN,"-")
+26 ;AFTER DASHES ARE REMOVED FR NSN, PAD UPTO 20 SPACES W BLANKS
+27 IF $LENGTH(NSN)<20
SET NSN=NSN_" "
SET NSN=$EXTRACT(NSN,1,20)
+28 ;
+29 ;LINE ITEM NUMBER'S FORMAT W LEADING ZEROS UPTO 3 DIGITS
+30 SET PRCHLITM=$PIECE(I0,U)
SET PRCHLINO="00"_PRCHLITM
+31 SET PRCHLINO=$EXTRACT(PRCHLINO,$LENGTH(PRCHLINO)-2,99)
+32 ;
+33 ;#DE SEGMENT (DESCR LINE COUNT) FORMAT UPTO 3 CHARS. W LEADING ZEROS
+34 SET PRCHDESC=$PIECE(I2,U,4)
SET PRCHDELE="00"_PRCHDESC
+35 IF $DATA(PRCHDESC)
SET PRCHDESP=$EXTRACT(PRCHDELE,$LENGTH(PRCHDELE)-2,99)
+36 ;
+37 SET ^TMP($JOB,"STRING",NUM)="DL"_"^"_DAT_"^"_$PIECE(I4,U,2)_"^"_NSN_"^"_PRCHLINO_"^"_$PIECE(I2,U,2)_"^^^^^^^^^^"_"STATUS^PRCHDESP^|"
End DoDot:3
End DoDot:2
End DoDot:1
