| [613] | 1 | PRCHQ2A ;(WASH IRMFO)/LKG-RFQ Enter/Edit ;8/6/96 20:50
|
|---|
| 2 | ;;5.1;IFCAP;;Oct 20, 2000
|
|---|
| 3 | ;Per VHA Directive 10-93-142, this routine should not be modified.
|
|---|
| 4 | IT ;Entrance point for copying 2237's item information into RFQ entry
|
|---|
| 5 | N PRCE,PRCI,PRCJ,PRCK,PRCL,PRCM,PRCN,PRCP,PRCQ,PRCX,PRCY
|
|---|
| 6 | S PRCI=0,PRCJ=$P($G(^PRC(444,PRCDA,2,0)),U,3,4),PRCQ=$P(PRCJ,U,2),PRCJ=$P(PRCJ,U)
|
|---|
| 7 | F S PRCI=$O(^PRCS(410,PRCDA410,"IT",PRCI)) Q:PRCI'?1.N D
|
|---|
| 8 | . K PRCK S PRCK(0)=$G(^PRCS(410,PRCDA410,"IT",PRCI,0))
|
|---|
| 9 | . Q:'$D(^PRCS(410,PRCDA410,"IT","AB",$P(PRCK(0),U)))
|
|---|
| 10 | . S PRCJ=PRCJ+1,PRCQ=PRCQ+1
|
|---|
| 11 | . S PRCE(0)=PRCJ_U_$P(PRCK(0),U,2)_U_$P(PRCK(0),U,3)
|
|---|
| 12 | . S PRCP=0,PRCL=0
|
|---|
| 13 | . F S PRCP=$O(^PRCS(410,PRCDA410,"IT",PRCI,1,PRCP)) Q:PRCP="" D
|
|---|
| 14 | . . S:$D(^PRCS(410,PRCDA410,"IT",PRCI,1,PRCP,0)) PRCL=PRCL+1,^PRC(444,PRCDA,2,PRCJ,2,PRCL,0)=^(0)
|
|---|
| 15 | . I $P(PRCK(0),U,6)]"" S PRCL=PRCL+1,^PRC(444,PRCDA,2,PRCJ,2,PRCL,0)="Stock #: "_$P(PRCK(0),U,6)
|
|---|
| 16 | . S:PRCL>0 ^PRC(444,PRCDA,2,PRCJ,2,0)="^^"_PRCL_U_PRCL_U_DT_"^^^^"
|
|---|
| 17 | . S:$P(PRCK(0),U,4)]"" $P(^PRC(444,PRCDA,2,PRCJ,1),U,8)=+$P(PRCK(0),U,4)
|
|---|
| 18 | . S PRCM=$P(PRCK(0),U,5)
|
|---|
| 19 | . I PRCM?1.N D
|
|---|
| 20 | . . S PRCL=$P($G(^PRC(444,PRCDA,2,PRCJ,2,0)),U,3)+0,PRCP=0
|
|---|
| 21 | . . F S PRCP=$O(^PRC(441,PRCM,1,PRCP)) Q:PRCP="" D
|
|---|
| 22 | . . . S:$D(^PRC(441,PRCM,1,PRCP,0)) PRCL=PRCL+1,^PRC(444,PRCDA,2,PRCJ,2,PRCL,0)=^(0)
|
|---|
| 23 | . . S:PRCL>0 ^PRC(444,PRCDA,2,PRCJ,2,0)="^^"_PRCL_U_PRCL_U_DT_"^^^^"
|
|---|
| 24 | . . S $P(PRCE(0),U,4)=PRCM,PRCL=$G(^PRC(441,PRCM,0))
|
|---|
| 25 | . . S $P(PRCE(0),U,5,6)=$P(PRCL,U,3)_U_$P(PRCL,U,5)
|
|---|
| 26 | . . S $P(PRCE(0),U,7)=$P($G(^PRC(441,PRCM,3)),U,10)
|
|---|
| 27 | . . S $P(PRCE(0),U,11)=$P(PRCL,U,14)
|
|---|
| 28 | . . S $P(^PRC(444,PRCDA,2,PRCJ,5),U)=$P(PRCL,U,2)
|
|---|
| 29 | . . S PRCX=$P(PRCL,U,4)
|
|---|
| 30 | . . I PRCX?1.N D
|
|---|
| 31 | . . . S PRCN=$G(^PRC(441,PRCM,2,PRCX,0))
|
|---|
| 32 | . . . S $P(PRCE(0),U,8)=$P(PRCN,U,5)
|
|---|
| 33 | . . . S $P(^PRC(444,PRCDA,2,PRCJ,1),U,3,7)=$P(PRCN,U)_U_$P(PRCN,U,4)_U_$P(PRCN,U,2)_U_$P(PRCN,U,7)_U_$P(PRCN,U,6)
|
|---|
| 34 | . . S PRCX=$S($P(PRC410(3),U,4)]"":$P(PRC410(3),U,4),$P(PRCL,U,4)]"":$P(PRCL,U,4),1:"")
|
|---|
| 35 | . . I PRCX]"" D
|
|---|
| 36 | . . . S PRCN=$G(^PRC(441,PRCM,2,PRCX,0))
|
|---|
| 37 | . . . S X=$P(PRCN,U,8) Q:X=""
|
|---|
| 38 | . . . S X="PACKAGING MULTIPLE: "_X,Y=$P(PRCN,U,7)
|
|---|
| 39 | . . . S:Y]"" X=X_"/"_$P($G(^PRCD(420.5,Y,0)),U)
|
|---|
| 40 | . . . S Y=$P($G(^PRC(444,PRCDA,2,PRCJ,2,0)),U,3)+1
|
|---|
| 41 | . . . S ^PRC(444,PRCDA,2,PRCJ,2,Y,0)=X
|
|---|
| 42 | . . . S ^PRC(444,PRCDA,2,PRCJ,2,0)="^^"_Y_U_Y_U_DT_"^^^^"
|
|---|
| 43 | . . S $P(PRCE(0),U,9)=$P($G(^PRC(441,PRCM,3)),U,5)
|
|---|
| 44 | . S ^PRC(444,PRCDA,2,PRCJ,0)=PRCE(0)
|
|---|
| 45 | . S ^PRC(444,PRCDA,2,PRCJ,3)=PRCDA410_U_$P(PRCK(0),U)_U_U_U_U_U_U_U_U_$P(PRCK(0),U,7)
|
|---|
| 46 | . S PRCL=0,PRCP=0
|
|---|
| 47 | . F S PRCP=$O(^PRCS(410,PRCDA410,"IT",PRCI,2,PRCP)) Q:PRCP'?1.N D
|
|---|
| 48 | . . S PRCX=$G(^PRCS(410,PRCDA410,"IT",PRCI,2,PRCP,0)) Q:PRCX=""
|
|---|
| 49 | . . S PRCL=PRCL+1,^PRC(444,PRCDA,2,PRCJ,4,PRCL,0)=$P(PRCX,U)_U
|
|---|
| 50 | . . S PRCX=$P(PRCX,U,2)
|
|---|
| 51 | . . I PRCX?1.N D
|
|---|
| 52 | . . . S PRCY=$G(^PRCS(410.6,PRCX,0)) Q:PRCY=""
|
|---|
| 53 | . . . S $P(^PRC(444,PRCDA,2,PRCJ,4,PRCL,0),U,2,6)=$P(PRCY,U,2)_U_$P(PRCY,U,4)_U_$P(PRCY,U,3)_U_$P(PRCY,U,5)_U_PRCX
|
|---|
| 54 | . S:PRCL>0 ^PRC(444,PRCDA,2,PRCJ,4,0)=U_$P(^DD(444.019,20,0),U,2)_U_PRCL_U_PRCL
|
|---|
| 55 | . I $P($G(^PRC(444,PRCDA,2,PRCJ,5)),U)="" D
|
|---|
| 56 | . . S PRCL=$O(^PRC(444,PRCDA,2,PRCJ,2,0)) Q:PRCL=""
|
|---|
| 57 | . . S $P(^PRC(444,PRCDA,2,PRCJ,5),U)=$E($G(^PRC(444,PRCDA,2,PRCJ,2,PRCL,0)),1,60)
|
|---|
| 58 | S:PRCJ>0 ^PRC(444,PRCDA,2,0)=U_$P(^DD(444,19,0),U,2)_U_PRCJ_U_PRCQ
|
|---|
| 59 | Q
|
|---|
