Routine: PRCHED10

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  Apr 09, 2024@21:15:41                                                                                                                                                                                                    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

PRCHED10.m