- PRCHQRP5 ;WISC/KMB-2237 TRACKING REPORT ;10/6/96 08:53
- ;;5.1;IFCAP;;Oct 20, 2000
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- START ;
- N RFQLINE,X,P,PDATE,XXZ,Z,Z1,STR,XI,ODA,RDA,ITEMNO,COUNT,Y,RFQ,RFQNUM,IMF,PONUM,OLINE,NREC,NLINE,I,LNR
- N Q,OREC,PHONE,PA,L,STR,RDATA,SORT,DA,DIRUT,DIROUT,DTOUT,DUOUT,II,POP
- ;
- W @IOF D EN3^PRCSUT Q:'$D(PRC("SITE")) Q:Y<0
- S DIC="^PRCS(410,",DIC(0)="AEMQZ",DIC("A")="Select 2237 transaction number: "
- S DIC("S")="I +^(0),$P($G(^(0)),""^"",4)'=1,$D(^(3)),+^(3)=+$P(PRC(""CP""),"" ""),$P(^(0),""^"",5)=PRC(""SITE"")"
- D ^DIC K DIC Q:Y<0 S DA=+Y
- I '$O(^PRC(444,"C",DA,0)) W !,"No RFQ has been created for this 2237.",! H 2 G START
- S DIR(0)="SM^1:Destination;2:Original 2237 line item"
- S DIR("?",1)="Enter 1 to sort by destination (PO, RFQ, new 2237)",DIR("?")="or 2 to sort by original 2237 line number"
- D ^DIR Q:$D(DIRUT) S SORT=Y K DIR
- W @IOF S %ZIS="MQ" D ^%ZIS Q:POP
- I $D(IO("Q")) S ZTRTN="PROCESS^PRCHQRP5",ZTSAVE("SORT")="",ZTSAVE("DA")="",ZTSAVE("DUZ")="" D ^%ZTLOAD,^%ZISC G START
- D PROCESS,^%ZISC H 2 W @IOF G START
- PROCESS ;
- S P=1,I=0
- D NOW^%DTC S Y=X D DD^%DT S PDATE=Y
- S RFQ=0 F S RFQ=$O(^PRC(444,"C",DA,RFQ)) Q:RFQ="" D
- .S OREC=$P($G(^PRCS(410,DA,0)),"^")
- .S RFQNUM=$P($G(^PRC(444,RFQ,0)),"^")
- .S RFQLINE=0 F S RFQLINE=$O(^PRC(444,"C",DA,RFQ,RFQLINE)) Q:RFQLINE="" D
- ..S (PONUM,NREC)=""
- ..S PA=$P($G(^PRC(444,RFQ,0)),"^",4) S:$G(PA)'="" PHONE=$P($G(^VA(200,PA,.13)),"^",5)
- ..S:$G(PA)'="" PA=$P($G(^VA(200,PA,0)),"^")
- ..S IMF=$P($G(^PRC(444,RFQ,2,RFQLINE,0)),"^")
- ..S OLINE=$P($G(^(3)),"^",2),NREC=$P($G(^(3)),"^",6)
- ..I NREC'="" S NREC=$P($G(^PRCS(410,NREC,0)),"^"),PONUM=$P($G(^PRCS(410,NREC,4)),"^",5)
- ..S RDATA=OREC_"^"_OLINE_"^"_IMF_"^"_PA_"^"_PHONE
- ..I SORT=1 F I=PONUM,RFQNUM,NREC I $G(I)'="" S STR(I,OLINE)=RDATA
- ..I SORT=2 S STR(OLINE)=OREC_"^"_OLINE_"^"_IMF_"^"_RFQNUM_" LINE # "_RFQLINE
- WRITE ;
- I '$D(STR) W !,"No data was available for your sort criteria" H 2 Q
- U IO S (P,Z1)=1 D HDR
- S Q="" F S Q=$O(STR(Q)) Q:(Z1[U)!(Q="") D
- .I IOSL-($Y#IOSL)<6 D HOLD Q:Z1[U D HDR
- .I SORT=2 W !,$P(STR(Q),"^"),?20,$P(STR(Q),"^",2),?28,$P(STR(Q),"^",3),?35,$P(STR(Q),"^",4),?60,$P(STR(Q),"^",5)
- .I SORT=1 W !,?10,Q S L="" F S L=$O(STR(Q,L)) Q:L="" W !,$P(STR(Q,L),"^"),?20,$P(STR(Q,L),"^",2),?28,$P(STR(Q,L),"^",3),?35,$P(STR(Q,L),"^",4),?60,$P(STR(Q,L),"^",5)
- QUIT
- HDR ;
- W @IOF W !,"2237 TRACKING REPORT",?40,PDATE,?60,"PAGE ",P,!
- I SORT=1 W !,?10,"DESTINATION",!,"ORIGINAL 2237",?20,"LINE #",?28,"IMF #",?35,"PURCHASING AGENT",?60,"PA PHONE",!
- I SORT=2 W !,"ORIGINAL 2237",?20,"LINE #",?28,"IMF #",?35,"DESTINATION DESCRIPTION",!
- ;
- F II=1:1:8 W "----------"
- S P=P+1 Q
- HOLD G HDR:$D(ZTQUEUED) W !,"Press return to continue, '^' to exit: " R XXZ:DTIME S:'$T Z1=U D:Z1'=U HDR Q
- NOTIFY ; notify users that RFQ quotes are due
- N %,X,Y,COUNT,STR,XXZ,PDATE,TDATE,SDA,PA,RNUM,I,Z1,ZIP,P,PRCI
- Q:'$D(DUZ) S I=1,COUNT=0
- D NOW^%DTC S (Y,TDATE)=$P(%,".") D DD^%DT S PDATE=Y
- S ZIP="" F S ZIP=$O(^PRC(444,"QD",ZIP)) Q:ZIP="" D
- .Q:ZIP'=TDATE
- .S SDA="" F S SDA=$O(^PRC(444,"QD",ZIP,SDA)) Q:SDA="" D
- ..Q:$P($G(^PRC(444,SDA,0)),"^",4)'=DUZ S PA=$P($G(^VA(200,DUZ,0)),"^")
- ..S COUNT=COUNT+1,RNUM=$P($G(^PRC(444,SDA,0)),"^"),STR(COUNT)=RNUM_"^"_PA
- I $D(STR),$D(FLAG) W !,"You have ",COUNT," RFQ(s) which have quotations due today",!,"Use the RFQs Due Report to review them." K FLAG QUIT
- I $D(FLAG) K FLAG QUIT
- I '$D(STR) W !,"There are no RFQs with quotes due today." QUIT
- W !,"Use this option to create a report of RFQs which require quotations.",!
- W ! S %ZIS="MQ" D ^%ZIS Q:POP
- I $D(IO("Q")) S ZTRTN="QUOTES^PRCHQRP5",ZTSAVE("PDATE")="",ZTSAVE("COUNT")="",ZTSAVE("STR(")="" D ^%ZTLOAD,HOME^%ZIS K ZTSK QUIT
- D QUOTES QUIT
- QUOTES ;
- S XXZ=""
- U IO S (P,Z1)=1 D HDR1
- F PRCI=1:1:COUNT D Q:XXZ["^"
- . I PRCL+3>IOSL D HOLD1 Q:XXZ["^"
- .W !,?20,$P(STR(PRCI),"^"),?45,$P(STR(PRCI),"^",2) S PRCL=PRCL+1
- I $E(IOST,1,2)="C-"&'$D(ZTQUEUED) R !,"Enter RETURN to continue ",XXZ:DTIME
- K XXZ,P,Z1,STR,PRCI,PRCL
- S:$D(ZTQUEUED) ZTREQ="@" D ^%ZISC
- QUIT
- HOLD1 I $E(IOST,1,2)="C-"&'$D(ZTQUEUED) W !,"Enter RETURN to continue or '^' to exit: " R XXZ:DTIME Q:XXZ["^"
- HDR1 ;
- W @IOF
- W !,"RFQ WITH QUOTATIONS DUE REPORT",?40,PDATE,?70,"PAGE ",P,!
- W !,?20,"RFQ REFERENCE",?45,"PURCHASING AGENT"
- S P=P+1,PRCL=4 W ! F I=1:1:8 W "----------"
- QUIT
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHQRP5 4434 printed Feb 18, 2025@23:36:26 Page 2
- PRCHQRP5 ;WISC/KMB-2237 TRACKING REPORT ;10/6/96 08:53
- +1 ;;5.1;IFCAP;;Oct 20, 2000
- +2 ;Per VHA Directive 10-93-142, this routine should not be modified.
- START ;
- +1 NEW RFQLINE,X,P,PDATE,XXZ,Z,Z1,STR,XI,ODA,RDA,ITEMNO,COUNT,Y,RFQ,RFQNUM,IMF,PONUM,OLINE,NREC,NLINE,I,LNR
- +2 NEW Q,OREC,PHONE,PA,L,STR,RDATA,SORT,DA,DIRUT,DIROUT,DTOUT,DUOUT,II,POP
- +3 ;
- +4 WRITE @IOF
- DO EN3^PRCSUT
- if '$DATA(PRC("SITE"))
- QUIT
- if Y<0
- QUIT
- +5 SET DIC="^PRCS(410,"
- SET DIC(0)="AEMQZ"
- SET DIC("A")="Select 2237 transaction number: "
- +6 SET DIC("S")="I +^(0),$P($G(^(0)),""^"",4)'=1,$D(^(3)),+^(3)=+$P(PRC(""CP""),"" ""),$P(^(0),""^"",5)=PRC(""SITE"")"
- +7 DO ^DIC
- KILL DIC
- if Y<0
- QUIT
- SET DA=+Y
- +8 IF '$ORDER(^PRC(444,"C",DA,0))
- WRITE !,"No RFQ has been created for this 2237.",!
- HANG 2
- GOTO START
- +9 SET DIR(0)="SM^1:Destination;2:Original 2237 line item"
- +10 SET DIR("?",1)="Enter 1 to sort by destination (PO, RFQ, new 2237)"
- SET DIR("?")="or 2 to sort by original 2237 line number"
- +11 DO ^DIR
- if $DATA(DIRUT)
- QUIT
- SET SORT=Y
- KILL DIR
- +12 WRITE @IOF
- SET %ZIS="MQ"
- DO ^%ZIS
- if POP
- QUIT
- +13 IF $DATA(IO("Q"))
- SET ZTRTN="PROCESS^PRCHQRP5"
- SET ZTSAVE("SORT")=""
- SET ZTSAVE("DA")=""
- SET ZTSAVE("DUZ")=""
- DO ^%ZTLOAD
- DO ^%ZISC
- GOTO START
- +14 DO PROCESS
- DO ^%ZISC
- HANG 2
- WRITE @IOF
- GOTO START
- PROCESS ;
- +1 SET P=1
- SET I=0
- +2 DO NOW^%DTC
- SET Y=X
- DO DD^%DT
- SET PDATE=Y
- +3 SET RFQ=0
- FOR
- SET RFQ=$ORDER(^PRC(444,"C",DA,RFQ))
- if RFQ=""
- QUIT
- Begin DoDot:1
- +4 SET OREC=$PIECE($GET(^PRCS(410,DA,0)),"^")
- +5 SET RFQNUM=$PIECE($GET(^PRC(444,RFQ,0)),"^")
- +6 SET RFQLINE=0
- FOR
- SET RFQLINE=$ORDER(^PRC(444,"C",DA,RFQ,RFQLINE))
- if RFQLINE=""
- QUIT
- Begin DoDot:2
- +7 SET (PONUM,NREC)=""
- +8 SET PA=$PIECE($GET(^PRC(444,RFQ,0)),"^",4)
- if $GET(PA)'=""
- SET PHONE=$PIECE($GET(^VA(200,PA,.13)),"^",5)
- +9 if $GET(PA)'=""
- SET PA=$PIECE($GET(^VA(200,PA,0)),"^")
- +10 SET IMF=$PIECE($GET(^PRC(444,RFQ,2,RFQLINE,0)),"^")
- +11 SET OLINE=$PIECE($GET(^(3)),"^",2)
- SET NREC=$PIECE($GET(^(3)),"^",6)
- +12 IF NREC'=""
- SET NREC=$PIECE($GET(^PRCS(410,NREC,0)),"^")
- SET PONUM=$PIECE($GET(^PRCS(410,NREC,4)),"^",5)
- +13 SET RDATA=OREC_"^"_OLINE_"^"_IMF_"^"_PA_"^"_PHONE
- +14 IF SORT=1
- FOR I=PONUM,RFQNUM,NREC
- IF $GET(I)'=""
- SET STR(I,OLINE)=RDATA
- +15 IF SORT=2
- SET STR(OLINE)=OREC_"^"_OLINE_"^"_IMF_"^"_RFQNUM_" LINE # "_RFQLINE
- End DoDot:2
- End DoDot:1
- WRITE ;
- +1 IF '$DATA(STR)
- WRITE !,"No data was available for your sort criteria"
- HANG 2
- QUIT
- +2 USE IO
- SET (P,Z1)=1
- DO HDR
- +3 SET Q=""
- FOR
- SET Q=$ORDER(STR(Q))
- if (Z1[U)!(Q="")
- QUIT
- Begin DoDot:1
- +4 IF IOSL-($Y#IOSL)<6
- DO HOLD
- if Z1[U
- QUIT
- DO HDR
- +5 IF SORT=2
- WRITE !,$PIECE(STR(Q),"^"),?20,$PIECE(STR(Q),"^",2),?28,$PIECE(STR(Q),"^",3),?35,$PIECE(STR(Q),"^",4),?60,$PIECE(STR(Q),"^",5)
- +6 IF SORT=1
- WRITE !,?10,Q
- SET L=""
- FOR
- SET L=$ORDER(STR(Q,L))
- if L=""
- QUIT
- WRITE !,$PIECE(STR(Q,L),"^"),?20,$PIECE(STR(Q,L),"^",2),?28,$PIECE(STR(Q,L),"^",3),?35,$PIECE(STR(Q,L),"^",4),?60,$PIECE(STR(Q,L),"^",5)
- End DoDot:1
- +7 QUIT
- HDR ;
- +1 WRITE @IOF
- WRITE !,"2237 TRACKING REPORT",?40,PDATE,?60,"PAGE ",P,!
- +2 IF SORT=1
- WRITE !,?10,"DESTINATION",!,"ORIGINAL 2237",?20,"LINE #",?28,"IMF #",?35,"PURCHASING AGENT",?60,"PA PHONE",!
- +3 IF SORT=2
- WRITE !,"ORIGINAL 2237",?20,"LINE #",?28,"IMF #",?35,"DESTINATION DESCRIPTION",!
- +4 ;
- +5 FOR II=1:1:8
- WRITE "----------"
- +6 SET P=P+1
- QUIT
- HOLD if $DATA(ZTQUEUED)
- GOTO HDR
- WRITE !,"Press return to continue, '^' to exit: "
- READ XXZ:DTIME
- if '$TEST
- SET Z1=U
- if Z1'=U
- DO HDR
- QUIT
- NOTIFY ; notify users that RFQ quotes are due
- +1 NEW %,X,Y,COUNT,STR,XXZ,PDATE,TDATE,SDA,PA,RNUM,I,Z1,ZIP,P,PRCI
- +2 if '$DATA(DUZ)
- QUIT
- SET I=1
- SET COUNT=0
- +3 DO NOW^%DTC
- SET (Y,TDATE)=$PIECE(%,".")
- DO DD^%DT
- SET PDATE=Y
- +4 SET ZIP=""
- FOR
- SET ZIP=$ORDER(^PRC(444,"QD",ZIP))
- if ZIP=""
- QUIT
- Begin DoDot:1
- +5 if ZIP'=TDATE
- QUIT
- +6 SET SDA=""
- FOR
- SET SDA=$ORDER(^PRC(444,"QD",ZIP,SDA))
- if SDA=""
- QUIT
- Begin DoDot:2
- +7 if $PIECE($GET(^PRC(444,SDA,0)),"^",4)'=DUZ
- QUIT
- SET PA=$PIECE($GET(^VA(200,DUZ,0)),"^")
- +8 SET COUNT=COUNT+1
- SET RNUM=$PIECE($GET(^PRC(444,SDA,0)),"^")
- SET STR(COUNT)=RNUM_"^"_PA
- End DoDot:2
- End DoDot:1
- +9 IF $DATA(STR)
- IF $DATA(FLAG)
- WRITE !,"You have ",COUNT," RFQ(s) which have quotations due today",!,"Use the RFQs Due Report to review them."
- KILL FLAG
- QUIT
- +10 IF $DATA(FLAG)
- KILL FLAG
- QUIT
- +11 IF '$DATA(STR)
- WRITE !,"There are no RFQs with quotes due today."
- QUIT
- +12 WRITE !,"Use this option to create a report of RFQs which require quotations.",!
- +13 WRITE !
- SET %ZIS="MQ"
- DO ^%ZIS
- if POP
- QUIT
- +14 IF $DATA(IO("Q"))
- SET ZTRTN="QUOTES^PRCHQRP5"
- SET ZTSAVE("PDATE")=""
- SET ZTSAVE("COUNT")=""
- SET ZTSAVE("STR(")=""
- DO ^%ZTLOAD
- DO HOME^%ZIS
- KILL ZTSK
- QUIT
- +15 DO QUOTES
- QUIT
- QUOTES ;
- +1 SET XXZ=""
- +2 USE IO
- SET (P,Z1)=1
- DO HDR1
- +3 FOR PRCI=1:1:COUNT
- Begin DoDot:1
- +4 IF PRCL+3>IOSL
- DO HOLD1
- if XXZ["^"
- QUIT
- +5 WRITE !,?20,$PIECE(STR(PRCI),"^"),?45,$PIECE(STR(PRCI),"^",2)
- SET PRCL=PRCL+1
- End DoDot:1
- if XXZ["^"
- QUIT
- +6 IF $EXTRACT(IOST,1,2)="C-"&'$DATA(ZTQUEUED)
- READ !,"Enter RETURN to continue ",XXZ:DTIME
- +7 KILL XXZ,P,Z1,STR,PRCI,PRCL
- +8 if $DATA(ZTQUEUED)
- SET ZTREQ="@"
- DO ^%ZISC
- +9 QUIT
- HOLD1 IF $EXTRACT(IOST,1,2)="C-"&'$DATA(ZTQUEUED)
- WRITE !,"Enter RETURN to continue or '^' to exit: "
- READ XXZ:DTIME
- if XXZ["^"
- QUIT
- HDR1 ;
- +1 WRITE @IOF
- +2 WRITE !,"RFQ WITH QUOTATIONS DUE REPORT",?40,PDATE,?70,"PAGE ",P,!
- +3 WRITE !,?20,"RFQ REFERENCE",?45,"PURCHASING AGENT"
- +4 SET P=P+1
- SET PRCL=4
- WRITE !
- FOR I=1:1:8
- WRITE "----------"
- +5 QUIT