PRCHQ10 ;(WASH IRMFO)/LKG-RFQ CLOSE ;8/6/96 20:42
;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
EN ;Close RFQ and Transmit 864 Text Message notification
K DIC S DIC="^PRC(444,",DIC(0)="AEMQ",DIC("S")="I "";2;""[("";""_$P(^(0),U,8)_"";"")"
S DIC("A")="Select RFQ to Close: " 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 Closure."
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 Closure."
. D ^DIR K DIR
S PRCMSG="" D ESIG^PRCUESIG(DUZ,.PRCMSG) G:PRCMSG'=1 EX1
S PRCDUZ=DUZ D CLOSE
G EN
CLOSE ;Close RFQ to further quotes
D NOW^%DTC S PRCDT=% K %
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:'$D(ZTQUEUED) !,"No 864 Text Message has been entered!" L -^PRC(444,PRCDA) D EX1 Q
S PRCDA2=+Y
S $P(^PRC(444,PRCDA,1),U,5,6)=PRCMSGN_U_PRCOUTN
K ^UTILITY("DIQ1",$J) S DA=PRCDUZ,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 Closure Notification **",DR="9///^S X=PRCX" D ^DIE
S DR="13////^S X=PRCDUZ;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 closed to further quotes."
S ^PRC(444,PRCDA,7,PRCDA2,2,0)="^^2^2^"_$P(PRCDT,".")
K PRCERR
D TRANS864^PRCHQ4A
I $G(PRCERR),'$D(ZTQUEUED) D EN^DDIOL("Electronic Transmission Aborted!")
K PRCDA2,PRCERR
STATUS S DIE=444,DA=PRCDA,DR="7////3;20.7////^S X=PRCDUZ;20.8////^S X=PRCDT"
D ^DIE K DIE,DR,PRCDT
L -^PRC(444,PRCDA)
Q
EX1 L:$D(PRCDA) -^PRC(444,PRCDA) K PRCDA,PRCRFQ,X,Y,DTOUT,DUOUT,DIRUT,DIROUT
K DA,PRCX,PRCMSGN,PRCOUTN,DA,DD,DO,PRCDT,PRCMSG,PRCDUZ
Q
BKGND ;Automatic closure upon reaching Quote Due Date. This code
;;can be invoked as a Scheduled Option
K ^TMP($J,"RFQ"),^TMP($J,"PRCHQ10") D:'$D(U)!'$D(DUZ) DT^DICRW
N PRCDA,PRCDUZ,PRCLCNT,PRCQDT
S ^TMP($J,"RFQ",1)="The following RFQs have been closed automatically as the Quote Due Date"
S ^TMP($J,"RFQ",2)="has been reached.",^TMP($J,"RFQ",3)=" "
S PRCDA=0,PRCLCNT=3
S PRCDA=0
F S PRCDA=$O(^PRC(444,"AH",2,PRCDA)) Q:PRCDA="" D
. N PRCDT,PRCX,PRCMSGN,PRCOUTN,DD,DO,DA,DIC,X,DINUM,DLAYGO,X,Y
. N PRCDA2,PRCA,PRCB,DIE,DR,PRCERR,PRCRFQ
. D NOW^%DTC Q:%<$P($G(^PRC(444,PRCDA,0)),U,3)
. S PRCRFQ=$P($G(^PRC(444,PRCDA,0)),U),PRCQDT=$P($G(^(0)),U,3),PRCDUZ=$P($G(^(0)),U,4)
. S ^TMP($J,"PRCHQ10",PRCDUZ)=""
. S PRCQDT=+$E(PRCQDT,4,5)_"/"_(+$E(PRCQDT,6,7))_"/"_$E(PRCQDT,2,3)_$S($P(PRCQDT,".",2)]"":"@"_$E($P(PRCQDT,".",2)_"000000",1,4),1:"")
. D CLOSE
. S PRCLCNT=PRCLCNT+1,^TMP($J,"RFQ",PRCLCNT)=" "_PRCRFQ_" Quote Due: "_PRCQDT_" CO: "_$P($G(^VA(200,PRCDUZ,0)),U)
I PRCLCNT>3 D
. N XMY,XMZ,XMTEXT,XMSUB,XMDUZ
. S XMTEXT="^TMP($J,""RFQ"",",XMSUB="RFQs Closed by Scheduled Option"
. S PRCDUZ=""
. F S PRCDUZ=$O(^TMP($J,"PRCHQ10",PRCDUZ)) Q:PRCDUZ="" S XMY(PRCDUZ)=""
. S XMY("G.PRCHQ RFQ")="",XMDUZ="BACKGROUND RFQ CLOSE OPTION"
. D ^XMD K XMZ,XMY,XMTEXT,XMSUB
K ^TMP($J,"RFQ"),^TMP($J,"PRCHQ10")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHQ10 4559 printed Apr 09, 2024@21:17:33 Page 2
PRCHQ10 ;(WASH IRMFO)/LKG-RFQ CLOSE ;8/6/96 20:42
+1 ;;5.1;IFCAP;;Oct 20, 2000
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
EN ;Close RFQ and Transmit 864 Text Message notification
+1 KILL DIC
SET DIC="^PRC(444,"
SET DIC(0)="AEMQ"
SET DIC("S")="I "";2;""[("";""_$P(^(0),U,8)_"";"")"
+2 SET DIC("A")="Select RFQ to Close: "
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 Closure."
+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 Closure."
+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 SET PRCDUZ=DUZ
DO CLOSE
+17 GOTO EN
CLOSE ;Close RFQ to further quotes
+1 DO NOW^%DTC
SET PRCDT=%
KILL %
+2 if $PIECE($GET(^PRC(444,PRCDA,1)),U,11)=""
GOTO STATUS
+3 SET PRCX=$GET(^PRC(444,PRCDA,1))
SET PRCMSGN=$PIECE(PRCX,U,5)+1
SET PRCOUTN=$PIECE(PRCX,U,6)+1
+4 KILL DD,DO
SET DA(1)=PRCDA
SET DIC="^PRC(444,DA(1),7,"
SET DIC(0)="L"
+5 SET DIC("P")=$PIECE(^DD(444,21,0),U,2)
SET X=PRCMSGN
SET DINUM=PRCMSGN
SET DLAYGO=444.021
+6 DO FILE^DICN
KILL DIC,DINUM,DLAYGO
+7 IF Y<1
if '$DATA(ZTQUEUED)
WRITE !,"No 864 Text Message has been entered!"
LOCK -^PRC(444,PRCDA)
DO EX1
QUIT
+8 SET PRCDA2=+Y
+9 SET $PIECE(^PRC(444,PRCDA,1),U,5,6)=PRCMSGN_U_PRCOUTN
+10 KILL ^UTILITY("DIQ1",$JOB)
SET DA=PRCDUZ
SET DIC=200
SET DR=".01;.135"
DO EN^DIQ1
+11 SET PRCA=^UTILITY("DIQ1",$JOB,200,DA,.01)
SET PRCB=^(.135)
KILL ^UTILITY("DIQ1",$JOB)
+12 SET DA=PRCDA2
SET DA(1)=PRCDA
SET DIE="^PRC(444,DA(1),7,"
+13 SET DR="1////O;4///^S X=PRCOUTN;5///NOW;6///NOW;7///^S X=PRCA"
DO ^DIE
+14 IF PRCB]""
SET DR="8///^S X=PRCB"
DO ^DIE
+15 SET PRCA=$PIECE($GET(^PRC(444,PRCDA,1)),U,8)
IF PRCA]""
SET DR="12////^S X=PRCA"
DO ^DIE
+16 SET PRCX="** RFQ Closure Notification **"
SET DR="9///^S X=PRCX"
DO ^DIE
+17 SET DR="13////^S X=PRCDUZ;13.1////^S X=PRCDT"
DO ^DIE
+18 KILL DIE,DR,DA,PRCA,PRCB,PRCX,PRCMSGN,PRCOUTN
+19 IF $PIECE($GET(^PRC(444,PRCDA,5,0)),U,4)>0
Begin DoDot:1
+20 NEW PRCX,PRCY,PRCDA3
+21 SET PRCX=0
SET PRCDA3=0
+22 FOR
SET PRCX=$ORDER(^PRC(444,PRCDA,5,PRCX))
if PRCX'?1.N
QUIT
Begin DoDot:2
+23 SET PRCY=$GET(^PRC(444,PRCDA,5,PRCX,0))
if PRCY=""
QUIT
+24 if $PIECE(PRCY,U,2)'="e"&($PIECE(PRCY,U,2)'="b")
QUIT
SET PRCY=$PIECE(PRCY,U)
if PRCY=""
QUIT
+25 SET PRCDA3=PRCDA3+1
SET ^PRC(444,PRCDA,7,PRCDA2,3,PRCDA3,0)=PRCY
+26 SET ^PRC(444,PRCDA,7,PRCDA2,3,"B",PRCY,PRCDA3)=""
End DoDot:2
+27 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
+28 SET ^PRC(444,PRCDA,7,PRCDA2,2,1,0)="This is to notify you that RFQ #: "_PRCRFQ_" has "
+29 SET ^PRC(444,PRCDA,7,PRCDA2,2,2,0)="been closed to further quotes."
+30 SET ^PRC(444,PRCDA,7,PRCDA2,2,0)="^^2^2^"_$PIECE(PRCDT,".")
+31 KILL PRCERR
+32 DO TRANS864^PRCHQ4A
+33 IF $GET(PRCERR)
IF '$DATA(ZTQUEUED)
DO EN^DDIOL("Electronic Transmission Aborted!")
+34 KILL PRCDA2,PRCERR
STATUS SET DIE=444
SET DA=PRCDA
SET DR="7////3;20.7////^S X=PRCDUZ;20.8////^S X=PRCDT"
+1 DO ^DIE
KILL DIE,DR,PRCDT
+2 LOCK -^PRC(444,PRCDA)
+3 QUIT
EX1 if $DATA(PRCDA)
LOCK -^PRC(444,PRCDA)
KILL PRCDA,PRCRFQ,X,Y,DTOUT,DUOUT,DIRUT,DIROUT
+1 KILL DA,PRCX,PRCMSGN,PRCOUTN,DA,DD,DO,PRCDT,PRCMSG,PRCDUZ
+2 QUIT
BKGND ;Automatic closure upon reaching Quote Due Date. This code
+1 ;;can be invoked as a Scheduled Option
+2 KILL ^TMP($JOB,"RFQ"),^TMP($JOB,"PRCHQ10")
if '$DATA(U)!'$DATA(DUZ)
DO DT^DICRW
+3 NEW PRCDA,PRCDUZ,PRCLCNT,PRCQDT
+4 SET ^TMP($JOB,"RFQ",1)="The following RFQs have been closed automatically as the Quote Due Date"
+5 SET ^TMP($JOB,"RFQ",2)="has been reached."
SET ^TMP($JOB,"RFQ",3)=" "
+6 SET PRCDA=0
SET PRCLCNT=3
+7 SET PRCDA=0
+8 FOR
SET PRCDA=$ORDER(^PRC(444,"AH",2,PRCDA))
if PRCDA=""
QUIT
Begin DoDot:1
+9 NEW PRCDT,PRCX,PRCMSGN,PRCOUTN,DD,DO,DA,DIC,X,DINUM,DLAYGO,X,Y
+10 NEW PRCDA2,PRCA,PRCB,DIE,DR,PRCERR,PRCRFQ
+11 DO NOW^%DTC
if %<$PIECE($GET(^PRC(444,PRCDA,0)),U,3)
QUIT
+12 SET PRCRFQ=$PIECE($GET(^PRC(444,PRCDA,0)),U)
SET PRCQDT=$PIECE($GET(^(0)),U,3)
SET PRCDUZ=$PIECE($GET(^(0)),U,4)
+13 SET ^TMP($JOB,"PRCHQ10",PRCDUZ)=""
+14 SET PRCQDT=+$EXTRACT(PRCQDT,4,5)_"/"_(+$EXTRACT(PRCQDT,6,7))_"/"_$EXTRACT(PRCQDT,2,3)_$SELECT($PIECE(PRCQDT,".",2)]"":"@"_$EXTRACT($PIECE(PRCQDT,".",2)_"000000",1,4),1:"")
+15 DO CLOSE
+16 SET PRCLCNT=PRCLCNT+1
SET ^TMP($JOB,"RFQ",PRCLCNT)=" "_PRCRFQ_" Quote Due: "_PRCQDT_" CO: "_$PIECE($GET(^VA(200,PRCDUZ,0)),U)
End DoDot:1
+17 IF PRCLCNT>3
Begin DoDot:1
+18 NEW XMY,XMZ,XMTEXT,XMSUB,XMDUZ
+19 SET XMTEXT="^TMP($J,""RFQ"","
SET XMSUB="RFQs Closed by Scheduled Option"
+20 SET PRCDUZ=""
+21 FOR
SET PRCDUZ=$ORDER(^TMP($JOB,"PRCHQ10",PRCDUZ))
if PRCDUZ=""
QUIT
SET XMY(PRCDUZ)=""
+22 SET XMY("G.PRCHQ RFQ")=""
SET XMDUZ="BACKGROUND RFQ CLOSE OPTION"
+23 DO ^XMD
KILL XMZ,XMY,XMTEXT,XMSUB
End DoDot:1
+24 KILL ^TMP($JOB,"RFQ"),^TMP($JOB,"PRCHQ10")
+25 QUIT
