source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCPRCAT.m@ 1078

Last change on this file since 1078 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR
File size: 5.0 KB
Line 
1PRCPRCAT ;WISC/RFJ/DL-order form ; 1/28/98 1000
2V ;;5.1;IFCAP;**1**;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 D ^PRCPUSEL Q:'$G(PRCP("I"))
5 N PRCPBLNK,PRCPDATE,PRCPEND,PRCPINFR,PRCPINPT,PRCPFLAG,PRCPFONE,PRCPFNON,PRCPSSIT,X,Y,Z
6 K X S X(1)="The Order Form prints the current or selected inventory point's items sorted by main storage location and description. Blanks for daily ordering may be included."
7 D DISPLAY^PRCPUX2(40,79,.X)
8 ;
9 I PRCP("DPTYPE")="S" S PRCPINPT=PRCP("I") G MONTHYR
10 ;
11 K X S X(1)="Select a Distribution Point or press the <return> key to select the current inventory point."
12 D DISPLAY^PRCPUX2(2,40,.X)
13 S PRCPINPT=$$TO^PRCPUDPT(PRCP("I")) Q:PRCPINPT["^"
14 I 'PRCPINPT S PRCPINPT=PRCP("I")
15 ;
16 ; jump to here if a secondary
17MONTHYR W ! K X S X(1)="Select the month-year of the order form for "_$$INVNAME^PRCPUX1(PRCPINPT)_"."
18 D DISPLAY^PRCPUX2(2,40,.X)
19 S %DT("A")="Print Catalog/Order Form for DATE: "
20 S %DT("B")="TODAY",%DT="AEX" D ^%DT K %DT Q:Y<0
21 S PRCPEND=$P("31^28^31^30^31^30^31^31^30^31^30^31","^",+$E(Y,4,5))
22 I PRCPEND=28 S Z=$E(Y,1,3)+1700,PRCPEND=$S(Z#400=0:29,(Z#4=0&(Z#100'=0)):29,1:28)
23 S Y=$E(Y,1,5)_"00" D DD^%DT S PRCPDATE=Y
24 ;
25 D Q:$G(PRCPFLAG) G BLANKS:$P($G(^PRCP(445,PRCPINPT,0)),"^",3)="S"
26 . S PRCPSSIT=1
27 . S XP="Print only items with a non-zero normal level"
28 . S XH="Enter YES to print only items whose normal level is not zero in "_$$INVNAME^PRCPUX1(PRCPINPT)_"."
29 . S XH(1)="Enter NO to print all items in "_$$INVNAME^PRCPUX1(PRCPINPT)_"."
30 . S XH(2)="Enter ^ to exit."
31 . W ! S %=$$YN^PRCPUYN(1) I %<1 S PRCPFLAG=1 Q
32 . I %=2 K PRCPSSIT
33 ;
34 S PRCPINFR=$$FROMCHEK^PRCPUDPT(PRCPINPT,0)
35 I PRCPINFR D Q:$G(PRCPFLAG)
36 . S XP="Print only the items stocked by "_$$INVNAME^PRCPUX1(PRCPINFR)
37 . S XH="Enter YES to only print the items stocked by "_$$INVNAME^PRCPUX1(PRCPINFR)_"."
38 . S XH(1)="Enter NO to print all items in "_$$INVNAME^PRCPUX1(PRCPINPT)_"."
39 . S XH(2)="Enter ^ to exit."
40 . W ! S %=$$YN^PRCPUYN(1) I %<1 S PRCPFLAG=1 Q
41 . I %=2 K PRCPINFR
42 ;
43BLANKS S PRCPBLNK=1
44 I "SP"[(PRCP("DPTYPE")) D
45 . S XP="Include blanks on printout"
46 . S XH="Enter YES to print blanks on the order form."
47 . S XH(1)="Enter NO to print just the items and related information."
48 . S XH(2)="Enter ^ to exit."
49 . W ! S %=$$YN^PRCPUYN(1) I %<1 S PRCPFLAG=1 Q
50 . I %=2 K PRCPBLNK
51 ;
52 S %ZIS="Q" D ^%ZIS Q:POP I $D(IO("Q")) D D ^%ZTLOAD K IO("Q"),ZTSK Q
53 . S ZTDESC="Order Form",ZTRTN="DQ^PRCPRCAT"
54 . S ZTSAVE("PRCP*")="",ZTSAVE("ZTREQ")="@"
55 W !!,"<*> please wait <*>"
56 ;
57 ; queue comes here
58DQ N %I,DAY,DAY1,DESCR,ITEMCOST,ITEMDA,ITEMDATA,MAINLOC,NOW,PAGE,PRCPFLAG,PRCPINNM,SCREEN,WHSESRCE,X,Y
59 K ^TMP($J,"PRCPRCAT")
60 S ITEMDA=0 F S ITEMDA=$O(^PRCP(445,PRCPINPT,1,ITEMDA)) Q:'ITEMDA D
61 . I $G(PRCPINFR),'$D(^PRCP(445,PRCPINFR,1,ITEMDA,0)) Q
62 . I '$D(^PRCP(445,PRCPINPT,1,ITEMDA,0)) Q
63 . I $G(PRCPSSIT),$P(^PRCP(445,PRCPINPT,1,ITEMDA,0),"^",9)'>0 Q
64 . S MAINLOC=$$STORAGE^PRCPESTO(PRCPINPT,ITEMDA)
65 . S DESCR=$$DESCR^PRCPUX1(PRCPINPT,ITEMDA) S:DESCR="" DESCR=" "
66 . S ^TMP($J,"PRCPRCAT",MAINLOC,$E(DESCR,1,20),ITEMDA)=""
67 ;
68 ; setup order form format
69 S DAY="" F %=1:1:PRCPEND S DAY=DAY_"| "_$J(%,2)
70 I IOM<81 S DAY1="|"_$P(DAY,"15|",2),DAY=$P(DAY,"15|")_"15"
71 ;
72 S WHSESRCE=+$O(^PRC(440,"AC","W",0))
73 S PRCPINNM=$$INVNAME^PRCPUX1(PRCPINPT)
74 D NOW^%DTC S Y=% D DD^%DT S NOW=Y,SCREEN=$$SCRPAUSE^PRCPUREP,PAGE=1 U IO D H
75 S MAINLOC="" F S MAINLOC=$O(^TMP($J,"PRCPRCAT",MAINLOC)) Q:MAINLOC=""!($G(PRCPFLAG)) D
76 . I $G(ZTQUEUED),$$S^%ZTLOAD S PRCPFLAG=1 W !?10,"<<< TASKMANAGER JOB TERMINATED BY USER >>>" Q
77 . I $Y>(IOSL-7) D:SCREEN P^PRCPUREP Q:$G(PRCPFLAG) D H
78 . W !!?5,"MAIN STORAGE LOCATION: ",$S(MAINLOC=" ":"<< NONE >>",1:MAINLOC)
79 . I '$G(PRCPBLNK) W !
80 . S DESCR="" F S DESCR=$O(^TMP($J,"PRCPRCAT",MAINLOC,DESCR)) Q:DESCR=""!($G(PRCPFLAG)) S ITEMDA=0 F S ITEMDA=$O(^TMP($J,"PRCPRCAT",MAINLOC,DESCR,ITEMDA)) Q:'ITEMDA!($G(PRCPFLAG)) D
81 . . I $Y>(IOSL-8) D:SCREEN P^PRCPUREP Q:$G(PRCPFLAG) D H
82 . . S ITEMDATA=$G(^PRCP(445,PRCPINPT,1,ITEMDA,0))
83 . . S ITEMCOST=$P(ITEMDATA,"^",22) I $P(ITEMDATA,"^",15)>ITEMCOST S ITEMCOST=$P(ITEMDATA,"^",15)
84 . . I $G(PRCPBLNK) W !!
85 . . W $E($$DESCR^PRCPUX1(PRCPINPT,ITEMDA),1,28),?29,ITEMDA,?35,$TR($$NSN^PRCPUX1(ITEMDA),"-"),?50,$J($$UNIT^PRCPUX1(PRCPINPT,ITEMDA,"/"),8),$J($P(ITEMDATA,"^",10),6),$J($P(ITEMDATA,"^",9),6),$J(ITEMCOST,9,2),!
86 . . I $$MANDSRCE^PRCPU441(ITEMDA)=WHSESRCE W "*"
87 . . I $G(PRCPBLNK) D
88 . . . W ?2,"DAY: ",DAY,"|",!?2,"QTY: ",$TR(DAY,"1234567890"," "),"|"
89 . . . I $D(DAY1) W !?2,"DAY: ",DAY1,"|",!?2,"QTY: ",$TR(DAY1,"1234567890"," "),"|"
90 I '$G(PRCPFLAG) D END^PRCPUREP
91 K ^TMP($J,"PRCPRCAT") D ^%ZISC Q
92 ;
93 ;
94H S %=NOW_" PAGE "_PAGE,PAGE=PAGE+1 I PAGE'=2!(SCREEN) W @IOF
95 W $C(13),"ORDER FORM FOR: ",PRCPINNM,?(IOM-$L(%)),%
96 W !?5,"FOR THE MONTH-YEAR: ",PRCPDATE
97 W ?58,$J("STAND",6),$J("NORM",6),$J("UNIT",10),!,"DESCRIPTION",?29,"MI#",?35,"NSN",?50,$J("UNIT/IS",8),$J("REOPT",6),$J("STLVL",6),$J("COST",10)
98 S %="",$P(%,"-",IOM+1)="" W !,%
99 Q
Note: See TracBrowser for help on using the repository browser.