source: FOIAVistA/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHRPT.m@ 1607

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

initial load of FOIAVistA 6/30/08 version

File size: 4.8 KB
Line 
1PRCHRPT ;WIRMFO/RSD/REW,RHD-PRINT OPTIONS ;11/13/00 4:27pm
2 ;;5.1;IFCAP;**7**;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5ST S PRCF("X")="SP"
6 D ^PRCFSITE
7 Q
8 ;
9PO S PRCHP("S")="$P(^(0),U,2)<10!($P(^(0),U,2)=25)"
10 I $G(PRCHPC) S PRCHP("S")="$P(^(0),U,2)=25" ; <<< Patch 72
11 I $G(PRCHDELV) S PRCHP("S")="$P($G(^(23)),U,11)=""D"""
12 S PRCHP("A")="P.O./REQ.NO.: "
13 D EN3^PRCHPAT
14 I $D(PRCHPO),$D(^PRC(442,+PRCHPO,0)),$P(^(0),U,2)=8 S PRCHNRQ=1
15 Q
16 ;
17EN ;REPRINTS ON A&MM PRINTER
18 D ST
19 ;
20EN0 Q:'$D(PRC("PARAM"))
21 D PO
22 Q:'$D(PRCHPO)
23 I X<10 I '$G(PRCHPC) W " ?? Incorrect Status for this option",$C(7) G EN0
24 S (DEFPNT,%ZIS("B"))=$S($G(PRCHPC):"",1:$O(^PRC(411,+PRC("SITE"),2,"AC","S8",0)))
25 N IOP,PL
26R S %ZIS="Q"
27 S %ZIS("A")="Print on what Device: "
28 D ^%ZIS
29 I POP>0 D ^%ZISC,QK G EN0
30 S:'$D(PL) PL=DEFPNT
31 S PRCHIO=DEFPNT
32 S NOZTDTH=""
33 S PRCHQ=1
34 S D0=PRCHPO
35 S PRCHQ("DEST")=PL
36 S X=$S($P(PRC("PARAM"),U,11)=1:1,1:2)
37 S PRCHQ=$S(X=2:"^PRCHFPNT",1:"^PRCHPNT")
38 S PRCHREPR=1
39 I $G(ION)["MESSAGE" S:0 ZTIO=ION_";"_IOST D:0 ^%ZISC D MESS D K G EN0
40 I PRCHQ="^PRCHPNT",'$D(^PRC(411,+PRC("SITE"),2,"AC","S9")) D W G EN
41 I $G(IO("Q"))="" D G EN0
42 . U IO
43 . D @PRCHQ
44 . D ^%ZISC
45 . D K
46 . Q
47 S PRCHQ("DEST")=ION
48 D ^%ZISC,^PRCHQUE,K
49 G EN0
50 ;
51EN1 ;REPRINTS PO IN FISCAL
52 D ST
53 ;
54EN10 D PO Q:'$D(PRCHPO) I X<10 W " ?? Incorrect Status for this option",$C(7) G EN10
55 I X'=10,X'=28,X'=33 W !,$C(7)," Please note the STATUS of this Order--it has already been obligated.",! S %A="Are you sure you want to re-print it ",%=2 D ^PRCFYN Q:%=-1 G:%'=1 EN10
56 S D0=PRCHPO,PRCHQ="^PRCHFPNT",PRCHREPR=1,PRCHQ("DEST")="F" D ^PRCHQUE,K
57 G EN10
58 ;
59EN2 ;REPRINT AMENDMENT
60 D ST
61EN20 D PO Q:'$D(PRCHPO) S D0=PRCHPO I '$D(^PRC(442,D0,6,"B")) W !?2,$C(7),"No Amendments for this Order" G EN20
62 ;
63EN21 R !?5,"Amendment number: ",X:DTIME G EN20:X=""!(X["^"),EN2H:$E(X)="?"!('$D(^PRC(442,D0,6,"B",X)))
64 S D1=X,PRCHQ="^PRCHPAM",PRCHREPR=1 D ^PRCHQUE,K
65 G EN20
66 ;
67EN2H W !?5,"Enter an amendment number. Choose from: " S X=0 F I=0:1 S X=$O(^PRC(442,D0,6,"B",X)) Q:'X W:I "," W X
68 G EN21
69 ;
70EN3 ;DISPLAY P.O.
71 D ST
72EN30 D PO Q:'$D(PRCHPO)
73 I X<10 W $C(7)," >>> Status makes this record non-specifiable here."
74 S D0=PRCHPO D ^PRCHDP1,K
75 G EN30
76 ;
77EN4 ;PRINT PO FOR RECEIVING
78 D ST
79EN40 D PO Q:'$D(PRCHPO) I X<10!(X>51) W " ?? Incorrect Status for this option",$C(7) G EN40 ; was > 40, changed per DUB-0397-32163
80 S Y=0 I $D(^PRC(442,DA,11,0)) S DIC="^PRC(442,DA,11,",DIC(0)="NEAZ",DIC("A")="RECEIVING REPORT DATE: " D ^DIC
81 S PRCHFPT=$S(Y>0:+Y,1:0),D0=PRCHPO,PRCHQ="^PRCHFPNT",PRCHQ("DEST")="R" D ^PRCHQUE
82 D K G EN40
83 ;
84EN5 ;FCP BALANCE
85 D ST
86EN50 Q:'$D(PRC("SITE")) I '$D(^PRC(420,PRC("SITE"),1,0)) W !,"No Control Points exists for this station.",$C(7) K PRC Q
87 S DIC="^PRC(420,"_PRC("SITE")_",1,",DIC(0)="AEMNQZ",DIC("A")="Select CONTROL POINT: " D ^DIC K DIC Q:Y<0 S PRC("CP")=$P($P(Y(0),U,1)," ",1),C1=1
88 S %DT="AEP",%DT("B")="TODAY",%DT("A")="BALANCE AS OF DATE: " D ^%DT K %DT Q:Y<0
89 S PRC("QTR")=$P("2^2^2^3^3^3^4^4^4^1^1^1","^",$E(Y,4,5)),PRC("FY")=$E(100+$E(Y,2,3)+$E(Y,4),2,3) S (Z,PRCSZ)=PRC("SITE")_"-"_PRC("FY")_"-"_PRC("QTR")_"-"_PRC("CP")
90 D QUE^PRCSP1A K C1,DIC,PRC,Z
91 G EN50
92 ;
93EN6 ;PRINT SF18 QUOTATION FOR BID
94 D ST G EN60^PRCHRPT7
95 ;
96EN7 ;PRINT/DISPLAY 2237
97 S DIC="^PRCS(410,",DIC(0)="AEMQZ",DIC("A")="2237 REFERENCE NUMBER: ",DIC("S")="I $P(^(0),U,4)'=1,$P(^(0),U,2)=""O""!($P(^(0),U,2)=""CA"")"
98 D ^PRCSDIC K DIC Q:Y<0 S D0=+Y,PRC("SITE")=+Y(0) W ! D ^PRCHDR K D0 W !!
99 G EN7
100 ;
101EN8 ;DISPLAY ITEM INFORMATION
102 W ! S DIC="^PRC(441,",DIC(0)="AEMQ" D ^DIC K DIC Q:Y<0 S DA=+Y,DIQ(0)="C",DIC="^PRC(441," D EN^DIQ K DIC,DIQ,DA,D0
103 G EN8
104 ;
105QK N DEFPNT
106K K DEFPNT,ZTSK,ZTSAVE,ZTDTH,ZTRTN,PRCHREPR,PRCHNRQ,OK,PL,PRCHQ
107 K X,Y,I
108 Q
109 ;
110W W $C(7),!!,"You are set up to print the P.O.'s on preprinted forms, but you have not",!,"defined printer 'S9 SUPPLY 2139' on the Site Paramater File.",!
111 W "This printer MUST be defined to print the second and subsequent pages.",!,"of the Purchase Order."
112 Q
113 ;
114X W $C(7),!!,"Your printer selection is not defined in the site parameter file."
115 Q
116 ;
117MESS ;Put message into report
118 N XMDUZ,XMN,AA S XMDUZ=DUZ,XMN=0
119 D DES^XMA21 Q:$S($O(XMY(""))="":1,$E($G(X))["^":1,1:0)
120 W ! S AA=X D ENTS S XMSUB=X S X=AA
121 I X="" S ZTRTN="ZTSK^PRCHRPT",ZTSAVE("XMY(")="",ZTSAVE("D0")="",ZTSAVE("U")="",ZTSAVE("PRCHQ(""DEST"")")="",ZTSAVE("XMSUB")="",ZTDTH=$H
122 I S ZTSAVE("PRC(""SITE"")")="" D ^%ZTLOAD
123 ;
124CLN K XMY,XMN,XMDUZ,XMSUB
125 G K
126 ;
127ZTSK ;
128 I '$D(XMDUZ),$D(DUZ),DUZ S XMDUZ=DUZ
129 I 'XMDUZ S XMDUZ=.5
130 D ^PRCHFPNT W:'$D(ZTQUEUED) !
131 Q
132ENTS ;ASK SUBJECT
133S I $D(XMSUB) S Y=XMSUB
134 W !,"Subject: " G F:'$D(XMSUB) S I=XMSUB
135 I I["~U~" S I=$$DECODEUP^XMCU1(I)
136 I $L(I) W I,"//"
137F R X:DTIME S:'$T X="^" S:X="" X=$S($D(XMSUB):XMSUB,1:"^") S Y=X
138 Q:Y=U S (X,Y)=$$ENT^XMGAPI0(Y,1) G S:+X S (X,Y)=$P(X,U,2)
139 Q
Note: See TracBrowser for help on using the repository browser.