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