source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHDEP4.m@ 1702

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

initial load of WorldVistAEHR
File size: 3.5 KB
RevLine 
[613]1PRCHDEP4 ;WISC/RWS-SUPPLEMENTAL ROUTINES CALLED FROM PRCHDEP3 ;4/20/92 9:34 AM
2V ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4EDIT G:$D(PRCHENT) E2 S %A=" Do you want to generate the codesheets",%B=" Answer NO if you do not wish to build the LOG codesheets at this time.",%=1 D ^PRCFYN I %=-1 K PRCHPO Q
5 G:%=1 E2 W !!," Do you want to remove this P.O. or Receiving Report from the list of",!,"pending codesheets?"
6 S %A="REMOVE FROM LIST",%B="If you answer YES, and later want to generate codesheets, you will have",%B(1)="to use the 'Create a Codesheet' option.",%=2 D ^PRCFYN D:%=1 R S DA=PRCHPO,DIC="^PRC(442," D UNLCK^PRCHDEP3 K PRCHPO Q
7E2 S PRCHPONO=$P(^PRC(442,PRCHPO,0),U,1)
8 S X=$G(^PRC(442,PRCHPO,17)),Y=$G(^(18))
9 W !!,"P.O.(PAT) No.: "_PRCHPONO,!,"Document Identifier: ",$P(Y,U,3) W:PRCHN("SC")=1 ?35,"Requisition Number: ",$P(Y,U,10) W !
10 W:PRCHN("SFC")'=2&(PRCHN("SC")'=0) "Department No.: ",$P(X,U,1),! W "Source Code: "_PRCHN("SC"),!
11 Q
12 ;
13SETUP ;S PRCHN("SC")="" I $D(^PRC(442,PRCHPO,1)) S PRCHN("SC")=$S($D(^PRCD(420.8,+$P(^(1),U,7),0)):$P(^(0),U,1),1:"") S:"013"[PRCHN("SC") PRCHNRQ=1
14 S PRCHN("SC")="" I $D(^PRC(442,PRCHPO,1)) S PRCHN("SC")=$P($G(^PRCD(420.8,+$P(^(1),U,7),0)),U,1) S:"013"[PRCHN("SC") PRCHNRQ=1
15 ;S PRCHN("MP")=$S($D(^PRCD(442.5,+$P(^PRC(442,PRCHPO,0),U,2),0)):$P(^(0),U,3),1:"")
16 S PRCHN("MP")=$P($G(^PRCD(442.5,+$P(^PRC(442,PRCHPO,0),U,2),0)),U,3)
17 ;S PRCHN("SFC")=$P(^PRC(442,PRCHPO,0),U,19),PRCHEMG=$S($D(^(1)):$P(^(1),U,17),1:"") Q
18 S PRCHN("SFC")=$P(^PRC(442,PRCHPO,0),U,19),PRCHEMG=$P($G(^(1)),U,17)
19 Q
20 ;
21OBL Q:'$P(^PRC(442,PRCHPO,0),U,12) I $D(^PRC(442,PRCHPO,18)),$P(^(18),U,12) W $C(7),!!!,"Control Point Obligated Balances have already been updated.",!! Q
22 W !! S %A=" Update Control Point Obligated Balance",%B=" Review the Order first to make sure it is correct. This step should be",%B(1)="done to make sure the Control Point Balance matches CALM."
23 S %=2 D ^PRCFYN I %'=1 K PRCHPO Q
24 D OBL^PRCHNRQ
25 Q
26 ;
27ASK W !!!,$C(7),"**** Do you want to print a report showing code sheets to be created? ****" S %A="PRINT REPORT",%B="Answer 'Y' to see what orders have not yet had code sheets generated",%=2
28 D YN^PRCFYN
29 Q
30 ;
31R ;REMOVE P.O. OR RECEIVING REPORT FROM PENDING LIST
32 I PRCHTYP="A" K ^PRC(442,"AE","N",PRCHPO) Q
33 I PRCHTYP="R" K ^PRC(442,"AF","N",PRCHPO,PRCHRPT)
34 Q
35 ;
36EN001 S PRCFA("DICS")="I Y=401",PRCFA("TTF")=401
37 D GT^PRCHEC I '% D UNLCK^PRCHDEP3 G EN01^PRCHDEP3
38 D B401
39 D SC^PRCHCS0
40 D ^PRCHCS
41 G EN01^PRCHDEP3
42 ;
43B401 ;DEPOT DUE-IN TRANSACTION 401
44 S PRCHTP(1,1)="S X=PRCHPO;344",PRCHTP(1,2)=".1;385",PRCHTP(1,3)="D DOCID^PRCHCS2;344",PRCHTP(1,4)="7;406"
45 S PRCHTP(1,5)="D:'$D(PRCFA(1)) DEFAULT^PRCHDEP4 S X=PRCFA(1);408"
46 S PRCHTP(1,6)="S X=PRCFA(2);384"
47 S PRCHTP(1,7)="S Y=$E(PRCFA(3),1,5),PRCFLN=5 D LZF^PRCFU S X=Y K Y;386"
48 S PRCHTP(1,8)="S X=PRCFA(4);387"
49 S PRCHTP(1,9)="S X=401;3"
50 S PRCHTP(1,10)="S X=1;396"
51 S PRCHTP(1,11)="S X="" "";389"
52 S PRCHTP(1,12)="S X=""00000"";390"
53 S PRCHTP(1,13)="S X=""00000"";391"
54 S PRCHTP(1,14)="S X=""00000"";392"
55 S PRCHTP(2,1)=".01;300",PRCHTP(2,2)="2;405",PRCHTP(2,3)="S X=$P(PRCHDIC1(2,0),U,13),X=$P(X,""-"",2)_$P(X,""-"",3)_$P(X,""-"",4);308",PRCHTP(2,4)="3;303",PRCHTP(2,5)="5;388"
56 Q
57 ;
58DEFAULT S DR="[PRCH-DEP LOG 401]",DIE=423 D ^DIE
59 Q:'$D(^PRCF(423,DA,0)) S PRCFA(1)=$P(^(304),U,16)
60 S PRCFA(2)=$P(^PRCF(423,DA,302),U,9)
61 S PRCFA(3)=$P(^PRCF(423,DA,303),U,1)
62 S PRCFA(4)=$P(^PRCF(423,DA,303),U,2)
63 Q
64 ;
65B431 ;DEPOT 431 AND 434 TRANSACTIONS
66 S PRCHTP(1,1)="S X=PRCHPO;5.1"
67 S PRCHTP(2,1)=".01;300"
68 Q
Note: See TracBrowser for help on using the repository browser.