- PRCHQ2B ;(WASH IRMFO)/LKG-RFQ Enter/Edit cont ;9/8/96 21:07
- ;;5.1;IFCAP;;Oct 20, 2000
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- I $P(PRC410(3),U,4)]"" D
- . S ^PRC(444,PRCDA,5,0)="^"_$P(^DD(444,20,0),U,2)_"^1^1"
- . S ^PRC(444,PRCDA,5,1,0)=$P(PRC410(3),U,4)_";PRC(440,"
- I $P(PRC410(3),U,4)="" D
- . N DIC,DIE,DR,Y,DA
- . S DIC=444.1,DIC(0)="XL",DLAYGO=444.1,X=$P(PRC410(2),U) D ^DIC K DLAYGO
- . Q:+Y<1
- . S ^PRC(444,PRCDA,5,0)="^"_$P(^DD(444,20,0),U,2)_"^1^1"
- . S ^PRC(444,PRCDA,5,1,0)=+Y_";PRC(444.1,"
- . I $P(Y,U,3) D
- . . S DA=+Y,DIE=444.1 L +^PRC(444.1,DA):5 E W !,"Vendor ",$P(PRC410(2),U)," is being edited by another user." Q
- . . S PRCX=$P(PRC410(2),U,2) I PRCX]"" S DR="1///^S X=PRCX" D ^DIE
- . . S PRCX=$P(PRC410(2),U,3) I PRCX]"" S DR="2///^S X=PRCX" D ^DIE
- . . S PRCX=$P(PRC410(2),U,4) I PRCX]"" S DR="3///^S X=PRCX" D ^DIE
- . . S PRCX=$P(PRC410(2),U,5) I PRCX]"" S DR="4///^S X=PRCX" D ^DIE
- . . S PRCX=$P(PRC410(2),U,6) I PRCX]"" S DR="4.2///^S X=PRCX" D ^DIE
- . . S PRCX=$P(PRC410(2),U,7) I PRCX]"" S DR="4.4////^S X=PRCX" D ^DIE
- . . S PRCX=$P(PRC410(2),U,8) I PRCX]"" S DR="4.6///^S X=PRCX" D ^DIE
- . . S PRCX=$P(PRC410(2),U,9) I PRCX]"" S DR="4.8///^S X=PRCX" D ^DIE
- . . S PRCX=$P(PRC410(2),U,10) I PRCX]"" S DR="5///^S X=PRCX" D ^DIE
- . . L -^PRC(444.1,DA)
- S DA=PRCDA410,DIE="^PRC(443,",DR="1.5////79" D ^DIE K DA,DIE,DR
- L:$D(PRCDA410) -(^PRCS(410,PRCDA410),^PRC(443,PRCDA410))
- K DA,I,PRCDA410,PRC410,PRC443,PRCE,PRCI,PRCJ,PRCK,PRCL,PRCM,PRCN,PRCP,PRCQ,PRCX,PRCY,X,Y
- K DIR S DIR(0)="YA",DIR("A")="Do you wish to import items from an additional 2237? "
- S DIR("B")="NO"
- S DIR("?",1)="If you answer 'YES', you will be prompted for an Assigned to Purchasing Agent"
- S DIR("?",2)="2237 with the same Fund Control Point."
- S DIR("?")="All item information on that 2237 will be imported into this RFQ"
- D ^DIR K DIR G INDX:$D(DIRUT),INDX:Y'=1
- S PRCX=$P($P(^PRC(444,PRCDA,0),U,14)," ")
- LOOP K DIC S DIC="^PRC(443,",DIC(0)="AEMN"
- S DIC("S")="I "";70;80;""[("";""_$P(^(0),U,7)_"";""),PRCX=$P($P($G(^PRCS(410,Y,0)),U),""-"",4),$P($G(^PRCS(410,Y,4)),U,5)="""""
- S DIC("A")="Enter additional 2237 Transaction #: " D ^DIC K DIC
- I Y<1!$D(DTOUT)!$D(DUOUT) G INDX
- S PRCDA410=+Y
- L +^PRC(443,PRCDA410):5 E W !,"Work Sheet entry in use, please try later!" G INDX
- L +^PRCS(410,PRCDA410):5 E W !,"Someone is editing the source 2237, please try later!" G INDX
- W !,"Importing item information into this RFQ entry..."
- S PRC410(3)=$G(^PRCS(410,PRCDA410,3))
- D IT^PRCHQ2A
- S DA=PRCDA410,DIE="^PRC(443,",DR="1.5////79" D ^DIE K DA,DIE,DR
- L -(^PRCS(410,PRCDA410),^PRC(443,PRCDA410))
- K PRCDA410
- G LOOP
- INDX ;Index the entry
- K PRC410
- D NOW^%DTC S $P(^PRC(444,PRCDA,1),U,9,10)=DUZ_U_% K %,%H,%I
- W !,"Building the cross references..."
- S DIK="^PRC(444,",DA=PRCDA D IX1^DIK K DA,DIK
- G:$D(DUOUT)!$D(DIRUT)!$D(DTOUT) OUT
- CONT D EDIT L -^PRC(444,PRCDA)
- I '$D(DTOUT)&'$D(DUOUT)&'$D(DIRUT)&'$D(DIROUT) G B^PRCHQ2:$G(PRCNEW),A^PRCHQ2
- OUT ;
- L:$D(PRCDA410) -(^PRCS(410,PRCDA410),^PRC(443,PRCDA410))
- L:$D(PRCDA) -^PRC(444,PRCDA)
- K DA,DIC,DIRUT,DIROUT,DTOUT,DUOUT,PRCDA,PRCDA410,PRCOUT,PRCX,X,Y,PRCNEW,PRCEDIT
- Q
- EDIT ;Edit RFQ
- N %,%H,%I
- I PRCEDIT="s" D
- . K DA S DDSPARM="CS"
- . S DDSFILE=444,DR="[PRCHQ1]",DA=PRCDA,DDSPAGE=1 D ^DDS
- . K DA,DDSFILE,DR,DDSPAGE,DDSPARM,DIMSG,PRCMSG,%
- I PRCEDIT="i" D
- . N PRCMSG,PRCI,PRCX,PRCRD,PRCRQD,PRCDA2,PRCITMO,PRCIEN,PRCVEN
- . S PRCMSG="" D ESIG^PRCUESIG(DUZ,.PRCMSG)
- . I PRCMSG'=1 D EN^DDIOL("Electronic Signature Failed, Edit aborted") S PRCERR=10 Q
- . K DA S DIE="^PRC(444,",DA=PRCDA,DR="[PRCHQ RFQ REQUEST]" D ^DIE K DIE,DR
- . D NOW^%DTC S $P(^PRC(444,PRCDA,1),U,9,10)=DUZ_U_%
- . I $D(DTOUT) S PRCERR=10 Q
- . I $D(DUOUT) K DIR S DIR(0)="YA",DIR("A")="Do you wish to continue? ",DIR("B")="NO" D ^DIR K DIR I Y'=1 S PRCERR=10 Q
- . K DUOUT
- . S PRCI=0
- . F S PRCI=$O(^PRC(444,PRCDA,5,PRCI)) Q:+PRCI'=PRCI D Q:$G(PRCERR)
- . . S PRCX=$G(^PRC(444,PRCDA,5,PRCI,0)) Q:$P(PRCX,U)'["PRC(444.1,"
- . . W !!,"Editing Solicited Vendor in RFQ Temporary Vendor File..."
- . . L +^PRC(444.1,+PRCX):3 E S X="Vendor "_$P($G(^PRC(444.1,+PRCX,0)),U)_" is locked, please try later!" D EN^DDIOL(X) Q
- . . K DA S DA=+PRCX,DIE="^PRC(444.1,",DR=".01;18.3;38;4.8;5;46;1R;2;3;4;4.2R;4.4R;4.6"
- . . D ^DIE K DIE,DR,DA L -^PRC(444.1,+PRCX)
- . . I $D(DTOUT) S PRCERR=10 Q
- . . I $D(DUOUT) K DIR S DIR(0)="YA",DIR("A")="Do you wish to continue? ",DIR("B")="NO" D ^DIR K DIR I Y'=1 S PRCERR=10 Q
- . . K DUOUT
- . K DIR S DIR(0)="YA",DIR("A")="Do you wish to view the RFQ? "
- . S DIR("B")="YES" D ^DIR K DIR I $D(DIROUT)!$D(DIRUT) S PRCERR=10 Q
- . I Y=1 D
- . . S PRCRFQ=$P($G(^PRC(444,PRCDA,0)),U)
- . . S DIC=444,BY=.01,FLDS="[PRCHQ RFQ FULL]",L=0,(FR,TO)=PRCRFQ,DHD="@"
- . . D EN1^DIP K BY,DIC,DHD,FLDS,FR,L,TO
- I $G(DDSCHANG)=1!($G(DDSSAVE)=1)!(PRCEDIT="i"&'$G(PRCERR)) D
- . N PRCRFQ,PRCTYPE,PRCNOPRT S PRCRFQ=$P(^PRC(444,PRCDA,0),U)
- . K DIR S DIR(0)="YA",DIR("A")="Do you wish to transmit this RFQ to 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)
- . I $P($G(^PRC(444,PRCDA,1)),U,8)'="y",$P($G(^PRC(444,PRCDA,5,0)),U,4)'>0 D EN^DDIOL("Warning - Transmit aborted as there are NO RECIPIENTS!") Q
- . S PRCTYPE="00"
- . K PRCERR
- . D TRANS840^PRCHQ4A(PRCTYPE)
- . I $G(PRCERR) D EN^DDIOL("Due to Error Conditions Transmission Was Aborted!") Q
- . S PRCNOPRT=$$MANUAL
- . I $P($G(^PRC(444,PRCDA,1)),U,11)=""&PRCNOPRT D EN^DDIOL("RFQ has not been transmitted, use option Edit Incomplete RFQ to complete.") Q
- . D:PRCNOPRT EN^DDIOL("Required manual RFQs were not printed, use option Manual Print of RFQ.")
- . I $P($G(^PRC(444,PRCDA,1)),U,11)]""!('PRCNOPRT) D
- . . N PRCAR,PRCSTAT,PRCSTRG
- . . S PRCSTRG="CANCELLED^INCOMPLETE^PENDING QUOTES^CLOSED^EVALUATION COMPLETE^AWARDED",PRCSTAT=$P(PRCSTRG,U,$P(^PRC(444,PRCDA,0),U,8)+1)
- . . K DA S DA=PRCDA,DR="7////2",DIE="^PRC(444," D ^DIE K DA,DIE,DR
- . . S PRCAR(1)="The status of RFQ #: "_PRCRFQ_" has been changed from"
- . . S PRCAR(2)=" '"_PRCSTAT_"' to '"_$P(PRCSTRG,U,$P($G(^PRC(444,PRCDA,0)),U,8)+1)_"'."
- . . D EN^DDIOL(.PRCAR)
- K DDSCHANG,DDSSAVE,PRCERR
- Q
- MANUAL() ;Print Manual RFQ
- N X,Y,POP,%,%H,%I,DA
- S X=0,Y=0
- F S X=$O(^PRC(444,PRCDA,5,X)) Q:+X'=X I $P($G(^PRC(444,PRCDA,5,X,0)),U,2)="m" S Y=1 Q
- I 'Y D EN^DDIOL("There are no vendors for Manual Solicitation") Q 0
- MANA K %ZIS S %ZIS("A")="90 Column Printer for Manual RFQ: "
- S %ZIS("B")="",%ZIS="PQ" D ^%ZIS I POP Q 1
- I $E(IOST)'="P"!(IOM'>89) D ^%ZISC,EN^DDIOL("Device must be a printer supporting 90 characters per line.") G MANA
- I $D(IO("Q")) S ZTRTN="PROCESS^PRCHQM1",ZTSAVE("DA")=PRCDA D ^%ZTLOAD,HOME^%ZIS G:$G(ZTSK)>0 XMANUAL Q 1
- S DA=PRCDA D PROCESS^PRCHQM1
- XMANUAL ;
- Q 0
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHQ2B 6897 printed Feb 18, 2025@23:36:06 Page 2
- PRCHQ2B ;(WASH IRMFO)/LKG-RFQ Enter/Edit cont ;9/8/96 21:07
- +1 ;;5.1;IFCAP;;Oct 20, 2000
- +2 ;Per VHA Directive 10-93-142, this routine should not be modified.
- +3 IF $PIECE(PRC410(3),U,4)]""
- Begin DoDot:1
- +4 SET ^PRC(444,PRCDA,5,0)="^"_$PIECE(^DD(444,20,0),U,2)_"^1^1"
- +5 SET ^PRC(444,PRCDA,5,1,0)=$PIECE(PRC410(3),U,4)_";PRC(440,"
- End DoDot:1
- +6 IF $PIECE(PRC410(3),U,4)=""
- Begin DoDot:1
- +7 NEW DIC,DIE,DR,Y,DA
- +8 SET DIC=444.1
- SET DIC(0)="XL"
- SET DLAYGO=444.1
- SET X=$PIECE(PRC410(2),U)
- DO ^DIC
- KILL DLAYGO
- +9 if +Y<1
- QUIT
- +10 SET ^PRC(444,PRCDA,5,0)="^"_$PIECE(^DD(444,20,0),U,2)_"^1^1"
- +11 SET ^PRC(444,PRCDA,5,1,0)=+Y_";PRC(444.1,"
- +12 IF $PIECE(Y,U,3)
- Begin DoDot:2
- +13 SET DA=+Y
- SET DIE=444.1
- LOCK +^PRC(444.1,DA):5
- IF '$TEST
- WRITE !,"Vendor ",$PIECE(PRC410(2),U)," is being edited by another user."
- QUIT
- +14 SET PRCX=$PIECE(PRC410(2),U,2)
- IF PRCX]""
- SET DR="1///^S X=PRCX"
- DO ^DIE
- +15 SET PRCX=$PIECE(PRC410(2),U,3)
- IF PRCX]""
- SET DR="2///^S X=PRCX"
- DO ^DIE
- +16 SET PRCX=$PIECE(PRC410(2),U,4)
- IF PRCX]""
- SET DR="3///^S X=PRCX"
- DO ^DIE
- +17 SET PRCX=$PIECE(PRC410(2),U,5)
- IF PRCX]""
- SET DR="4///^S X=PRCX"
- DO ^DIE
- +18 SET PRCX=$PIECE(PRC410(2),U,6)
- IF PRCX]""
- SET DR="4.2///^S X=PRCX"
- DO ^DIE
- +19 SET PRCX=$PIECE(PRC410(2),U,7)
- IF PRCX]""
- SET DR="4.4////^S X=PRCX"
- DO ^DIE
- +20 SET PRCX=$PIECE(PRC410(2),U,8)
- IF PRCX]""
- SET DR="4.6///^S X=PRCX"
- DO ^DIE
- +21 SET PRCX=$PIECE(PRC410(2),U,9)
- IF PRCX]""
- SET DR="4.8///^S X=PRCX"
- DO ^DIE
- +22 SET PRCX=$PIECE(PRC410(2),U,10)
- IF PRCX]""
- SET DR="5///^S X=PRCX"
- DO ^DIE
- +23 LOCK -^PRC(444.1,DA)
- End DoDot:2
- End DoDot:1
- +24 SET DA=PRCDA410
- SET DIE="^PRC(443,"
- SET DR="1.5////79"
- DO ^DIE
- KILL DA,DIE,DR
- +25 if $DATA(PRCDA410)
- LOCK -(^PRCS(410,PRCDA410),^PRC(443,PRCDA410))
- +26 KILL DA,I,PRCDA410,PRC410,PRC443,PRCE,PRCI,PRCJ,PRCK,PRCL,PRCM,PRCN,PRCP,PRCQ,PRCX,PRCY,X,Y
- +27 KILL DIR
- SET DIR(0)="YA"
- SET DIR("A")="Do you wish to import items from an additional 2237? "
- +28 SET DIR("B")="NO"
- +29 SET DIR("?",1)="If you answer 'YES', you will be prompted for an Assigned to Purchasing Agent"
- +30 SET DIR("?",2)="2237 with the same Fund Control Point."
- +31 SET DIR("?")="All item information on that 2237 will be imported into this RFQ"
- +32 DO ^DIR
- KILL DIR
- if $DATA(DIRUT)
- GOTO INDX
- if Y'=1
- GOTO INDX
- +33 SET PRCX=$PIECE($PIECE(^PRC(444,PRCDA,0),U,14)," ")
- LOOP KILL DIC
- SET DIC="^PRC(443,"
- SET DIC(0)="AEMN"
- +1 SET DIC("S")="I "";70;80;""[("";""_$P(^(0),U,7)_"";""),PRCX=$P($P($G(^PRCS(410,Y,0)),U),""-"",4),$P($G(^PRCS(410,Y,4)),U,5)="""""
- +2 SET DIC("A")="Enter additional 2237 Transaction #: "
- DO ^DIC
- KILL DIC
- +3 IF Y<1!$DATA(DTOUT)!$DATA(DUOUT)
- GOTO INDX
- +4 SET PRCDA410=+Y
- +5 LOCK +^PRC(443,PRCDA410):5
- IF '$TEST
- WRITE !,"Work Sheet entry in use, please try later!"
- GOTO INDX
- +6 LOCK +^PRCS(410,PRCDA410):5
- IF '$TEST
- WRITE !,"Someone is editing the source 2237, please try later!"
- GOTO INDX
- +7 WRITE !,"Importing item information into this RFQ entry..."
- +8 SET PRC410(3)=$GET(^PRCS(410,PRCDA410,3))
- +9 DO IT^PRCHQ2A
- +10 SET DA=PRCDA410
- SET DIE="^PRC(443,"
- SET DR="1.5////79"
- DO ^DIE
- KILL DA,DIE,DR
- +11 LOCK -(^PRCS(410,PRCDA410),^PRC(443,PRCDA410))
- +12 KILL PRCDA410
- +13 GOTO LOOP
- INDX ;Index the entry
- +1 KILL PRC410
- +2 DO NOW^%DTC
- SET $PIECE(^PRC(444,PRCDA,1),U,9,10)=DUZ_U_%
- KILL %,%H,%I
- +3 WRITE !,"Building the cross references..."
- +4 SET DIK="^PRC(444,"
- SET DA=PRCDA
- DO IX1^DIK
- KILL DA,DIK
- +5 if $DATA(DUOUT)!$DATA(DIRUT)!$DATA(DTOUT)
- GOTO OUT
- CONT DO EDIT
- LOCK -^PRC(444,PRCDA)
- +1 IF '$DATA(DTOUT)&'$DATA(DUOUT)&'$DATA(DIRUT)&'$DATA(DIROUT)
- if $GET(PRCNEW)
- GOTO B^PRCHQ2
- GOTO A^PRCHQ2
- OUT ;
- +1 if $DATA(PRCDA410)
- LOCK -(^PRCS(410,PRCDA410),^PRC(443,PRCDA410))
- +2 if $DATA(PRCDA)
- LOCK -^PRC(444,PRCDA)
- +3 KILL DA,DIC,DIRUT,DIROUT,DTOUT,DUOUT,PRCDA,PRCDA410,PRCOUT,PRCX,X,Y,PRCNEW,PRCEDIT
- +4 QUIT
- EDIT ;Edit RFQ
- +1 NEW %,%H,%I
- +2 IF PRCEDIT="s"
- Begin DoDot:1
- +3 KILL DA
- SET DDSPARM="CS"
- +4 SET DDSFILE=444
- SET DR="[PRCHQ1]"
- SET DA=PRCDA
- SET DDSPAGE=1
- DO ^DDS
- +5 KILL DA,DDSFILE,DR,DDSPAGE,DDSPARM,DIMSG,PRCMSG,%
- End DoDot:1
- +6 IF PRCEDIT="i"
- Begin DoDot:1
- +7 NEW PRCMSG,PRCI,PRCX,PRCRD,PRCRQD,PRCDA2,PRCITMO,PRCIEN,PRCVEN
- +8 SET PRCMSG=""
- DO ESIG^PRCUESIG(DUZ,.PRCMSG)
- +9 IF PRCMSG'=1
- DO EN^DDIOL("Electronic Signature Failed, Edit aborted")
- SET PRCERR=10
- QUIT
- +10 KILL DA
- SET DIE="^PRC(444,"
- SET DA=PRCDA
- SET DR="[PRCHQ RFQ REQUEST]"
- DO ^DIE
- KILL DIE,DR
- +11 DO NOW^%DTC
- SET $PIECE(^PRC(444,PRCDA,1),U,9,10)=DUZ_U_%
- +12 IF $DATA(DTOUT)
- SET PRCERR=10
- QUIT
- +13 IF $DATA(DUOUT)
- KILL DIR
- SET DIR(0)="YA"
- SET DIR("A")="Do you wish to continue? "
- SET DIR("B")="NO"
- DO ^DIR
- KILL DIR
- IF Y'=1
- SET PRCERR=10
- QUIT
- +14 KILL DUOUT
- +15 SET PRCI=0
- +16 FOR
- SET PRCI=$ORDER(^PRC(444,PRCDA,5,PRCI))
- if +PRCI'=PRCI
- QUIT
- Begin DoDot:2
- +17 SET PRCX=$GET(^PRC(444,PRCDA,5,PRCI,0))
- if $PIECE(PRCX,U)'["PRC(444.1,"
- QUIT
- +18 WRITE !!,"Editing Solicited Vendor in RFQ Temporary Vendor File..."
- +19 LOCK +^PRC(444.1,+PRCX):3
- IF '$TEST
- SET X="Vendor "_$PIECE($GET(^PRC(444.1,+PRCX,0)),U)_" is locked, please try later!"
- DO EN^DDIOL(X)
- QUIT
- +20 KILL DA
- SET DA=+PRCX
- SET DIE="^PRC(444.1,"
- SET DR=".01;18.3;38;4.8;5;46;1R;2;3;4;4.2R;4.4R;4.6"
- +21 DO ^DIE
- KILL DIE,DR,DA
- LOCK -^PRC(444.1,+PRCX)
- +22 IF $DATA(DTOUT)
- SET PRCERR=10
- QUIT
- +23 IF $DATA(DUOUT)
- KILL DIR
- SET DIR(0)="YA"
- SET DIR("A")="Do you wish to continue? "
- SET DIR("B")="NO"
- DO ^DIR
- KILL DIR
- IF Y'=1
- SET PRCERR=10
- QUIT
- +24 KILL DUOUT
- End DoDot:2
- if $GET(PRCERR)
- QUIT
- +25 KILL DIR
- SET DIR(0)="YA"
- SET DIR("A")="Do you wish to view the RFQ? "
- +26 SET DIR("B")="YES"
- DO ^DIR
- KILL DIR
- IF $DATA(DIROUT)!$DATA(DIRUT)
- SET PRCERR=10
- QUIT
- +27 IF Y=1
- Begin DoDot:2
- +28 SET PRCRFQ=$PIECE($GET(^PRC(444,PRCDA,0)),U)
- +29 SET DIC=444
- SET BY=.01
- SET FLDS="[PRCHQ RFQ FULL]"
- SET L=0
- SET (FR,TO)=PRCRFQ
- SET DHD="@"
- +30 DO EN1^DIP
- KILL BY,DIC,DHD,FLDS,FR,L,TO
- End DoDot:2
- End DoDot:1
- +31 IF $GET(DDSCHANG)=1!($GET(DDSSAVE)=1)!(PRCEDIT="i"&'$GET(PRCERR))
- Begin DoDot:1
- +32 NEW PRCRFQ,PRCTYPE,PRCNOPRT
- SET PRCRFQ=$PIECE(^PRC(444,PRCDA,0),U)
- +33 KILL DIR
- SET DIR(0)="YA"
- SET DIR("A")="Do you wish to transmit this RFQ to vendors? "
- +34 SET DIR("B")="YES"
- SET DIR("?")="Accept default of 'YES' to transmit, enter 'NO' to avoid transmitting."
- +35 DO ^DIR
- KILL DIR
- if Y'=1!$DATA(DIRUT)!$DATA(DIROUT)!$DATA(DTOUT)!$DATA(DUOUT)
- QUIT
- +36 IF $PIECE($GET(^PRC(444,PRCDA,1)),U,8)'="y"
- IF $PIECE($GET(^PRC(444,PRCDA,5,0)),U,4)'>0
- DO EN^DDIOL("Warning - Transmit aborted as there are NO RECIPIENTS!")
- QUIT
- +37 SET PRCTYPE="00"
- +38 KILL PRCERR
- +39 DO TRANS840^PRCHQ4A(PRCTYPE)
- +40 IF $GET(PRCERR)
- DO EN^DDIOL("Due to Error Conditions Transmission Was Aborted!")
- QUIT
- +41 SET PRCNOPRT=$$MANUAL
- +42 IF $PIECE($GET(^PRC(444,PRCDA,1)),U,11)=""&PRCNOPRT
- DO EN^DDIOL("RFQ has not been transmitted, use option Edit Incomplete RFQ to complete.")
- QUIT
- +43 if PRCNOPRT
- DO EN^DDIOL("Required manual RFQs were not printed, use option Manual Print of RFQ.")
- +44 IF $PIECE($GET(^PRC(444,PRCDA,1)),U,11)]""!('PRCNOPRT)
- Begin DoDot:2
- +45 NEW PRCAR,PRCSTAT,PRCSTRG
- +46 SET PRCSTRG="CANCELLED^INCOMPLETE^PENDING QUOTES^CLOSED^EVALUATION COMPLETE^AWARDED"
- SET PRCSTAT=$PIECE(PRCSTRG,U,$PIECE(^PRC(444,PRCDA,0),U,8)+1)
- +47 KILL DA
- SET DA=PRCDA
- SET DR="7////2"
- SET DIE="^PRC(444,"
- DO ^DIE
- KILL DA,DIE,DR
- +48 SET PRCAR(1)="The status of RFQ #: "_PRCRFQ_" has been changed from"
- +49 SET PRCAR(2)=" '"_PRCSTAT_"' to '"_$PIECE(PRCSTRG,U,$PIECE($GET(^PRC(444,PRCDA,0)),U,8)+1)_"'."
- +50 DO EN^DDIOL(.PRCAR)
- End DoDot:2
- End DoDot:1
- +51 KILL DDSCHANG,DDSSAVE,PRCERR
- +52 QUIT
- MANUAL() ;Print Manual RFQ
- +1 NEW X,Y,POP,%,%H,%I,DA
- +2 SET X=0
- SET Y=0
- +3 FOR
- SET X=$ORDER(^PRC(444,PRCDA,5,X))
- if +X'=X
- QUIT
- IF $PIECE($GET(^PRC(444,PRCDA,5,X,0)),U,2)="m"
- SET Y=1
- QUIT
- +4 IF 'Y
- DO EN^DDIOL("There are no vendors for Manual Solicitation")
- QUIT 0
- MANA KILL %ZIS
- SET %ZIS("A")="90 Column Printer for Manual RFQ: "
- +1 SET %ZIS("B")=""
- SET %ZIS="PQ"
- DO ^%ZIS
- IF POP
- QUIT 1
- +2 IF $EXTRACT(IOST)'="P"!(IOM'>89)
- DO ^%ZISC
- DO EN^DDIOL("Device must be a printer supporting 90 characters per line.")
- GOTO MANA
- +3 IF $DATA(IO("Q"))
- SET ZTRTN="PROCESS^PRCHQM1"
- SET ZTSAVE("DA")=PRCDA
- DO ^%ZTLOAD
- DO HOME^%ZIS
- if $GET(ZTSK)>0
- GOTO XMANUAL
- QUIT 1
- +4 SET DA=PRCDA
- DO PROCESS^PRCHQM1
- XMANUAL ;
- +1 QUIT 0