Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PRCHHI10

PRCHHI10.m

Go to the documentation of this file.
  1. PRCHHI10 ;WISC/TGH-IFCAP SEGMENT DL - ('RC1' Partial's) ;6/19/92 11:25 AM
  1. V ;;5.1;IFCAP;;Oct 20, 2000
  1. ;Per VHA Directive 10-93-142, this routine should not be modified.
  1. ;;
  1. DL(VAR1,PRCHPAR,NUM) ;Prism delivery Order Line
  1. Q:'$D(^PRC(442,VAR1,2,"AB",PRCHPAR))
  1. N A2,A3,DAT,DESCLN,NSN,PART,SKU,X,Y,I0,I2,I4,ITEM,BLANKS,LP,PRCHLINO,PRCHLIFI,PRCHLITM,PRCHDESC,PRCHDESP,PRCHDELE
  1. S (ITEM,ITEMCNT,PART)=0,TOTAL=$P($G(^PRC(442,VAR1,2,0)),U,4)+7
  1. S A2=2,A3="DE"
  1. F S ITEM=$O(^PRC(442,VAR1,2,"AB",PRCHPAR,ITEM)) Q:ITEM="" D
  1. .F S PART=$O(^PRC(442,VAR1,2,"AB",PRCHPAR,ITEM,PART)) Q:PART="" D
  1. ..S I0=$G(^PRC(442,VAR1,2,ITEM,0))
  1. ..S I2=$G(^PRC(442,VAR1,2,ITEM,2))
  1. ..S I4=$G(^PRC(442,VAR1,2,ITEM,3,PART,0))
  1. ..S X=$P($P(I4,U),".") D JD^PRCFDLN S DAT=$E(X,1,3)+1700_$E(Y,1,3)
  1. ..S PRCHTP1(0,20)="|DL"
  1. ..S PRCHTP(1,18)=DAT ;DATE RECEIVED
  1. ..S PRCHTP(0,8)=$P(I4,U,2) ;QTY RECEIVED
  1. ..S PRCHTP1(0,2)=$P(I0,U,13) ;NSN
  1. ..S PRCHTP1(0,1)=$P(I0,U) ;ITEM LINE NO.
  1. ..S PRCHTP1(1,8)=$P(I2,U,2) ;CONTRACT #
  1. ..S PRCHTP1(1,10)=0
  1. ..D
  1. ...N I,J S (I,J)=""
  1. ...;S $P(^PRCF(423,PRCFA("CSDA"),52,0),U,3,4)=$P(^PRC(442,VAR1,2,0),U,3,4)
  1. ...F S I=$O(PRCHTP1(I)) Q:I="" F S J=$O(PRCHTP1(I,J)) Q:J="" D
  1. ....;S $P(^PRCF(423,PRCFA("CSDA"),52,ITEM,I),U,J)=PRCHTP1(I,J)
  1. ....Q
  1. ...S NUM=NUM+1
  1. ...S NSN=$P(I0,U,13),NSN=$TR(NSN,"-")
  1. ...;AFTER DASHES ARE REMOVED FR NSN, PAD UPTO 20 SPACES W BLANKS
  1. ...I $L(NSN)<20 S NSN=NSN_" ",NSN=$E(NSN,1,20)
  1. ...;
  1. ...;LINE ITEM NUMBER'S FORMAT W LEADING ZEROS UPTO 3 DIGITS
  1. ...S PRCHLITM=$P(I0,U),PRCHLINO="00"_PRCHLITM
  1. ...S PRCHLINO=$E(PRCHLINO,$L(PRCHLINO)-2,99)
  1. ...;
  1. ...;#DE SEGMENT (DESCR LINE COUNT) FORMAT UPTO 3 CHARS. W LEADING ZEROS
  1. ...S PRCHDESC=$P(I2,U,4),PRCHDELE="00"_PRCHDESC
  1. ...I $D(PRCHDESC) S PRCHDESP=$E(PRCHDELE,$L(PRCHDELE)-2,99)
  1. ...;
  1. ...S ^TMP($J,"STRING",NUM)="DL"_"^"_DAT_"^"_$P(I4,U,2)_"^"_NSN_"^"_PRCHLINO_"^"_$P(I2,U,2)_"^^^^^^^^^^"_"STATUS^PRCHDESP^|"