PRCHQ410 ;WISC/KMB-CREATE 2237 FOR RFQ ;8/6/96 20:54
;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
;;Extrinsic function $$REQUEST^PRCHQ410(SDA,QUOTE,ITEMARR)
;;Builds 2237 from winning quote during award
;;Returns resulting 2237's internal entry # if exits normally; 0 if premature
;;SDA - RFQ internal entry number
;;QUOTE - Quote's internal entry number
;;ITEMARR - Closed Global Root of Index for items assigned to Quote
;; i.e. "^TMP($J,"RFQ",QUOTE,FOB_CODE)" where the descendents are
;; ^TMP($J,"RFQ",QUOTE,FOB_CODE,RFQ_LINE_NBR_OF_ITEM)
REQUEST(SDA,QUOTE,ITEMARR) ; create 2237 from RFQ
N CP,CTR,DA,DIC,DIE,DLAYGO,DR,STA,V,VF,VP,X,X1,XDA,Y,Z,ZP,TDATE,CDATE,TOTAL,MESSAGE
N PRC,PRCDA,PRCDRN,PRCSDA,PRC410DA,PRCQ,PRCU,PRCV,PRCW,PRCX,PRCY,PRCZ
N PRCCOUNT,PRCIENS,PRCINV,PRCITM,PRCNODE,PRCSCP,PRCSSCP,PRCSSI,PRCTOT
N PRCXND,PRCX1,PRCO2237
K ^TMP($J,"PRCHQ410") S XDA=0
G:'$D(SDA) EX
;
S PRCX=0
F S PRCX=$O(@ITEMARR@(PRCX)) Q:PRCX="" I $D(^PRC(444,SDA,2,PRCX,3)),$P(^(3),U,6)="" Q
G:PRCX="" EX
S PRC410DA=$P($G(^PRC(444,SDA,0)),"^",9)
S (STA,PRC("SITE"))=$P(^PRC(444,SDA,0),"-"),PRC("SST")=$P($G(^(0)),"^",10)
S CP=$P(^PRC(444,SDA,0),U,14),PRC("CP")=$P($G(^PRC(420,STA,1,+CP,0)),"^")
G:PRC("CP")="" EX
D NOW^%DTC S PRC("FY")=$E(100+$E(X,2,3)+$S($E(X,4,5)>9:1,1:0),2,3)
S PRC("QTR")=$P("2^2^2^3^3^3^4^4^4^1^1^1","^",+$E(X,4,5))
S (Y,TDATE)=X D DD^%DT S CDATE=Y
;
;
S Z=PRC("SITE")_"-"_PRC("FY")_"-"_PRC("QTR")_"-"_$P(PRC("CP")," ")
S PRC("BBFY")=$$BBFY^PRCSUT(PRC("SITE"),PRC("FY"),PRC("CP"),1)
S X=$P(Z,"-",1,2)_"-"_$P(PRC("CP")," ")
D EN1^PRCSUT3 G:$G(X)']"" EX S (PRCX1,X1)=X D EN2^PRCSUT3 G:'$D(X1) EX S XDA=DA
L +^PRCS(410,DA):30 E W !,"Unable to lock 2237 entry" S XDA=0 G EX
S PRCXND=0,PRCCOUNT=0,TOTAL=+$P($G(^PRC(444,SDA,8,QUOTE,1)),U,2)
F S PRCXND=$O(@ITEMARR@(PRCXND)) Q:PRCXND="" D
. Q:$P($G(^PRC(444,SDA,2,PRCXND,3)),U,6)]""
. S PRCCOUNT=PRCCOUNT+1,X=$P(^PRC(444,SDA,2,PRCXND,0),U)
. S PRCDA=$O(^PRC(444,SDA,8,QUOTE,3,"B",X,"")) Q:PRCDA=""
. S PRCQ(0)=$G(^PRC(444,SDA,8,QUOTE,3,PRCDA,0)),PRCQ(1)=$G(^PRC(444,SDA,8,QUOTE,3,PRCDA,1))
. S:$G(PRCO2237)="" PRCO2237=$P($G(^PRC(444,SDA,2,PRCXND,3)),U)
. K DA,DIC S DA(1)=XDA,DIC="^PRCS(410,DA(1),""IT"",",DIC(0)="LX",DLAYGO=410.02
. S DIC("P")=$P(^DD(410,10,0),U,2),X=PRCCOUNT D ^DIC K DIC,DLAYGO
. Q:+Y<1 S PRCSDA=+Y
. S $P(^PRC(444,SDA,2,PRCXND,3),U,6,7)=XDA_U_PRCCOUNT
. S ^PRC(444,"AE",XDA,SDA,PRCXND)=""
. S PRCY=$G(^PRC(444,SDA,2,PRCXND,3)) S:PRCY>0 PRCZ=$P(PRCY,U,2)
. I PRCY>0,PRCZ>0 S ^TMP($J,"PRCHQ410",+PRCY,PRCZ)=""
. S DA=PRCSDA,DIE="^PRCS(410,DA(1),""IT"","
. S $P(^PRCS(410,XDA,"IT",DA,0),U,2)=$P(PRCQ(0),U,2)
. S DR="3////^S X=$P(PRCQ(0),U,3)" D ^DIE
. S PRCY=$P($G(^PRC(444,SDA,2,PRCXND,1)),U,8) I PRCY]"" S DR="4////^S X=$P($G(^PRCD(420.2,PRCY,0)),U)" D ^DIE
. S PRCY=$P($G(^PRC(444,SDA,2,PRCXND,0)),U,4) I PRCY]"" S DR="5///^S X=PRCY" D ^DIE
. S PRCY=$P(PRCQ(0),U,4) S:PRCY="" PRCY=$P(PRCQ(0),U,9) S:PRCY="" PRCY=$P(PRCQ(0),U,6)
. I PRCY]"" S DR="6///^S X=PRCY" D ^DIE
. S $P(^PRCS(410,XDA,"IT",DA,0),U,7)=$P(PRCQ(1),U,3)
. S TOTAL=$P(PRCQ(0),U,2)*$P(PRCQ(1),U,3)+TOTAL
. S PRCNODE=$S($P($G(^PRC(444,SDA,8,QUOTE,3,PRCDA,2,0)),U,4)>0:"^PRC(444,SDA,8,QUOTE,3,PRCDA,2)",1:"^PRC(444,SDA,2,PRCXND,2)")
. K ^TMP("DIERR",$J) S PRCIENS=PRCSDA_","_XDA_","
. D WP^DIE(410.02,PRCIENS,1,"",PRCNODE) K ^TMP("DIERR",$J)
. S ZP=0
. F S ZP=$O(^PRC(444,SDA,8,QUOTE,3,PRCDA,3,ZP)) Q:+ZP'=ZP D
. . S PRCY=$G(^PRC(444,SDA,8,QUOTE,3,PRCDA,3,ZP,0))
. . S CTR=$P(PRCY,U),X=PRCX1_"-"_PRCCOUNT_"-"_CTR K DIC
. . S DIC=410.6,DIC(0)="LX",DLAYGO=410.6 D ^DIC K DIC,DLAYGO
. . I +Y<1 W !,"Unable to add Delivery Schedule Entry" Q
. . S DA=+Y
. . L +^PRCS(410.6,DA):30 E W !,"Unable to lock Delivery Schedule Entry" Q
. . S DIE=410.6,DR="1////^S X=$P(PRCY,U,2);3////^S X=$P(PRCY,U,3)"
. . D ^DIE
. . S PRCY=$G(^PRC(444,SDA,2,PRCXND,4,CTR,0))
. . S:PRCY="" PRCY=$G(^PRC(444,SDA,2,PRCXND,4,1,0))
. . I PRCY]"" S DR="2////^S X=$P(PRCY,U,4);4////^S X=$P(PRCY,U,5)" D ^DIE
. . K DR,DIE L -^PRCS(410.6,DA)
. . S PRCDRN=DA K DA,DIC
. . S DA(2)=XDA,DA(1)=PRCSDA,DIC="^PRCS(410,DA(2),""IT"",DA(1),2,",DIC(0)="LX"
. . S DIC("P")=$P(^DD(410.02,12,0),U,2),X=CTR D ^DIC Q:+Y<1 S DA=+Y
. . S DIE=DIC K DIC S DR="1////^S X=PRCDRN" D ^DIE K DIE,DR,DA
K DA S DA=XDA
S DIE=410,DR="448////^S X=$P($G(^PRC(444,SDA,0)),U,10)" D ^DIE
S DR=".5///^S X=$P($P($G(^PRC(444,SDA,0)),U),""-"")" D ^DIE
S DR="1////O;3////4" D ^DIE
S PRCY=$P($G(^PRCS(410,PRC410DA,0)),U,6) I PRCY]"" S DR="4////^S X=PRCY" D ^DIE
S DR="5////^S X=$P(^PRCS(410,PRC410DA,1),U)" D ^DIE
S DR="6.3////^S X=$P($G(^PRC(444,SDA,0)),U,11)" D ^DIE
S DR="7.5////^S X=$P($G(^PRC(444,SDA,0)),U,6)" D ^DIE
S DR="7////^S X=$P($G(^PRC(444,SDA,1)),U,2)" D ^DIE
S $P(^PRCS(410,XDA,4),U)=TOTAL,$P(^PRCS(410,XDA,4),U,8)=TOTAL
S DR="21////^S X=TDATE" D ^DIE
S DR="15.5///^S X=$P($G(^PRCS(410,PRC410DA,3)),U,3)" D ^DIE
I PRCFOB="O" S X=$P($G(^PRC(444,SDA,8,QUOTE,1)),U,2) I X>0 S DR="48.1///"_X D ^DIE
S DR="50///^S X=PRCCOUNT" D ^DIE
S PRCY=$P($G(^PRCS(410,PRC410DA,7)),U) I PRCY]"" S DR="40////^S X=PRCY" D ^DIE
S PRCY=$P($G(^PRC(444,SDA,1)),U,4) I PRCY]"" S DR="46///^S X=PRCY" D ^DIE
S DR="56///60" D ^DIE
S:PRCO2237]"" PRCO2237=$S($D(^PRCS(410,PRCO2237,0)):$P(^(0),U),1:"")
I PRCO2237]"" S DR="51///^S X=PRCO2237" D ^DIE
K DIE,DR
S ^PRCS(410,XDA,"CO",0)="^^1^1^"_TDATE
S ^PRCS(410,XDA,"CO",1,0)="This 2237 is derived from RFQ #"_$P($G(^PRC(444,SDA,0)),U)
D ERS410^PRC0G(DA_"^A")
K ^TMP("DIERR",$J) S PRCIENS=XDA_","
D:$D(^PRC(444,SDA,3)) WP^DIE(410,PRCIENS,9,"","^PRC(444,SDA,3)")
K ^TMP("DIERR",$J) S PRCIENS=XDA_","
D:$D(^PRCS(410,PRC410DA,8)) WP^DIE(410,PRCIENS,45,"","^PRCS(410,PRC410DA,8)")
K ^TMP("DIERR",$J)
G IN^PRCHQ41B
EX Q XDA
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHQ410 5907 printed Oct 16, 2024@18:10:31 Page 2
PRCHQ410 ;WISC/KMB-CREATE 2237 FOR RFQ ;8/6/96 20:54
+1 ;;5.1;IFCAP;;Oct 20, 2000
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;;Extrinsic function $$REQUEST^PRCHQ410(SDA,QUOTE,ITEMARR)
+4 ;;Builds 2237 from winning quote during award
+5 ;;Returns resulting 2237's internal entry # if exits normally; 0 if premature
+6 ;;SDA - RFQ internal entry number
+7 ;;QUOTE - Quote's internal entry number
+8 ;;ITEMARR - Closed Global Root of Index for items assigned to Quote
+9 ;; i.e. "^TMP($J,"RFQ",QUOTE,FOB_CODE)" where the descendents are
+10 ;; ^TMP($J,"RFQ",QUOTE,FOB_CODE,RFQ_LINE_NBR_OF_ITEM)
REQUEST(SDA,QUOTE,ITEMARR) ; create 2237 from RFQ
+1 NEW CP,CTR,DA,DIC,DIE,DLAYGO,DR,STA,V,VF,VP,X,X1,XDA,Y,Z,ZP,TDATE,CDATE,TOTAL,MESSAGE
+2 NEW PRC,PRCDA,PRCDRN,PRCSDA,PRC410DA,PRCQ,PRCU,PRCV,PRCW,PRCX,PRCY,PRCZ
+3 NEW PRCCOUNT,PRCIENS,PRCINV,PRCITM,PRCNODE,PRCSCP,PRCSSCP,PRCSSI,PRCTOT
+4 NEW PRCXND,PRCX1,PRCO2237
+5 KILL ^TMP($JOB,"PRCHQ410")
SET XDA=0
+6 if '$DATA(SDA)
GOTO EX
+7 ;
+8 SET PRCX=0
+9 FOR
SET PRCX=$ORDER(@ITEMARR@(PRCX))
if PRCX=""
QUIT
IF $DATA(^PRC(444,SDA,2,PRCX,3))
IF $PIECE(^(3),U,6)=""
QUIT
+10 if PRCX=""
GOTO EX
+11 SET PRC410DA=$PIECE($GET(^PRC(444,SDA,0)),"^",9)
+12 SET (STA,PRC("SITE"))=$PIECE(^PRC(444,SDA,0),"-")
SET PRC("SST")=$PIECE($GET(^(0)),"^",10)
+13 SET CP=$PIECE(^PRC(444,SDA,0),U,14)
SET PRC("CP")=$PIECE($GET(^PRC(420,STA,1,+CP,0)),"^")
+14 if PRC("CP")=""
GOTO EX
+15 DO NOW^%DTC
SET PRC("FY")=$EXTRACT(100+$EXTRACT(X,2,3)+$SELECT($EXTRACT(X,4,5)>9:1,1:0),2,3)
+16 SET PRC("QTR")=$PIECE("2^2^2^3^3^3^4^4^4^1^1^1","^",+$EXTRACT(X,4,5))
+17 SET (Y,TDATE)=X
DO DD^%DT
SET CDATE=Y
+18 ;
+19 ;
+20 SET Z=PRC("SITE")_"-"_PRC("FY")_"-"_PRC("QTR")_"-"_$PIECE(PRC("CP")," ")
+21 SET PRC("BBFY")=$$BBFY^PRCSUT(PRC("SITE"),PRC("FY"),PRC("CP"),1)
+22 SET X=$PIECE(Z,"-",1,2)_"-"_$PIECE(PRC("CP")," ")
+23 DO EN1^PRCSUT3
if $GET(X)']""
GOTO EX
SET (PRCX1,X1)=X
DO EN2^PRCSUT3
if '$DATA(X1)
GOTO EX
SET XDA=DA
+24 LOCK +^PRCS(410,DA):30
IF '$TEST
WRITE !,"Unable to lock 2237 entry"
SET XDA=0
GOTO EX
+25 SET PRCXND=0
SET PRCCOUNT=0
SET TOTAL=+$PIECE($GET(^PRC(444,SDA,8,QUOTE,1)),U,2)
+26 FOR
SET PRCXND=$ORDER(@ITEMARR@(PRCXND))
if PRCXND=""
QUIT
Begin DoDot:1
+27 if $PIECE($GET(^PRC(444,SDA,2,PRCXND,3)),U,6)]""
QUIT
+28 SET PRCCOUNT=PRCCOUNT+1
SET X=$PIECE(^PRC(444,SDA,2,PRCXND,0),U)
+29 SET PRCDA=$ORDER(^PRC(444,SDA,8,QUOTE,3,"B",X,""))
if PRCDA=""
QUIT
+30 SET PRCQ(0)=$GET(^PRC(444,SDA,8,QUOTE,3,PRCDA,0))
SET PRCQ(1)=$GET(^PRC(444,SDA,8,QUOTE,3,PRCDA,1))
+31 if $GET(PRCO2237)=""
SET PRCO2237=$PIECE($GET(^PRC(444,SDA,2,PRCXND,3)),U)
+32 KILL DA,DIC
SET DA(1)=XDA
SET DIC="^PRCS(410,DA(1),""IT"","
SET DIC(0)="LX"
SET DLAYGO=410.02
+33 SET DIC("P")=$PIECE(^DD(410,10,0),U,2)
SET X=PRCCOUNT
DO ^DIC
KILL DIC,DLAYGO
+34 if +Y<1
QUIT
SET PRCSDA=+Y
+35 SET $PIECE(^PRC(444,SDA,2,PRCXND,3),U,6,7)=XDA_U_PRCCOUNT
+36 SET ^PRC(444,"AE",XDA,SDA,PRCXND)=""
+37 SET PRCY=$GET(^PRC(444,SDA,2,PRCXND,3))
if PRCY>0
SET PRCZ=$PIECE(PRCY,U,2)
+38 IF PRCY>0
IF PRCZ>0
SET ^TMP($JOB,"PRCHQ410",+PRCY,PRCZ)=""
+39 SET DA=PRCSDA
SET DIE="^PRCS(410,DA(1),""IT"","
+40 SET $PIECE(^PRCS(410,XDA,"IT",DA,0),U,2)=$PIECE(PRCQ(0),U,2)
+41 SET DR="3////^S X=$P(PRCQ(0),U,3)"
DO ^DIE
+42 SET PRCY=$PIECE($GET(^PRC(444,SDA,2,PRCXND,1)),U,8)
IF PRCY]""
SET DR="4////^S X=$P($G(^PRCD(420.2,PRCY,0)),U)"
DO ^DIE
+43 SET PRCY=$PIECE($GET(^PRC(444,SDA,2,PRCXND,0)),U,4)
IF PRCY]""
SET DR="5///^S X=PRCY"
DO ^DIE
+44 SET PRCY=$PIECE(PRCQ(0),U,4)
if PRCY=""
SET PRCY=$PIECE(PRCQ(0),U,9)
if PRCY=""
SET PRCY=$PIECE(PRCQ(0),U,6)
+45 IF PRCY]""
SET DR="6///^S X=PRCY"
DO ^DIE
+46 SET $PIECE(^PRCS(410,XDA,"IT",DA,0),U,7)=$PIECE(PRCQ(1),U,3)
+47 SET TOTAL=$PIECE(PRCQ(0),U,2)*$PIECE(PRCQ(1),U,3)+TOTAL
+48 SET PRCNODE=$SELECT($PIECE($GET(^PRC(444,SDA,8,QUOTE,3,PRCDA,2,0)),U,4)>0:"^PRC(444,SDA,8,QUOTE,3,PRCDA,2)",1:"^PRC(444,SDA,2,PRCXND,2)")
+49 KILL ^TMP("DIERR",$JOB)
SET PRCIENS=PRCSDA_","_XDA_","
+50 DO WP^DIE(410.02,PRCIENS,1,"",PRCNODE)
KILL ^TMP("DIERR",$JOB)
+51 SET ZP=0
+52 FOR
SET ZP=$ORDER(^PRC(444,SDA,8,QUOTE,3,PRCDA,3,ZP))
if +ZP'=ZP
QUIT
Begin DoDot:2
+53 SET PRCY=$GET(^PRC(444,SDA,8,QUOTE,3,PRCDA,3,ZP,0))
+54 SET CTR=$PIECE(PRCY,U)
SET X=PRCX1_"-"_PRCCOUNT_"-"_CTR
KILL DIC
+55 SET DIC=410.6
SET DIC(0)="LX"
SET DLAYGO=410.6
DO ^DIC
KILL DIC,DLAYGO
+56 IF +Y<1
WRITE !,"Unable to add Delivery Schedule Entry"
QUIT
+57 SET DA=+Y
+58 LOCK +^PRCS(410.6,DA):30
IF '$TEST
WRITE !,"Unable to lock Delivery Schedule Entry"
QUIT
+59 SET DIE=410.6
SET DR="1////^S X=$P(PRCY,U,2);3////^S X=$P(PRCY,U,3)"
+60 DO ^DIE
+61 SET PRCY=$GET(^PRC(444,SDA,2,PRCXND,4,CTR,0))
+62 if PRCY=""
SET PRCY=$GET(^PRC(444,SDA,2,PRCXND,4,1,0))
+63 IF PRCY]""
SET DR="2////^S X=$P(PRCY,U,4);4////^S X=$P(PRCY,U,5)"
DO ^DIE
+64 KILL DR,DIE
LOCK -^PRCS(410.6,DA)
+65 SET PRCDRN=DA
KILL DA,DIC
+66 SET DA(2)=XDA
SET DA(1)=PRCSDA
SET DIC="^PRCS(410,DA(2),""IT"",DA(1),2,"
SET DIC(0)="LX"
+67 SET DIC("P")=$PIECE(^DD(410.02,12,0),U,2)
SET X=CTR
DO ^DIC
if +Y<1
QUIT
SET DA=+Y
+68 SET DIE=DIC
KILL DIC
SET DR="1////^S X=PRCDRN"
DO ^DIE
KILL DIE,DR,DA
End DoDot:2
End DoDot:1
+69 KILL DA
SET DA=XDA
+70 SET DIE=410
SET DR="448////^S X=$P($G(^PRC(444,SDA,0)),U,10)"
DO ^DIE
+71 SET DR=".5///^S X=$P($P($G(^PRC(444,SDA,0)),U),""-"")"
DO ^DIE
+72 SET DR="1////O;3////4"
DO ^DIE
+73 SET PRCY=$PIECE($GET(^PRCS(410,PRC410DA,0)),U,6)
IF PRCY]""
SET DR="4////^S X=PRCY"
DO ^DIE
+74 SET DR="5////^S X=$P(^PRCS(410,PRC410DA,1),U)"
DO ^DIE
+75 SET DR="6.3////^S X=$P($G(^PRC(444,SDA,0)),U,11)"
DO ^DIE
+76 SET DR="7.5////^S X=$P($G(^PRC(444,SDA,0)),U,6)"
DO ^DIE
+77 SET DR="7////^S X=$P($G(^PRC(444,SDA,1)),U,2)"
DO ^DIE
+78 SET $PIECE(^PRCS(410,XDA,4),U)=TOTAL
SET $PIECE(^PRCS(410,XDA,4),U,8)=TOTAL
+79 SET DR="21////^S X=TDATE"
DO ^DIE
+80 SET DR="15.5///^S X=$P($G(^PRCS(410,PRC410DA,3)),U,3)"
DO ^DIE
+81 IF PRCFOB="O"
SET X=$PIECE($GET(^PRC(444,SDA,8,QUOTE,1)),U,2)
IF X>0
SET DR="48.1///"_X
DO ^DIE
+82 SET DR="50///^S X=PRCCOUNT"
DO ^DIE
+83 SET PRCY=$PIECE($GET(^PRCS(410,PRC410DA,7)),U)
IF PRCY]""
SET DR="40////^S X=PRCY"
DO ^DIE
+84 SET PRCY=$PIECE($GET(^PRC(444,SDA,1)),U,4)
IF PRCY]""
SET DR="46///^S X=PRCY"
DO ^DIE
+85 SET DR="56///60"
DO ^DIE
+86 if PRCO2237]""
SET PRCO2237=$SELECT($DATA(^PRCS(410,PRCO2237,0)):$PIECE(^(0),U),1:"")
+87 IF PRCO2237]""
SET DR="51///^S X=PRCO2237"
DO ^DIE
+88 KILL DIE,DR
+89 SET ^PRCS(410,XDA,"CO",0)="^^1^1^"_TDATE
+90 SET ^PRCS(410,XDA,"CO",1,0)="This 2237 is derived from RFQ #"_$PIECE($GET(^PRC(444,SDA,0)),U)
+91 DO ERS410^PRC0G(DA_"^A")
+92 KILL ^TMP("DIERR",$JOB)
SET PRCIENS=XDA_","
+93 if $DATA(^PRC(444,SDA,3))
DO WP^DIE(410,PRCIENS,9,"","^PRC(444,SDA,3)")
+94 KILL ^TMP("DIERR",$JOB)
SET PRCIENS=XDA_","
+95 if $DATA(^PRCS(410,PRC410DA,8))
DO WP^DIE(410,PRCIENS,45,"","^PRCS(410,PRC410DA,8)")
+96 KILL ^TMP("DIERR",$JOB)
+97 GOTO IN^PRCHQ41B
EX QUIT XDA
