- 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 Mar 13, 2025@21:14:34 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 ;
