Released PRC*5.1*133 SEQ #117 Extracted from mail message **KIDS**:PRC*5.1*133^ **INSTALL NAME** PRC*5.1*133 "BLD",5924,0) PRC*5.1*133^IFCAP^0^3100506^y "BLD",5924,1,0) ^^5^5^3090327^^ "BLD",5924,1,1,0) 1. Simplied or Detailed PO question "BLD",5924,1,2,0) "BLD",5924,1,3,0) 2. Partials with fractions unable to receive in inventory "BLD",5924,1,4,0) "BLD",5924,1,5,0) 3. Purchasing Agents Statistics report prints for all users "BLD",5924,4,0) ^9.64PA^^ "BLD",5924,6.3) 5 "BLD",5924,"ABPKG") n "BLD",5924,"KRN",0) ^9.67PA^779.2^20 "BLD",5924,"KRN",.4,0) .4 "BLD",5924,"KRN",.401,0) .401 "BLD",5924,"KRN",.402,0) .402 "BLD",5924,"KRN",.402,"NM",0) ^9.68A^1^1 "BLD",5924,"KRN",.402,"NM",1,0) PRCHSIMP FILE #442^442^0 "BLD",5924,"KRN",.402,"NM","B","PRCHSIMP FILE #442",1) "BLD",5924,"KRN",.403,0) .403 "BLD",5924,"KRN",.5,0) .5 "BLD",5924,"KRN",.84,0) .84 "BLD",5924,"KRN",3.6,0) 3.6 "BLD",5924,"KRN",3.8,0) 3.8 "BLD",5924,"KRN",9.2,0) 9.2 "BLD",5924,"KRN",9.8,0) 9.8 "BLD",5924,"KRN",9.8,"NM",0) ^9.68A^2^2 "BLD",5924,"KRN",9.8,"NM",1,0) PRCHREC1^^0^B22440228 "BLD",5924,"KRN",9.8,"NM",2,0) PRCHDPO^^0^B28795225 "BLD",5924,"KRN",9.8,"NM","B","PRCHDPO",2) "BLD",5924,"KRN",9.8,"NM","B","PRCHREC1",1) "BLD",5924,"KRN",19,0) 19 "BLD",5924,"KRN",19.1,0) 19.1 "BLD",5924,"KRN",101,0) 101 "BLD",5924,"KRN",409.61,0) 409.61 "BLD",5924,"KRN",771,0) 771 "BLD",5924,"KRN",779.2,0) 779.2 "BLD",5924,"KRN",870,0) 870 "BLD",5924,"KRN",8989.51,0) 8989.51 "BLD",5924,"KRN",8989.52,0) 8989.52 "BLD",5924,"KRN",8994,0) 8994 "BLD",5924,"KRN","B",.4,.4) "BLD",5924,"KRN","B",.401,.401) "BLD",5924,"KRN","B",.402,.402) "BLD",5924,"KRN","B",.403,.403) "BLD",5924,"KRN","B",.5,.5) "BLD",5924,"KRN","B",.84,.84) "BLD",5924,"KRN","B",3.6,3.6) "BLD",5924,"KRN","B",3.8,3.8) "BLD",5924,"KRN","B",9.2,9.2) "BLD",5924,"KRN","B",9.8,9.8) "BLD",5924,"KRN","B",19,19) "BLD",5924,"KRN","B",19.1,19.1) "BLD",5924,"KRN","B",101,101) "BLD",5924,"KRN","B",409.61,409.61) "BLD",5924,"KRN","B",771,771) "BLD",5924,"KRN","B",779.2,779.2) "BLD",5924,"KRN","B",870,870) "BLD",5924,"KRN","B",8989.51,8989.51) "BLD",5924,"KRN","B",8989.52,8989.52) "BLD",5924,"KRN","B",8994,8994) "BLD",5924,"QUES",0) ^9.62^^ "BLD",5924,"REQB",0) ^9.611^1^1 "BLD",5924,"REQB",1,0) PRC*5.1*8^2 "BLD",5924,"REQB","B","PRC*5.1*8",1) "KRN",.402,2662,-1) 0^1 "KRN",.402,2662,0) PRCHSIMP^3090116.0916^^442^^^3090421 "KRN",.402,2662,"DIAB",1,0,442,6) P.O. DATE//TODAY "KRN",.402,2662,"DIAB",2,0,442,7) PCDO VENDOR;REQ "KRN",.402,2662,"DIAB",2,0,442,8) FREE TEXT VENDOR;REQ "KRN",.402,2662,"DIAB",7,0,442,2) SUBSTATION;REQ "KRN",.402,2662,"DIAB",9,0,442,9) PURCHASE COST;REQ "KRN",.402,2662,"DR",1,442) Q:'$D(PRC("SITE")) S (PRCHN("SVC"),PRCHN("CC"),PRCHN("SC"),PRCHN("INV"))="",PRCHN("SFC")=+$P(^PRC(442,DA,0),U,19),PRCHN("FOB")=$S($D(^(1)):$P(^(1),U,6),1:""),PRCHN(12)=$S($D(^PRC(442,DA,12)):^(12),1:""); "KRN",.402,2662,"DR",1,442,1) S PRCHPONO=$P(^PRC(442,DA,0),U,1),PRCHSTN=$P(PRCHPONO,"-") S PRCHIEN=DA;S PRCX=$O(^PRC(411,PRC("SITE"),1,0)) S:$G(PRCX)]"" PRCY=$P($G(^PRC(411,PRC("SITE"),1,PRCX,0)),U) K PRCX;S PRCHDUZ=$P(^VA(200,DUZ,0),U,1);16////^S X=DUZ; "KRN",.402,2662,"DR",1,442,2) 56////^S X=DUZ;.02///^S X=25;48///^S X="S";63///^S X=1;54///^S X="N";I '$D(^PRC(411,"UP",PRC("SITE"))) S Y="@46";31R~;S SUB=X;I $D(SUB) S PRCX=$O(^PRC(411,SUB,1,0)) S:$G(PRCX)]"" PRCY=$P($G(^PRC(411,SUB,1,PRCX,0)),U) K PRCX;@46; "KRN",.402,2662,"DR",1,442,3) S PRCHCDNO=$P($G(^PRC(442,DA,23)),U,8);S PRCHNN=0 F PRCHII=1:1 S PRCHNN=$O(^PRC(440.5,"C",DUZ,PRCHNN)) Q:'PRCHNN S PRCHCDF=$P(^PRC(440.5,PRCHNN,0),U);S PRCHCDFT="" I PRCHII=2 S PRCHCDFT=PRCHCDF;D LOOK^PRCSPC; "KRN",.402,2662,"DR",1,442,4) I (X="")!(X["^") S ERRFLG=1,Y=0;I $G(PRCHXXX)="" S ERRFLG=1,Y=0;46////^S X=$G(PRCHXXX);I PRCHCDNO'="",X'=PRCHCDNO W !,?5,"Please verify the accounting information for the new Purchase Card.",!; "KRN",.402,2662,"DR",1,442,5) I X]"" S PRCHP0=^PRC(440.5,X,0),PRCHFCP=$P(PRCHP0,U,2),PRCHCC=$P(PRCHP0,U,3),PRCHBOC1=$P(PRCHP0,U,4),PRCHDLOC=$P(PRCHP0,U,7),PRCHCD=$P(PRCHP0,U),PRCHCDNO=+X,PRCHHLDR=$P(PRCHP0,U,8);61////^S X=PRCHHLDR;55///^S X=PRCHCD;Q;Q;Q;Q; "KRN",.402,2662,"DR",1,442,6) .1//^S X=DT;I +X
3000 W !,$C(7),"COST CANNOT EXCEED $3000.00 - YOU MUST USE DETAILED PURCHASE CARD!!" S Y="@3";5.4///^S X="SIMPLIFIED"; "KRN",.402,2662,"DR",1,442,10) S $P(^PRC(442,DA,0),"^",15)=PRCHTOT; "MBREQ") 0 "ORD",7,.402) .402;7;;;EDEOUT^DIFROMSO(.402,DA,"",XPDA);FPRE^DIFROMSI(.402,"",XPDA);EPRE^DIFROMSI(.402,DA,$E("N",$G(XPDNEW)),XPDA,"",OLDA);;EPOST^DIFROMSI(.402,DA,"",XPDA);DEL^DIFROMSK(.402,"",%) "ORD",7,.402,0) INPUT TEMPLATE "PKG",455,-1) 1^1 "PKG",455,0) IFCAP^PRC^IFCAP System Files "PKG",455,20,0) ^9.402P^^ "PKG",455,22,0) ^9.49I^1^1 "PKG",455,22,1,0) 5.1^3001012^3001019^68 "PKG",455,22,1,"PAH",1,0) 133^3100506 "PKG",455,22,1,"PAH",1,1,0) ^^5^5^3100506 "PKG",455,22,1,"PAH",1,1,1,0) 1. Simplied or Detailed PO question "PKG",455,22,1,"PAH",1,1,2,0) "PKG",455,22,1,"PAH",1,1,3,0) 2. Partials with fractions unable to receive in inventory "PKG",455,22,1,"PAH",1,1,4,0) "PKG",455,22,1,"PAH",1,1,5,0) 3. Purchasing Agents Statistics report prints for all users "QUES","XPF1",0) Y "QUES","XPF1","??") ^D REP^XPDH "QUES","XPF1","A") Shall I write over your |FLAG| File "QUES","XPF1","B") YES "QUES","XPF1","M") D XPF1^XPDIQ "QUES","XPF2",0) Y "QUES","XPF2","??") ^D DTA^XPDH "QUES","XPF2","A") Want my data |FLAG| yours "QUES","XPF2","B") YES "QUES","XPF2","M") D XPF2^XPDIQ "QUES","XPI1",0) YO "QUES","XPI1","??") ^D INHIBIT^XPDH "QUES","XPI1","A") Want KIDS to INHIBIT LOGONs during the install "QUES","XPI1","B") NO "QUES","XPI1","M") D XPI1^XPDIQ "QUES","XPM1",0) PO^VA(200,:EM "QUES","XPM1","??") ^D MG^XPDH "QUES","XPM1","A") Enter the Coordinator for Mail Group '|FLAG|' "QUES","XPM1","B") "QUES","XPM1","M") D XPM1^XPDIQ "QUES","XPO1",0) Y "QUES","XPO1","??") ^D MENU^XPDH "QUES","XPO1","A") Want KIDS to Rebuild Menu Trees Upon Completion of Install "QUES","XPO1","B") NO "QUES","XPO1","M") D XPO1^XPDIQ "QUES","XPZ1",0) Y "QUES","XPZ1","??") ^D OPT^XPDH "QUES","XPZ1","A") Want to DISABLE Scheduled Options, Menu Options, and Protocols "QUES","XPZ1","B") NO "QUES","XPZ1","M") D XPZ1^XPDIQ "QUES","XPZ2",0) Y "QUES","XPZ2","??") ^D RTN^XPDH "QUES","XPZ2","A") Want to MOVE routines to other CPUs "QUES","XPZ2","B") NO "QUES","XPZ2","M") D XPZ2^XPDIQ "RTN") 2 "RTN","PRCHDPO") 0^2^B28795225^B20296136 "RTN","PRCHDPO",1,0) PRCHDPO ;WOIFO/CR - DELINQUENT DELIVERY LISTING PA OPTION ; 2/20/01 12:55 PM "RTN","PRCHDPO",2,0) ;;5.1;IFCAP;**8,133**;Oct 20, 2000;Build 5 "RTN","PRCHDPO",3,0) ;Per VHA Directive 2004-038, this routine should not be modified. "RTN","PRCHDPO",4,0) A1 ; "RTN","PRCHDPO",5,0) D CLEAN "RTN","PRCHDPO",6,0) TYPE K Y,SELECT S SELECTW="" W !! "RTN","PRCHDPO",7,0) S DIR("?")=" ",DIR("?",1)="Enter the Supply Employee code desired." "RTN","PRCHDPO",8,0) S DIR("?",2)="Enter multiple codes if needed, ex. 1,3 or 2-4" "RTN","PRCHDPO",9,0) S DIR("?",3)="Normal run has been for 6-ALL" "RTN","PRCHDPO",10,0) S DIR(0)="L^1:6:0" "RTN","PRCHDPO",11,0) S DIR("A",1)="Supply Employee type selection: ",DIR("A",2)="",DIR("A",3)="1:WAREHOUSE",DIR("A",4)="2:PPM ACCOUNTABLE OFFICER" "RTN","PRCHDPO",12,0) S DIR("A",5)="3:PURCHASING AGENT",DIR("A",6)="4:MANAGER",DIR("A",7)="5:PURCHASE CARD HOLDER" "RTN","PRCHDPO",13,0) S DIR("A",8)="6:ALL OF THE ABOVE",DIR("A",9)="" "RTN","PRCHDPO",14,0) S DIR("A")="By Type of Supply Employee: ",DIR("B")="6" D ^DIR "RTN","PRCHDPO",15,0) Q:$D(DIRUT)!($D(DTOUT)) "RTN","PRCHDPO",16,0) S SELECT=Y I SELECT[6 S SELECTW="",SELECT="6," "RTN","PRCHDPO",17,0) E F I=1:1 S X=$P(SELECT,",",I) Q:X="" I X>0 S:SELECTW'="" SELECTW=SELECTW_"," S SELECTW=SELECTW_$P("WAREHOUSE,PPM ACCT OFFICER,PURCHASING AGENT,MANAGER,PURCHASE CARD HOLDER",",",X) "RTN","PRCHDPO",18,0) W !!,"SELECTED: ",$E(SELECT,1,($L(SELECT)-1))," / ",SELECTW,! "RTN","PRCHDPO",19,0) K DR,DIR,X,Y,DIRUT,DTOUT "RTN","PRCHDPO",20,0) DATE S DIR("A")="START WITH DELIVERY DATE",DIR(0)="D^^" D ^DIR K DIR Q:Y["^"!(Y<1) "RTN","PRCHDPO",21,0) S FDATE=+Y W " ",Y(0) "RTN","PRCHDPO",22,0) ; "RTN","PRCHDPO",23,0) S DIR("A")="GO TO DELIVERY DATE",DIR(0)="D^^" D ^DIR K DIR Q:Y["^"!(Y<1) "RTN","PRCHDPO",24,0) S EDATE=+Y W " ",Y(0) "RTN","PRCHDPO",25,0) I EDATEEDATE "RTN","PRCHDPO",56,0) ..S Y=DELDT D DD^%DT,FRMDT1 S DELDT=X1 ; Show a human-readable date "RTN","PRCHDPO",57,0) ..S VENPTR=$P(ZP1,"^",1) "RTN","PRCHDPO",58,0) ..Q:VENPTR=""!(VENPTR=0)!(VENPTR'>0) "RTN","PRCHDPO",59,0) ..S VENDOR=$P(^PRC(440,VENPTR,0),"^",1) "RTN","PRCHDPO",60,0) ..S PHONE=$P($G(^PRC(440,VENPTR,0)),"^",10) "RTN","PRCHDPO",61,0) ..S PRCHPA=+$P(ZP1,"^",10) Q:PRCHPA=""!(PRCHPA=0) "RTN","PRCHDPO",62,0) ..I $D(^VA(200,PRCHPA,0)) S USER=$P(^VA(200,PRCHPA,0),"^")_">"_PRCHPA "RTN","PRCHDPO",63,0) ..I SELECT'[6 Q:+$G(^VA(200,PRCHPA,400))=0&(SELECT'[5) Q:+$G(^VA(200,PRCHPA,400))>0&(SELECT'[+$G(^VA(200,PRCHPA,400))) "RTN","PRCHDPO",64,0) ..S:$D(^PRC(442,ZP,7)) ZP7=^PRC(442,ZP,7) "RTN","PRCHDPO",65,0) ..S SUPT=+$P(ZP7,"^",1) "RTN","PRCHDPO",66,0) ..S PRCSTAT=$P($G(^PRCD(442.3,SUPT,0)),"^") "RTN","PRCHDPO",67,0) ..S SUPORD=$P(ZP7,"^",2) "RTN","PRCHDPO",68,0) ..Q:"^20^21^22^23^24^25^26^27^28^29^32^34^39^44^46^47^"'[("^"_SUPORD_"^") "RTN","PRCHDPO",69,0) ..S TOTAMT=$P(ZP0,"^",15),LIQAMT=$P(ZP0,"^",17) "RTN","PRCHDPO",70,0) ..I LIQAMT<0,(TOTAMT-LIQAMT)>TOTAMT S COSOUT=0 "RTN","PRCHDPO",71,0) ..E S COSOUT=TOTAMT-LIQAMT I COSOUT<0 S COSOUT=0 "RTN","PRCHDPO",72,0) ..S ^TMP($J,USER,VENDOR,PONUM)=PONUM_"^"_PRCSTAT_"^"_COSOUT_"^"_VENDOR_"^"_PHONE_"^"_DELDT "RTN","PRCHDPO",73,0) ; "RTN","PRCHDPO",74,0) PRINT ; Let's print the outstanding orders and dollar amounts. "RTN","PRCHDPO",75,0) ; "RTN","PRCHDPO",76,0) U IO "RTN","PRCHDPO",77,0) D FRMDT "RTN","PRCHDPO",78,0) S (P,EX)=1,(TOT,AMT1)=0 "RTN","PRCHDPO",79,0) I '$D(^TMP($J)) S P=1,(Q,Q1)="" D HEADER W !!!!,?10,"*** NO RECORDS TO PRINT ***" Q "RTN","PRCHDPO",80,0) S Q="" F S Q=$O(^TMP($J,Q)) Q:Q="" Q:EX="^" D "RTN","PRCHDPO",81,0) .D HEADER S (VENTOT,SUBUSER)="" "RTN","PRCHDPO",82,0) .S Q1="" F S Q1=$O(^TMP($J,Q,Q1)) Q:Q1="" Q:EX="^" D "RTN","PRCHDPO",83,0) ..W:Q1]"" !,?18,"VENDOR: ",Q1 "RTN","PRCHDPO",84,0) ..S Q2="" F S Q2=$O(^TMP($J,Q,Q1,Q2)) Q:Q2="" Q:EX="^" D "RTN","PRCHDPO",85,0) ...S AMT1=0 "RTN","PRCHDPO",86,0) ...S STR3=^TMP($J,Q,Q1,Q2) "RTN","PRCHDPO",87,0) ...W !,$P(STR3,"^",1),?15,$P(STR3,"^",2),?60,$J($P(STR3,"^",3),10,2) "RTN","PRCHDPO",88,0) ...W !,?3,$P(STR3,"^",6),?17,$P(STR3,"^",5) "RTN","PRCHDPO",89,0) ...I (IOSL-$Y)<8 D HOLD Q:EX="^" "RTN","PRCHDPO",90,0) ...S AMT1=$P(STR3,"^",3),TOT=AMT1+$G(TOT),VENTOT(USER,VENPTR)=TOT "RTN","PRCHDPO",91,0) ..W !,?60,"----------" "RTN","PRCHDPO",92,0) ..W !,"SUBTOTAL",?60,$J(VENTOT(USER,VENPTR),10,2),! "RTN","PRCHDPO",93,0) ..S GTOT=$G(GTOT)+VENTOT(USER,VENPTR),SUBUSER(USER)=VENTOT(USER,VENPTR)+$G(SUBUSER(USER)) "RTN","PRCHDPO",94,0) ..S TOT=0 "RTN","PRCHDPO",95,0) .I $E(IOST,1,2)="C-",EX'["^" W !,"Press return to continue, '^' to exit: " R XXZ:DTIME S:XXZ="^" EX="^" S:'$T EX="^" "RTN","PRCHDPO",96,0) .I $G(Q2)="" D "RTN","PRCHDPO",97,0) ..W ?60,"----------" "RTN","PRCHDPO",98,0) ..W !,"SUBTOTAL",?60,$J(SUBUSER(USER),10,2) S SUBUSER(USER)="" "RTN","PRCHDPO",99,0) ..; This is the subtotal for the user including all the vendors used. "RTN","PRCHDPO",100,0) W !,?60,"----------" "RTN","PRCHDPO",101,0) W !,"TOTAL",?55,$J(GTOT,15,2) "RTN","PRCHDPO",102,0) D CLEAN "RTN","PRCHDPO",103,0) Q "RTN","PRCHDPO",104,0) ; "RTN","PRCHDPO",105,0) 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="^" I EX'="^",$G(Q2)'="" D HEADER "RTN","PRCHDPO",106,0) Q "RTN","PRCHDPO",107,0) ; "RTN","PRCHDPO",108,0) HEADER ; "RTN","PRCHDPO",109,0) W @IOF "RTN","PRCHDPO",110,0) W !,"DELINQUENT PURCHASE ORDERS",?42,DATE,?68,"PAGE ",P,! "RTN","PRCHDPO",111,0) W "** FOR SUPPLY EMPLOYEE: ",SELECTW,! "RTN","PRCHDPO",112,0) W !,"PO NUMBER",?15,"SUPPLY STATUS",?63,"COST",! "RTN","PRCHDPO",113,0) W ?3,"DELIVERY",?17,"PHONE",?60,"OUTSTANDING",! "RTN","PRCHDPO",114,0) W ?3,"DATE",?17,"NUMBER",?45,"(QTY*UNIT COST FOR ITEMS NOT REC'D)",! "RTN","PRCHDPO",115,0) F I=1:1:10 W "--------" "RTN","PRCHDPO",116,0) W !!,?15,"PA/PPM/AUTHORIZED BUYER: ",$P(Q,">"),! "RTN","PRCHDPO",117,0) S P=P+1 "RTN","PRCHDPO",118,0) Q "RTN","PRCHDPO",119,0) ; "RTN","PRCHDPO",120,0) CLEAN K AMT1,COSOUT,DATE,DELDT,EDATE,FDATE,PRCHPA,PRCSTAT,Q,Q1,Q2,^TMP($J) "RTN","PRCHDPO",121,0) K SUPT,TOT,TOTAMT,VENDOR,VENPTR,VENTOT,X,X1,X2,X3,XXZ,Y,ZP,ZP0,ZP1,ZP7 "RTN","PRCHDPO",122,0) K EX,ENTOT,GTOT,I,LIQAMT,MOP,P,PHONE,PONUM,STR3,SUBUSER,SUPORD,USER "RTN","PRCHDPO",123,0) K SELECT,SELECTW "RTN","PRCHDPO",124,0) Q "RTN","PRCHREC1") 0^1^B22440228^B17009071 "RTN","PRCHREC1",1,0) PRCHREC1 ;ID/RSD,SF/TKW/RHD-CONT. OF RECEIVING ;2/9/93 14:53 "RTN","PRCHREC1",2,0) V ;;5.1;IFCAP;**133**;Oct 20, 2000;Build 5 "RTN","PRCHREC1",3,0) ;Per VHA Directive 2004-038, this routine should not be modified. "RTN","PRCHREC1",4,0) ; "RTN","PRCHREC1",5,0) EN1 S PRCHRQ3="",DA=PRCHPO,D="C",DIC="^PRC(442,DA,2,",DIC(0)="QZXE" W !!?3,"Item: ",X D IX^DIC Q:Y<0 "RTN","PRCHREC1",6,0) S PRCHRDY=+$O(^PRC(442,DA,2,"AB",PRCHRD,+Y,0)) S:'$D(^PRC(442,DA,2,+Y,3,PRCHRDY,0)) PRCHRDY=0 S:PRCHRDY PRCHRQ3=$P(^(0),U,2),$P(^(0),U,2)=0 "RTN","PRCHREC1",7,0) S PRCHRIT=Y,PRCHRQ1=$P(Y(0),U,2),$P(^PRC(442,DA,2,+Y,2),U,8)=$P(^PRC(442,DA,2,+Y,2),U,8)-PRCHRQ3,PRCHRQ2=$P(^(2),U,8),PRCHRAM=$P(^(2),U,1),PRCHRDA=+$P(^(2),U,6) D WP^PRCHREC2 "RTN","PRCHREC1",8,0) W !,"UNIT OF PRCH: ",$P($G(^PRCD(420.5,+$P(Y(0),U,3),0)),U,1)," QTY ORDERED: ",PRCHRQ1," PREVIOUSLY RECEIVED: ",PRCHRQ2,! "RTN","PRCHREC1",9,0) I $D(^TMP("PRCHREC4",$J)) W ! "RTN","PRCHREC1",10,0) F I=0:0 S I=$O(^TMP("PRCHREC4",$J,+$P(^PRC(442,DA,2,+PRCHRIT,0),U,1),I)) Q:'I S X=^(I) W ?10,"Delv.Location: ",$P($G(^PRCS(410.8,+X,0)),U,1),?56,"Delv.Qty.:"_$J(+$P(X,U,2),4),! "RTN","PRCHREC1",11,0) N PRCCKER,PRCHITCV,PRCHITIN,PRCHITRQ,PRCHMULT,PRCHCALC "RTN","PRCHREC1",12,0) S PRCHITRQ=$P(^PRC(442,DA,2,+PRCHRIT,0),U,11) I PRCHITRQ'="" S PRCHITIN=$P($G(^PRCS(410,PRCHITRQ,0)),U,6) "RTN","PRCHREC1",13,0) S PRCHITCV=$P(^PRC(442,DA,2,+PRCHRIT,0),U,17),PRCHMULT=+$P(^PRC(442,DA,2,+PRCHRIT,0),U,12) "RTN","PRCHREC1",14,0) ENQTY W !?3,"QTY BEING RECEIVED: ",PRCHRQ3 W:PRCHRQ3]"" "// " "RTN","PRCHREC1",15,0) S PRCHRTP=0,PRCCKER=0 R PRCHRQ:DTIME I PRCHRDY G DEL1^PRCHREC2:PRCHRQ="@" S:PRCHRQ3&((PRCHRQ="")!(PRCHRQ["^")) PRCHRQ=PRCHRQ3 "RTN","PRCHREC1",16,0) Q:PRCHRQ=""!(PRCHRQ["^") G:PRCHRQ'=+PRCHRQ!(PRCHRQ<0)!(PRCHRQ?.E1"."3N.N) HLP "RTN","PRCHREC1",17,0) I $P(PRCHRQ,".",2)>0 D "RTN","PRCHREC1",18,0) . I PRCHMULT>0 S PRCHCALC=PRCHRQ*PRCHMULT I +$P(PRCHCALC,".",2)=0 Q "RTN","PRCHREC1",19,0) . I PRCHITCV>0 S PRCHCALC=PRCHRQ*PRCHITCV I +$P(PRCHCALC,".",2)=0 Q "RTN","PRCHREC1",20,0) . W !,"This appears to be an inventory item that will have PURCHASE ORDER RECEIVING TO" "RTN","PRCHREC1",21,0) . W !,"INVENTORY. You CANNOT enter a fractional quantity as it WILL NOT be allowed to" "RTN","PRCHREC1",22,0) . W !,"be received into Inventory. Please OK the fractional amount is for a non" "RTN","PRCHREC1",23,0) . W !,"inventory receipt.",! "RTN","PRCHREC1",24,0) . W $C(7) S %A="Receiving a fractional quantity, is this a non-inventory item receipt",%B="",%=2 D ^PRCFYN I %'=1 S PRCCKER=1 "RTN","PRCHREC1",25,0) I PRCCKER=1 G ENQTY "RTN","PRCHREC1",26,0) I PRCHRQ>(PRCHRQ1-PRCHRQ2) W $C(7) S %A=" You are receiving an overage, do you want to continue",%B="",%=2 D ^PRCFYN Q:%'=1 S PRCHROV="" "RTN","PRCHREC1",27,0) ; "RTN","PRCHREC1",28,0) EN3 I PRCHRQ'=PRCHRQ1 S PRCHRAM=$P(^PRC(442,PRCHPO,2,+PRCHRIT,0),U,9),PRCHRAM=$J(PRCHRAM*PRCHRQ,0,2),PRCHRDA=PRCHRDA/PRCHRQ1*PRCHRQ "RTN","PRCHREC1",29,0) K DIC I 'PRCHRDY S DA(2)=PRCHPO,DA(1)=+PRCHRIT,DIC="^PRC(442,DA(2),2,DA(1),3,",DIC(0)="LX",DLAYGO=442,X=PRCHRD S:'$D(@(DIC_"0)")) ^(0)="^442.08DA^^0" D ^DIC K DIC,DA,DLAYGO Q:Y<0 S PRCHRDY=+Y "RTN","PRCHREC1",30,0) S $P(^(2),U,8)=$P(^PRC(442,PRCHPO,2,+PRCHRIT,2),U,8)+PRCHRQ,$P(^PRC(442,PRCHPO,2,+PRCHRIT,3,PRCHRDY,0),U,2,3)=PRCHRQ_U_+PRCHRAM,$P(^(0),U,5)=PRCHRDA "RTN","PRCHREC1",31,0) W:'PRCHRTP ?35,"AMOUNT: ",PRCHRAM "RTN","PRCHREC1",32,0) D:$P(PRC("PARAM"),U,7)=2 ^PRCHREC7 Q "RTN","PRCHREC1",33,0) ; "RTN","PRCHREC1",34,0) LI R !!!,"LINE ITEM: ",X:DTIME G 2^PRCHREC:X=""!(X["^"),HLP1:$E(X)="?",LI1:"Aa"[$E(X),COM:"Cc"[$E(X) "RTN","PRCHREC1",35,0) S X1="" F I=1:1 S Y=$P(X,",",I) Q:Y="" S:Y'[":"&(Y?1N.N) X1=X1_Y_",",Y="" I Y]"" K:Y'[":"!($P(Y,":",1)'?1N.N)!($P(Y,":",2)'?1N.N) X Q:'$D(X) S X1=X1_+Y_":1:"_$P(Y,":",2)_"," "RTN","PRCHREC1",36,0) G:'$D(X) 2^PRCHREC S X=$E(X1,1,$L(X1)-1) X "F PRCHX="_X_" S X=PRCHX D EN1" "RTN","PRCHREC1",37,0) G LI "RTN","PRCHREC1",38,0) ; "RTN","PRCHREC1",39,0) LI1 S PRCHX=0 F I=0:0 S PRCHX=$O(^PRC(442,PRCHPO,2,"C",PRCHX)) Q:PRCHX=""!(PRCHX'>0) S X=PRCHX D EN1 "RTN","PRCHREC1",40,0) G LI "RTN","PRCHREC1",41,0) ; "RTN","PRCHREC1",42,0) COM S %A=" Complete P.O. as is",%B="",%=1 D ^PRCFYN G:$D(PRCHIMP)&(%'=1) 2^PRCHREC G:%'=1 LI "RTN","PRCHREC1",43,0) ; "RTN","PRCHREC1",44,0) COM1 ;ENTRY POINT FOR AUTOMATIC GENERATION OF PROOF OF ORDER FOR GUARANTEED DELIVERY P.O.S "RTN","PRCHREC1",45,0) S I=0 F S I=$O(^PRC(442,PRCHPO,2,"C",I)) Q:I=""!(I'>0) S PRCHRIT=+$O(^(I,0))_"^"_I,PRCHRQ1=$P(^PRC(442,PRCHPO,2,+PRCHRIT,0),U,2),PRCHRQ2=$P(^(2),U,8),PRCHRAM=$P(^(2),U,1),PRCHRDA=$P(^(2),U,6) D COM2 "RTN","PRCHREC1",46,0) G 2^PRCHREC "RTN","PRCHREC1",47,0) ; "RTN","PRCHREC1",48,0) COM2 Q:$O(^PRC(442,PRCHPO,2,"AB",PRCHRD,+PRCHRIT,0))&($D(^PRC(442,PRCHPO,2,+PRCHRIT,3,+$O(^(0)),0))) S PRCHRTP=1,PRCHRQ=PRCHRQ1-PRCHRQ2,PRCHRDY=0 S:PRCHRQ<0 PRCHRQ=0 D EN3 "RTN","PRCHREC1",49,0) Q "RTN","PRCHREC1",50,0) ; "RTN","PRCHREC1",51,0) HLP W !?3,"Enter a number between .01 and 99999" W:PRCHRDY " or '@' to delete" W "." "RTN","PRCHREC1",52,0) Q "RTN","PRCHREC1",53,0) ; "RTN","PRCHREC1",54,0) HLP1 W !?3,"Enter a Line Item number in the following format: 1,2,3,4 or 1:4 .",!?3,"You may also enter 'C' to complete P.O. as is, or 'A' to see all items." "RTN","PRCHREC1",55,0) S X="??",D="C",DA=PRCHPO,DIC="^PRC(442,DA,2,",DIC(0)="QEM",DIC("S")="I '$D(^PRC(442,DA,2,""AB"",+Y))" D IX^DIC K DIC "RTN","PRCHREC1",56,0) G LI "VER") 8.0^22.0 "BLD",5924,6) ^117 **END** **END**