PRCHED10 ;WISC/TGH-IFCAP SEGMENT DL -(Partial's) ;1/30/92 3:41 PM
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
;;
DL(VAR1,PRCHPAR) ;Prism delivery Order Line
N A2,A3,DAT,DESCLN,SKU,X,Y,I0,I2,I4,ITEM
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 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"
.;REC DATE
.;SKU TOTAL
.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 #
.;STATUS
.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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHED10 1106 printed Nov 22, 2024@17:17:17 Page 2
PRCHED10 ;WISC/TGH-IFCAP SEGMENT DL -(Partial's) ;1/30/92 3:41 PM
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 ;;
DL(VAR1,PRCHPAR) ;Prism delivery Order Line
+1 NEW A2,A3,DAT,DESCLN,SKU,X,Y,I0,I2,I4,ITEM
+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 I0=$GET(^PRC(442,VAR1,2,ITEM,0))
+7 ;S DESCLN=$G(^PRC(442,VAR1,2,ITEM,1,0)),DESCLN=$P(DESCLN,U,4)
+8 SET I2=$GET(^PRC(442,VAR1,2,ITEM,2))
+9 SET I4=$GET(^PRC(442,VAR1,2,ITEM,4))
+10 ;
+11 SET PRCHTP1(0,20)="|DL"
+12 ;REC DATE
+13 ;SKU TOTAL
+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 ;STATUS
+18 SET PRCHTP1(1,10)=0
+19 Begin DoDot:2
+20 NEW I,J
SET (I,J)=""
+21 SET $PIECE(^PRCF(423,PRCFA("CSDA"),52,0),U,3,4)=$PIECE(^PRC(442,VAR1,2,0),U,3,4)
+22 FOR
SET I=$ORDER(PRCHTP1(I))
if I=""
QUIT
FOR
SET J=$ORDER(PRCHTP1(I,J))
if J=""
QUIT
Begin DoDot:3
+23 SET $PIECE(^PRCF(423,PRCFA("CSDA"),52,ITEM,I),U,J)=PRCHTP1(I,J)
+24 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
