Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PRCHRP7

PRCHRP7.m

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