- PRCHHI7 ;WISC/TGH-IFCAP SEGMENT DL -(IT) ;8/12/92 10:00 AM
- V ;;5.1;IFCAP;;Oct 20, 2000
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- ;;
- DL(A,VAR1,NUM,DLCNT) ;Prism delivery Order Line
- N A2,A3,DAT,DESCLN,SKU,X,Y,I0,I2,I4,ITEM,KEPNUM,PRCHNSN,PRCHDIFF,PRCHQTY,PRCHJUDT
- S (ITEM,ITEMCNT)=0,TOTAL=$P($G(^PRC(442,VAR1,2,0)),U,4)+7
- S A2=2,A3="DE"
- D NOW^%DTC S X=$P(%,".") D JD^PRCFDLN S DAT=$E(X,1,3)+1700_$E(Y,1,3)
- F S ITEM=$O(^PRC(442,VAR1,2,ITEM)) K PRCHTP1 Q:ITEM'>0 D
- .S DLCNT=DLCNT+1
- .S I0=$G(^PRC(442,VAR1,2,ITEM,0))
- .S DESCLN=$G(^PRC(442,VAR1,2,ITEM,1,0)),DESCLN=$P(DESCLN,U,4)
- .S I2=$G(^PRC(442,VAR1,2,ITEM,2))
- .S I4=$G(^PRC(442,VAR1,2,ITEM,4))
- .;
- .S PRCHTP1(0,20)="|DL"
- .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(0,11)=$P(A,U,10) ;DEL DATE
- .S PRCHTP1(1,1)=$P(I0,U,2)\1 ;QTY ORDERED
- .S SKU=$P(I0,U,16) I SKU]"" S SKU=$G(^PRCD(420.5,SKU,0))
- .S PRCHTP1(0,3)=$P(SKU,U)
- .S PRCHTP1(1,10)=DESCLN
- .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
- ..; WAS 3.'s $P(^PRCF(423,PRCFA("CSDA"),52,ITEM,I),U,J)=PRCHTP1(I,J)
- ..;REMOVE DASHES FROM NSN & FORMAT UPTO 20 CHARS W TRAILING SPACES
- ..S PRCHNSN=$TR($P(I0,U,13),"-")
- ..I $D(PRCHNSN) S PRCHNSN=PRCHNSN_" ",PRCHNSN=$E(PRCHNSN,1,20)
- ..;
- ..;LINE ITEM NUMBER FORMAT UPTO 3 CHARS W LEADING ZEROS
- ..S PRCHLINU=$P(I0,U),PRCHLINE="00"_PRCHLINU
- ..I $D(PRCHLINU) S PRCHLINE=$E(PRCHLINE,$L(PRCHLINE)-2,99)
- ..;
- ..;REQUESTED DEL DATE FORMAT UPTO 7 CHARS W JULIAN DATE
- ..S X=$P(A,U,10) D JD^PRCFDLN S PRCHJUDT=$E(X,1,3)+1700_$E(Y,1,3)
- ..;
- ..;QTY ORDERED FORMATTED UPTO 9 CHARS W LEADING ZEROS & 2 DEC. IMPLIED
- ..S PRCHQTY=$TR($J($P(I0,U,2),0,2),".")
- ..S PRCHQTY="000000000"_PRCHQTY
- ..S PRCHQTY=$E(PRCHQTY,$L(PRCHQTY)-8,99)
- ..;
- ..S NUM=NUM+1
- ..S ^TMP($J,"STRING",NUM)="DL"_"^^^"_PRCHNSN_"^"_PRCHLINE_"^"_$P(I2,U,2)_"^^"_PRCHJUDT_"^"_PRCHQTY_"^^^^"_$P(SKU,U)_"^^^^^|"
- ..S KEPNUM=NUM D CO^PRCHHI9(A2,A3,VAR1,ITEM,.NUM)
- ..;
- ..;#DE SEGMENT (DESCR. COUNT) FORMATTED UPTO 3 CHARS W LEADING ZEROS
- ..;IN DL STRING (3lines above) THE 17Tth piece is set to null
- ..S PRCHDIFF=NUM-KEPNUM,PRCHDIFF="00"_PRCHDIFF
- ..S PRCHDIFF=$E(PRCHDIFF,$L(PRCHDIFF)-2,99)
- ..S $P(^TMP($J,"STRING",KEPNUM),U,17)=PRCHDIFF
- ..Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHHI7 2513 printed Feb 18, 2025@23:34:16 Page 2
- PRCHHI7 ;WISC/TGH-IFCAP SEGMENT DL -(IT) ;8/12/92 10:00 AM
- V ;;5.1;IFCAP;;Oct 20, 2000
- +1 ;Per VHA Directive 10-93-142, this routine should not be modified.
- +2 ;;
- DL(A,VAR1,NUM,DLCNT) ;Prism delivery Order Line
- +1 NEW A2,A3,DAT,DESCLN,SKU,X,Y,I0,I2,I4,ITEM,KEPNUM,PRCHNSN,PRCHDIFF,PRCHQTY,PRCHJUDT
- +2 SET (ITEM,ITEMCNT)=0
- SET TOTAL=$PIECE($GET(^PRC(442,VAR1,2,0)),U,4)+7
- +3 SET A2=2
- SET A3="DE"
- +4 DO NOW^%DTC
- SET X=$PIECE(%,".")
- DO JD^PRCFDLN
- SET DAT=$EXTRACT(X,1,3)+1700_$EXTRACT(Y,1,3)
- +5 FOR
- SET ITEM=$ORDER(^PRC(442,VAR1,2,ITEM))
- KILL PRCHTP1
- if ITEM'>0
- QUIT
- Begin DoDot:1
- +6 SET DLCNT=DLCNT+1
- +7 SET I0=$GET(^PRC(442,VAR1,2,ITEM,0))
- +8 SET DESCLN=$GET(^PRC(442,VAR1,2,ITEM,1,0))
- SET DESCLN=$PIECE(DESCLN,U,4)
- +9 SET I2=$GET(^PRC(442,VAR1,2,ITEM,2))
- +10 SET I4=$GET(^PRC(442,VAR1,2,ITEM,4))
- +11 ;
- +12 SET PRCHTP1(0,20)="|DL"
- +13 ;NSN
- SET PRCHTP1(0,2)=$PIECE(I0,U,13)
- +14 ;ITEM LINE NO.
- SET PRCHTP1(0,1)=$PIECE(I0,U)
- +15 ;CONTRACT #
- SET PRCHTP1(1,8)=$PIECE(I2,U,2)
- +16 ;DEL DATE
- SET PRCHTP1(0,11)=$PIECE(A,U,10)
- +17 ;QTY ORDERED
- SET PRCHTP1(1,1)=$PIECE(I0,U,2)\1
- +18 SET SKU=$PIECE(I0,U,16)
- IF SKU]""
- SET SKU=$GET(^PRCD(420.5,SKU,0))
- +19 SET PRCHTP1(0,3)=$PIECE(SKU,U)
- +20 SET PRCHTP1(1,10)=DESCLN
- +21 Begin DoDot:2
- +22 NEW I,J
- SET (I,J)=""
- +23 ;S $P(^PRCF(423,PRCFA("CSDA"),52,0),U,3,4)=$P(^PRC(442,VAR1,2,0),U,3,4)
- +24 ;F S I=$O(PRCHTP1(I)) Q:I="" F S J=$O(PRCHTP1(I,J)) Q:J="" D
- +25 ; WAS 3.'s $P(^PRCF(423,PRCFA("CSDA"),52,ITEM,I),U,J)=PRCHTP1(I,J)
- +26 ;REMOVE DASHES FROM NSN & FORMAT UPTO 20 CHARS W TRAILING SPACES
- +27 SET PRCHNSN=$TRANSLATE($PIECE(I0,U,13),"-")
- +28 IF $DATA(PRCHNSN)
- SET PRCHNSN=PRCHNSN_" "
- SET PRCHNSN=$EXTRACT(PRCHNSN,1,20)
- +29 ;
- +30 ;LINE ITEM NUMBER FORMAT UPTO 3 CHARS W LEADING ZEROS
- +31 SET PRCHLINU=$PIECE(I0,U)
- SET PRCHLINE="00"_PRCHLINU
- +32 IF $DATA(PRCHLINU)
- SET PRCHLINE=$EXTRACT(PRCHLINE,$LENGTH(PRCHLINE)-2,99)
- +33 ;
- +34 ;REQUESTED DEL DATE FORMAT UPTO 7 CHARS W JULIAN DATE
- +35 SET X=$PIECE(A,U,10)
- DO JD^PRCFDLN
- SET PRCHJUDT=$EXTRACT(X,1,3)+1700_$EXTRACT(Y,1,3)
- +36 ;
- +37 ;QTY ORDERED FORMATTED UPTO 9 CHARS W LEADING ZEROS & 2 DEC. IMPLIED
- +38 SET PRCHQTY=$TRANSLATE($JUSTIFY($PIECE(I0,U,2),0,2),".")
- +39 SET PRCHQTY="000000000"_PRCHQTY
- +40 SET PRCHQTY=$EXTRACT(PRCHQTY,$LENGTH(PRCHQTY)-8,99)
- +41 ;
- +42 SET NUM=NUM+1
- +43 SET ^TMP($JOB,"STRING",NUM)="DL"_"^^^"_PRCHNSN_"^"_PRCHLINE_"^"_$PIECE(I2,U,2)_"^^"_PRCHJUDT_"^"_PRCHQTY_"^^^^"_$PIECE(SKU,U)_"^^^^^|"
- +44 SET KEPNUM=NUM
- DO CO^PRCHHI9(A2,A3,VAR1,ITEM,.NUM)
- +45 ;
- +46 ;#DE SEGMENT (DESCR. COUNT) FORMATTED UPTO 3 CHARS W LEADING ZEROS
- +47 ;IN DL STRING (3lines above) THE 17Tth piece is set to null
- +48 SET PRCHDIFF=NUM-KEPNUM
- SET PRCHDIFF="00"_PRCHDIFF
- +49 SET PRCHDIFF=$EXTRACT(PRCHDIFF,$LENGTH(PRCHDIFF)-2,99)
- +50 SET $PIECE(^TMP($JOB,"STRING",KEPNUM),U,17)=PRCHDIFF
- +51 QUIT
- End DoDot:2
- End DoDot:1