- PRCHQM1 ;WISC/KMB-MANUAL PRINT RFQ PROCESSING 3/26/96 ;7/23/99 16:33
- ;;5.1;IFCAP;;Oct 20, 2000
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- START ;
- W !!!,"Use this option to print the 90 column manual quotation form to a printer.",!
- K DIR S DIR(0)="SMB^A:ALL MANUALLY SOLICITED;I:INDIVIDUAL"
- S DIR("A",1)="Do you wish to print RFQs for All manually solicited or an"
- S DIR("A")="Individual vendor"
- S DIR("?",1)="All manually solicited vendors will print a RFQ form for each vendor"
- S DIR("?",2)="who has previously been selected for manual solicitation. Individual"
- S DIR("?",3)="will enable you to print a manual RFQ for any single vendor, whether"
- S DIR("?",4)="or not he has previously been specified for manual solicitation."
- S DIR("?",5)="If the vendor has not been specified for solicitation earlier, he"
- S DIR("?")="will be added to the list of manually solicited vendors."
- D ^DIR K DIR
- I $D(DTOUT)!$D(DUOUT)!$D(DIRUT)!$D(DIROUT) K DTOUT,DUOUT,DIRUT,DIROUT Q
- I Y="I" G SELECT
- ASK S DIC="^PRC(444,",DIC("S")="I $P(^(0),""^"",8)>1",DIC(0)="AEMQZ"
- D ^DIC K DIC I Y<0 K DA,X,Y Q
- S DA=+Y
- S X=0,Y=0
- F S X=$O(^PRC(444,DA,5,X)) Q:+X'=X I $P($G(^PRC(444,DA,5,X,0)),U,2)="m" S Y=1 Q
- I 'Y W !!,"There are no vendors for Manual Solicitation!" K DA G ASK
- A S %ZIS("B")="",%ZIS="MQ" D ^%ZIS Q:POP
- I $E(IOST)'="P"!(IOM'>89) D ^%ZISC,EN^DDIOL("Device must be a printer supporting 90 characters per line.") G A
- I $D(IO("Q")) S ZTRTN="PROCESS^PRCHQM1",ZTSAVE("DA")="" D ^%ZTLOAD,HOME^%ZIS Q
- D PROCESS
- Q
- PROCESS ;
- N X,Y,FOB,FOB1,FOB2,SB1,SB2,FOB1,FOB2,FOB3,FOB4,I,J,P,UPU,UPR,LOC,IP,FLG
- N SVEND,PPHONE,REF,LN,LDESC,QTY,ADATE,CBDATE,RDATE,SRC,PA,ZIP,ZIP1,LD
- N SRC,ISS,K,D0,BC1,BC2,BC3,BC4,BC5,BC6,RFQNUM,LDATE,FDES1,FDES2,FDES3,FDES4
- N PRCSUB,Z,C1,DIW,DIWF,DIWI,DIWL,DIWR,DIWT,DIWTC,DIWX,PAFAX,PRCEMAIL,VENPH,VENFAX
- K ^TMP($J) S D0=DA
- S SVEND=$P($G(^PRC(444,DA,5,0)),"^",4)
- S (FDES1,FDES2,FDES3,FDES4,BC1,BC2,BC3,BC4,BC5,BC6)=""
- S (J,P)=1,(PAFAX,PPHONE,SB1,FOB2)=" ",FOB1="x"
- S:$P($G(^PRC(444,DA,1)),"^")="O" FOB1=" ",FOB2="x"
- S RFQNUM=$P($G(^PRC(444,DA,0)),"^",1),RDATE=$P($G(^PRC(444,DA,0)),"^",2),CBDATE=$P($G(^PRC(444,DA,0)),"^",3)
- S REF=$P($G(^PRC(444,DA,0)),"^",9),PA=$P($G(^PRC(444,DA,0)),"^",4)
- I PA>0 D
- . N PRCX,DIC,DR,DA,DIQ,D0 K ^UTILITY("DIQ1",$J)
- . S DIC=200,DR=".01;.135;.136;.151",DA=PA,DIQ="PRCX",DIQ(0)="I" D EN^DIQ1
- . S PA=PRCX(200,DA,.01,"I"),PPHONE=PRCX(200,DA,.135,"I"),PAFAX=PRCX(200,DA,.136,"I"),PRCEMAIL=PRCX(200,DA,.151,"I") K ^UTILITY("DIQ1",$J)
- S IP=$P(RFQNUM,"-") I IP'="" S IP=$P($G(^PRC(411,IP,0)),"^",10)
- I IP'="" S ISS(5)=$P($G(^DIC(4,IP,0)),"^",2),ISS(1)=$P($G(^(0)),"^",8),ISS(6)=$P($G(^(1)),"^",4) F I=1:1:3 S ISS(I+1)=$P($G(^DIC(4,IP,1)),"^",I)
- S:$G(ISS(5))'="" ISS(5)=$P($G(^DIC(5,ISS(5),0)),"^",2)
- S Y=$P($G(^PRC(444,DA,1)),"^",3)
- I Y'="" D
- . N PRCX,PRCSHIP
- . S PRCSUB=$P(^PRC(444,DA,0),"^",10) S:PRCSUB="" PRCSUB=$P($P(^PRC(444,DA,0),"^"),"-")
- . S PRCSHIP=$G(^PRC(411,PRCSUB,1,Y,0)),FDES1=$P(PRCSHIP,"^")
- . S PRCX=$P(PRCSHIP,"^",5)_", "_$S($P(PRCSHIP,"^",6)]"":$P($G(^DIC(5,$P(PRCSHIP,"^",6),0)),"^",2),1:"")_" "_$P(PRCSHIP,"^",7)
- . S FDES2=$P(PRCSHIP,"^",2) I FDES2="" S FDES2=PRCX Q
- . S FDES3=$P(PRCSHIP,"^",3) I FDES3="" S FDES3=PRCX Q
- . S FDES4=PRCX
- S SB1=$P($G(^PRC(444,DA,1)),"^",7),ADATE=$P($G(^(1)),"^",2) S:SB1="" SB2="x"
- ;
- IDATA ;
- S ZIP=0 F S ZIP=$O(^PRC(444,DA,2,ZIP)) Q:+ZIP=0 D
- .S LN=$P($G(^PRC(444,DA,2,ZIP,0)),"^"),QTY=$P($G(^(0)),"^",2),UPU=$P($G(^(0)),"^",3)
- .S:UPU'="" UPU=$P($G(^PRCD(420.5,UPU,0)),"^")
- .S UPR=""
- .S FLG=0,ZIP1=$P($G(^PRC(444,DA,2,ZIP,4,0)),"^",4) S:+ZIP1=0 ZIP1=1,FLG=1 F LD=1:1:ZIP1 D
- ..S LOC=$P($G(^PRC(444,DA,2,ZIP,4,LD,0)),"^",4),LDATE=$P($G(^(0)),"^",2) S:FLG=0 QTY=$P($G(^(0)),"^",3)
- ..S:LOC'="" LOC=$P(^PRCS(410.8,LOC,0),"^")
- ..I LDATE'="" S Y=LDATE D DD^%DT S LDATE=Y
- ..S ^TMP($J,LN,LD)=LN_"^"_LOC_"^"_QTY_"^"_UPU_"^"_UPR_"^"_LDATE_"^"_" "
- S Y=RDATE D DD^%DT S RDATE=Y
- S Y=ADATE D DD^%DT S ADATE=Y
- S Y=CBDATE D DD^%DT S CBDATE=Y
- FVEND ;
- ;
- I $G(PRCOPTN)'="ONE" F K=1:1:SVEND D SVEND^PRCHQM3 I '$D(FLAG) D ^PRCHQM2,REP^PRCHQM4,VET^PRCHQM3,ADMCERT^PRCHQM4(DA,P) W !?28,"--LAST PAGE--"
- I $G(PRCOPTN)="ONE" D
- . N FILE,VEN,KK,VEN440
- . S KK=$P(PRCVEN,";"),FILE=$P(PRCVEN,";",2),VEN=@("^"_FILE_KK_",0)")
- . S VENPH=$S(FILE[440:$P(VEN,U,10),FILE[444.1:$P(VEN,U,6),1:"")
- . I FILE[440 F I=1:1:8 S SRC(I)=$P(VEN,"^",I)
- . I FILE[444.1 S SRC(1)=$P(VEN,"^"),VEN(1)=$G(^PRC(444.1,KK,1)) F I=1:1:7 S SRC(I+1)=$P(VEN(1),"^",I)
- . S:SRC(7)'="" SRC(7)=$P($G(^DIC(5,SRC(7),0)),"^",2)
- . I FILE[444.1 S VENFAX=$P($G(VEN),"^",7)
- . I FILE[440 S VEN440=$G(@("^"_FILE_KK_",10)")),VENFAX=$P(VEN440,"^",6)
- . D ^PRCHQM2,REP^PRCHQM4,VET^PRCHQM3,ADMCERT^PRCHQM4(DA,P)
- . W !?28,"--LAST PAGE--"
- . I '$D(^PRC(444,PRCDA,5,"B",PRCVEN)) D
- . . N DD,DO,DIC,DA,DIE,DR
- . . S X=PRCVEN,DIC="^PRC(444,PRCDA,5,",DIC(0)="LX",DLAYGO=444.01
- . . S DIC("P")=$P(^DD(444,20,0),U,2),DA(1)=PRCDA
- . . D FILE^DICN K DIC,DLAYGO
- . . Q:+Y<1
- . . S DIE="^PRC(444,PRCDA,5,",DA(1)=PRCDA,DA=+Y,DR="1////m"
- . . D ^DIE
- I $P($G(^PRC(444,DA,9)),U)="" D
- . N X,Y,%,%H,%I D NOW^%DTC
- . S $P(^PRC(444,DA,9),U)=%
- K ^TMP($J),DA,FLAG,PRCVEN I $D(ZTQUEUED) S ZTREQ="@" K PRCOPTN,PRCDA
- D ^%ZISC
- Q
- SELECT ;Entry point for Print Single RFQ
- K DIR,DA,DIC
- S DIC="^PRC(444,",DIC("S")="I $P(^(0),U,8)=2",DIC(0)="AEMQZ"
- D ^DIC K DIC I Y<1 K DA,X,Y,DTOUT,DUOUT Q
- S PRCDA=+Y
- VSELECT ;Vendor select
- K DIR,DA S DIR(0)="444.01,.01",DIR("A")="Enter an existing Vendor or RETURN"
- S DIR("?")="^D HELP^PRCHQM1" D ^DIR K DIR
- I $D(DTOUT)!$D(DUOUT)!$D(DIROUT) G EX
- S:Y>0 PRCVEN=Y
- I Y<1 D G:$G(PRCOUT) EX
- . K DIC,DA S DIC="^PRC(444.1,",DIC(0)="AELMQ",DLAYGO=444.1
- . S DIC("A")="Enter the Vendor's Name: "
- . D ^DIC K DIC,DLAYGO
- . I Y<1 W !,"The vendor was NOT added to the RFQ VENDOR File!" S PRCOUT=1 Q
- . S DA=+Y,PRCVEN=DA
- . L +^PRC(444.1,PRCVEN):3 E W !,"This vendor entry is in use, please try later!" S PRCOUT=1 Q
- . S 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,PRCVEN)
- . S PRCVEN=PRCVEN_";PRC(444.1,"
- K DA S DA=PRCDA,PRCOPTN="ONE"
- DEVICE S %ZIS("A")="Device to Print RFQ: ",%ZIS("B")="",%ZIS="MQ" D ^%ZIS
- G:POP EX
- I $E(IOST)'="P"!(IOM'>89) D ^%ZISC,EN^DDIOL("Device must be a printer supporting 90 characters per line.") G DEVICE
- I $D(IO("Q")) S ZTRTN="PROCESS^PRCHQM1",ZTSAVE("DA")="",ZTSAVE("PRCVEN")="",ZTSAVE("PRCOPTN")="",ZTSAVE("PRCDA")="" D ^%ZTLOAD,HOME^%ZIS K ZTSK G EX
- D PROCESS
- EX K PRCX,PRCDA,PRCVEN,DA,PRCOPTN,PRCOUT,POP,DIC,DIE,DIRUT,DIROUT,DTOUT,DUOUT,X,Y
- Q
- HELP ;Help for DIR lookup of vendor
- N PRCA,PRCX,PRCJ,X,Y,Z,PRCTMP S $P(PRCA," ",81)=""
- S PRCTMP(1)="The current Solicited Vendors for this RFQ are: "
- S PRCX=0,PRCJ=1
- F S PRCX=$O(^PRC(444,PRCDA,5,PRCX)) Q:+PRCX'=PRCX D
- . Q:'$D(^PRC(444,PRCDA,5,PRCX,0)) S X=^(0)
- . S Y=$P(X,U),Y=$P($G(@("^"_$P(Y,";",2)_$P(Y,";")_",0)")),U)
- . S Z=$P(";EDI;MANUAL",";",$F("em",$P(X,U,2)))
- . S PRCJ=PRCJ+1,PRCTMP(PRCJ)=" "_Y_$E(PRCA,$L(Y)+1,50)_Z
- S PRCJ=PRCJ+1,PRCTMP(PRCJ)=""
- S PRCJ=PRCJ+1,PRCTMP(PRCJ)="First check that the Vendor in not already on file in the VENDOR file (#440)"
- S PRCJ=PRCJ+1,PRCTMP(PRCJ)=" or the RFQ VENDOR file (#444.1). By entering RETURN, you will be"
- S PRCJ=PRCJ+1,PRCTMP(PRCJ)=" given an opportunity to add a new vendor to the RFQ VENDOR file."
- S PRCJ=PRCJ+1,PRCTMP(PRCJ)=""
- D EN^DDIOL(.PRCTMP)
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHQM1 7520 printed Jan 18, 2025@03:11:07 Page 2
- PRCHQM1 ;WISC/KMB-MANUAL PRINT RFQ PROCESSING 3/26/96 ;7/23/99 16:33
- +1 ;;5.1;IFCAP;;Oct 20, 2000
- +2 ;Per VHA Directive 10-93-142, this routine should not be modified.
- START ;
- +1 WRITE !!!,"Use this option to print the 90 column manual quotation form to a printer.",!
- +2 KILL DIR
- SET DIR(0)="SMB^A:ALL MANUALLY SOLICITED;I:INDIVIDUAL"
- +3 SET DIR("A",1)="Do you wish to print RFQs for All manually solicited or an"
- +4 SET DIR("A")="Individual vendor"
- +5 SET DIR("?",1)="All manually solicited vendors will print a RFQ form for each vendor"
- +6 SET DIR("?",2)="who has previously been selected for manual solicitation. Individual"
- +7 SET DIR("?",3)="will enable you to print a manual RFQ for any single vendor, whether"
- +8 SET DIR("?",4)="or not he has previously been specified for manual solicitation."
- +9 SET DIR("?",5)="If the vendor has not been specified for solicitation earlier, he"
- +10 SET DIR("?")="will be added to the list of manually solicited vendors."
- +11 DO ^DIR
- KILL DIR
- +12 IF $DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIRUT)!$DATA(DIROUT)
- KILL DTOUT,DUOUT,DIRUT,DIROUT
- QUIT
- +13 IF Y="I"
- GOTO SELECT
- ASK SET DIC="^PRC(444,"
- SET DIC("S")="I $P(^(0),""^"",8)>1"
- SET DIC(0)="AEMQZ"
- +1 DO ^DIC
- KILL DIC
- IF Y<0
- KILL DA,X,Y
- QUIT
- +2 SET DA=+Y
- +3 SET X=0
- SET Y=0
- +4 FOR
- SET X=$ORDER(^PRC(444,DA,5,X))
- if +X'=X
- QUIT
- IF $PIECE($GET(^PRC(444,DA,5,X,0)),U,2)="m"
- SET Y=1
- QUIT
- +5 IF 'Y
- WRITE !!,"There are no vendors for Manual Solicitation!"
- KILL DA
- GOTO ASK
- A SET %ZIS("B")=""
- SET %ZIS="MQ"
- DO ^%ZIS
- if POP
- QUIT
- +1 IF $EXTRACT(IOST)'="P"!(IOM'>89)
- DO ^%ZISC
- DO EN^DDIOL("Device must be a printer supporting 90 characters per line.")
- GOTO A
- +2 IF $DATA(IO("Q"))
- SET ZTRTN="PROCESS^PRCHQM1"
- SET ZTSAVE("DA")=""
- DO ^%ZTLOAD
- DO HOME^%ZIS
- QUIT
- +3 DO PROCESS
- +4 QUIT
- PROCESS ;
- +1 NEW X,Y,FOB,FOB1,FOB2,SB1,SB2,FOB1,FOB2,FOB3,FOB4,I,J,P,UPU,UPR,LOC,IP,FLG
- +2 NEW SVEND,PPHONE,REF,LN,LDESC,QTY,ADATE,CBDATE,RDATE,SRC,PA,ZIP,ZIP1,LD
- +3 NEW SRC,ISS,K,D0,BC1,BC2,BC3,BC4,BC5,BC6,RFQNUM,LDATE,FDES1,FDES2,FDES3,FDES4
- +4 NEW PRCSUB,Z,C1,DIW,DIWF,DIWI,DIWL,DIWR,DIWT,DIWTC,DIWX,PAFAX,PRCEMAIL,VENPH,VENFAX
- +5 KILL ^TMP($JOB)
- SET D0=DA
- +6 SET SVEND=$PIECE($GET(^PRC(444,DA,5,0)),"^",4)
- +7 SET (FDES1,FDES2,FDES3,FDES4,BC1,BC2,BC3,BC4,BC5,BC6)=""
- +8 SET (J,P)=1
- SET (PAFAX,PPHONE,SB1,FOB2)=" "
- SET FOB1="x"
- +9 if $PIECE($GET(^PRC(444,DA,1)),"^")="O"
- SET FOB1=" "
- SET FOB2="x"
- +10 SET RFQNUM=$PIECE($GET(^PRC(444,DA,0)),"^",1)
- SET RDATE=$PIECE($GET(^PRC(444,DA,0)),"^",2)
- SET CBDATE=$PIECE($GET(^PRC(444,DA,0)),"^",3)
- +11 SET REF=$PIECE($GET(^PRC(444,DA,0)),"^",9)
- SET PA=$PIECE($GET(^PRC(444,DA,0)),"^",4)
- +12 IF PA>0
- Begin DoDot:1
- +13 NEW PRCX,DIC,DR,DA,DIQ,D0
- KILL ^UTILITY("DIQ1",$JOB)
- +14 SET DIC=200
- SET DR=".01;.135;.136;.151"
- SET DA=PA
- SET DIQ="PRCX"
- SET DIQ(0)="I"
- DO EN^DIQ1
- +15 SET PA=PRCX(200,DA,.01,"I")
- SET PPHONE=PRCX(200,DA,.135,"I")
- SET PAFAX=PRCX(200,DA,.136,"I")
- SET PRCEMAIL=PRCX(200,DA,.151,"I")
- KILL ^UTILITY("DIQ1",$JOB)
- End DoDot:1
- +16 SET IP=$PIECE(RFQNUM,"-")
- IF IP'=""
- SET IP=$PIECE($GET(^PRC(411,IP,0)),"^",10)
- +17 IF IP'=""
- SET ISS(5)=$PIECE($GET(^DIC(4,IP,0)),"^",2)
- SET ISS(1)=$PIECE($GET(^(0)),"^",8)
- SET ISS(6)=$PIECE($GET(^(1)),"^",4)
- FOR I=1:1:3
- SET ISS(I+1)=$PIECE($GET(^DIC(4,IP,1)),"^",I)
- +18 if $GET(ISS(5))'=""
- SET ISS(5)=$PIECE($GET(^DIC(5,ISS(5),0)),"^",2)
- +19 SET Y=$PIECE($GET(^PRC(444,DA,1)),"^",3)
- +20 IF Y'=""
- Begin DoDot:1
- +21 NEW PRCX,PRCSHIP
- +22 SET PRCSUB=$PIECE(^PRC(444,DA,0),"^",10)
- if PRCSUB=""
- SET PRCSUB=$PIECE($PIECE(^PRC(444,DA,0),"^"),"-")
- +23 SET PRCSHIP=$GET(^PRC(411,PRCSUB,1,Y,0))
- SET FDES1=$PIECE(PRCSHIP,"^")
- +24 SET PRCX=$PIECE(PRCSHIP,"^",5)_", "_$SELECT($PIECE(PRCSHIP,"^",6)]"":$PIECE($GET(^DIC(5,$PIECE(PRCSHIP,"^",6),0)),"^",2),1:"")_" "_$PIECE(PRCSHIP,"^",7)
- +25 SET FDES2=$PIECE(PRCSHIP,"^",2)
- IF FDES2=""
- SET FDES2=PRCX
- QUIT
- +26 SET FDES3=$PIECE(PRCSHIP,"^",3)
- IF FDES3=""
- SET FDES3=PRCX
- QUIT
- +27 SET FDES4=PRCX
- End DoDot:1
- +28 SET SB1=$PIECE($GET(^PRC(444,DA,1)),"^",7)
- SET ADATE=$PIECE($GET(^(1)),"^",2)
- if SB1=""
- SET SB2="x"
- +29 ;
- IDATA ;
- +1 SET ZIP=0
- FOR
- SET ZIP=$ORDER(^PRC(444,DA,2,ZIP))
- if +ZIP=0
- QUIT
- Begin DoDot:1
- +2 SET LN=$PIECE($GET(^PRC(444,DA,2,ZIP,0)),"^")
- SET QTY=$PIECE($GET(^(0)),"^",2)
- SET UPU=$PIECE($GET(^(0)),"^",3)
- +3 if UPU'=""
- SET UPU=$PIECE($GET(^PRCD(420.5,UPU,0)),"^")
- +4 SET UPR=""
- +5 SET FLG=0
- SET ZIP1=$PIECE($GET(^PRC(444,DA,2,ZIP,4,0)),"^",4)
- if +ZIP1=0
- SET ZIP1=1
- SET FLG=1
- FOR LD=1:1:ZIP1
- Begin DoDot:2
- +6 SET LOC=$PIECE($GET(^PRC(444,DA,2,ZIP,4,LD,0)),"^",4)
- SET LDATE=$PIECE($GET(^(0)),"^",2)
- if FLG=0
- SET QTY=$PIECE($GET(^(0)),"^",3)
- +7 if LOC'=""
- SET LOC=$PIECE(^PRCS(410.8,LOC,0),"^")
- +8 IF LDATE'=""
- SET Y=LDATE
- DO DD^%DT
- SET LDATE=Y
- +9 SET ^TMP($JOB,LN,LD)=LN_"^"_LOC_"^"_QTY_"^"_UPU_"^"_UPR_"^"_LDATE_"^"_" "
- End DoDot:2
- End DoDot:1
- +10 SET Y=RDATE
- DO DD^%DT
- SET RDATE=Y
- +11 SET Y=ADATE
- DO DD^%DT
- SET ADATE=Y
- +12 SET Y=CBDATE
- DO DD^%DT
- SET CBDATE=Y
- FVEND ;
- +1 ;
- +2 IF $GET(PRCOPTN)'="ONE"
- FOR K=1:1:SVEND
- DO SVEND^PRCHQM3
- IF '$DATA(FLAG)
- DO ^PRCHQM2
- DO REP^PRCHQM4
- DO VET^PRCHQM3
- DO ADMCERT^PRCHQM4(DA,P)
- WRITE !?28,"--LAST PAGE--"
- +3 IF $GET(PRCOPTN)="ONE"
- Begin DoDot:1
- +4 NEW FILE,VEN,KK,VEN440
- +5 SET KK=$PIECE(PRCVEN,";")
- SET FILE=$PIECE(PRCVEN,";",2)
- SET VEN=@("^"_FILE_KK_",0)")
- +6 SET VENPH=$SELECT(FILE[440:$PIECE(VEN,U,10),FILE[444.1:$PIECE(VEN,U,6),1:"")
- +7 IF FILE[440
- FOR I=1:1:8
- SET SRC(I)=$PIECE(VEN,"^",I)
- +8 IF FILE[444.1
- SET SRC(1)=$PIECE(VEN,"^")
- SET VEN(1)=$GET(^PRC(444.1,KK,1))
- FOR I=1:1:7
- SET SRC(I+1)=$PIECE(VEN(1),"^",I)
- +9 if SRC(7)'=""
- SET SRC(7)=$PIECE($GET(^DIC(5,SRC(7),0)),"^",2)
- +10 IF FILE[444.1
- SET VENFAX=$PIECE($GET(VEN),"^",7)
- +11 IF FILE[440
- SET VEN440=$GET(@("^"_FILE_KK_",10)"))
- SET VENFAX=$PIECE(VEN440,"^",6)
- +12 DO ^PRCHQM2
- DO REP^PRCHQM4
- DO VET^PRCHQM3
- DO ADMCERT^PRCHQM4(DA,P)
- +13 WRITE !?28,"--LAST PAGE--"
- +14 IF '$DATA(^PRC(444,PRCDA,5,"B",PRCVEN))
- Begin DoDot:2
- +15 NEW DD,DO,DIC,DA,DIE,DR
- +16 SET X=PRCVEN
- SET DIC="^PRC(444,PRCDA,5,"
- SET DIC(0)="LX"
- SET DLAYGO=444.01
- +17 SET DIC("P")=$PIECE(^DD(444,20,0),U,2)
- SET DA(1)=PRCDA
- +18 DO FILE^DICN
- KILL DIC,DLAYGO
- +19 if +Y<1
- QUIT
- +20 SET DIE="^PRC(444,PRCDA,5,"
- SET DA(1)=PRCDA
- SET DA=+Y
- SET DR="1////m"
- +21 DO ^DIE
- End DoDot:2
- End DoDot:1
- +22 IF $PIECE($GET(^PRC(444,DA,9)),U)=""
- Begin DoDot:1
- +23 NEW X,Y,%,%H,%I
- DO NOW^%DTC
- +24 SET $PIECE(^PRC(444,DA,9),U)=%
- End DoDot:1
- +25 KILL ^TMP($JOB),DA,FLAG,PRCVEN
- IF $DATA(ZTQUEUED)
- SET ZTREQ="@"
- KILL PRCOPTN,PRCDA
- +26 DO ^%ZISC
- +27 QUIT
- SELECT ;Entry point for Print Single RFQ
- +1 KILL DIR,DA,DIC
- +2 SET DIC="^PRC(444,"
- SET DIC("S")="I $P(^(0),U,8)=2"
- SET DIC(0)="AEMQZ"
- +3 DO ^DIC
- KILL DIC
- IF Y<1
- KILL DA,X,Y,DTOUT,DUOUT
- QUIT
- +4 SET PRCDA=+Y
- VSELECT ;Vendor select
- +1 KILL DIR,DA
- SET DIR(0)="444.01,.01"
- SET DIR("A")="Enter an existing Vendor or RETURN"
- +2 SET DIR("?")="^D HELP^PRCHQM1"
- DO ^DIR
- KILL DIR
- +3 IF $DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)
- GOTO EX
- +4 if Y>0
- SET PRCVEN=Y
- +5 IF Y<1
- Begin DoDot:1
- +6 KILL DIC,DA
- SET DIC="^PRC(444.1,"
- SET DIC(0)="AELMQ"
- SET DLAYGO=444.1
- +7 SET DIC("A")="Enter the Vendor's Name: "
- +8 DO ^DIC
- KILL DIC,DLAYGO
- +9 IF Y<1
- WRITE !,"The vendor was NOT added to the RFQ VENDOR File!"
- SET PRCOUT=1
- QUIT
- +10 SET DA=+Y
- SET PRCVEN=DA
- +11 LOCK +^PRC(444.1,PRCVEN):3
- IF '$TEST
- WRITE !,"This vendor entry is in use, please try later!"
- SET PRCOUT=1
- QUIT
- +12 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"
- +13 DO ^DIE
- KILL DIE,DR,DA
- LOCK -^PRC(444.1,PRCVEN)
- +14 SET PRCVEN=PRCVEN_";PRC(444.1,"
- End DoDot:1
- if $GET(PRCOUT)
- GOTO EX
- +15 KILL DA
- SET DA=PRCDA
- SET PRCOPTN="ONE"
- DEVICE SET %ZIS("A")="Device to Print RFQ: "
- SET %ZIS("B")=""
- SET %ZIS="MQ"
- DO ^%ZIS
- +1 if POP
- GOTO EX
- +2 IF $EXTRACT(IOST)'="P"!(IOM'>89)
- DO ^%ZISC
- DO EN^DDIOL("Device must be a printer supporting 90 characters per line.")
- GOTO DEVICE
- +3 IF $DATA(IO("Q"))
- SET ZTRTN="PROCESS^PRCHQM1"
- SET ZTSAVE("DA")=""
- SET ZTSAVE("PRCVEN")=""
- SET ZTSAVE("PRCOPTN")=""
- SET ZTSAVE("PRCDA")=""
- DO ^%ZTLOAD
- DO HOME^%ZIS
- KILL ZTSK
- GOTO EX
- +4 DO PROCESS
- EX KILL PRCX,PRCDA,PRCVEN,DA,PRCOPTN,PRCOUT,POP,DIC,DIE,DIRUT,DIROUT,DTOUT,DUOUT,X,Y
- +1 QUIT
- HELP ;Help for DIR lookup of vendor
- +1 NEW PRCA,PRCX,PRCJ,X,Y,Z,PRCTMP
- SET $PIECE(PRCA," ",81)=""
- +2 SET PRCTMP(1)="The current Solicited Vendors for this RFQ are: "
- +3 SET PRCX=0
- SET PRCJ=1
- +4 FOR
- SET PRCX=$ORDER(^PRC(444,PRCDA,5,PRCX))
- if +PRCX'=PRCX
- QUIT
- Begin DoDot:1
- +5 if '$DATA(^PRC(444,PRCDA,5,PRCX,0))
- QUIT
- SET X=^(0)
- +6 SET Y=$PIECE(X,U)
- SET Y=$PIECE($GET(@("^"_$PIECE(Y,";",2)_$PIECE(Y,";")_",0)")),U)
- +7 SET Z=$PIECE(";EDI;MANUAL",";",$FIND("em",$PIECE(X,U,2)))
- +8 SET PRCJ=PRCJ+1
- SET PRCTMP(PRCJ)=" "_Y_$EXTRACT(PRCA,$LENGTH(Y)+1,50)_Z
- End DoDot:1
- +9 SET PRCJ=PRCJ+1
- SET PRCTMP(PRCJ)=""
- +10 SET PRCJ=PRCJ+1
- SET PRCTMP(PRCJ)="First check that the Vendor in not already on file in the VENDOR file (#440)"
- +11 SET PRCJ=PRCJ+1
- SET PRCTMP(PRCJ)=" or the RFQ VENDOR file (#444.1). By entering RETURN, you will be"
- +12 SET PRCJ=PRCJ+1
- SET PRCTMP(PRCJ)=" given an opportunity to add a new vendor to the RFQ VENDOR file."
- +13 SET PRCJ=PRCJ+1
- SET PRCTMP(PRCJ)=""
- +14 DO EN^DDIOL(.PRCTMP)
- +15 QUIT