PRCHQ9 ;(WASH IRMFO)/LKG-RFQ CANCEL ; [8/31/98 11:24am]
;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
EN ;Cancel RFQ and Transmit Cancel 840
K DIC S DIC="^PRC(444,",DIC(0)="AEMQ",DIC("S")="I "";1;2;3;4;""[("";""_$P(^(0),U,8)_"";"")"
S DIC("A")="Select RFQ to Cancel: " D ^DIC K DIC
G EX1:+Y<1!$D(DTOUT)!$D(DUOUT)
S PRCDA=+Y,PRCRFQ=$P(Y,U,2)
L +^PRC(444,PRCDA):5 E W !,"This RFQ entry is in use, please try later!" G EN
K DIR S DIR(0)="YA",DIR("A")="Do you wish to review a synopsis of this RFQ? "
S DIR("B")="YES",DIR("?")="Answer 'YES' if you wish to view the RFQ prior to Cancellation."
D ^DIR K DIR
I Y=1 D G:Y'=1 EX1
. N L,DIC,DR,FLDS,BY,FR,TO,IOP S DIC=444,BY=.01,(FR,TO)=PRCRFQ,L=0,IOP="HOME"
. S FLDS="[PRCHQ RFQ SYNOPSIS]" D EN1^DIP K DIC,FLDS,BY,FR,DR,L
. S DIR(0)="YA",DIR("A")="Is this the correct RFQ? ",DIR("B")="NO"
. S DIR("?")="Answer 'NO' to abort the Cancellation."
. D ^DIR K DIR
S PRCMSG="" D ESIG^PRCUESIG(DUZ,.PRCMSG) G:PRCMSG'=1 EX1
D NOW^%DTC S PRCDT=% K %
S PRCSTOLD=$P(^PRC(444,PRCDA,0),U,8)
G:$P($G(^PRC(444,PRCDA,1)),U,11)="" STATUS
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 Cancellation Message has been entered!" L -^PRC(444,PRCDA) G EX1
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
S PRCX="** RFQ Cancellation Message **",DR="9///^S X=PRCX" D ^DIE
S DR="13////^S X=DUZ;13.1////^S X=PRCDT" D ^DIE
K DIE,DR,DA,PRCA,PRCB,PRCX,PRCMSGN,PRCOUTN
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
S ^PRC(444,PRCDA,7,PRCDA2,2,1,0)="This is to notify you that RFQ #: "_PRCRFQ_" has "
S ^PRC(444,PRCDA,7,PRCDA2,2,2,0)="been cancelled."
S ^PRC(444,PRCDA,7,PRCDA2,2,0)="^^2^2^"_$P(PRCDT,".")
K DA S DA=PRCDA2,DA(1)=PRCDA,DIE="^PRC(444,DA(1),7,",DR="10Reason for Cancellation"
D ^DIE K DA,DIE,DR
K ^TMP($J,"STRING"),^TMP($J,"VE")
D HE^PRCHQ4 S PRCCOUNT=1
I $G(PRCERR) D EN^DDIOL("Electronic Transmission & Status Change Aborted!") K PRCERR,PRCCOUNT,^TMP($J,"STRING") D EX1 G EN
S $P(^TMP($J,"STRING",1),U,18)=$$VELST^PRCHQ4(.PRCCOUNT)
I $P(^TMP($J,"STRING",1),U,18)=0 D EN^DDIOL("No Vendors for Electronic Transmission - Transmission & Status Change Aborted!") K PRCCOUNT,^TMP($J,"STRING"),^TMP($J,"VE") D EX1 G EN
D ST^PRCHQ4(.PRCCOUNT)
D MI^PRCHQ4("01",.PRCCOUNT)
D AC^PRCHQ4(.PRCCOUNT)
S $P(^TMP($J,"STRING",1),U,14)=$$TX^PRCHQ4("^PRC(444,PRCDA,7,PRCDA2,2)",.PRCCOUNT)
D IT^PRCHQ4(.PRCCOUNT)
S PRCSORC=$O(^PRC(411,"B",$P(PRCRFQ,"-"),""))
I PRCSORC="" S PRCERR=4 D EN^DDIOL("Sending Station not in File 411")
I $G(PRCERR) D EN^DDIOL("Electronic Transmission & Status Change Aborted!") K PRCERR,PRCCOUNT,^TMP($J,"STRING"),^TMP($J,"VE") D EX1 G EN
S PRCDEST=$S($P($G(^PRC(411,PRCSORC,9)),U,4)="T":"EDT",1:"EDP")
D TRANSMIT^PRCPSMCS($P(PRCRFQ,"-"),"RFQ",PRCRFQ,PRCDEST,200,1)
K ^TMP($J,"STRING") S XMZ=$O(PRCPXMZ(0))
I XMZ>0 D
. N PRCV
. S $P(^PRC(444,PRCDA,1),U,11)=PRCPXMZ(XMZ)
. S $P(^PRC(444,PRCDA,7,PRCDA2,1),U,3)=PRCPXMZ(XMZ)
. S X="MailMan Msg #: "_PRCPXMZ(XMZ)
. D EN^DDIOL(X)
. S PRCV=""
. F S PRCV=$O(^TMP($J,"VE",PRCV)) Q:PRCV="" D ENTER^PRCOEDI(PRCRFQ,"RFQ",PRCPXMZ(XMZ),PRCV,$P($G(^PRC(444,PRCDA,0)),U,4),PRCDA,"01")
K ^TMP($J,"VE")
K PRCCOUNT,PRCPXMZ,XMZ,X
STATUS S DIE=444,DA=PRCDA,DR="7////0;20.7////^S X=DUZ;20.8////^S X=PRCDT"
D ^DIE K DIE,DR,PRCDT
I $P($G(^PRC(444,PRCDA,1)),U,11)]""!($P($G(^PRC(444,PRCDA,9)),U)]"") D COPY(PRCDA) G:PRCCOPY EX1
K PRC S PRCDA2=0,DIE="^PRC(443,"
F S PRCDA2=$O(^PRC(444,PRCDA,2,PRCDA2)) Q:PRCDA2'?1.N D
. N PRCOSTAT,PRC2237,PRCAR
. S DA=$P($G(^PRC(444,PRCDA,2,PRCDA2,3)),U) Q:DA=""
. I '$D(PRC(DA)) D
. . S PRCOSTAT=$P(^PRC(443,DA,0),U,7)
. . S:PRCOSTAT?1.N PRCOSTAT=$P(^PRCD(442.3,PRCOSTAT,0),U)
. . L +^PRC(443,DA):300 S DR="1.5////70" D ^DIE S PRC(DA)="" L -^PRC(433,DA)
. . S PRC2237=$P(^PRCS(410,DA,0),U)
. . S PRCAR(1)="Status of 2237 #"_PRC2237_" has been changed from"
. . S PRCAR(2)=" "_PRCOSTAT_" to "_$P(^PRCD(442.3,70,0),U)
. . D EN^DDIOL(.PRCAR)
K DIE,DR,PRC,PRCDA2
I PRCSTOLD=1,$P($G(^PRC(444,PRCDA,1)),U,11)="" D
. K DIR S DIR(0)="YA",DIR("A",1)="As it appears that this RFQ was never transmitted electronically,"
. S DIR("A")="do you wish to delete this RFQ? ",DIR("B")="YES"
. S DIR("?")="Enter 'YES' to delete, 'NO' to retain in the database."
. D ^DIR K DIR
. Q:Y'=1
. S DIK="^PRC(444,",DA=PRCDA D ^DIK K DIK,DA
. S X="RFQ #"_PRCRFQ_" has been deleted!" D EN^DDIOL(X)
L -^PRC(444,PRCDA)
G EN:'$D(DIRUT)&'$D(DIROUT)&'$D(DTOUT)
EX1 L:$D(PRCDA) -^PRC(444,PRCDA) K PRCDA,PRCRFQ,X,Y,DTOUT,DUOUT,DIRUT,DIROUT
K DA,DIC,PRCX,PRCMSGN,PRCOUTN,DA,DD,DO,PRCDT,PRCMSG,PRCDA2,PRCERR,PRCSTOLD,PRCCOPY,PRCSORC,PRCDEST
Q
COPY(PRCDA) ;Requires PRCDA the IEN of RFQ
N PRCI,PRCJ,PRCK,PRCX,DIC,PRCEDIT S PRCCOPY=0
K DIR S DIR(0)="YA",DIR("A")="Do you wish to copy this RFQ into a new RFQ entry? "
S DIR("B")="NO",DIR("?")="Answer 'YES' if you wish to copy this RFQ to make changes and reissue."
D ^DIR K DIR
Q:Y'=1 S PRCCOPY=1
W !,"Copying this RFQ into a new entry..."
K ^TMP($J,"RFQ") M ^TMP($J,"RFQ")=^PRC(444,PRCDA)
F PRCI=6:1:9 K ^TMP($J,"RFQ",PRCI)
F PRCI=5,6,11:1:19 S $P(^TMP($J,"RFQ",1),U,PRCI)=""
S PRCI=0
F S PRCI=$O(^TMP($J,"RFQ",2,PRCI)) Q:+PRCI'=PRCI D
. Q:'$D(^TMP($J,"RFQ",2,PRCI,3))
. S PRCK=^TMP($J,"RFQ",2,PRCI,3)
. F PRCJ=3:1:9 S $P(PRCK,U,PRCJ)=""
. S ^TMP($J,"RFQ",2,PRCI,3)=PRCK
K ^TMP($J,"RFQ",2,"AG"),^TMP($J,"RFQ",2,"AJ") S $P(^TMP($J,"RFQ",0),U,8)=1
S PRCX=$$GETNUM^PRCHQ2($P($P(^TMP($J,"RFQ",0),U),"-",1,2))
I 'PRCX W !,"Unable to get new RFQ # - Please notify IRM staff" Q
S $P(^TMP($J,"RFQ",0),U)=PRCX,X=PRCX
K DIC S DIC="^PRC(444,",DIC(0)="LX",DLAYGO=444 D ^DIC K DIC,DLAYGO
I +Y<1 W !,"Unable to add RFQ entry - Please notify IRM staff." Q
S PRCDA=+Y
W !,"RFQ # ",$P(Y,U,2)," has been added."
L +^PRC(444,PRCDA):5 E W !,"Someone else is editing this RFQ entry, please try later!" Q
M ^PRC(444,PRCDA)=^TMP($J,"RFQ")
K DA S DA=PRCDA,DIK="^PRC(444," D IX1^DIK K DA,DIK
K ^TMP($J,"RFQ")
K DIR S DIR(0)="YA",DIR("A")="Do you wish to edit this new RFQ now? "
S DIR("B")="YES",DIR("?")="Enter 'YES' to edit now, or 'NO' to exit."
D ^DIR K DIR
Q:Y'=1
S PRCEDIT=$$EDITOR^PRCHQ1C
I PRCEDIT="" D EN^DDIOL("Edit mode not indicated, aborting the edit.") G COPYX
D EDIT^PRCHQ2B
COPYX L -^PRC(444,PRCDA)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHQ9 7425 printed Dec 13, 2024@02:09:54 Page 2
PRCHQ9 ;(WASH IRMFO)/LKG-RFQ CANCEL ; [8/31/98 11:24am]
+1 ;;5.1;IFCAP;;Oct 20, 2000
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
EN ;Cancel RFQ and Transmit Cancel 840
+1 KILL DIC
SET DIC="^PRC(444,"
SET DIC(0)="AEMQ"
SET DIC("S")="I "";1;2;3;4;""[("";""_$P(^(0),U,8)_"";"")"
+2 SET DIC("A")="Select RFQ to Cancel: "
DO ^DIC
KILL DIC
+3 if +Y<1!$DATA(DTOUT)!$DATA(DUOUT)
GOTO EX1
+4 SET PRCDA=+Y
SET PRCRFQ=$PIECE(Y,U,2)
+5 LOCK +^PRC(444,PRCDA):5
IF '$TEST
WRITE !,"This RFQ entry is in use, please try later!"
GOTO EN
+6 KILL DIR
SET DIR(0)="YA"
SET DIR("A")="Do you wish to review a synopsis of this RFQ? "
+7 SET DIR("B")="YES"
SET DIR("?")="Answer 'YES' if you wish to view the RFQ prior to Cancellation."
+8 DO ^DIR
KILL DIR
+9 IF Y=1
Begin DoDot:1
+10 NEW L,DIC,DR,FLDS,BY,FR,TO,IOP
SET DIC=444
SET BY=.01
SET (FR,TO)=PRCRFQ
SET L=0
SET IOP="HOME"
+11 SET FLDS="[PRCHQ RFQ SYNOPSIS]"
DO EN1^DIP
KILL DIC,FLDS,BY,FR,DR,L
+12 SET DIR(0)="YA"
SET DIR("A")="Is this the correct RFQ? "
SET DIR("B")="NO"
+13 SET DIR("?")="Answer 'NO' to abort the Cancellation."
+14 DO ^DIR
KILL DIR
End DoDot:1
if Y'=1
GOTO EX1
+15 SET PRCMSG=""
DO ESIG^PRCUESIG(DUZ,.PRCMSG)
if PRCMSG'=1
GOTO EX1
+16 DO NOW^%DTC
SET PRCDT=%
KILL %
+17 SET PRCSTOLD=$PIECE(^PRC(444,PRCDA,0),U,8)
+18 if $PIECE($GET(^PRC(444,PRCDA,1)),U,11)=""
GOTO STATUS
+19 SET PRCX=$GET(^PRC(444,PRCDA,1))
SET PRCMSGN=$PIECE(PRCX,U,5)+1
SET PRCOUTN=$PIECE(PRCX,U,6)+1
+20 KILL DD,DO
SET DA(1)=PRCDA
SET DIC="^PRC(444,DA(1),7,"
SET DIC(0)="L"
+21 SET DIC("P")=$PIECE(^DD(444,21,0),U,2)
SET X=PRCMSGN
SET DINUM=PRCMSGN
SET DLAYGO=444.021
+22 DO FILE^DICN
KILL DIC,DINUM,DLAYGO
+23 IF Y<1
WRITE !,"No Cancellation Message has been entered!"
LOCK -^PRC(444,PRCDA)
GOTO EX1
+24 SET PRCDA2=+Y
+25 SET $PIECE(^PRC(444,PRCDA,1),U,5,6)=PRCMSGN_U_PRCOUTN
+26 KILL ^UTILITY("DIQ1",$JOB)
SET DA=DUZ
SET DIC=200
SET DR=".01;.135"
DO EN^DIQ1
+27 SET PRCA=^UTILITY("DIQ1",$JOB,200,DA,.01)
SET PRCB=^(.135)
KILL ^UTILITY("DIQ1",$JOB)
+28 SET DA=PRCDA2
SET DA(1)=PRCDA
SET DIE="^PRC(444,DA(1),7,"
+29 SET DR="1////O;4///^S X=PRCOUTN;5///NOW;6///NOW;7///^S X=PRCA"
DO ^DIE
+30 IF PRCB]""
SET DR="8///^S X=PRCB"
DO ^DIE
+31 SET PRCA=$PIECE($GET(^PRC(444,PRCDA,1)),U,8)
IF PRCA]""
SET DR="12////^S X=PRCA"
DO ^DIE
+32 SET PRCX="** RFQ Cancellation Message **"
SET DR="9///^S X=PRCX"
DO ^DIE
+33 SET DR="13////^S X=DUZ;13.1////^S X=PRCDT"
DO ^DIE
+34 KILL DIE,DR,DA,PRCA,PRCB,PRCX,PRCMSGN,PRCOUTN
+35 IF $PIECE($GET(^PRC(444,PRCDA,5,0)),U,4)>0
Begin DoDot:1
+36 NEW PRCX,PRCY,PRCDA3
+37 SET PRCX=0
SET PRCDA3=0
+38 FOR
SET PRCX=$ORDER(^PRC(444,PRCDA,5,PRCX))
if PRCX'?1.N
QUIT
Begin DoDot:2
+39 SET PRCY=$GET(^PRC(444,PRCDA,5,PRCX,0))
if PRCY=""
QUIT
+40 if $PIECE(PRCY,U,2)'="e"&($PIECE(PRCY,U,2)'="b")
QUIT
SET PRCY=$PIECE(PRCY,U)
if PRCY=""
QUIT
+41 SET PRCDA3=PRCDA3+1
SET ^PRC(444,PRCDA,7,PRCDA2,3,PRCDA3,0)=PRCY
+42 SET ^PRC(444,PRCDA,7,PRCDA2,3,"B",PRCY,PRCDA3)=""
End DoDot:2
+43 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
+44 SET ^PRC(444,PRCDA,7,PRCDA2,2,1,0)="This is to notify you that RFQ #: "_PRCRFQ_" has "
+45 SET ^PRC(444,PRCDA,7,PRCDA2,2,2,0)="been cancelled."
+46 SET ^PRC(444,PRCDA,7,PRCDA2,2,0)="^^2^2^"_$PIECE(PRCDT,".")
+47 KILL DA
SET DA=PRCDA2
SET DA(1)=PRCDA
SET DIE="^PRC(444,DA(1),7,"
SET DR="10Reason for Cancellation"
+48 DO ^DIE
KILL DA,DIE,DR
+49 KILL ^TMP($JOB,"STRING"),^TMP($JOB,"VE")
+50 DO HE^PRCHQ4
SET PRCCOUNT=1
+51 IF $GET(PRCERR)
DO EN^DDIOL("Electronic Transmission & Status Change Aborted!")
KILL PRCERR,PRCCOUNT,^TMP($JOB,"STRING")
DO EX1
GOTO EN
+52 SET $PIECE(^TMP($JOB,"STRING",1),U,18)=$$VELST^PRCHQ4(.PRCCOUNT)
+53 IF $PIECE(^TMP($JOB,"STRING",1),U,18)=0
DO EN^DDIOL("No Vendors for Electronic Transmission - Transmission & Status Change Aborted!")
KILL PRCCOUNT,^TMP($JOB,"STRING"),^TMP($JOB,"VE")
DO EX1
GOTO EN
+54 DO ST^PRCHQ4(.PRCCOUNT)
+55 DO MI^PRCHQ4("01",.PRCCOUNT)
+56 DO AC^PRCHQ4(.PRCCOUNT)
+57 SET $PIECE(^TMP($JOB,"STRING",1),U,14)=$$TX^PRCHQ4("^PRC(444,PRCDA,7,PRCDA2,2)",.PRCCOUNT)
+58 DO IT^PRCHQ4(.PRCCOUNT)
+59 SET PRCSORC=$ORDER(^PRC(411,"B",$PIECE(PRCRFQ,"-"),""))
+60 IF PRCSORC=""
SET PRCERR=4
DO EN^DDIOL("Sending Station not in File 411")
+61 IF $GET(PRCERR)
DO EN^DDIOL("Electronic Transmission & Status Change Aborted!")
KILL PRCERR,PRCCOUNT,^TMP($JOB,"STRING"),^TMP($JOB,"VE")
DO EX1
GOTO EN
+62 SET PRCDEST=$SELECT($PIECE($GET(^PRC(411,PRCSORC,9)),U,4)="T":"EDT",1:"EDP")
+63 DO TRANSMIT^PRCPSMCS($PIECE(PRCRFQ,"-"),"RFQ",PRCRFQ,PRCDEST,200,1)
+64 KILL ^TMP($JOB,"STRING")
SET XMZ=$ORDER(PRCPXMZ(0))
+65 IF XMZ>0
Begin DoDot:1
+66 NEW PRCV
+67 SET $PIECE(^PRC(444,PRCDA,1),U,11)=PRCPXMZ(XMZ)
+68 SET $PIECE(^PRC(444,PRCDA,7,PRCDA2,1),U,3)=PRCPXMZ(XMZ)
+69 SET X="MailMan Msg #: "_PRCPXMZ(XMZ)
+70 DO EN^DDIOL(X)
+71 SET PRCV=""
+72 FOR
SET PRCV=$ORDER(^TMP($JOB,"VE",PRCV))
if PRCV=""
QUIT
DO ENTER^PRCOEDI(PRCRFQ,"RFQ",PRCPXMZ(XMZ),PRCV,$PIECE($GET(^PRC(444,PRCDA,0)),U,4),PRCDA,"01")
End DoDot:1
+73 KILL ^TMP($JOB,"VE")
+74 KILL PRCCOUNT,PRCPXMZ,XMZ,X
STATUS SET DIE=444
SET DA=PRCDA
SET DR="7////0;20.7////^S X=DUZ;20.8////^S X=PRCDT"
+1 DO ^DIE
KILL DIE,DR,PRCDT
+2 IF $PIECE($GET(^PRC(444,PRCDA,1)),U,11)]""!($PIECE($GET(^PRC(444,PRCDA,9)),U)]"")
DO COPY(PRCDA)
if PRCCOPY
GOTO EX1
+3 KILL PRC
SET PRCDA2=0
SET DIE="^PRC(443,"
+4 FOR
SET PRCDA2=$ORDER(^PRC(444,PRCDA,2,PRCDA2))
if PRCDA2'?1.N
QUIT
Begin DoDot:1
+5 NEW PRCOSTAT,PRC2237,PRCAR
+6 SET DA=$PIECE($GET(^PRC(444,PRCDA,2,PRCDA2,3)),U)
if DA=""
QUIT
+7 IF '$DATA(PRC(DA))
Begin DoDot:2
+8 SET PRCOSTAT=$PIECE(^PRC(443,DA,0),U,7)
+9 if PRCOSTAT?1.N
SET PRCOSTAT=$PIECE(^PRCD(442.3,PRCOSTAT,0),U)
+10 LOCK +^PRC(443,DA):300
SET DR="1.5////70"
DO ^DIE
SET PRC(DA)=""
LOCK -^PRC(433,DA)
+11 SET PRC2237=$PIECE(^PRCS(410,DA,0),U)
+12 SET PRCAR(1)="Status of 2237 #"_PRC2237_" has been changed from"
+13 SET PRCAR(2)=" "_PRCOSTAT_" to "_$PIECE(^PRCD(442.3,70,0),U)
+14 DO EN^DDIOL(.PRCAR)
End DoDot:2
End DoDot:1
+15 KILL DIE,DR,PRC,PRCDA2
+16 IF PRCSTOLD=1
IF $PIECE($GET(^PRC(444,PRCDA,1)),U,11)=""
Begin DoDot:1
+17 KILL DIR
SET DIR(0)="YA"
SET DIR("A",1)="As it appears that this RFQ was never transmitted electronically,"
+18 SET DIR("A")="do you wish to delete this RFQ? "
SET DIR("B")="YES"
+19 SET DIR("?")="Enter 'YES' to delete, 'NO' to retain in the database."
+20 DO ^DIR
KILL DIR
+21 if Y'=1
QUIT
+22 SET DIK="^PRC(444,"
SET DA=PRCDA
DO ^DIK
KILL DIK,DA
+23 SET X="RFQ #"_PRCRFQ_" has been deleted!"
DO EN^DDIOL(X)
End DoDot:1
+24 LOCK -^PRC(444,PRCDA)
+25 if '$DATA(DIRUT)&'$DATA(DIROUT)&'$DATA(DTOUT)
GOTO EN
EX1 if $DATA(PRCDA)
LOCK -^PRC(444,PRCDA)
KILL PRCDA,PRCRFQ,X,Y,DTOUT,DUOUT,DIRUT,DIROUT
+1 KILL DA,DIC,PRCX,PRCMSGN,PRCOUTN,DA,DD,DO,PRCDT,PRCMSG,PRCDA2,PRCERR,PRCSTOLD,PRCCOPY,PRCSORC,PRCDEST
+2 QUIT
COPY(PRCDA) ;Requires PRCDA the IEN of RFQ
+1 NEW PRCI,PRCJ,PRCK,PRCX,DIC,PRCEDIT
SET PRCCOPY=0
+2 KILL DIR
SET DIR(0)="YA"
SET DIR("A")="Do you wish to copy this RFQ into a new RFQ entry? "
+3 SET DIR("B")="NO"
SET DIR("?")="Answer 'YES' if you wish to copy this RFQ to make changes and reissue."
+4 DO ^DIR
KILL DIR
+5 if Y'=1
QUIT
SET PRCCOPY=1
+6 WRITE !,"Copying this RFQ into a new entry..."
+7 KILL ^TMP($JOB,"RFQ")
MERGE ^TMP($JOB,"RFQ")=^PRC(444,PRCDA)
+8 FOR PRCI=6:1:9
KILL ^TMP($JOB,"RFQ",PRCI)
+9 FOR PRCI=5,6,11:1:19
SET $PIECE(^TMP($JOB,"RFQ",1),U,PRCI)=""
+10 SET PRCI=0
+11 FOR
SET PRCI=$ORDER(^TMP($JOB,"RFQ",2,PRCI))
if +PRCI'=PRCI
QUIT
Begin DoDot:1
+12 if '$DATA(^TMP($JOB,"RFQ",2,PRCI,3))
QUIT
+13 SET PRCK=^TMP($JOB,"RFQ",2,PRCI,3)
+14 FOR PRCJ=3:1:9
SET $PIECE(PRCK,U,PRCJ)=""
+15 SET ^TMP($JOB,"RFQ",2,PRCI,3)=PRCK
End DoDot:1
+16 KILL ^TMP($JOB,"RFQ",2,"AG"),^TMP($JOB,"RFQ",2,"AJ")
SET $PIECE(^TMP($JOB,"RFQ",0),U,8)=1
+17 SET PRCX=$$GETNUM^PRCHQ2($PIECE($PIECE(^TMP($JOB,"RFQ",0),U),"-",1,2))
+18 IF 'PRCX
WRITE !,"Unable to get new RFQ # - Please notify IRM staff"
QUIT
+19 SET $PIECE(^TMP($JOB,"RFQ",0),U)=PRCX
SET X=PRCX
+20 KILL DIC
SET DIC="^PRC(444,"
SET DIC(0)="LX"
SET DLAYGO=444
DO ^DIC
KILL DIC,DLAYGO
+21 IF +Y<1
WRITE !,"Unable to add RFQ entry - Please notify IRM staff."
QUIT
+22 SET PRCDA=+Y
+23 WRITE !,"RFQ # ",$PIECE(Y,U,2)," has been added."
+24 LOCK +^PRC(444,PRCDA):5
IF '$TEST
WRITE !,"Someone else is editing this RFQ entry, please try later!"
QUIT
+25 MERGE ^PRC(444,PRCDA)=^TMP($JOB,"RFQ")
+26 KILL DA
SET DA=PRCDA
SET DIK="^PRC(444,"
DO IX1^DIK
KILL DA,DIK
+27 KILL ^TMP($JOB,"RFQ")
+28 KILL DIR
SET DIR(0)="YA"
SET DIR("A")="Do you wish to edit this new RFQ now? "
+29 SET DIR("B")="YES"
SET DIR("?")="Enter 'YES' to edit now, or 'NO' to exit."
+30 DO ^DIR
KILL DIR
+31 if Y'=1
QUIT
+32 SET PRCEDIT=$$EDITOR^PRCHQ1C
+33 IF PRCEDIT=""
DO EN^DDIOL("Edit mode not indicated, aborting the edit.")
GOTO COPYX
+34 DO EDIT^PRCHQ2B
COPYX LOCK -^PRC(444,PRCDA)
+1 QUIT
