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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHQ6 5286 printed Nov 22, 2024@17:19:55 Page 2
PRCHQ6 ;(WASH IRMFO)/LKG-RFQ SERVER UNPACKING VENDOR QUOTE ;8/6/96 20:57
+1 ;;5.1;IFCAP;;Oct 20, 2000
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
+3 QUIT
IN ;
+1 KILL ^TMP("DIERR",$JOB),^TMP($JOB,"PRCERR")
DO NOW^%DTC
SET PRCRCVDT=%
KILL %,%H,%I
+2 SET PRCI=0
SET PRCI=$ORDER(^PRCF(423.6,PRCDA,1,PRCI))
IF PRCI=""
SET PRCERR=1
GOTO ERR^PRCHQ6B
+3 SET PRCX=$GET(^PRCF(423.6,PRCDA,1,PRCI,0))
+4 IF $PIECE(PRCX,U)'="ISM"!($PIECE(PRCX,U,4)'="VQT")
SET PRCERR=2
GOTO ERR^PRCHQ6B
+5 SET PRCRFQ=$PIECE($PIECE(PRCX,U,7)," ")
+6 SET PRCI=$ORDER(^PRCF(423.6,PRCDA,1,PRCI))
IF PRCI=""
SET PRCERR=3
GOTO ERR^PRCHQ6B
+7 SET PRCX=$GET(^PRCF(423.6,PRCDA,1,PRCI,0))
IF $PIECE(PRCX,U)'="HE"
SET PRCERR=3
GOTO ERR^PRCHQ6B
+8 KILL PRC
SET X=$ORDER(^PRC(444,"B",PRCRFQ,""))
IF X'?1.N
SET PRCERR=4
GOTO ERR^PRCHQ6B
+9 SET PRC("D0")=X
LOCK +^PRC(444,PRC("D0")):1200
IF '$TEST
SET PRCERR=5
GOTO ERR^PRCHQ6B
+10 IF ";0;4;5;"[(";"_$PIECE($GET(^PRC(444,PRC("D0"),0)),U,8)_";")
GOTO EX^PRCHQ6B
+11 SET PRCVCN=$PIECE(PRCX,U,8)
SET PRCVCP=$PIECE(PRCX,U,9)
SET PRCICNT=+$PIECE(PRCX,U,12)
+12 SET PRCREF=$PIECE(PRCX,U,15)
SET PRCEFFDT=$$JD2FMD^PRCHQ7($PIECE(PRCX,U,16))
+13 SET PRCI=$ORDER(^PRCF(423.6,PRCDA,1,PRCI))
IF PRCI=""
SET PRCERR=6
GOTO ERR^PRCHQ6B
+14 SET PRCX=$GET(^PRCF(423.6,PRCDA,1,PRCI,0))
IF $PIECE(PRCX,U)'="VE"
SET PRCERR=6
GOTO ERR^PRCHQ6B
+15 SET PRCDB=$PIECE(PRCX,U,2)
SET PRCVNM=$PIECE(PRCX,U,3)
+16 SET PRCDBI="DUN"_PRCDB
SET PRCVDA=$ORDER(^PRC(440,"DB",PRCDBI,""))
+17 IF PRCVDA?1.N
Begin DoDot:1
+18 SET PRCVEN=PRCVDA_";PRC(440,"
End DoDot:1
+19 IF PRCVDA=""
Begin DoDot:1
+20 NEW DA,DIC,DIE,DR
+21 SET PRCVDA=$ORDER(^PRC(444.1,"DB",PRCDBI,""))
+22 IF PRCVDA=""
Begin DoDot:2
+23 KILL DD,DO
+24 SET X=$PIECE(PRCX,U,3)
SET DIC="^PRC(444.1,"
SET DIC(0)="LX"
SET DLAYGO=444.1
+25 DO FILE^DICN
KILL DIC,DLAYGO
+26 IF Y<1
SET PRCERR=7
QUIT
+27 SET PRCVDA=+Y
+28 SET DA=PRCVDA
SET DIE=444.1
SET DR="18.3///^S X=PRCDB"
DO ^DIE
KILL DA,DIE,DR
End DoDot:2
if $DATA(PRCERR)
QUIT
+29 SET PRCVEN=PRCVDA_";PRC(444.1,"
+30 LOCK +^PRC(444.1,PRCVDA):1200
IF '$TEST
QUIT
+31 SET DA=PRCVDA
SET DIE=444.1
SET DR=".01///^S X=$P(PRCX,U,3)"
DO ^DIE
+32 SET PRCY=$EXTRACT($PIECE(PRCX,U,4),1,33)
if PRCY=""
SET PRCY="@"
SET DR="1///^S X=PRCY"
DO ^DIE
+33 SET PRCY=$EXTRACT($PIECE(PRCX,U,5),1,33)
if PRCY=""
SET PRCY="@"
SET DR="2///^S X=PRCY"
DO ^DIE
+34 SET PRCY=$EXTRACT($PIECE(PRCX,U,6),1,25)
if PRCY=""
SET PRCY="@"
SET DR="3///^S X=PRCY"
DO ^DIE
+35 SET PRCY=$EXTRACT($PIECE(PRCX,U,7),1,20)
if PRCY=""
SET PRCY="@"
SET DR="4.2///^S X=PRCY"
DO ^DIE
+36 SET PRCY=$PIECE(PRCX,U,8)
+37 IF PRCY]""
Begin DoDot:2
+38 SET PRCY=$ORDER(^DIC(5,"C",PRCY,""))
if PRCY=""
QUIT
+39 SET DR="4.4////^S X=PRCY"
DO ^DIE
End DoDot:2
+40 IF PRCY=""
SET DR="4.4///@"
DO ^DIE
+41 SET PRCY=$PIECE(PRCX,U,9)
SET PRCY=$SELECT(PRCY="":"@",$LENGTH(PRCY)=5:PRCY,1:$EXTRACT(PRCY,1,5)_"-"_$EXTRACT(PRCY,6,9))
+42 SET DR="4.6///^S X=PRCY"
DO ^DIE
+43 IF PRCVCN]""
SET DR="4.8///^S X=PRCVCN"
DO ^DIE
+44 SET PRCY=$PIECE(PRCX,U,10)
if PRCY=""
SET PRCY="@"
SET DR="5///^S X=PRCY"
DO ^DIE
+45 SET PRCY=$PIECE(PRCX,U,11)
if PRCY=""
SET PRCY="@"
SET DR="38///^S X=PRCY"
DO ^DIE
+46 SET PRCY=$PIECE(PRCX,U,12)
+47 IF PRCY]""
Begin DoDot:2
+48 SET PRCY=$SELECT(PRCY=21:1,PRCY="B9":2,1:"")
if PRCY=""
QUIT
+49 SET DR="8.3////^S X=PRCY"
DO ^DIE
End DoDot:2
+50 SET PRCY=$PIECE(PRCX,U,19)
+51 IF PRCY]""
SET PRCY=$SELECT(PRCY="A6":"y",1:"n")
SET DR="50////^S X=PRCY"
DO ^DIE
+52 IF $PIECE(PRCX,U,13)=22!($PIECE(PRCX,U,14)=23)
DO TYPE("M")
+53 IF $PIECE(PRCX,U,15)=24!($PIECE(PRCX,U,16)=25)
DO TYPE("W")
+54 if $PIECE(PRCX,U,18)="A5"
DO TYPE("V")
+55 IF $DATA(^PRC(444.1,PRCVDA,4))
IF $PIECE(PRCX,U,17)=27!($PIECE(PRCX,U,18)="A5"&($PIECE(PRCX,U,12)=21))!($PIECE(PRCX,U,15)=24)
DO DELTNONE^PRCHQ6A
+56 if $PIECE(PRCX,U,17)=27
DO SOCIOECO("N")
+57 IF $PIECE(PRCX,U,18)="A5"
IF $PIECE(PRCX,U,12)=21
DO SOCIOECO("Q")
+58 if $PIECE(PRCX,U,15)=24
DO SOCIOECO("W")
+59 SET PRCI=$ORDER(^PRCF(423.6,PRCDA,1,PRCI))
if PRCI=""
QUIT
+60 SET PRCX=$GET(^PRCF(423.6,PRCDA,1,PRCI,0))
if $PIECE(PRCX,U)'="RT"
QUIT
+61 KILL DA
SET DA=PRCVDA
SET DIE=444.1
+62 SET PRCY=$EXTRACT($PIECE(PRCX,U,2),1,35)
if PRCY=""
SET PRCY="@"
SET DR="17.1///^S X=PRCY"
DO ^DIE
+63 SET PRCY=$EXTRACT($PIECE(PRCX,U,3),1,35)
if PRCY=""
SET PRCY="@"
SET DR="17.15///^S X=PRCY"
DO ^DIE
+64 SET PRCY=$EXTRACT($PIECE(PRCX,U,4),1,35)
if PRCY=""
SET PRCY="@"
SET DR="17.3///^S X=PRCY"
DO ^DIE
+65 SET PRCY=$EXTRACT($PIECE(PRCX,U,5),1,35)
if PRCY=""
SET PRCY="@"
SET DR="17.4///^S X=PRCY"
DO ^DIE
+66 SET PRCY=$EXTRACT($PIECE(PRCX,U,6),1,35)
if PRCY=""
SET PRCY="@"
SET DR="17.5///^S X=PRCY"
DO ^DIE
+67 SET PRCY=$EXTRACT($PIECE(PRCX,U,7),1,30)
if PRCY=""
SET PRCY="@"
SET DR="17.7///^S X=PRCY"
DO ^DIE
+68 SET PRCY=$PIECE(PRCX,U,8)
+69 IF PRCY]""
Begin DoDot:2
+70 SET PRCY=$ORDER(^DIC(5,"C",PRCY,""))
if PRCY=""
QUIT
+71 SET DR="17.8////^S X=PRCY"
DO ^DIE
End DoDot:2
+72 IF PRCY=""
SET DR="17.8///@"
DO ^DIE
+73 SET PRCY=$PIECE(PRCX,U,9)
SET PRCY=$SELECT(PRCY="":"@",$LENGTH(PRCY)=5:PRCY,1:$EXTRACT(PRCY,1,5)_"-"_$EXTRACT(PRCY,6,9))
+74 SET DR="17.9///^S X=PRCY"
DO ^DIE
+75 LOCK -^PRC(444.1,PRCVDA)
End DoDot:1
if $DATA(PRCERR)
GOTO ERR^PRCHQ6B
+76 ;I PRCRCVDT'>$P($G(^PRC(444,PRC("D0"),0)),U,3) D
+77 IF $PIECE($GET(^PRC(444,PRC("D0"),0)),U,8)'=3
Begin DoDot:1
+78 SET PRCNUM=$ORDER(^PRC(444,PRC("D0"),8,"B",PRCVEN,""))
+79 IF PRCNUM?1.N
Begin DoDot:2
+80 NEW DA
+81 SET DA=PRCNUM
SET DA(1)=PRC("D0")
SET DIK="^PRC(444,DA(1),8,"
DO ^DIK
KILL DIK
+82 SET DINUM=PRCNUM
End DoDot:2
End DoDot:1
+83 KILL DA,DD,DO
SET X=PRCVEN
SET DA(1)=PRC("D0")
SET DIC="^PRC(444,DA(1),8,"
SET DIC(0)="LX"
+84 SET DIC("P")=$PIECE(^DD(444,24,0),U,2)
+85 SET DLAYGO=444.024
DO FILE^DICN
KILL DIC,DLAYGO,DINUM
+86 IF Y<1
SET PRCERR=8
GOTO ERR^PRCHQ6B
+87 SET PRC("D1")=+Y
+88 KILL PRCAR
SET PRCIENS=PRC("D1")_","_PRC("D0")_","
+89 SET PRCAR(444.024,PRCIENS,3.5)=PRCDA
SET PRCAR(444.024,PRCIENS,3)=PRCRCVDT
+90 DO FILE^DIE("","PRCAR")
KILL PRCAR
if $DATA(^TMP("DIERR",$JOB))
DO ERRCOPY^PRCHQ6A
+91 GOTO A^PRCHQ6A
TYPE(X) ;Edit Type of Ownership multiple
+1 NEW DA,DIC,DLAYGO
+2 SET DA(1)=PRCVDA
SET DLAYGO=444.19
SET DIC="^PRC(444.1,DA(1),3,"
SET DIC(0)="LX"
+3 if '$DATA(^PRC(444.1,DA(1),3,0))
SET DIC("P")=$PIECE(^DD(444.1,9,0),U,2)
+4 DO ^DIC
+5 QUIT
SOCIOECO(X) ;Edit Socioeconomic Group multiple
+1 NEW DA,DIC,DLAYGO
+2 SET DA(1)=PRCVDA
SET DLAYGO=444.11
SET DIC="^PRC(444.1,DA(1),4,"
SET DIC(0)="LX"
+3 if '$DATA(^PRC(444.1,DA(1),4,0))
SET DIC("P")=$PIECE(^DD(444.1,10,0),U,2)
+4 DO ^DIC
+5 QUIT
