109 lines
5.1 KiB
Mathematica
109 lines
5.1 KiB
Mathematica
PRCHQ6 ;(WASH IRMFO)/LKG-RFQ SERVER UNPACKING VENDOR QUOTE ;8/6/96 20:57
|
|
;;5.1;IFCAP;;Oct 20, 2000
|
|
;Per VHA Directive 10-93-142, this routine should not be modified.
|
|
Q
|
|
IN ;
|
|
K ^TMP("DIERR",$J),^TMP($J,"PRCERR") D NOW^%DTC S PRCRCVDT=% K %,%H,%I
|
|
S PRCI=0 S PRCI=$O(^PRCF(423.6,PRCDA,1,PRCI)) I PRCI="" S PRCERR=1 G ERR^PRCHQ6B
|
|
S PRCX=$G(^PRCF(423.6,PRCDA,1,PRCI,0))
|
|
I $P(PRCX,U)'="ISM"!($P(PRCX,U,4)'="VQT") S PRCERR=2 G ERR^PRCHQ6B
|
|
S PRCRFQ=$P($P(PRCX,U,7)," ")
|
|
S PRCI=$O(^PRCF(423.6,PRCDA,1,PRCI)) I PRCI="" S PRCERR=3 G ERR^PRCHQ6B
|
|
S PRCX=$G(^PRCF(423.6,PRCDA,1,PRCI,0)) I $P(PRCX,U)'="HE" S PRCERR=3 G ERR^PRCHQ6B
|
|
K PRC S X=$O(^PRC(444,"B",PRCRFQ,"")) I X'?1.N S PRCERR=4 G ERR^PRCHQ6B
|
|
S PRC("D0")=X L +^PRC(444,PRC("D0")):1200 E S PRCERR=5 G ERR^PRCHQ6B
|
|
I ";0;4;5;"[(";"_$P($G(^PRC(444,PRC("D0"),0)),U,8)_";") G EX^PRCHQ6B
|
|
S PRCVCN=$P(PRCX,U,8),PRCVCP=$P(PRCX,U,9),PRCICNT=+$P(PRCX,U,12)
|
|
S PRCREF=$P(PRCX,U,15),PRCEFFDT=$$JD2FMD^PRCHQ7($P(PRCX,U,16))
|
|
S PRCI=$O(^PRCF(423.6,PRCDA,1,PRCI)) I PRCI="" S PRCERR=6 G ERR^PRCHQ6B
|
|
S PRCX=$G(^PRCF(423.6,PRCDA,1,PRCI,0)) I $P(PRCX,U)'="VE" S PRCERR=6 G ERR^PRCHQ6B
|
|
S PRCDB=$P(PRCX,U,2),PRCVNM=$P(PRCX,U,3)
|
|
S PRCDBI="DUN"_PRCDB,PRCVDA=$O(^PRC(440,"DB",PRCDBI,""))
|
|
I PRCVDA?1.N D
|
|
. S PRCVEN=PRCVDA_";PRC(440,"
|
|
I PRCVDA="" D G:$D(PRCERR) ERR^PRCHQ6B
|
|
. N DA,DIC,DIE,DR
|
|
. S PRCVDA=$O(^PRC(444.1,"DB",PRCDBI,""))
|
|
. I PRCVDA="" D Q:$D(PRCERR)
|
|
. . K DD,DO
|
|
. . S X=$P(PRCX,U,3),DIC="^PRC(444.1,",DIC(0)="LX",DLAYGO=444.1
|
|
. . D FILE^DICN K DIC,DLAYGO
|
|
. . I Y<1 S PRCERR=7 Q
|
|
. . S PRCVDA=+Y
|
|
. . S DA=PRCVDA,DIE=444.1,DR="18.3///^S X=PRCDB" D ^DIE K DA,DIE,DR
|
|
. S PRCVEN=PRCVDA_";PRC(444.1,"
|
|
. L +^PRC(444.1,PRCVDA):1200 E Q
|
|
. S DA=PRCVDA,DIE=444.1,DR=".01///^S X=$P(PRCX,U,3)" D ^DIE
|
|
. S PRCY=$E($P(PRCX,U,4),1,33) S:PRCY="" PRCY="@" S DR="1///^S X=PRCY" D ^DIE
|
|
. S PRCY=$E($P(PRCX,U,5),1,33) S:PRCY="" PRCY="@" S DR="2///^S X=PRCY" D ^DIE
|
|
. S PRCY=$E($P(PRCX,U,6),1,25) S:PRCY="" PRCY="@" S DR="3///^S X=PRCY" D ^DIE
|
|
. S PRCY=$E($P(PRCX,U,7),1,20) S:PRCY="" PRCY="@" S DR="4.2///^S X=PRCY" D ^DIE
|
|
. S PRCY=$P(PRCX,U,8)
|
|
. I PRCY]"" D
|
|
. . S PRCY=$O(^DIC(5,"C",PRCY,"")) Q:PRCY=""
|
|
. . S DR="4.4////^S X=PRCY" D ^DIE
|
|
. I PRCY="" S DR="4.4///@" D ^DIE
|
|
. S PRCY=$P(PRCX,U,9),PRCY=$S(PRCY="":"@",$L(PRCY)=5:PRCY,1:$E(PRCY,1,5)_"-"_$E(PRCY,6,9))
|
|
. S DR="4.6///^S X=PRCY" D ^DIE
|
|
. I PRCVCN]"" S DR="4.8///^S X=PRCVCN" D ^DIE
|
|
. S PRCY=$P(PRCX,U,10) S:PRCY="" PRCY="@" S DR="5///^S X=PRCY" D ^DIE
|
|
. S PRCY=$P(PRCX,U,11) S:PRCY="" PRCY="@" S DR="38///^S X=PRCY" D ^DIE
|
|
. S PRCY=$P(PRCX,U,12)
|
|
. I PRCY]"" D
|
|
. . S PRCY=$S(PRCY=21:1,PRCY="B9":2,1:"") Q:PRCY=""
|
|
. . S DR="8.3////^S X=PRCY" D ^DIE
|
|
. S PRCY=$P(PRCX,U,19)
|
|
. I PRCY]"" S PRCY=$S(PRCY="A6":"y",1:"n"),DR="50////^S X=PRCY" D ^DIE
|
|
. I $P(PRCX,U,13)=22!($P(PRCX,U,14)=23) D TYPE("M")
|
|
. I $P(PRCX,U,15)=24!($P(PRCX,U,16)=25) D TYPE("W")
|
|
. D:$P(PRCX,U,18)="A5" TYPE("V")
|
|
. I $D(^PRC(444.1,PRCVDA,4)),$P(PRCX,U,17)=27!($P(PRCX,U,18)="A5"&($P(PRCX,U,12)=21))!($P(PRCX,U,15)=24) D DELTNONE^PRCHQ6A
|
|
. D:$P(PRCX,U,17)=27 SOCIOECO("N")
|
|
. I $P(PRCX,U,18)="A5",$P(PRCX,U,12)=21 D SOCIOECO("Q")
|
|
. D:$P(PRCX,U,15)=24 SOCIOECO("W")
|
|
. S PRCI=$O(^PRCF(423.6,PRCDA,1,PRCI)) Q:PRCI=""
|
|
. S PRCX=$G(^PRCF(423.6,PRCDA,1,PRCI,0)) Q:$P(PRCX,U)'="RT"
|
|
. K DA S DA=PRCVDA,DIE=444.1
|
|
. S PRCY=$E($P(PRCX,U,2),1,35) S:PRCY="" PRCY="@" S DR="17.1///^S X=PRCY" D ^DIE
|
|
. S PRCY=$E($P(PRCX,U,3),1,35) S:PRCY="" PRCY="@" S DR="17.15///^S X=PRCY" D ^DIE
|
|
. S PRCY=$E($P(PRCX,U,4),1,35) S:PRCY="" PRCY="@" S DR="17.3///^S X=PRCY" D ^DIE
|
|
. S PRCY=$E($P(PRCX,U,5),1,35) S:PRCY="" PRCY="@" S DR="17.4///^S X=PRCY" D ^DIE
|
|
. S PRCY=$E($P(PRCX,U,6),1,35) S:PRCY="" PRCY="@" S DR="17.5///^S X=PRCY" D ^DIE
|
|
. S PRCY=$E($P(PRCX,U,7),1,30) S:PRCY="" PRCY="@" S DR="17.7///^S X=PRCY" D ^DIE
|
|
. S PRCY=$P(PRCX,U,8)
|
|
. I PRCY]"" D
|
|
. . S PRCY=$O(^DIC(5,"C",PRCY,"")) Q:PRCY=""
|
|
. . S DR="17.8////^S X=PRCY" D ^DIE
|
|
. I PRCY="" S DR="17.8///@" D ^DIE
|
|
. S PRCY=$P(PRCX,U,9),PRCY=$S(PRCY="":"@",$L(PRCY)=5:PRCY,1:$E(PRCY,1,5)_"-"_$E(PRCY,6,9))
|
|
. S DR="17.9///^S X=PRCY" D ^DIE
|
|
. L -^PRC(444.1,PRCVDA)
|
|
;I PRCRCVDT'>$P($G(^PRC(444,PRC("D0"),0)),U,3) D
|
|
I $P($G(^PRC(444,PRC("D0"),0)),U,8)'=3 D
|
|
. S PRCNUM=$O(^PRC(444,PRC("D0"),8,"B",PRCVEN,""))
|
|
. I PRCNUM?1.N D
|
|
. . N DA
|
|
. . S DA=PRCNUM,DA(1)=PRC("D0"),DIK="^PRC(444,DA(1),8," D ^DIK K DIK
|
|
. . S DINUM=PRCNUM
|
|
K DA,DD,DO S X=PRCVEN,DA(1)=PRC("D0"),DIC="^PRC(444,DA(1),8,",DIC(0)="LX"
|
|
S DIC("P")=$P(^DD(444,24,0),U,2)
|
|
S DLAYGO=444.024 D FILE^DICN K DIC,DLAYGO,DINUM
|
|
I Y<1 S PRCERR=8 G ERR^PRCHQ6B
|
|
S PRC("D1")=+Y
|
|
K PRCAR S PRCIENS=PRC("D1")_","_PRC("D0")_","
|
|
S PRCAR(444.024,PRCIENS,3.5)=PRCDA,PRCAR(444.024,PRCIENS,3)=PRCRCVDT
|
|
D FILE^DIE("","PRCAR") K PRCAR D:$D(^TMP("DIERR",$J)) ERRCOPY^PRCHQ6A
|
|
G A^PRCHQ6A
|
|
TYPE(X) ;Edit Type of Ownership multiple
|
|
N DA,DIC,DLAYGO
|
|
S DA(1)=PRCVDA,DLAYGO=444.19,DIC="^PRC(444.1,DA(1),3,",DIC(0)="LX"
|
|
S:'$D(^PRC(444.1,DA(1),3,0)) DIC("P")=$P(^DD(444.1,9,0),U,2)
|
|
D ^DIC
|
|
Q
|
|
SOCIOECO(X) ;Edit Socioeconomic Group multiple
|
|
N DA,DIC,DLAYGO
|
|
S DA(1)=PRCVDA,DLAYGO=444.11,DIC="^PRC(444.1,DA(1),4,",DIC(0)="LX"
|
|
S:'$D(^PRC(444.1,DA(1),4,0)) DIC("P")=$P(^DD(444.1,10,0),U,2)
|
|
D ^DIC
|
|
Q
|