PRCHQ5 ;(WASH IRMFO)/LKG-RFQ 864 Text Message Create ;9/6/96 15:00
;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
EN ;Entry point
S PRCEDIT=$$EDITOR^PRCHQ1C
I PRCEDIT="" D EN^DDIOL("Edit mode not indicated, aborting the edit") K PRCEDIT Q
S PRCMSG="" D ESIG^PRCUESIG(DUZ,.PRCMSG)
I PRCMSG'=1 D EN^DDIOL("Electronic Signature Failed, Edit aborted") G OUT
S DIC="^PRC(444,",DIC(0)="AEMQ",DIC("S")="I "";2;3;4;""[("";""_$P(^(0),U,8)_"";"")"
S DIC("A")="Enter RFQ #: " D ^DIC K DIC I Y<1!$D(DTOUT)!$D(DUOUT) G OUT
S PRCDA=+Y
L +^PRC(444,PRCDA):3 E W !,"Someone else is editing this entry, please try later!" G OUT
S PRCX=$G(^PRC(444,PRCDA,1)),PRCMSGN=$P(PRCX,U,5)+1,PRCOUTN=$P(PRCX,U,6)+1
K DD,DO S DA(1)=PRCDA,DIC="^PRC(444,DA(1),7,",DIC(0)="L"
S DIC("P")=$P(^DD(444,21,0),U,2),X=PRCMSGN,DINUM=PRCMSGN,DLAYGO=444.021
D FILE^DICN K DIC,DINUM,DLAYGO
I Y<1 W !,"No entry was made.!" L -^PRC(444,PRCDA) G EX
S PRCDA2=+Y
S $P(^PRC(444,PRCDA,1),U,5,6)=PRCMSGN_U_PRCOUTN
K ^UTILITY("DIQ1",$J) S DA=DUZ,DIC=200,DR=".01;.135" D EN^DIQ1
S PRCA=^UTILITY("DIQ1",$J,200,DA,.01),PRCB=^(.135) K ^UTILITY("DIQ1",$J)
S DA=PRCDA2,DA(1)=PRCDA,DIE="^PRC(444,DA(1),7,"
S DR="1////O;4///^S X=PRCOUTN;5///NOW;6///NOW;7///^S X=PRCA" D ^DIE
I PRCB]"" S DR="8///^S X=PRCB" D ^DIE
S PRCA=$P($G(^PRC(444,PRCDA,1)),U,8) I PRCA]"" S DR="12////^S X=PRCA" D ^DIE
K DIE,DR,DA,PRCA,PRCB
I $P($G(^PRC(444,PRCDA,5,0)),U,4)>0 D
. N PRCX,PRCY,PRCDA3
. S PRCX=0,PRCDA3=0
. F S PRCX=$O(^PRC(444,PRCDA,5,PRCX)) Q:PRCX'?1.N D
. . S PRCY=$G(^PRC(444,PRCDA,5,PRCX,0)) Q:PRCY=""
. . Q:$P(PRCY,U,2)'="e"&($P(PRCY,U,2)'="b") S PRCY=$P(PRCY,U) Q:PRCY=""
. . S PRCDA3=PRCDA3+1,^PRC(444,PRCDA,7,PRCDA2,3,PRCDA3,0)=PRCY
. . S ^PRC(444,PRCDA,7,PRCDA2,3,"B",PRCY,PRCDA3)=""
. S:PRCDA3>0 ^PRC(444,PRCDA,7,PRCDA2,3,0)=U_$P(^DD(444.021,11,0),U,2)_U_PRCDA3_U_PRCDA3
DDS ;Test FORM
S PRCRFQ=$P($G(^PRC(444,PRCDA,0)),U)
I PRCEDIT="s" D G EX:$D(DTOUT)
. S DDSPARM="S"
. S DDSFILE=444,DDSFILE(1)=444.021,DA(1)=PRCDA,DA=PRCDA2,DR="[PRCHQ4]"
. D ^DDS
. K DDSCHANG,DDSPARM,DIMSG,DDSFILE,DA,DR
I PRCEDIT="i" D G EX:$D(DTOUT)!$D(DUOUT)
. N %,%H,%I
. K DA S DA=PRCDA2,DA(1)=PRCDA,DIE="^PRC(444,PRCDA,7,",DR="9R;10R;8R;12R;11",DR(2,444.022)=".01"
. D ^DIE K DIE,DR
. D NOW^%DTC S $P(^PRC(444,PRCDA,7,PRCDA2,0),U,10,11)=DUZ_U_%
I $G(DDSSAVE)=1!(PRCEDIT="i") D
. S DIR(0)="YA",DIR("A")="Do you wish to transmit this message to the vendors? "
. S DIR("B")="YES",DIR("?")="Accept default of 'YES' to transmit, enter 'No' to avoid transmitting."
. D ^DIR K DIR Q:Y'=1!$D(DIRUT)!$D(DIROUT)!$D(DTOUT)!$D(DUOUT)
. K PRCERR
. D TRANS864^PRCHQ4A
. I $G(PRCERR) D EN^DDIOL("Electronic Transmission Aborted!")
EX L:$D(PRCDA) -^PRC(444,PRCDA) K DDSSAVE,PRCERR
OUT K PRCX,PRCMSGN,PRCOUTN,PRCDA,PRCDA2,PRCRFQ,DTOUT,DUOUT,DA,DIRUT,DIROUT,X,Y,PRCMSG,%,PRCEDIT
Q
SC() ;Screen for File 440 and File 444.1 vendors
N PRC,PRCX,PRCZ S PRC=0,PRCX=Y_";"_$P(DIC,U,2)
I $D(PRCDA) D
. S PRCZ=$O(^PRC(444,PRCDA,5,"B",PRCX,""))
. I PRCZ]"",$P($G(^PRC(444,PRCDA,5,PRCZ,0)),U,2)="e" S PRC=1 Q
. I $P($G(^PRC(444,PRCDA,1)),U,8)="y",PRCX["PRC(440",$P($G(^PRC(440,+PRCX,3)),U,2)="Y",$P($G(^PRC(440,+PRCX,7)),U,12)]"" S PRC=1 Q
Q PRC
RHLP ;Executable Help for Recipient Lookup
N PRCAR S PRCAR(1)="Choices are restricted to Electronic Solicited Vendors unless the RFQ's"
S PRCAR(2)=" transmission was Public. Vendor must be EDI and have Duns #."
D EN^DDIOL(.PRCAR)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHQ5 3546 printed Oct 16, 2024@18:10:34 Page 2
PRCHQ5 ;(WASH IRMFO)/LKG-RFQ 864 Text Message Create ;9/6/96 15:00
+1 ;;5.1;IFCAP;;Oct 20, 2000
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
EN ;Entry point
+1 SET PRCEDIT=$$EDITOR^PRCHQ1C
+2 IF PRCEDIT=""
DO EN^DDIOL("Edit mode not indicated, aborting the edit")
KILL PRCEDIT
QUIT
+3 SET PRCMSG=""
DO ESIG^PRCUESIG(DUZ,.PRCMSG)
+4 IF PRCMSG'=1
DO EN^DDIOL("Electronic Signature Failed, Edit aborted")
GOTO OUT
+5 SET DIC="^PRC(444,"
SET DIC(0)="AEMQ"
SET DIC("S")="I "";2;3;4;""[("";""_$P(^(0),U,8)_"";"")"
+6 SET DIC("A")="Enter RFQ #: "
DO ^DIC
KILL DIC
IF Y<1!$DATA(DTOUT)!$DATA(DUOUT)
GOTO OUT
+7 SET PRCDA=+Y
+8 LOCK +^PRC(444,PRCDA):3
IF '$TEST
WRITE !,"Someone else is editing this entry, please try later!"
GOTO OUT
+9 SET PRCX=$GET(^PRC(444,PRCDA,1))
SET PRCMSGN=$PIECE(PRCX,U,5)+1
SET PRCOUTN=$PIECE(PRCX,U,6)+1
+10 KILL DD,DO
SET DA(1)=PRCDA
SET DIC="^PRC(444,DA(1),7,"
SET DIC(0)="L"
+11 SET DIC("P")=$PIECE(^DD(444,21,0),U,2)
SET X=PRCMSGN
SET DINUM=PRCMSGN
SET DLAYGO=444.021
+12 DO FILE^DICN
KILL DIC,DINUM,DLAYGO
+13 IF Y<1
WRITE !,"No entry was made.!"
LOCK -^PRC(444,PRCDA)
GOTO EX
+14 SET PRCDA2=+Y
+15 SET $PIECE(^PRC(444,PRCDA,1),U,5,6)=PRCMSGN_U_PRCOUTN
+16 KILL ^UTILITY("DIQ1",$JOB)
SET DA=DUZ
SET DIC=200
SET DR=".01;.135"
DO EN^DIQ1
+17 SET PRCA=^UTILITY("DIQ1",$JOB,200,DA,.01)
SET PRCB=^(.135)
KILL ^UTILITY("DIQ1",$JOB)
+18 SET DA=PRCDA2
SET DA(1)=PRCDA
SET DIE="^PRC(444,DA(1),7,"
+19 SET DR="1////O;4///^S X=PRCOUTN;5///NOW;6///NOW;7///^S X=PRCA"
DO ^DIE
+20 IF PRCB]""
SET DR="8///^S X=PRCB"
DO ^DIE
+21 SET PRCA=$PIECE($GET(^PRC(444,PRCDA,1)),U,8)
IF PRCA]""
SET DR="12////^S X=PRCA"
DO ^DIE
+22 KILL DIE,DR,DA,PRCA,PRCB
+23 IF $PIECE($GET(^PRC(444,PRCDA,5,0)),U,4)>0
Begin DoDot:1
+24 NEW PRCX,PRCY,PRCDA3
+25 SET PRCX=0
SET PRCDA3=0
+26 FOR
SET PRCX=$ORDER(^PRC(444,PRCDA,5,PRCX))
if PRCX'?1.N
QUIT
Begin DoDot:2
+27 SET PRCY=$GET(^PRC(444,PRCDA,5,PRCX,0))
if PRCY=""
QUIT
+28 if $PIECE(PRCY,U,2)'="e"&($PIECE(PRCY,U,2)'="b")
QUIT
SET PRCY=$PIECE(PRCY,U)
if PRCY=""
QUIT
+29 SET PRCDA3=PRCDA3+1
SET ^PRC(444,PRCDA,7,PRCDA2,3,PRCDA3,0)=PRCY
+30 SET ^PRC(444,PRCDA,7,PRCDA2,3,"B",PRCY,PRCDA3)=""
End DoDot:2
+31 if PRCDA3>0
SET ^PRC(444,PRCDA,7,PRCDA2,3,0)=U_$PIECE(^DD(444.021,11,0),U,2)_U_PRCDA3_U_PRCDA3
End DoDot:1
DDS ;Test FORM
+1 SET PRCRFQ=$PIECE($GET(^PRC(444,PRCDA,0)),U)
+2 IF PRCEDIT="s"
Begin DoDot:1
+3 SET DDSPARM="S"
+4 SET DDSFILE=444
SET DDSFILE(1)=444.021
SET DA(1)=PRCDA
SET DA=PRCDA2
SET DR="[PRCHQ4]"
+5 DO ^DDS
+6 KILL DDSCHANG,DDSPARM,DIMSG,DDSFILE,DA,DR
End DoDot:1
if $DATA(DTOUT)
GOTO EX
+7 IF PRCEDIT="i"
Begin DoDot:1
+8 NEW %,%H,%I
+9 KILL DA
SET DA=PRCDA2
SET DA(1)=PRCDA
SET DIE="^PRC(444,PRCDA,7,"
SET DR="9R;10R;8R;12R;11"
SET DR(2,444.022)=".01"
+10 DO ^DIE
KILL DIE,DR
+11 DO NOW^%DTC
SET $PIECE(^PRC(444,PRCDA,7,PRCDA2,0),U,10,11)=DUZ_U_%
End DoDot:1
if $DATA(DTOUT)!$DATA(DUOUT)
GOTO EX
+12 IF $GET(DDSSAVE)=1!(PRCEDIT="i")
Begin DoDot:1
+13 SET DIR(0)="YA"
SET DIR("A")="Do you wish to transmit this message to the vendors? "
+14 SET DIR("B")="YES"
SET DIR("?")="Accept default of 'YES' to transmit, enter 'No' to avoid transmitting."
+15 DO ^DIR
KILL DIR
if Y'=1!$DATA(DIRUT)!$DATA(DIROUT)!$DATA(DTOUT)!$DATA(DUOUT)
QUIT
+16 KILL PRCERR
+17 DO TRANS864^PRCHQ4A
+18 IF $GET(PRCERR)
DO EN^DDIOL("Electronic Transmission Aborted!")
End DoDot:1
EX if $DATA(PRCDA)
LOCK -^PRC(444,PRCDA)
KILL DDSSAVE,PRCERR
OUT KILL PRCX,PRCMSGN,PRCOUTN,PRCDA,PRCDA2,PRCRFQ,DTOUT,DUOUT,DA,DIRUT,DIROUT,X,Y,PRCMSG,%,PRCEDIT
+1 QUIT
SC() ;Screen for File 440 and File 444.1 vendors
+1 NEW PRC,PRCX,PRCZ
SET PRC=0
SET PRCX=Y_";"_$PIECE(DIC,U,2)
+2 IF $DATA(PRCDA)
Begin DoDot:1
+3 SET PRCZ=$ORDER(^PRC(444,PRCDA,5,"B",PRCX,""))
+4 IF PRCZ]""
IF $PIECE($GET(^PRC(444,PRCDA,5,PRCZ,0)),U,2)="e"
SET PRC=1
QUIT
+5 IF $PIECE($GET(^PRC(444,PRCDA,1)),U,8)="y"
IF PRCX["PRC(440"
IF $PIECE($GET(^PRC(440,+PRCX,3)),U,2)="Y"
IF $PIECE($GET(^PRC(440,+PRCX,7)),U,12)]""
SET PRC=1
QUIT
End DoDot:1
+6 QUIT PRC
RHLP ;Executable Help for Recipient Lookup
+1 NEW PRCAR
SET PRCAR(1)="Choices are restricted to Electronic Solicited Vendors unless the RFQ's"
+2 SET PRCAR(2)=" transmission was Public. Vendor must be EDI and have Duns #."
+3 DO EN^DDIOL(.PRCAR)
+4 QUIT
