source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHDEP3.m@ 1046

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

initial load of WorldVistAEHR
File size: 4.1 KB
Line 
1PRCHDEP3 ;WISC/RWS-DEPOT EDIT FOR SUPPLY SYSTEM--LOG CODE SHEETS ;3/9/92 11:35 AM
2V ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4EN1 ;CREATE ACQUISITIONS LOG CODE SHEETS, UPDATE OBLIGATED BALANCE (IF SUPPLY FUND P.O.)
5 D ST G:'$D(PRC("SITE")) Q D ASK^PRCHDEP4 G:%=-1 Q I %=1 S PRCHQ="EN1" D EN^PRCHRCS
6EN01 Q:'$D(PRC("SITE")) G:$D(PRCHENT) Q2 S PRCHP("S")="$D(^PRC(442,""AE"",""N"",+Y))" D PO G:'$D(PRCHPO) Q
7 I $D(^PRC(442,PRCHPO,1)),"013"[$P(^(1),U,7) S PRCHNRQ=1
8 S %=1,%B="",%A=" Review Order " D ^PRCFYN G:%=-1 Q I %=1 S D0=PRCHPO D ^PRCHDP1
9EN11 ;ENTRY POINT IF CALLED WHEN REQUISITION SIGNED.
10 D SETUP^PRCHDEP4,CAL2^PRCHEC2
11 ;IF SUPPLY FUND P.O. & NOT IMPREST FUNDS, UPDATE OBLIGATED BALANCE. IF PAYMENT IN ADVANCE, SET STATUS TO 'TRANSACTION COMPLETE'
12 I PRCHN("SFC")=2,PRCHN("MP")'=12,'$D(PRCHNRQ) D OBL^PRCHDEP4 G:'$D(PRCHPO) Q I $P(^PRC(442,PRCHPO,0),U,2)=3 S X=40,DA=PRCHPO D ENS^PRCHSTAT
13 I $D(^PRC(442,PRCHPO,18)),$P(^(18),U,6)]"" D ERR G EN01
14 D LCK1 G:'$D(DA) EN01
15 S PRCHTYP="A" D EDIT^PRCHDEP4 G:'$D(PRCHPO) EN01 S PRCHKEY=PRCHPONO W !!!
16 G EN001^PRCHDEP4
17 ;
18EN2 ;CREATE LOG RECEIPT CODE SHEETS
19 D ST G:'$D(PRC("SITE")) Q D ASK^PRCHDEP4 G:%=-1 Q I %=1 S PRCHQ="EN2",PRCHSAVQ=PRCHQ,PRCHQ=PRCHQ_"^PRCHRCS",PRCHQ("DEST")="S" D ^PRCHQUE
20EN20 Q:'$D(PRC("SITE")) S PRCHP("S")="$D(^PRC(442,""AF"",""N"",+Y))"
21 D PO G:'$D(PRCHPO) Q I X<25!(X>44) W $C(7)," ??" G EN20
22 D LCK1 G:'$D(DA) EN20
23 I '$O(^PRC(442,PRCHPO,11,0)) W !?3,"P.O. has no Receiving Reports !",$C(7) S DIC="^PRC(442," D UNLCK^PRCHDEP3 G EN20
24 S DIC="^PRC(442,PRCHPO,11,",DIC(0)="QEANZ" D ^DIC K DIC G:Y<0 EN20 S (PRCHRPT,PRCHDPT)=+Y,(PRCHRD,PRCHDRD)=$P(Y(0),U,1),PRCHCMI=$S($P(Y(0),U,9)="":"P",1:"")
25 I $D(^PRC(442,PRCHPO,11,PRCHRPT,1)),$P(^(1),U,4)]"" D ERR S DIC="^PRC(442," D UNLCK^PRCHDEP3 G EN20
26 S PRCHTYP="R",PRCHPONO=$P(^PRC(442,PRCHPO,0),U,1),PRCHKEY=PRCHPONO_"."_PRCHRPT
27 ;S PRCHDIET=$S($D(^PRC(442,PRCHPO,11,PRCHRPT,1)):$P(^(1),U,2),1:""),PRCHDTP=1
28 S PRCHDIET=$P($G(^PRC(442,PRCHPO,11,PRCHRPT,1)),U,2),PRCHDTP=1
29 W !!! S %A="DISPLAY RECEIVING REPORT ONLINE ",%=2 D ^PRCFYN G:%=-1 EN20 D:%=1 ^PRCHDP3 W !!!
30 S PRCFA("DICS")="I Y=431!(Y=434)",PRCFA("TT")=$S($D(PRCHNRQ):431,1:434),PRCFA("EDIT")="[PRCHL"_PRCFA("TT")_"]"
31 S Y=PRCFA("TT") D B431^PRCHDEP4
32 D 1^PRCHDEP2
33 G EN20
34 ;
35Q K PRC,PRCHPO,PRCHN,PRCHNM,PRCHNRQ
36Q2 K PRCF,PRCFA,PRCFASYS,PRCHCS,PRCHTP,PRCHAMT,PRCHCNT,PRCHENT,PRCHRPT,PRCHRD,PRCHCMI,PRCHEMG,PRCHEST,PRCHFA,PRCHLOG,PRCHDIET,PRCHDPT,PRCHDRD,PRCHDT,PRCHDTP,PRCHKEY,PRCHPONO,PRCHT,PRCHTP,PRCHTYP,X,Y,Z
37 Q
38 ;
39 ;CREATE REPORT OF CODE SHEETS TO BE GENERATED, FOR PPM
40LCK1 S DIC="^PRC(442,"
41LCK L @("+"_DIC_DA_"):5") E W !,$C(7),"ANOTHER USER IS EDITING THIS ENTRY!" K DA
42 Q
43 ;
44ST S PRCF("X")="S",PRCHLOG="",PRCFA("SYS")="LOG" D ^PRCFSITE Q:$P(PRC("PARAM"),U,7)=2
45 W !,"This is not a DEPOT facility",!
46 G Q
47 ;
48PO S PRCHP("S")="""13478""[$P(^(0),U,2),"_PRCHP("S"),PRCHP("A")="P.O./REQ.NO.: " D EN3^PRCHPAT Q:'$D(PRCHPO) Q:'PRCHPO ;the ^(0),U,2 on line PO is a string set to a namespaced variable like DIC("S") which is used in EN3^PRCHPAT
49 S PRCHSAVX=X S:'$D(^PRC(442,PRCHPO,18)) ^(18)="" I $P(^(18),U,3)="" D DOCID^PRCHUTL K Z
50 S:'$D(^PRC(442,PRCHPO,17)) ^(17)="" I $P(^(17),U,1)="" D LOGDPT^PRCHEC2
51 S X=PRCHSAVX K PRCHSAVX
52 Q
53 ;
54GT S PRCHLOG=1,PRCFASYS="LOG" D TT^PRCFAC Q:'% S PRCFA("TTF")=PRCFA("TT")
55 K PRCHTP S PRCHTP(1)="442,"_PRCHPO_",^PRC(442,",PRCHTP(2)="442.01,PRCHLI,^PRC(442,"_PRCHPO_",2,"
56 Q
57 ;
58 ;K PRCHTP S:0 PRCHTP(1)="423,"_PRCFA("CSDA")_",^PRCF(423," Q
59ERR W !?3,"LOG code sheets already created and signed. Use Edit A Code Sheet option.",$C(7)
60 Q
61 ;
62UNLCK ;RELEASE LOCK FOR "^PRC(442,DA"
63 L @("-"_DIC_DA_")")
64 Q
65 ;
66UNLCK1 ;RELEASE LOCK FOR "^PRCF(423,DA"
67 ;Screen out types "A" and "R" for this code to work. The variables
68 ;PRCHCNT and PRCHLCNT are defined during DEPOT Due-in and Receiving
69 ;Code Sheets Generation.
70 ;
71 I $D(PRCFA("CSDA")) S DA=PRCFA("CSDA")
72 I PRCHTYP="A",PRCHCNT>0 F D Q:PRCHCNT=0
73 . L -^PRCF(423,DA),-^PRCF(423,0)
74 . S DA=$G(DA)-1,PRCHCNT=$G(PRCHCNT)-1
75 ;
76 I PRCHTYP="R",PRCHLCNT>0 F D Q:PRCHLCNT=0
77 . L -^PRCF(423,DA),-^PRCF(423,0)
78 . S DA=$G(DA)-1,PRCHLCNT=$G(PRCHLCNT)-1
79 Q
Note: See TracBrowser for help on using the repository browser.