111 lines
5.7 KiB
Mathematica
111 lines
5.7 KiB
Mathematica
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
|