- 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 Feb 18, 2025@23:34:10 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