- PRCHRP7 ;WISC/KMB/CR-DELINQUENT PC LISTING ;6/05/98 13:17
- ;;5.1;IFCAP;**8**;Oct 20, 2000
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- STRT ;
- N FLAG S FLAG=2
- STRT1 ;
- S:$G(FLAG)="" FLAG=1
- START ;
- K ^TMP($J)
- N AMT1,END,PNUM,Y,P,USER,VEN,VEND,PC,PC1,STATUS,VPHONE,ADATE,TDATE,Z1,Z2,Z3,QTY,QTYOUT,CP,X,XXZ,EX,QTYORD,QTYPRCD,QTYOUT,ITEM,PART,PARTDATE,STR,YDATE,TAMT,TIMEDATE
- N DETAIL1,DETAIL2,DETAIL3,I,PCNAME,ZP,CC,LDESC,CCP,ORDTOT,QTYAMT,QSTATUS
- N AMTDSCT,PDATE,PRC,PRCRI,STR1,STR2,STR3,Q,Q1,Q2,Q3
- S:$G(FLAG)="" FLAG=0
- S PRCF("X")="S" D ^PRCFSITE Q:'$D(PRC("SITE")) Q:$G(X)="^"
- W !,"Please enter a device for printing this report",!
- S %ZIS("B")="",%ZIS="MQ" D ^%ZIS Q:POP
- I $D(IO("Q")) S ZTSAVE("*")="",ZTRTN="DEL^PRCHRP7" D ^%ZTLOAD,^%ZISC K FLAG QUIT
- D DEL,^%ZISC K FLAG
- Q
- ;
- DEL ;
- D NOW^%DTC S TDATE=$P(%,"."),(P,EX)=1
- S ZP="" F S ZP=$O(^PRC(442,"F",25,ZP)) Q:ZP="" D
- .S Z1=$G(^PRC(442,ZP,0)),Z2=$G(^PRC(442,ZP,1)),Z3=$G(^PRC(442,ZP,23)) S ADATE=$P($G(^PRC(442,ZP,1)),"^",15)
- .;Do not mix orders from different stations.
- .I $D(PRC("SITE")) Q:$P(Z1,"-")'=PRC("SITE")
- .Q:$P(Z1,"^",10)>TDATE
- .S QSTATUS=+$P($G(^PRC(442,ZP,7)),"^",2)
- .Q:"^22^23^24^25^26^29^32^34^39^44^46^47^"'[("^"_QSTATUS_"^")
- .S Y=$P(ADATE,".") D DD^%DT S PDATE=Y
- .Q:$G(^PRC(442,ZP,2,0))=""
- .S VEN=$P(Z2,"^"),VPHONE=$P($G(^PRC(440,+VEN,0)),"^",10),VEND=$P($G(^PRC(440,+VEN,0)),"^")
- .I VEND="SIMPLIFIED",$P($G(^PRC(442,ZP,24)),"^",2)'="" S VEND=$P($G(^PRC(442,ZP,24)),"^",2)
- .S STATUS=$P($G(^PRC(442,ZP,7)),"^")
- .S STATUS=$P($G(^PRCD(442.3,+STATUS,0)),"^") S:STATUS="" STATUS=0
- .S STATUS=$E(STATUS,1,34)
- .S PC1=$P(Z3,"^",8) Q:+PC1=0 S PC=$P($G(^PRC(440.5,+PC1,0)),"^") Q:PC=""
- .I $G(FLAG)=1 I $P($G(^PRC(440.5,+PC1,0)),"^",9)'=DUZ QUIT
- .I $G(FLAG)=2 I $P($G(^PRC(440.5,+PC1,0)),"^",8)'=DUZ QUIT
- .S PCNAME=$P($G(^PRC(440.5,PC1,0)),"^",11),PCNAME=$E(PCNAME,1,15)
- .S CP=$P(Z1,"^",3),CP=$P(CP," ")
- .S USER=$P($G(^PRC(440.5,PC1,0)),"^",8),USER=$P($G(^VA(200,+USER,0)),"^") Q:USER=""
- .S PNUM=$P(Z1,"^",1)
- .S ITEM=0 F S ITEM=$O(^PRC(442,ZP,2,ITEM)) Q:ITEM="" D
- ..Q:'$D(^PRC(442,ZP,2,"C",ITEM))
- ..;
- ..;Get the orders with partials received.
- ..I $D(^PRC(442,ZP,2,ITEM))&($D(^PRC(442,ZP,2,ITEM,3))) D
- ...S DETAIL1=^PRC(442,ZP,2,ITEM,0),QTYORD=$P(DETAIL1,"^",2),QTYAMT=$P(DETAIL1,"^",9)
- ...S (PART,ORDTOT)=0 F S PART=$O(^PRC(442,ZP,2,ITEM,3,PART)) Q:PART="" D
- ....S STR=$G(^PRC(442,ZP,2,ITEM,3,PART,0)) Q:STR=""
- ....S YDATE=$P(STR,"^")
- ....S Y=$P(YDATE,".") D DD^%DT S PARTDATE=Y
- ....D DETAIL2
- ..;
- ..;Get orders without any partials received.
- ..I $D(^PRC(442,ZP,2,ITEM))&('$D(^PRC(442,ZP,2,ITEM,3))) D
- ...S DETAIL1=^PRC(442,ZP,2,ITEM,0),QTYORD=$P(DETAIL1,"^",2),QTYAMT=$P(DETAIL1,"^",9)
- ...S YDATE=$P(^PRC(442,ZP,0),"^",10)
- ...S Y=$P(YDATE,".") D DD^%DT S PARTDATE=Y
- ...D DETAIL2
- ;
- D PRINT
- K ^TMP($J)
- Q
- ;
- DETAIL2 ; Get common calculations in one place, account for discounts too.
- S DETAIL3=$G(^PRC(442,ZP,2,ITEM,2)),QTYPRCD=$P(DETAIL3,"^",8)
- S AMTDSCT=$P(DETAIL3,"^",6)
- S QTYOUT=QTYORD-QTYPRCD
- S ORDTOT=QTYOUT*QTYAMT I AMTDSCT>0 S ORDTOT=ORDTOT-AMTDSCT
- S ORDTOT=$J(ORDTOT,0,2)
- S LDESC=$G(^PRC(442,ZP,2,ITEM,1,1,0)),LDESC=$E(LDESC,1,40)
- S ^TMP($J,USER,PNUM,STATUS,PC,1)=PCNAME_"^"_PNUM_"^"_STATUS_"^"_PDATE
- S ^TMP($J,USER,PNUM,STATUS,PC,2,ITEM)=PARTDATE_"^"_ITEM_"^"_QTYORD_"^"_QTYOUT_"^"_ORDTOT_"^"_LDESC
- S ^TMP($J,USER,PNUM,STATUS,PC,3)=VEND_"^"_VPHONE
- Q
- ;
- PRINT ; Variable AMT1 equals the total amount outstanding by purchase card
- ; and user.
- D NOW^%DTC S Y=% D DD^%DT S TIMEDATE=Y
- U IO
- I '$D(^TMP($J)) S P=1,Q="" D HEADER W !!!!,?10,"*** NO RECORDS TO PRINT ***" Q
- S Q=0 F S Q=$O(^TMP($J,Q)) Q:Q="" Q:EX="^" D
- .D HEADER
- .S AMT1=0
- .S Q1="" F S Q1=$O(^TMP($J,Q,Q1)) Q:Q1="" Q:EX="^" D
- ..S Q2="" F S Q2=$O(^TMP($J,Q,Q1,Q2)) Q:Q2="" Q:EX="^" D
- ...S Q3="" F S Q3=$O(^TMP($J,Q,Q1,Q2,Q3)) Q:Q3="" Q:EX="^" D
- ....S STR1=^TMP($J,Q,Q1,Q2,Q3,1),STR2=^TMP($J,Q,Q1,Q2,Q3,3)
- ....W !,$P(STR1,"^"),?20,$P(STR1,"^",2),?32,$P(STR1,"^",3),?68,$P(STR1,"^",4),!,$P(STR2,"^"),?45,$P(STR2,"^",2)
- ....S ITEM="" F S ITEM=$O(^TMP($J,Q,Q1,Q2,Q3,2,ITEM)) Q:ITEM="" Q:EX="^" D
- .....S STR3=^TMP($J,Q,Q1,Q2,Q3,2,ITEM) W !,$P(STR3,"^"),?15,$P(STR3,"^",2),?40,$P(STR3,"^",3),?54,$P(STR3,"^",4),!,$P(STR3,"^",5),?30,$P(STR3,"^",6)
- .....S AMT1=$P(STR3,"^",5)+$G(AMT1)
- .....I (IOSL-$Y)<7 D HOLD Q:EX[U
- ....W !,"PURCHASE CARD SUBTOTAL: ",$J(AMT1,0,2),!
- .I $E(IOST,1,2)="C-",EX'["^" W !,"Press return to continue, '^' to exit: " R XXZ:DTIME S:XXZ["^" EX="^" S:'$T EX=U
- QUIT
- ;
- HOLD G HEADER:$E(IOST,1,2)'="C-"!(IO'=IO(0)) W !,"Press return to continue, '^' to exit: " R XXZ:DTIME S:XXZ["^" EX="^" S:'$T EX=U I EX'="^",$G(Q3)'="" D HEADER
- QUIT
- ;
- W @IOF
- W "DELINQUENT PURCHASE CARD LISTING",?45,TIMEDATE,?70,"PAGE ",P
- W !!,"PURCHASE CARD NAME",?20,"PO NUMBER",?32,"STATUS",?67,"PO DATE",!,"VENDOR",?45,"VENDOR PHONE"
- W !,"DELIVERY DATE",?15,"LINE ITEM OUTSTANDING",?40,"QTY ORDERED",?54,"QTY OUTSTANDING",!,"AMOUNT OUTSTANDING",?30,"ITEM DESCRIPTION"
- W ! F I=1:1:8 W "----------"
- W !,?20,"BUYER: ",Q,!
- S P=P+1 QUIT
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHRP7 5195 printed Jan 18, 2025@03:11:34 Page 2
- PRCHRP7 ;WISC/KMB/CR-DELINQUENT PC LISTING ;6/05/98 13:17
- +1 ;;5.1;IFCAP;**8**;Oct 20, 2000
- +2 ;Per VHA Directive 10-93-142, this routine should not be modified.
- STRT ;
- +1 NEW FLAG
- SET FLAG=2
- STRT1 ;
- +1 if $GET(FLAG)=""
- SET FLAG=1
- START ;
- +1 KILL ^TMP($JOB)
- +2 NEW AMT1,END,PNUM,Y,P,USER,VEN,VEND,PC,PC1,STATUS,VPHONE,ADATE,TDATE,Z1,Z2,Z3,QTY,QTYOUT,CP,X,XXZ,EX,QTYORD,QTYPRCD,QTYOUT,ITEM,PART,PARTDATE,STR,YDATE,TAMT,TIMEDATE
- +3 NEW DETAIL1,DETAIL2,DETAIL3,I,PCNAME,ZP,CC,LDESC,CCP,ORDTOT,QTYAMT,QSTATUS
- +4 NEW AMTDSCT,PDATE,PRC,PRCRI,STR1,STR2,STR3,Q,Q1,Q2,Q3
- +5 if $GET(FLAG)=""
- SET FLAG=0
- +6 SET PRCF("X")="S"
- DO ^PRCFSITE
- if '$DATA(PRC("SITE"))
- QUIT
- if $GET(X)="^"
- QUIT
- +7 WRITE !,"Please enter a device for printing this report",!
- +8 SET %ZIS("B")=""
- SET %ZIS="MQ"
- DO ^%ZIS
- if POP
- QUIT
- +9 IF $DATA(IO("Q"))
- SET ZTSAVE("*")=""
- SET ZTRTN="DEL^PRCHRP7"
- DO ^%ZTLOAD
- DO ^%ZISC
- KILL FLAG
- QUIT
- +10 DO DEL
- DO ^%ZISC
- KILL FLAG
- +11 QUIT
- +12 ;
- DEL ;
- +1 DO NOW^%DTC
- SET TDATE=$PIECE(%,".")
- SET (P,EX)=1
- +2 SET ZP=""
- FOR
- SET ZP=$ORDER(^PRC(442,"F",25,ZP))
- if ZP=""
- QUIT
- Begin DoDot:1
- +3 SET Z1=$GET(^PRC(442,ZP,0))
- SET Z2=$GET(^PRC(442,ZP,1))
- SET Z3=$GET(^PRC(442,ZP,23))
- SET ADATE=$PIECE($GET(^PRC(442,ZP,1)),"^",15)
- +4 ;Do not mix orders from different stations.
- +5 IF $DATA(PRC("SITE"))
- if $PIECE(Z1,"-")'=PRC("SITE")
- QUIT
- +6 if $PIECE(Z1,"^",10)>TDATE
- QUIT
- +7 SET QSTATUS=+$PIECE($GET(^PRC(442,ZP,7)),"^",2)
- +8 if "^22^23^24^25^26^29^32^34^39^44^46^47^"'[("^"_QSTATUS_"^")
- QUIT
- +9 SET Y=$PIECE(ADATE,".")
- DO DD^%DT
- SET PDATE=Y
- +10 if $GET(^PRC(442,ZP,2,0))=""
- QUIT
- +11 SET VEN=$PIECE(Z2,"^")
- SET VPHONE=$PIECE($GET(^PRC(440,+VEN,0)),"^",10)
- SET VEND=$PIECE($GET(^PRC(440,+VEN,0)),"^")
- +12 IF VEND="SIMPLIFIED"
- IF $PIECE($GET(^PRC(442,ZP,24)),"^",2)'=""
- SET VEND=$PIECE($GET(^PRC(442,ZP,24)),"^",2)
- +13 SET STATUS=$PIECE($GET(^PRC(442,ZP,7)),"^")
- +14 SET STATUS=$PIECE($GET(^PRCD(442.3,+STATUS,0)),"^")
- if STATUS=""
- SET STATUS=0
- +15 SET STATUS=$EXTRACT(STATUS,1,34)
- +16 SET PC1=$PIECE(Z3,"^",8)
- if +PC1=0
- QUIT
- SET PC=$PIECE($GET(^PRC(440.5,+PC1,0)),"^")
- if PC=""
- QUIT
- +17 IF $GET(FLAG)=1
- IF $PIECE($GET(^PRC(440.5,+PC1,0)),"^",9)'=DUZ
- QUIT
- +18 IF $GET(FLAG)=2
- IF $PIECE($GET(^PRC(440.5,+PC1,0)),"^",8)'=DUZ
- QUIT
- +19 SET PCNAME=$PIECE($GET(^PRC(440.5,PC1,0)),"^",11)
- SET PCNAME=$EXTRACT(PCNAME,1,15)
- +20 SET CP=$PIECE(Z1,"^",3)
- SET CP=$PIECE(CP," ")
- +21 SET USER=$PIECE($GET(^PRC(440.5,PC1,0)),"^",8)
- SET USER=$PIECE($GET(^VA(200,+USER,0)),"^")
- if USER=""
- QUIT
- +22 SET PNUM=$PIECE(Z1,"^",1)
- +23 SET ITEM=0
- FOR
- SET ITEM=$ORDER(^PRC(442,ZP,2,ITEM))
- if ITEM=""
- QUIT
- Begin DoDot:2
- +24 if '$DATA(^PRC(442,ZP,2,"C",ITEM))
- QUIT
- +25 ;
- +26 ;Get the orders with partials received.
- +27 IF $DATA(^PRC(442,ZP,2,ITEM))&($DATA(^PRC(442,ZP,2,ITEM,3)))
- Begin DoDot:3
- +28 SET DETAIL1=^PRC(442,ZP,2,ITEM,0)
- SET QTYORD=$PIECE(DETAIL1,"^",2)
- SET QTYAMT=$PIECE(DETAIL1,"^",9)
- +29 SET (PART,ORDTOT)=0
- FOR
- SET PART=$ORDER(^PRC(442,ZP,2,ITEM,3,PART))
- if PART=""
- QUIT
- Begin DoDot:4
- +30 SET STR=$GET(^PRC(442,ZP,2,ITEM,3,PART,0))
- if STR=""
- QUIT
- +31 SET YDATE=$PIECE(STR,"^")
- +32 SET Y=$PIECE(YDATE,".")
- DO DD^%DT
- SET PARTDATE=Y
- +33 DO DETAIL2
- End DoDot:4
- End DoDot:3
- +34 ;
- +35 ;Get orders without any partials received.
- +36 IF $DATA(^PRC(442,ZP,2,ITEM))&('$DATA(^PRC(442,ZP,2,ITEM,3)))
- Begin DoDot:3
- +37 SET DETAIL1=^PRC(442,ZP,2,ITEM,0)
- SET QTYORD=$PIECE(DETAIL1,"^",2)
- SET QTYAMT=$PIECE(DETAIL1,"^",9)
- +38 SET YDATE=$PIECE(^PRC(442,ZP,0),"^",10)
- +39 SET Y=$PIECE(YDATE,".")
- DO DD^%DT
- SET PARTDATE=Y
- +40 DO DETAIL2
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +41 ;
- +42 DO PRINT
- +43 KILL ^TMP($JOB)
- +44 QUIT
- +45 ;
- DETAIL2 ; Get common calculations in one place, account for discounts too.
- +1 SET DETAIL3=$GET(^PRC(442,ZP,2,ITEM,2))
- SET QTYPRCD=$PIECE(DETAIL3,"^",8)
- +2 SET AMTDSCT=$PIECE(DETAIL3,"^",6)
- +3 SET QTYOUT=QTYORD-QTYPRCD
- +4 SET ORDTOT=QTYOUT*QTYAMT
- IF AMTDSCT>0
- SET ORDTOT=ORDTOT-AMTDSCT
- +5 SET ORDTOT=$JUSTIFY(ORDTOT,0,2)
- +6 SET LDESC=$GET(^PRC(442,ZP,2,ITEM,1,1,0))
- SET LDESC=$EXTRACT(LDESC,1,40)
- +7 SET ^TMP($JOB,USER,PNUM,STATUS,PC,1)=PCNAME_"^"_PNUM_"^"_STATUS_"^"_PDATE
- +8 SET ^TMP($JOB,USER,PNUM,STATUS,PC,2,ITEM)=PARTDATE_"^"_ITEM_"^"_QTYORD_"^"_QTYOUT_"^"_ORDTOT_"^"_LDESC
- +9 SET ^TMP($JOB,USER,PNUM,STATUS,PC,3)=VEND_"^"_VPHONE
- +10 QUIT
- +11 ;
- PRINT ; Variable AMT1 equals the total amount outstanding by purchase card
- +1 ; and user.
- +2 DO NOW^%DTC
- SET Y=%
- DO DD^%DT
- SET TIMEDATE=Y
- +3 USE IO
- +4 IF '$DATA(^TMP($JOB))
- SET P=1
- SET Q=""
- DO HEADER
- WRITE !!!!,?10,"*** NO RECORDS TO PRINT ***"
- QUIT
- +5 SET Q=0
- FOR
- SET Q=$ORDER(^TMP($JOB,Q))
- if Q=""
- QUIT
- if EX="^"
- QUIT
- Begin DoDot:1
- +6 DO HEADER
- +7 SET AMT1=0
- +8 SET Q1=""
- FOR
- SET Q1=$ORDER(^TMP($JOB,Q,Q1))
- if Q1=""
- QUIT
- if EX="^"
- QUIT
- Begin DoDot:2
- +9 SET Q2=""
- FOR
- SET Q2=$ORDER(^TMP($JOB,Q,Q1,Q2))
- if Q2=""
- QUIT
- if EX="^"
- QUIT
- Begin DoDot:3
- +10 SET Q3=""
- FOR
- SET Q3=$ORDER(^TMP($JOB,Q,Q1,Q2,Q3))
- if Q3=""
- QUIT
- if EX="^"
- QUIT
- Begin DoDot:4
- +11 SET STR1=^TMP($JOB,Q,Q1,Q2,Q3,1)
- SET STR2=^TMP($JOB,Q,Q1,Q2,Q3,3)
- +12 WRITE !,$PIECE(STR1,"^"),?20,$PIECE(STR1,"^",2),?32,$PIECE(STR1,"^",3),?68,$PIECE(STR1,"^",4),!,$PIECE(STR2,"^"),?45,$PIECE(STR2,"^",2)
- +13 SET ITEM=""
- FOR
- SET ITEM=$ORDER(^TMP($JOB,Q,Q1,Q2,Q3,2,ITEM))
- if ITEM=""
- QUIT
- if EX="^"
- QUIT
- Begin DoDot:5
- +14 SET STR3=^TMP($JOB,Q,Q1,Q2,Q3,2,ITEM)
- WRITE !,$PIECE(STR3,"^"),?15,$PIECE(STR3,"^",2),?40,$PIECE(STR3,"^",3),?54,$PIECE(STR3,"^",4),!,$PIECE(STR3,"^",5),?30,$PIECE(STR3,"^",6)
- +15 SET AMT1=$PIECE(STR3,"^",5)+$GET(AMT1)
- +16 IF (IOSL-$Y)<7
- DO HOLD
- if EX[U
- QUIT
- End DoDot:5
- +17 WRITE !,"PURCHASE CARD SUBTOTAL: ",$JUSTIFY(AMT1,0,2),!
- End DoDot:4
- End DoDot:3
- End DoDot:2
- +18 IF $EXTRACT(IOST,1,2)="C-"
- IF EX'["^"
- WRITE !,"Press return to continue, '^' to exit: "
- READ XXZ:DTIME
- if XXZ["^"
- SET EX="^"
- if '$TEST
- SET EX=U
- End DoDot:1
- +19 QUIT
- +20 ;
- HOLD if $EXTRACT(IOST,1,2)'="C-"!(IO'=IO(0))
- GOTO HEADER
- WRITE !,"Press return to continue, '^' to exit: "
- READ XXZ:DTIME
- if XXZ["^"
- SET EX="^"
- if '$TEST
- SET EX=U
- IF EX'="^"
- IF $GET(Q3)'=""
- DO HEADER
- +1 QUIT
- +2 ;
- +1 WRITE @IOF
- +2 WRITE "DELINQUENT PURCHASE CARD LISTING",?45,TIMEDATE,?70,"PAGE ",P
- +3 WRITE !!,"PURCHASE CARD NAME",?20,"PO NUMBER",?32,"STATUS",?67,"PO DATE",!,"VENDOR",?45,"VENDOR PHONE"
- +4 WRITE !,"DELIVERY DATE",?15,"LINE ITEM OUTSTANDING",?40,"QTY ORDERED",?54,"QTY OUTSTANDING",!,"AMOUNT OUTSTANDING",?30,"ITEM DESCRIPTION"
- +5 WRITE !
- FOR I=1:1:8
- WRITE "----------"
- +6 WRITE !,?20,"BUYER: ",Q,!
- +7 SET P=P+1
- QUIT