source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHHI10.m@ 1500

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^|"