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