PRCHQ41B ;WISC/KMB-CREATE 2237 FOR RFQ ;10/21/96 11:07
;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
Q
IN D VENDOR
S X=$P($G(^PRC(444,SDA,0)),U,9),X=$S(X>0:$P($G(^PRCS(410,X,7)),U,3),1:0)
S DA=XDA,MESSAGE="" D ENCODE^PRCSC1(DA,X,.MESSAGE) K MESSAGE
S X=+$P($G(^PRCS(410,XDA,4)),U) D TRANS^PRCSES
K DA S PRCSSCP=0,DA=XDA
F PRCSSI=1:1 S PRCSSCP=$O(^PRCS(410,DA,12,PRCSSCP)) Q:PRCSSCP'>0 D
. Q:'$D(^PRCS(410,DA,12,PRCSSCP,0)) S X=$P(^(0),U,2) Q:X'>0
. S DA(1)=DA,DA=PRCSSCP D TRANS^PRCSEZZ
. S DA=DA(1)
S PRCSCP=$S($D(^PRC(420,PRC("SITE"),1,+PRC("CP"),0)):$P(^(0),U,12),1:"")
S X=$P(^PRCS(410,XDA,0),U),DIC="^PRC(443,",DIC(0)="L",DLAYGO=443
D ^DIC K DIC,DLAYGO,X S DA=+Y
L +^PRC(443,DA):15 E W !,"*** Unable to lock REQUEST WORKSHEET File entry!" L -^PRCS(410,XDA) G EX
S X=$G(^VA(200,DUZ,20))
S PRC("PER")=DUZ_U_$P(X,U,2)_U_$P(X,U,3)_U_$S($D(^VA(200,DUZ,.13)):$P(^(.13),U,2),1:"")
S DIE=443
S PRCX=$G(^PRC(443,PRC410DA,0))
S PRCY=$P(PRCX,U,9) I PRCY]"" S DR="9////^S X=PRCY" D ^DIE
S PRCY=$P(PRCX,U,10) I PRCY]"" S DR="10////^S X=PRCY" D ^DIE
S PRCY=$P(^PRCS(410,DA,0),U,6) I PRCY]"" S DR="11////^S X=PRCY" D ^DIE
S PRCY=$P(PRCX,U,12) I PRCY]"" S DR="13////^S X=PRCY" D ^DIE
S DR="1.5///70;2////^S X=+PRC(""PER"")" D ^DIE
K DIE,DR
D
. N PRCHG,P,PRCSIG,ROUTINE
. D ES1^PRCHG
L -^PRC(443,DA)
S DA=XDA D EN2^PRCPWI
;
S PRCY=0
F S PRCY=$O(^TMP($J,"PRCHQ410",PRCY)) Q:PRCY="" D
. S DA(1)=PRCY L +^PRCS(410,DA(1)):15 E W !,"Unable to Lock Source 2237" Q
. S:'$D(^PRCS(410,PRCY,"CO",0)) ^(0)="^^^^"_DT
. S PRCV=$P(^PRCS(410,PRCY,"CO",0),U,3,4),PRCU=PRCV+1,PRCV=$P(PRCV,U,2)+1
. S ^PRCS(410,PRCY,"CO",PRCU,0)=" During RFQ Award, this request has been split with the following"
. S PRCU=PRCU+1,PRCV=PRCV+1,^PRCS(410,PRCY,"CO",PRCU,0)="items transfered to 2237 # "_$P($G(^PRCS(410,XDA,0)),U)_":"
. S PRCINV=$P($G(^PRCS(410,DA(1),0)),U,6),PRCZ=0,PRCTOT=0
. F S PRCZ=$O(^TMP($J,"PRCHQ410",PRCY,PRCZ)) Q:PRCZ="" D
. . K ^PRCS(410,DA(1),"IT","AB",PRCZ)
. . S DA=$O(^PRCS(410,DA(1),"IT","B",PRCZ,"")) Q:DA=""
. . S PRCW=$G(^PRCS(410,DA(1),"IT",DA,0)) Q:PRCW=""
. . S PRCTOT=$P(PRCW,U,2)*$P(PRCW,U,7)+PRCTOT
. . S $P(^PRCS(410,DA(1),"IT",DA,0),U,7)=0
. . S:$L(^PRCS(410,PRCY,"CO",PRCU,0))>72 PRCU=PRCU+1,PRCV=PRCV+1
. . S ^(0)=$G(^PRCS(410,PRCY,"CO",PRCU,0))_" "_PRCZ_","
. . S PRCITM=+$P(PRCW,U,5) D:$G(PRCINV)'="" KILLTRAN^PRCPUTRA(PRCINV,PRCITM,DA(1))
. S:'$D(^PRCS(410,DA(1),"IT","AB")) PRCTOT=PRCTOT+$P($G(^PRCS(410,DA(1),9)),U,4)
. S X=PRCTOT D TRANK^PRCSES
. S DA(1)=PRCY,PRCZ=$G(^PRCS(410,DA(1),4)),$P(PRCZ,U)=$P(PRCZ,U)-PRCTOT
. S:$P(PRCZ,U)<0 $P(PRCZ,U)=0 S $P(PRCZ,U,8)=$P(PRCZ,U,8)-PRCTOT S:$P(PRCZ,U,8)<0 $P(PRCZ,U,8)=0
. S ^PRCS(410,DA(1),4)=PRCZ
. I '$D(^PRCS(410,DA(1),"IT","AB")) D
. . S DA=0
. . F S DA=$O(^PRCS(410,DA(1),12,DA)) Q:+DA'=DA D
. . . S X=$P($G(^PRCS(410,DA(1),12,DA,0)),U,2) Q:X'>0
. . . D TRANK^PRCSEZZ
. I '$D(^PRCS(410,PRCY,"IT","AB")),$D(^PRC(443,PRCY,0)) D
. . K DA S DA=PRCY,DIK="^PRC(443," D ^DIK K DIK
. . S $P(^PRCS(410,PRCY,0),U,12)="O"
. S $P(^PRCS(410,PRCY,"CO",0),U,3,4)=PRCU_U_PRCV
. S ^(0)=$E(^PRCS(410,PRCY,"CO",PRCU,0),1,$L(^PRCS(410,PRCY,"CO",PRCU,0))-1)
. S DA=PRCY,PRCZ="",PRCX=$P($G(^PRCS(410,DA,7)),U,3) S:PRCX<1 PRCX=DUZ
. D REMOVE^PRCSC1(DA),ENCODE^PRCSC1(DA,PRCX,.PRCZ) K PRCZ
. L -^PRCS(410,PRCY)
L -^PRCS(410,XDA)
K ^TMP($J,"PRCHQ410")
EX QUIT XDA
;
VENDOR ; determine vendor, put vendor data on 410 record
S V=$P($G(^PRC(444,SDA,8,QUOTE,0)),"^") Q:V=""
S VP=$P(V,";"),VF=$P(V,";",2),VF=$P($P(VF,","),"(",2)
Q:$G(^PRC(VF,VP,0))=""
I VF=444.1 D
. S PRCY=$P(^PRC(VF,VP,0),U,9) Q:PRCY=""
. Q:'$D(^PRC(440,PRCY))
. S VF=440,VP=PRCY
I VF=440 S ^PRCS(410,XDA,2)=$P(^PRC(440,VP,0),"^",1,10),$P(^PRCS(410,XDA,3),"^",4)=VP G VCR
S V=$P($G(^PRC(VF,VP,0)),"^")_"^"_$P($G(^PRC(VF,VP,1)),"^",1,7)
S $P(V,"^",9,10)=$P($G(^PRC(VF,VP,0)),"^",3)_"^"_$P($G(^(0)),"^",6)
S ^PRCS(410,XDA,2)=V
VCR S:$P(^PRCS(410,XDA,2),"^")'="" ^PRCS(410,"E",$E($P(^PRCS(410,XDA,2),"^"),1,30),XDA)=""
QUIT
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHQ41B 4142 printed Oct 16, 2024@18:10:32 Page 2
PRCHQ41B ;WISC/KMB-CREATE 2237 FOR RFQ ;10/21/96 11:07
+1 ;;5.1;IFCAP;;Oct 20, 2000
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
+3 QUIT
IN DO VENDOR
+1 SET X=$PIECE($GET(^PRC(444,SDA,0)),U,9)
SET X=$SELECT(X>0:$PIECE($GET(^PRCS(410,X,7)),U,3),1:0)
+2 SET DA=XDA
SET MESSAGE=""
DO ENCODE^PRCSC1(DA,X,.MESSAGE)
KILL MESSAGE
+3 SET X=+$PIECE($GET(^PRCS(410,XDA,4)),U)
DO TRANS^PRCSES
+4 KILL DA
SET PRCSSCP=0
SET DA=XDA
+5 FOR PRCSSI=1:1
SET PRCSSCP=$ORDER(^PRCS(410,DA,12,PRCSSCP))
if PRCSSCP'>0
QUIT
Begin DoDot:1
+6 if '$DATA(^PRCS(410,DA,12,PRCSSCP,0))
QUIT
SET X=$PIECE(^(0),U,2)
if X'>0
QUIT
+7 SET DA(1)=DA
SET DA=PRCSSCP
DO TRANS^PRCSEZZ
+8 SET DA=DA(1)
End DoDot:1
+9 SET PRCSCP=$SELECT($DATA(^PRC(420,PRC("SITE"),1,+PRC("CP"),0)):$PIECE(^(0),U,12),1:"")
+10 SET X=$PIECE(^PRCS(410,XDA,0),U)
SET DIC="^PRC(443,"
SET DIC(0)="L"
SET DLAYGO=443
+11 DO ^DIC
KILL DIC,DLAYGO,X
SET DA=+Y
+12 LOCK +^PRC(443,DA):15
IF '$TEST
WRITE !,"*** Unable to lock REQUEST WORKSHEET File entry!"
LOCK -^PRCS(410,XDA)
GOTO EX
+13 SET X=$GET(^VA(200,DUZ,20))
+14 SET PRC("PER")=DUZ_U_$PIECE(X,U,2)_U_$PIECE(X,U,3)_U_$SELECT($DATA(^VA(200,DUZ,.13)):$PIECE(^(.13),U,2),1:"")
+15 SET DIE=443
+16 SET PRCX=$GET(^PRC(443,PRC410DA,0))
+17 SET PRCY=$PIECE(PRCX,U,9)
IF PRCY]""
SET DR="9////^S X=PRCY"
DO ^DIE
+18 SET PRCY=$PIECE(PRCX,U,10)
IF PRCY]""
SET DR="10////^S X=PRCY"
DO ^DIE
+19 SET PRCY=$PIECE(^PRCS(410,DA,0),U,6)
IF PRCY]""
SET DR="11////^S X=PRCY"
DO ^DIE
+20 SET PRCY=$PIECE(PRCX,U,12)
IF PRCY]""
SET DR="13////^S X=PRCY"
DO ^DIE
+21 SET DR="1.5///70;2////^S X=+PRC(""PER"")"
DO ^DIE
+22 KILL DIE,DR
+23 Begin DoDot:1
+24 NEW PRCHG,P,PRCSIG,ROUTINE
+25 DO ES1^PRCHG
End DoDot:1
+26 LOCK -^PRC(443,DA)
+27 SET DA=XDA
DO EN2^PRCPWI
+28 ;
+29 SET PRCY=0
+30 FOR
SET PRCY=$ORDER(^TMP($JOB,"PRCHQ410",PRCY))
if PRCY=""
QUIT
Begin DoDot:1
+31 SET DA(1)=PRCY
LOCK +^PRCS(410,DA(1)):15
IF '$TEST
WRITE !,"Unable to Lock Source 2237"
QUIT
+32 if '$DATA(^PRCS(410,PRCY,"CO",0))
SET ^(0)="^^^^"_DT
+33 SET PRCV=$PIECE(^PRCS(410,PRCY,"CO",0),U,3,4)
SET PRCU=PRCV+1
SET PRCV=$PIECE(PRCV,U,2)+1
+34 SET ^PRCS(410,PRCY,"CO",PRCU,0)=" During RFQ Award, this request has been split with the following"
+35 SET PRCU=PRCU+1
SET PRCV=PRCV+1
SET ^PRCS(410,PRCY,"CO",PRCU,0)="items transfered to 2237 # "_$PIECE($GET(^PRCS(410,XDA,0)),U)_":"
+36 SET PRCINV=$PIECE($GET(^PRCS(410,DA(1),0)),U,6)
SET PRCZ=0
SET PRCTOT=0
+37 FOR
SET PRCZ=$ORDER(^TMP($JOB,"PRCHQ410",PRCY,PRCZ))
if PRCZ=""
QUIT
Begin DoDot:2
+38 KILL ^PRCS(410,DA(1),"IT","AB",PRCZ)
+39 SET DA=$ORDER(^PRCS(410,DA(1),"IT","B",PRCZ,""))
if DA=""
QUIT
+40 SET PRCW=$GET(^PRCS(410,DA(1),"IT",DA,0))
if PRCW=""
QUIT
+41 SET PRCTOT=$PIECE(PRCW,U,2)*$PIECE(PRCW,U,7)+PRCTOT
+42 SET $PIECE(^PRCS(410,DA(1),"IT",DA,0),U,7)=0
+43 if $LENGTH(^PRCS(410,PRCY,"CO",PRCU,0))>72
SET PRCU=PRCU+1
SET PRCV=PRCV+1
+44 SET ^(0)=$GET(^PRCS(410,PRCY,"CO",PRCU,0))_" "_PRCZ_","
+45 SET PRCITM=+$PIECE(PRCW,U,5)
if $GET(PRCINV)'=""
DO KILLTRAN^PRCPUTRA(PRCINV,PRCITM,DA(1))
End DoDot:2
+46 if '$DATA(^PRCS(410,DA(1),"IT","AB"))
SET PRCTOT=PRCTOT+$PIECE($GET(^PRCS(410,DA(1),9)),U,4)
+47 SET X=PRCTOT
DO TRANK^PRCSES
+48 SET DA(1)=PRCY
SET PRCZ=$GET(^PRCS(410,DA(1),4))
SET $PIECE(PRCZ,U)=$PIECE(PRCZ,U)-PRCTOT
+49 if $PIECE(PRCZ,U)<0
SET $PIECE(PRCZ,U)=0
SET $PIECE(PRCZ,U,8)=$PIECE(PRCZ,U,8)-PRCTOT
if $PIECE(PRCZ,U,8)<0
SET $PIECE(PRCZ,U,8)=0
+50 SET ^PRCS(410,DA(1),4)=PRCZ
+51 IF '$DATA(^PRCS(410,DA(1),"IT","AB"))
Begin DoDot:2
+52 SET DA=0
+53 FOR
SET DA=$ORDER(^PRCS(410,DA(1),12,DA))
if +DA'=DA
QUIT
Begin DoDot:3
+54 SET X=$PIECE($GET(^PRCS(410,DA(1),12,DA,0)),U,2)
if X'>0
QUIT
+55 DO TRANK^PRCSEZZ
End DoDot:3
End DoDot:2
+56 IF '$DATA(^PRCS(410,PRCY,"IT","AB"))
IF $DATA(^PRC(443,PRCY,0))
Begin DoDot:2
+57 KILL DA
SET DA=PRCY
SET DIK="^PRC(443,"
DO ^DIK
KILL DIK
+58 SET $PIECE(^PRCS(410,PRCY,0),U,12)="O"
End DoDot:2
+59 SET $PIECE(^PRCS(410,PRCY,"CO",0),U,3,4)=PRCU_U_PRCV
+60 SET ^(0)=$EXTRACT(^PRCS(410,PRCY,"CO",PRCU,0),1,$LENGTH(^PRCS(410,PRCY,"CO",PRCU,0))-1)
+61 SET DA=PRCY
SET PRCZ=""
SET PRCX=$PIECE($GET(^PRCS(410,DA,7)),U,3)
if PRCX<1
SET PRCX=DUZ
+62 DO REMOVE^PRCSC1(DA)
DO ENCODE^PRCSC1(DA,PRCX,.PRCZ)
KILL PRCZ
+63 LOCK -^PRCS(410,PRCY)
End DoDot:1
+64 LOCK -^PRCS(410,XDA)
+65 KILL ^TMP($JOB,"PRCHQ410")
EX QUIT XDA
+1 ;
VENDOR ; determine vendor, put vendor data on 410 record
+1 SET V=$PIECE($GET(^PRC(444,SDA,8,QUOTE,0)),"^")
if V=""
QUIT
+2 SET VP=$PIECE(V,";")
SET VF=$PIECE(V,";",2)
SET VF=$PIECE($PIECE(VF,","),"(",2)
+3 if $GET(^PRC(VF,VP,0))=""
QUIT
+4 IF VF=444.1
Begin DoDot:1
+5 SET PRCY=$PIECE(^PRC(VF,VP,0),U,9)
if PRCY=""
QUIT
+6 if '$DATA(^PRC(440,PRCY))
QUIT
+7 SET VF=440
SET VP=PRCY
End DoDot:1
+8 IF VF=440
SET ^PRCS(410,XDA,2)=$PIECE(^PRC(440,VP,0),"^",1,10)
SET $PIECE(^PRCS(410,XDA,3),"^",4)=VP
GOTO VCR
+9 SET V=$PIECE($GET(^PRC(VF,VP,0)),"^")_"^"_$PIECE($GET(^PRC(VF,VP,1)),"^",1,7)
+10 SET $PIECE(V,"^",9,10)=$PIECE($GET(^PRC(VF,VP,0)),"^",3)_"^"_$PIECE($GET(^(0)),"^",6)
+11 SET ^PRCS(410,XDA,2)=V
VCR if $PIECE(^PRCS(410,XDA,2),"^")'=""
SET ^PRCS(410,"E",$EXTRACT($PIECE(^PRCS(410,XDA,2),"^"),1,30),XDA)=""
+1 QUIT
+2 ;
