source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHRPT1.m@ 1582

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

initial load of WorldVistAEHR

File size: 6.1 KB
Line 
1PRCHRPT1 ;ID/RSD,SF-ISC/TKW-PRINT OPTIONS ; [1/13/99 1:27pm]
2V ;;5.1;IFCAP;**15,70,106**;Oct 20, 2000
3 ;Per VHA Directive 2004-038, this routine should not be modified.
4 ;
5EN ;DISPLAY ITEM HISTORY
6 S PRCF("X")="SP",AGN=1,LLCT=0,LNCT=0 D ^PRCFSITE
7EN0 Q:'$D(PRC("SITE")) W !! S DIC="^PRC(441,",DIC(0)="QEAMNZ" D ^DIC G Q:Y<0 S D0=+Y I '$D(^(4,0)) W !,"History for this item does not yet exist. Press <RETURN>" R X:DTIME G EN0
8 S PRCHQ="ITEM^PRCHRPT1",ITMY=Y(0) D RDTXS G:'$D(PRC("SITE")) Q D ^PRCHQUE K DIC,ZTSK,D0
9 G EN0
10 ;
11EN1 ;PRINT ITEM CATALOG
12 S PRCF("X")="SP" D ^PRCFSITE
13EN10 Q:'$D(PRC("SITE")) K PRCHD S M="FUND CONTROL POINT",DIS(0)="I PRC(""SITE"")=$E($O(^PRC(441,D0,4,""B"",PRC(""SITE""))),1,3)" D RNG G Q:FR["^"!(TO["^") I FR["?"!(TO["?") D DSP^PRCHRPT2 G EN10
14 I FR S X=+FR D FX S FR=X
15 I TO S X=+TO D FX S TO=X
16 S FR=FR_",!",TO=TO_",z",DIC="^PRC(441,",FLDS="[PRCHITCAT]",BY="#@FCP,FCP,FCP,LONG NAME;"""",@$E(SHORT DESCRIPTION,1,50)" S L=0 D EN1^DIP
17 ;
18Q K FR,TO,FLDS,BY,DIC,I,J,K,L,PRC,PRCHFCP,D0,DA,M,DIS,ZTSK
19 K %,ABORT,DIR,FCPNO,FCPTCNT,FCPTPGS,FR1,FR2,FR3,FR4,ITMNO,ITMY,LCNT,LLIM,NXD,PRCHQ,PRCRI,PRCI,RTX,^TEMP("FCPCNT"),^TEMP("FCPDT"),^TEMP("FCPNAME"),^TEMP("FCPPGS"),TO1,TO2,TO3,TO4,TXCNT,TXFCP,TXIEN,TXR,TXS,TXSTN,X,Y
20 K AGN,C,DDH,SCTL,STN,ITMDESC,^TMP("PRCHRPT1",$J)
21 QUIT
22 ;
23FX I $D(^PRC(420,+PRC("SITE"),1,X,0)) S X=PRC("SITE")_$P($P(^(0),U,1)," ",1)
24 Q
25 ;
26ITEM S TXR=$G(^TMP("PRCHITMH",0)) S:'TXR TXR=10
27 S U="^" Q:'$D(^PRC(441,D0,0)) S W=$P(^(0),U,2),ASK=0,(W1,W(3),W(4))=0,W(2)="",PRC("SITE")=$S($D(PRC("SITE")):PRC("SITE"),1:0),W(1)=PRC("SITE")_0 K ^TMP("PRCHRPT1",$J)
28 F W(1)=W(1):0 Q:'$O(^PRC(441,D0,4,"B",W(1))) S W(1)=$O(^PRC(441,D0,4,"B",W(1))) S PRCHFCP=$S($D(^PRC(420,PRC("SITE"),1,+$E(W(1),4,9),0)):$P(^(0),U,1),1:$E(W(1),4,9)) K ^TMP("PRCHRPT1",$J) D ITEM0 Q:ASK
29 K ASK,W,W1,DIC D:$D(ZTSK) KILL^%ZTLOAD K ZTSK
30 Q
31 ;
32ITEM0 I $D(^PRC(441,D0,4,W(1),1,"AC")) D
33 . S W(2)=""
34 . S W(3)=""
35 . S FLG=""
36 . S COUNT=""
37 . F S W(3)=$O(^PRC(441,D0,4,W(1),1,"AC",W(3))) Q:W(3)'>0 Q:FLG=1 D
38 . . S W(4)=""
39 . . F S W(4)=$O(^PRC(441,D0,4,W(1),1,"AC",W(3),W(4))) Q:W(4)'>0 D
40 . . . S ^TMP("PRCHRPT1",$J,(W(4)))=W(4)
41 . . . S COUNT=COUNT+1
42 . . . I COUNT=TXR S FLG=1 Q
43 . . . Q
44 . . Q
45 . Q
46 I '$D(^PRC(441,D0,4,W(1),1,"AC")) D Q
47 . D HDR
48 . I $D(PRCHFCP) W !!,"FCP: "_PRCHFCP_" has no history for this item."
49 . Q
50NONE I $O(^TMP("PRCHRPT1",$J,0))="" W !,"A history for this item does not yet exist." D Q
51 . I $G(ZTSK)'>0 W !,"Press RETURN to continue." R X:DTIME Q
52 I $G(LNCT)="" S LNCT=0
53 I LNCT=0 D HDR
54 I LNCT'=0,$E(IOST)="P" S LNCT=0 D HDR
55 I LNCT'=0,$E(IOST)'="P" D ASK Q:ASK S LNCT=0 D HDR
56 ;
57SKPTXS S NX=0 I $G(LNCT)="" S LNCT=0
58 F K=1:1:TXR Q:'$O(^TMP("PRCHRPT1",$J,NX)) S NX=$O(^TMP("PRCHRPT1",$J,NX)),W(6)=^TMP("PRCHRPT1",$J,NX) Q:W(6)="" S LNCT=LNCT+1,W(5)=0,W(5)=$O(^PRC(442,W(6),2,"AE",D0,W(5))) I W(5)'="" S W1=W1+1 D ITEM1 D CKLCT Q:ASK
59 I 'W1 K ^TMP("PRCHRPT1",$J) G NONE
60 Q
61 ;
62CKLCT I $E(IOST)'="P"&(LNCT=5) S LNCT=0 D ASK Q:ASK D HDR:$O(^TMP("PRCHRPT1",$J,NX))
63 I $E(IOST)="P"&(LNCT=50) S LNCT=0 D ASK Q:ASK D HDR:$O(^TMP("PRCHRPT1",$J,NX))
64 Q
65 ;
66ITEM1 W ! I $D(^PRC(442,W(6),1)),$P(^(1),U,15)'="" S Y=$P(^(1),U,15) D DD^%DT W Y
67 W ?15,$P(^PRC(442,W(6),0),U,1)
68 I $D(^PRC(442,W(6),2,W(5),2)) S W(7)=^(2) W ?26,$J($P(^(2),U,8),10)
69 I $D(^PRC(442,W(6),2,W(5),0)) S W(8)=^(0) W:+$P(W(8),U,3) ?38,$P($G(^PRCD(420.5,+$P(W(8),U,3),0)),U,1)
70 W:$D(W(8)) ?48,$J($P(W(8),U,9),9,2) W:$D(W(7)) ?59,$J($P(W(7),U,1),10,2) W:$D(W(8)) ?71,$J($P(W(8),U,2),8)
71 I $P($G(^PRC(442,W(6),1)),U,1)>0 S W(8)=$P(^(1),U,1),W(8)=$P($G(^PRC(440,W(8),0)),U,1) I W(8)'="" W !,"Vendor: ",W(8)
72 K W(7),W(8)
73 Q
74 ;
75ASK Q:$E(IOST)="P" W !!,"Press RETURN to continue, '^' to Quit" R X:DTIME I X["^" S ASK=1
76 Q
77 ;
78RNG ; ALLOW ENTRY OF BEGINNING AND ENDING RANGE
79 S FR="",TO="z" W !!!,"START WITH "_M_": FIRST//" R FR:DTIME S:$T=0 FR="^" I (FR["?")!(FR["^")!(FR="") Q
80 I FR'="@",$D(PRCHD),PRCHD="DATE" K %DT S X=FR D ^%DT S FR=Y W:Y=-1 $C(7),!,"INVALID DATE" G:Y=-1 RNG D DD^%DT W " ",Y
81 W !!,"GO TO "_M_": LAST//" R TO:DTIME S:$T=0 TO="^" Q:(TO["^")!(TO["?") S:TO="" TO="z" Q:TO="z"
82 I $D(PRCHD),PRCHD="DATE" S X=TO D ^%DT S TO=Y W:Y=-1 $C(7),!,"INVALID DATE" G:Y=-1 RNG D DD^%DT W " ",Y
83 I (+FR=FR)&(+TO=TO) I FR>TO W $C(7),!,"INVALID RANGE" G RNG
84 I FR'="@" I (+FR'=FR)!(+TO'=TO) I FR]TO W $C(7),!,"INVALID RANGE" G RNG
85 Q
86 ;
87PDT ; ROUTINE ALLOWING ENTRY OF A DATE FOR PRINTING, ETC. (DEFAULTS TO NOW)
88 W !!,"Enter date (and time, if not NOW) to "_M S %DT="AET",%DT("A")="DATE: NOW//" D ^%DT K %DT
89 S:X="" X="NOW",Y=$H S PRCHPDAT=Y Q:X="NOW"!(X["^") G:Y=-1 PDT
90 I +$P(Y,".",2)'>0 W $C(7),!,"You must enter the time as well as the date to print the report" G PDT
91 S PRCHPDAT=Y
92 Q
93 ;
94SDEV ; SELECT DEVICE FOR QUEUED PRINTING
95 W ! K %ZIS,IOP S %ZIS="Q",IOP="Q",%ZIS("B")="" D ^%ZIS
96 S IOP=ION_";"_IOST_";"_IOM_";"_IOSL I IO=IO(0) D ^%ZIS U IO D @ZTRTN D ^%ZISC
97 Q
98HDR ;
99 ;
100 I $G(LNCT)>0&($E(IOST)'="P") D ASK G:ASK Q
101 W @IOF,!!,"Item Number: ",D0,?25,"Description: ",W,!?8,"FCP: ",PRCHFCP,!!,?26,"Quantity",!,?26,"Previously",?38,"Unit of",?71,"Quantity"
102 W !,"Date Ordered",?15,"PO Number",?26,"Received",?38,"Purchase",?48,"Unit Cost",?59,"Total Cost",?71,"Ordered",! F I=1:1:80 W "_"
103 Q
104RDTXS ; Prompt for # back TX's to list for an FCP(default=10,max=9999)
105 W !
106RDTXS1 K DIR
107 S DIR(0)="F^1:4"
108 S DIR("A")="Enter # BACK TRANSACTIONS to list, 'S' to sort or '^' to EXIT"
109 S DIR("B")=10
110 S DIR("?")="Enter 1-9999 or 'S' to sort by PO Date, FCP, etc."
111 S DIR("??")="^D WARN^PRCHRPT1"
112 D ^DIR
113 S TXS=X
114 I $D(DIRUT) S ABORT=1 G Q
115 I TXS?.N&((TXS<1)!(TXS>9999)) D QUESTION G RDTXS1
116 I TXS?.N S TXR=TXS,^TMP("PRCHITMH",0)=TXR*1,TXR=^TMP("PRCHITMH",0),RTX="A" Q
117 I TXS'="s"&(TXS'="S") W ! D QUESTION G RDTXS1
118 S ITMNO=$P(ITMY,U,1) G EN^PRCHRPTX
119 Q
120 ;
121QUESTION ;
122 W !!,"Enter 1-9999 or 'S' to sort by PO Date, FCP, etc."
123 Q
124 ;
125WARN ;
126 W @IOF,!?10,"List Transaction History for Specified Item",!!
127 W !,"You may obtain either a listing of a specified number of back transactions",!,"for the item or all transactions (by FCP) within a specified date range."
128 W !!,"Please be aware that the latter involves complex sorting and may",!,"take awhile to complete. Therefore, it is suggested that it be queued to",!,"a printer to immediately free your workstation.",!
129 Q
Note: See TracBrowser for help on using the repository browser.