- 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 Mar 13, 2025@21:14:41 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
