PRCHQ6A ;(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
A I PRCVEN["PRC(440," D
. K XMB,XMZ
. F PRCJ=1:1:27 S XMB(PRCJ)=""
. S XMB="PRCHQ 843 UPDATE VENDOR INFO"
. S XMB(27)=PRCRFQ
. S XMB(1)=$P(PRCX,U,2),XMB(2)=$P(PRCX,U,3),XMB(3)=$P(PRCX,U,11)
. S XMB(4)=$P(PRCX,U,10),XMB(5)=$P(PRCX,U,4),XMB(6)=$P(PRCX,U,5)
. S XMB(7)=$P(PRCX,U,6),XMB(8)=$P(PRCX,U,7),XMB(9)=$P(PRCX,U,8)
. S XMB(10)=$P(PRCX,U,9)
. S X=$P(PRCX,U,12),XMB(11)=$S(X=21:"SMALL",X="B9":"LARGE",1:"")
. S XMB(12)=$S($P(PRCX,U,13)=22:"YES",1:"NO")
. S XMB(13)=$S($P(PRCX,U,14)=23:"YES",1:"NO")
. S XMB(14)=$S($P(PRCX,U,15)=24:"YES",1:"NO")
. S XMB(15)=$S($P(PRCX,U,16)=25:"YES",1:"NO")
. S XMB(16)=$S($P(PRCX,U,17)=27:"YES",1:"NO")
. S XMB(17)=$S($P(PRCX,U,18)="A5":"YES",1:"NO")
. S XMB(18)=$S($P(PRCX,U,19)="A6":"YES",1:"NO")
. S PRCI=$O(^PRCF(423.6,PRCDA,1,PRCI))
. S PRCX=$G(^PRCF(423.6,PRCDA,1,PRCI,0))
. I $P(PRCX,U)="RT" D
. . S XMB(19)=$P(PRCX,U,2),XMB(20)=$P(PRCX,U,3),XMB(21)=$P(PRCX,U,4)
. . S XMB(22)=$P(PRCX,U,5),XMB(23)=$P(PRCX,U,6),XMB(24)=$P(PRCX,U,7)
. . S XMB(25)=$P(PRCX,U,8),XMB(26)=$P(PRCX,U,9)
. S XMDUZ="843 Vendor Quote Filer" D ^XMB K XMB,XMDUZ,XMZ
I $P(PRCX,U)="RT" S PRCI=$O(^PRCF(423.6,PRCDA,1,PRCI)) I PRCI="" S PRCERR=10 G ERR^PRCHQ6B
S PRCX=$G(^PRCF(423.6,PRCDA,1,PRCI,0)) I $P(PRCX,U)'="AC" S PRCERR=10 G ERR^PRCHQ6B
K PRCAR S PRCIENS=PRC("D1")_","_PRC("D0")_","
S:PRCREF]"" PRCAR(444.024,PRCIENS,1)=PRCREF
S:PRCEFFDT]"" PRCAR(444.024,PRCIENS,2)=+$E(PRCEFFDT,4,5)_"/"_(+$E(PRCEFFDT,6,7))_"/"_($E(PRCEFFDT,1,3)+1700)
S:PRCVCN]"" PRCAR(444.024,PRCIENS,4)=$E(PRCVCN,1,30)
S:PRCVCP]"" PRCAR(444.024,PRCIENS,5)=PRCVCP
S PRCY=$P(PRCX,U,3) S:PRCY]"" PRCAR(444.024,PRCIENS,6)=$S(PRCY="O":"ORIGIN",PRCY="D":"DESTINATION",1:PRCY)
S PRCY=$P(PRCX,U,2) S:PRCY]"" PRCAR(444.024,PRCIENS,7)=PRCY/100
S PRCY=$P(PRCX,U,4) S:PRCY]"" PRCAR(444.024,PRCIENS,8)=PRCY/100
D FILE^DIE("E","PRCAR") K PRCAR,PRCENUM D:$D(^TMP("DIERR",$J)) ERRCOPY
S PRCIENS="+1,"_PRCIENS
S PRCY=$S($P(PRCX,U,5)>0:$P(PRCX,U,5),$P(PRCX,U,7)="N":"NET",1:"")
S:PRCY?1.N PRCY="."_PRCY*100
I PRCY]"" D G:$D(PRCERR) ERR^PRCHQ6B
. S PRCAR(444.025,PRCIENS,.01)=PRCY,PRCAR(444.025,PRCIENS,1)=$P(PRCX,U,6)
. D UPDATE^DIE("E","PRCAR","PRCENUM") D:$D(^TMP("DIERR",$J)) ERRCOPY
. S:$G(PRCENUM(1))'?1.N PRCERR=15
. K PRCIENS,PRCAR,PRCENUM
S PRCI=$O(^PRCF(423.6,PRCDA,1,PRCI)) I PRCI="" S PRCERR=11 G ERR^PRCHQ6B
S PRCX=$G(^PRCF(423.6,PRCDA,1,PRCI,0))
I $P(PRCX,U)="TX" D
. K ^TMP($J,"TX") S PRCJ=0
. F D Q:$P(PRCX,U)'="TX"
. . S PRCJ=PRCJ+1,^TMP($J,"TX",PRCJ,0)=$P(PRCX,U,3)
. . S PRCI=$O(^PRCF(423.6,PRCDA,1,PRCI))
. . S PRCX=$S(PRCI="":"",1:$G(^PRCF(423.6,PRCDA,1,PRCI,0)))
. S PRCY=$P($G(^PRC(444,PRC("D0"),1)),U,5)+1,$P(^(1),U,5)=PRCY
. S PRCIENS="+1,"_PRC("D0")_"," K PRCAR
. S PRCAR(444.021,PRCIENS,.01)=PRCY,PRCENUM(1)=PRCY
. D UPDATE^DIE("","PRCAR","PRCENUM") K PRCAR D:$D(^TMP("DIERR",$J)) ERRCOPY
. S PRCIENS=PRCENUM(1)_","_PRC("D0")_"," K PRCENUM
. S PRCAR(444.021,PRCIENS,1)="I",PRCAR(444.021,PRCIENS,2)=PRCDB
. S:PRCVNM]"" PRCAR(444.021,PRCIENS,2.5)=PRCVNM
. S PRCAR(444.021,PRCIENS,3)=PRCREF,PRCAR(444.021,PRCIENS,4)=999
. S PRCAR(444.021,PRCIENS,5)=PRCEFFDT,PRCAR(444.021,PRCIENS,6)=PRCRCVDT
. S PRCAR(444.021,PRCIENS,7)=PRCVCN,PRCAR(444.021,PRCIENS,8)=PRCVCP
. S PRCAR(444.021,PRCIENS,9)="Comments submitted with 843 Transaction."
. D FILE^DIE("","PRCAR") K PRCAR D:$D(^TMP("DIERR",$J)) ERRCOPY
. D WP^DIE(444.021,PRCIENS,10,"","^TMP($J,""TX"")") D:$D(^TMP("DIERR",$J)) ERRCOPY
. K ^TMP($J,"TX")
. K XMB,XMY S XMB="PRCHQ 864 NORMAL",XMB(1)=$G(PRCRFQ),XMB(2)=$G(PRCDB),XMB(3)=$P($G(PRCIENS),",")
. S X=$P($G(^PRC(444,PRC("D0"),0)),U,4) S:X?1.N XMY(X)=""
. S XMDUZ="864 Text Message Filer" D ^XMB K XMB,XMDUZ,XMZ
I PRCI="" S PRCERR=11 G ERR^PRCHQ6B
S PRCX=$G(^PRCF(423.6,PRCDA,1,PRCI,0)) I $P(PRCX,U)'="IT" S PRCERR=11 G ERR^PRCHQ6B
S PRCITEMS=0
G ITEM^PRCHQ6B
DELTNONE ;Delete Socioeconomic Group 'OO - None of the Above'
N DA,DIK S DA(1)=PRCVDA,DA=$O(^PRC(444.1,DA(1),4,"B",161,"")) Q:DA=""
S DIK="^PRC(444.1,DA(1),4," D ^DIK
Q
ERRCOPY ;Copy error messages to report file
N PRCJ,PRCK S PRCK=$G(^TMP($J,"PRCERR")),PRCJ=0
F S PRCJ=$O(^TMP("DIERR",$J,PRCJ)) Q:PRCJ'?1.N D
. I $D(^TMP("DIERR",$J,PRCJ,"TEXT",1)) D
. . S PRCK=PRCK+1,^TMP($J,"PRCERR",PRCK)=^TMP("DIERR",$J,PRCJ,"TEXT",1)
. . S:$D(^TMP("DIERR",$J,PRCJ,"PARAM","IENS")) ^TMP($J,"PRCERR",PRCK)=$E(^TMP($J,"PRCERR",PRCK),1,220)_"-IENS: "_^TMP("DIERR",$J,PRCJ,"PARAM","IENS")
S:PRCK>0 ^TMP($J,"PRCERR")=PRCK
K ^TMP("DIERR",$J)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHQ6A 4729 printed Apr 09, 2024@21:18:17 Page 2
PRCHQ6A ;(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
A IF PRCVEN["PRC(440,"
Begin DoDot:1
+1 KILL XMB,XMZ
+2 FOR PRCJ=1:1:27
SET XMB(PRCJ)=""
+3 SET XMB="PRCHQ 843 UPDATE VENDOR INFO"
+4 SET XMB(27)=PRCRFQ
+5 SET XMB(1)=$PIECE(PRCX,U,2)
SET XMB(2)=$PIECE(PRCX,U,3)
SET XMB(3)=$PIECE(PRCX,U,11)
+6 SET XMB(4)=$PIECE(PRCX,U,10)
SET XMB(5)=$PIECE(PRCX,U,4)
SET XMB(6)=$PIECE(PRCX,U,5)
+7 SET XMB(7)=$PIECE(PRCX,U,6)
SET XMB(8)=$PIECE(PRCX,U,7)
SET XMB(9)=$PIECE(PRCX,U,8)
+8 SET XMB(10)=$PIECE(PRCX,U,9)
+9 SET X=$PIECE(PRCX,U,12)
SET XMB(11)=$SELECT(X=21:"SMALL",X="B9":"LARGE",1:"")
+10 SET XMB(12)=$SELECT($PIECE(PRCX,U,13)=22:"YES",1:"NO")
+11 SET XMB(13)=$SELECT($PIECE(PRCX,U,14)=23:"YES",1:"NO")
+12 SET XMB(14)=$SELECT($PIECE(PRCX,U,15)=24:"YES",1:"NO")
+13 SET XMB(15)=$SELECT($PIECE(PRCX,U,16)=25:"YES",1:"NO")
+14 SET XMB(16)=$SELECT($PIECE(PRCX,U,17)=27:"YES",1:"NO")
+15 SET XMB(17)=$SELECT($PIECE(PRCX,U,18)="A5":"YES",1:"NO")
+16 SET XMB(18)=$SELECT($PIECE(PRCX,U,19)="A6":"YES",1:"NO")
+17 SET PRCI=$ORDER(^PRCF(423.6,PRCDA,1,PRCI))
+18 SET PRCX=$GET(^PRCF(423.6,PRCDA,1,PRCI,0))
+19 IF $PIECE(PRCX,U)="RT"
Begin DoDot:2
+20 SET XMB(19)=$PIECE(PRCX,U,2)
SET XMB(20)=$PIECE(PRCX,U,3)
SET XMB(21)=$PIECE(PRCX,U,4)
+21 SET XMB(22)=$PIECE(PRCX,U,5)
SET XMB(23)=$PIECE(PRCX,U,6)
SET XMB(24)=$PIECE(PRCX,U,7)
+22 SET XMB(25)=$PIECE(PRCX,U,8)
SET XMB(26)=$PIECE(PRCX,U,9)
End DoDot:2
+23 SET XMDUZ="843 Vendor Quote Filer"
DO ^XMB
KILL XMB,XMDUZ,XMZ
End DoDot:1
+24 IF $PIECE(PRCX,U)="RT"
SET PRCI=$ORDER(^PRCF(423.6,PRCDA,1,PRCI))
IF PRCI=""
SET PRCERR=10
GOTO ERR^PRCHQ6B
+25 SET PRCX=$GET(^PRCF(423.6,PRCDA,1,PRCI,0))
IF $PIECE(PRCX,U)'="AC"
SET PRCERR=10
GOTO ERR^PRCHQ6B
+26 KILL PRCAR
SET PRCIENS=PRC("D1")_","_PRC("D0")_","
+27 if PRCREF]""
SET PRCAR(444.024,PRCIENS,1)=PRCREF
+28 if PRCEFFDT]""
SET PRCAR(444.024,PRCIENS,2)=+$EXTRACT(PRCEFFDT,4,5)_"/"_(+$EXTRACT(PRCEFFDT,6,7))_"/"_($EXTRACT(PRCEFFDT,1,3)+1700)
+29 if PRCVCN]""
SET PRCAR(444.024,PRCIENS,4)=$EXTRACT(PRCVCN,1,30)
+30 if PRCVCP]""
SET PRCAR(444.024,PRCIENS,5)=PRCVCP
+31 SET PRCY=$PIECE(PRCX,U,3)
if PRCY]""
SET PRCAR(444.024,PRCIENS,6)=$SELECT(PRCY="O":"ORIGIN",PRCY="D":"DESTINATION",1:PRCY)
+32 SET PRCY=$PIECE(PRCX,U,2)
if PRCY]""
SET PRCAR(444.024,PRCIENS,7)=PRCY/100
+33 SET PRCY=$PIECE(PRCX,U,4)
if PRCY]""
SET PRCAR(444.024,PRCIENS,8)=PRCY/100
+34 DO FILE^DIE("E","PRCAR")
KILL PRCAR,PRCENUM
if $DATA(^TMP("DIERR",$JOB))
DO ERRCOPY
+35 SET PRCIENS="+1,"_PRCIENS
+36 SET PRCY=$SELECT($PIECE(PRCX,U,5)>0:$PIECE(PRCX,U,5),$PIECE(PRCX,U,7)="N":"NET",1:"")
+37 if PRCY?1.N
SET PRCY="."_PRCY*100
+38 IF PRCY]""
Begin DoDot:1
+39 SET PRCAR(444.025,PRCIENS,.01)=PRCY
SET PRCAR(444.025,PRCIENS,1)=$PIECE(PRCX,U,6)
+40 DO UPDATE^DIE("E","PRCAR","PRCENUM")
if $DATA(^TMP("DIERR",$JOB))
DO ERRCOPY
+41 if $GET(PRCENUM(1))'?1.N
SET PRCERR=15
+42 KILL PRCIENS,PRCAR,PRCENUM
End DoDot:1
if $DATA(PRCERR)
GOTO ERR^PRCHQ6B
+43 SET PRCI=$ORDER(^PRCF(423.6,PRCDA,1,PRCI))
IF PRCI=""
SET PRCERR=11
GOTO ERR^PRCHQ6B
+44 SET PRCX=$GET(^PRCF(423.6,PRCDA,1,PRCI,0))
+45 IF $PIECE(PRCX,U)="TX"
Begin DoDot:1
+46 KILL ^TMP($JOB,"TX")
SET PRCJ=0
+47 FOR
Begin DoDot:2
+48 SET PRCJ=PRCJ+1
SET ^TMP($JOB,"TX",PRCJ,0)=$PIECE(PRCX,U,3)
+49 SET PRCI=$ORDER(^PRCF(423.6,PRCDA,1,PRCI))
+50 SET PRCX=$SELECT(PRCI="":"",1:$GET(^PRCF(423.6,PRCDA,1,PRCI,0)))
End DoDot:2
if $PIECE(PRCX,U)'="TX"
QUIT
+51 SET PRCY=$PIECE($GET(^PRC(444,PRC("D0"),1)),U,5)+1
SET $PIECE(^(1),U,5)=PRCY
+52 SET PRCIENS="+1,"_PRC("D0")_","
KILL PRCAR
+53 SET PRCAR(444.021,PRCIENS,.01)=PRCY
SET PRCENUM(1)=PRCY
+54 DO UPDATE^DIE("","PRCAR","PRCENUM")
KILL PRCAR
if $DATA(^TMP("DIERR",$JOB))
DO ERRCOPY
+55 SET PRCIENS=PRCENUM(1)_","_PRC("D0")_","
KILL PRCENUM
+56 SET PRCAR(444.021,PRCIENS,1)="I"
SET PRCAR(444.021,PRCIENS,2)=PRCDB
+57 if PRCVNM]""
SET PRCAR(444.021,PRCIENS,2.5)=PRCVNM
+58 SET PRCAR(444.021,PRCIENS,3)=PRCREF
SET PRCAR(444.021,PRCIENS,4)=999
+59 SET PRCAR(444.021,PRCIENS,5)=PRCEFFDT
SET PRCAR(444.021,PRCIENS,6)=PRCRCVDT
+60 SET PRCAR(444.021,PRCIENS,7)=PRCVCN
SET PRCAR(444.021,PRCIENS,8)=PRCVCP
+61 SET PRCAR(444.021,PRCIENS,9)="Comments submitted with 843 Transaction."
+62 DO FILE^DIE("","PRCAR")
KILL PRCAR
if $DATA(^TMP("DIERR",$JOB))
DO ERRCOPY
+63 DO WP^DIE(444.021,PRCIENS,10,"","^TMP($J,""TX"")")
if $DATA(^TMP("DIERR",$JOB))
DO ERRCOPY
+64 KILL ^TMP($JOB,"TX")
+65 KILL XMB,XMY
SET XMB="PRCHQ 864 NORMAL"
SET XMB(1)=$GET(PRCRFQ)
SET XMB(2)=$GET(PRCDB)
SET XMB(3)=$PIECE($GET(PRCIENS),",")
+66 SET X=$PIECE($GET(^PRC(444,PRC("D0"),0)),U,4)
if X?1.N
SET XMY(X)=""
+67 SET XMDUZ="864 Text Message Filer"
DO ^XMB
KILL XMB,XMDUZ,XMZ
End DoDot:1
+68 IF PRCI=""
SET PRCERR=11
GOTO ERR^PRCHQ6B
+69 SET PRCX=$GET(^PRCF(423.6,PRCDA,1,PRCI,0))
IF $PIECE(PRCX,U)'="IT"
SET PRCERR=11
GOTO ERR^PRCHQ6B
+70 SET PRCITEMS=0
+71 GOTO ITEM^PRCHQ6B
DELTNONE ;Delete Socioeconomic Group 'OO - None of the Above'
+1 NEW DA,DIK
SET DA(1)=PRCVDA
SET DA=$ORDER(^PRC(444.1,DA(1),4,"B",161,""))
if DA=""
QUIT
+2 SET DIK="^PRC(444.1,DA(1),4,"
DO ^DIK
+3 QUIT
ERRCOPY ;Copy error messages to report file
+1 NEW PRCJ,PRCK
SET PRCK=$GET(^TMP($JOB,"PRCERR"))
SET PRCJ=0
+2 FOR
SET PRCJ=$ORDER(^TMP("DIERR",$JOB,PRCJ))
if PRCJ'?1.N
QUIT
Begin DoDot:1
+3 IF $DATA(^TMP("DIERR",$JOB,PRCJ,"TEXT",1))
Begin DoDot:2
+4 SET PRCK=PRCK+1
SET ^TMP($JOB,"PRCERR",PRCK)=^TMP("DIERR",$JOB,PRCJ,"TEXT",1)
+5 if $DATA(^TMP("DIERR",$JOB,PRCJ,"PARAM","IENS"))
SET ^TMP($JOB,"PRCERR",PRCK)=$EXTRACT(^TMP($JOB,"PRCERR",PRCK),1,220)_"-IENS: "_^TMP("DIERR",$JOB,PRCJ,"PARAM","IENS")
End DoDot:2
End DoDot:1
+6 if PRCK>0
SET ^TMP($JOB,"PRCERR")=PRCK
+7 KILL ^TMP("DIERR",$JOB)
+8 QUIT
