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