source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHREC4.m@ 623

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

initial load of WorldVistAEHR

File size: 3.9 KB
Line 
1PRCHREC4 ;ID/RSD,SF/TKW-CONTINUATION--PROCESS RECEIVING ;[7/6/98 10:03am] [7/6/98 10:15am]
2V ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5PRT ; IF METHOD OF PROCESSING=IMPREST FUNDS, UPDATE CONTROL POINT
6 ; OBLIGATED BALANCE
7 ;I $D(^PRCD(442.5,+$P(^PRC(442,DA,0),U,2),0)),$P(^(0),U,3)=12 D OBL^PRCHNRQ
8 ;
9PRT1 ; PRINT RECEIVING REPORT IN WAREHOUSE AND IN FISCAL, EXCEPT FOR
10 ; IMPREST FUNDS, WHICH PRINT WHERE REQUESTED BY USER, OR PROOF
11 ; OF DELIVERY FOR GUARANTEED DELIVERY, WHICH PRINTS ONLY IN FISCAL.
12 ;
13 G:$D(PRCHPOO) PRTF1
14 G:$G(MOPCHK)=25 PRT2
15 I '$P($G(^PRC(442,PRCHPO,24)),U),$D(PRCHIMP) K PRCHQ S PRCHQ("DEST2")="IFR",PRCHQ("DEST")="R",D0=PRCHPO,PRCHQ="^PRCHFPNT",PRCHFPT=PRCHRPT D ^PRCHQUE G PRTF
16PRT2 ;
17 K PRCHQ
18 I $P(PRC("PARAM"),U,12)="W" S PRCHQ("DEST")="R",D0=PRCHPO,PRCHQ="^PRCHFPNT",PRCHFPT=PRCHRPT D ^PRCHQUE
19 S DIR("A")="Do you want to print an additional copy"
20 S DIR("B")="NO"
21 S DIR(0)="Y"
22 D ^DIR
23 K DIR
24 I Y=1 D
25 . S D0=PRCHPO
26 . S PRCHFPT=PRCHRPT
27 . S PRCHQ("DEST")="R"
28 . S %ZIS="Q"
29 . D ^%ZIS
30 . G:POP FINI
31 . ;
32 . ; IF USER WANTS TO QUEUE THE SECOND PRINT -- DO IT.
33 . ;
34 . I $D(IO("Q")) D Q
35 . . S ZTRTN="^PRCHFPNT"
36 . . S ZTSAVE("PRCHFPT")=""
37 . . S ZTSAVE("PRCHQ(""DEST"")")=""
38 . . S ZTSAVE("D0")=""
39 . . D ^%ZTLOAD
40 . . D HOME^%ZIS
41 . . K IO("Q")
42 . . Q
43 . ;
44 . ; USER WANTED TO PRINT THE SECOND COPY LOCALLY.
45 . ;
46 . U IO
47 . D ^PRCHFPNT
48 . D ^%ZISC
49FINI . S:$D(ZTQUEUED) ZTREQ="@"
50 . Q
51 ;
52 Q:$G(MOPCHK)=25
53 ;
54PRTF Q:$P(PRC("PARAM"),U,8)'="Y"
55 I '$P($G(^PRC(442,PRCHPO,24)),U) D W Q:%'=1
56 ;I $P(^PRC(442,PRCHPO,0),U,19)=2,$P(^(0),U,2)'=25 D W Q:%'=1
57 ;
58PRTF1 I $D(PRCHPOO) S %A="Print a Copy of Proof of Order (Receiving Report) ",%B="Enter 'Y' (YES), to print Proof of Order on Fiscal Receiving Report Printer",%=1 D ^PRCFYN Q:%'=1
59 S PRCHQ("DEST")="R",PRCHQ("DEST2")="FR",D0=PRCHPO,PRCHQ="^PRCHFPNT",PRCHFPT=PRCHRPT
60 ;I $P($G(^PRC(442,PRCHPO,24)),U) I $P(^PRC(442,PRCHPO,0),U,19)'=2 S PRCHQ("DEST2")=""
61 D ^PRCHQUE
62 Q
63 ;
64W W !!,"Do you want to also print Receiving Report in FISCAL " S %=1 D YN^DICN Q:%'=0
65 W !!,"If you wish to allow Fiscal to process this receiving report immediately",!,"without waiting for acceptance by the service, answer 'Y' (yes) to this",!,"question."
66 G W
67WW W !!,"Do you want to print Receiving Report " S %=2 D YN^DICN Q:%'=0
68 W !!,"Please enter Yes or No."
69 G WW
70 ;
71ENTD ;PROMPT FOR ENTRY OF SCHEDULED DELIVERY DATE.
72 S PRCHDLVD="" I $D(PRCHRPT),$D(^PRC(442,PRCHPO,11,+PRCHRPT,1)) S PRCHDLVD=$P(^(1),U,8)
73 S PRCHPONO=$P(^PRC(442,PRCHPO,0),U,1) I '$O(^PRC(442.8,"B",PRCHPONO,0)) G EX
74 ;
75E2 W !! D D2 S PRCH="" I PRCHDLVD S Y=PRCHDLVD D DD^%DT S PRCH=Y
76 W !!,"Enter Scheduled Delivery Date: "_PRCH_"// " R X:DTIME S:'$T!(X["^") (X,PRCHDLVD)="^" S:X="" X=PRCH Q:X=""!(X="^") I X["?" D W2 G E2
77 S Y=X D ^%DT I '$O(^PRC(442.8,"AF",PRCHPONO,Y,0)) D W2 G E2
78 S PRCHDLVD=Y D DD^%DT W " "_Y S %A="RIGHT DATE ",%=1 D ^PRCFYN I %'=1 G E2
79 W !!,"Please wait: " K ^TMP("PRCHREC4",$J) F I=0:0 S I=$O(^PRC(442.8,"AF",PRCHPONO,PRCHDLVD,I)) Q:'I I $D(^PRC(442.8,I,0)) S X=^(0) I $P(X,U,2) S ^TMP("PRCHREC4",$J,$P(X,U,2),I)=$P(X,U,4)_U_$P(X,U,5) W "."
80 W !!
81 G EX
82 ;
83UPDD ;UPDATE SCHEDULED DELIVERY DATE FIELD
84 K DIE,DA S DIE="^PRC(442,"_PRCHPO_",11,",DA(1)=PRCHPO,DA=PRCHRPT,DR=".05///"_PRCHDLVD D ^DIE K DIE,DA
85 Q
86 ;
87DSPD ;DISPLAY MULTIPLE DELIVERY DATES
88 Q:'$D(^PRC(442,DA(1),0)) Q:$P(^(0),U,1)="" S PRCHPONO=$P(^(0),U,1) I '$O(^PRC(442.8,"B",PRCHPONO,0)) G EX
89 ;
90D2 W "Scheduled Delivery Dates:",! F I=0:0 S I=$O(^PRC(442.8,"AF",PRCHPONO,I)) Q:'I S Y=I D DD^%DT W " ",Y,!
91 Q
92 ;
93EX K PRCHPONO,I,X,Y
94 Q
95 ;
96W2 W $C(7),!!,"Select from one of the listed Scheduled Delivery Dates!",!!
97 Q
98 ;
99KILL ;CALLED FROM PRCHREC
100 S:$D(PRCHPOO) PRCFA("PARTIAL")=PRCHRPT
101 L K DIE,DIC,PRCHES,PRCHFPT,PRCHIMP,PRCHLC,PRCHNM,PRCHNRQ,PRCHR,PRCHRAM,PRCHRAMN,PRCHRD,PRCHRDA,PRCHRDY,PRCHRES,PRCHRFIN,PRCHRIT,PRCHROV,PRCHRPT,PRCHRQ,PRCHRQ1
102 K PRCHRQ2,PRCHRQ3,PRCHRS,PRCHRT0,PRCHRT,PRCHRT2,PRCHRTP,PRCHX,PRCHDLVD,X1,^TMP("PRCHREC4",$J),ROUTINE
103 Q
Note: See TracBrowser for help on using the repository browser.