source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCH7PA1.m@ 1093

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

initial load of WorldVistAEHR
File size: 4.5 KB
RevLine 
[613]1PRCH7PA1 ;Hines IOFO/RVD - PROS IFCAP GUI ADD PO ;8/13/03 07:58
2 ;;5.1;IFCAP;**68**;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5 ;This routine will take the next Common Numbering Series and update
6 ;file 442.6 for the next number. It will also create an entry in
7 ;file 442 (PO) to be used in obligation.
8 ;Line label AD1 is to be used for MUMPS entry point.
9 ;Line label ADDPO is an entry point for Remote Procedure Call.
10 ;
11 ; DUZ - User
12 ; PRCSITE - Station Number IEN
13 ; RMPRSITE - IEN of 669.9
14 ; PRCHXXX - IEN of 440.5 Purchase Card
15 ; PRCHVEN - IEN of 440 Vendor
16 ; PRC4426 - Common Numbering Series
17 ; RESULTS(0) = IEN of 442 ^ PO NUMBER
18 Q
19AD1(DUZ,PRCSITE,RMPRSITE,PRCHXXX,PRCHVEN,PRC4425) G AD2
20 ;
21ADDPO(RESULTS,DUZ,PRCSITE,RMPRSITE,PRCHXXX,PRCHVEN,PRC4426) ;create the next PAT number.
22 ;
23AD2 ;
24 Q:'$D(PRCSITE)
25EN1 ;
26 I '$D(^PRC(411,PRCSITE,0)) S RESULTS(0)="^IFCAP Station Not Defined in file # 411." Q
27 I PRC4426="" S RESULTS(0)="Common Numbering Series was not passed see your Supervisor." Q
28 L +^PRC(442.6,PRC4426,0):1 I '$T S RESULTS(0)="^Unable to Access IFCAP file (#442.6), Try Later." Q
29 D GETS^DIQ(442.6,PRC4426,".01;3;2;1","","PRCN")
30 S PRCLO=$G(PRCN(442.6,PRC4426_",",1))
31 S PRCNEXT=$G(PRCN(442.6,PRC4426_",",3))
32 S PRCSTPO=$G(PRCN(442.6,PRC4426_",",.01))
33 S PRCPO=$P(PRCSTPO,"-",2)
34 S PRCUPBO=$G(PRCN(442.6,PRC4426_",",2))
35 I PRCNEXT="" S RESULTS(0)="^The Common Numbering Series is Null."
36 S PRCNEXT=PRCNEXT+1
37 I PRCNEXT>PRCUPBO S RESULTS(0)="^The Common Numbering Series Exceeds the limit, please use a different Common Numbering Series." Q
38 ;calculate PO to be 6 places.
39 D NUM
40 S PRCNEXT=+PRCNEXT
41 S DIE="^PRC(442.6,"
42 S DA=PRC4426
43 S DR="3////^S X=PRCNEXT"
44 D ^DIE
45 L -^PRC(442.6,PRC4426,0)
46 K DIE,DA,DR
47 ;
48 I $D(^PRC(442,"B",PRCROBL)) S RESULTS(0)="^P.O. "_PRCROBL_" already exist, please use a different PO number." Q
49 ;
50PO ;PO must be defined in PRCROBL.
51 ;Create a PO entry in 442.
52 S X=PRCROBL
53 K DIC("S") S PRCHNEW="",DIC="^PRC(442,",DLAYGO=442,DIC(0)="L" D ^DIC
54 I +(Y)'>0 S RESULTS(0)="^UNABLE to Create a Purchase Order, Please Try Later." Q
55 S (DA,PRCHPO,PRC442)=+Y,%DT="T",X="NOW" D ^%DT S $P(^PRC(442,PRCHPO,12),U,4,5)=DUZ_U_Y
56 S (X,Y)=1,PRCHX=X,DIE="^PRC(442,",DR=".5////1" D ^DIE K DIE,DR
57 S $P(^PRC(442,PRCHPO,1),U,10)=DUZ
58 S PRCA=PRCSITE_"^"_PRCHVEN
59 S RESULTS(0)=PRCHPO_"^"_PRCROBL
60 S PRCRI(420)=+PRCA,PRC("SITE")=$P(PRCA,"^"),PRCRI(440)=$P(PRCA,"^",2)
61 S X="" S:$D(PRC("SITE")) PRC("PARAM")=^PRC(411,PRC("SITE"),0)
62 S (PRCPROST,PRCHPC)=1
63 S (PRCHN("SVC"),PRCHN("CC"),PRCHN("SC"),PRCHN("INV"))="",PRCHN("SFC")=+$P(^PRC(442,DA,0),U,19),PRCHN("FOB")=$S($D(^(1)):$P(^(1),U,6),1:""),PRCHN(12)=$S($D(^PRC(442,DA,12)):^(12),1:"")
64 S PRCHPONO=$P(^PRC(442,DA,0),U,1),PRCHSTN=$P(PRCHPONO,"-") S PRCHIEN=DA
65 S PRCX=$O(^PRC(411,PRC("SITE"),1,0)) S:$G(PRCX)]"" PRCY=$P($G(^PRC(411,PRC("SITE"),1,PRCX,0)),U) K PRCX
66 S DA=PRCHPO
67 D DOCID
68 S PRC31=PRCSITE
69 S DA=PRCHPO
70 S DIE="^PRC(442,"
71 S PRC48="S"
72 S PRC54="N"
73 S PRC5="SIMPLIFIED"
74 S PRC1="T"
75 S PRCHP=^PRC(440.5,PRCHXXX,0),PRCHFCP=$P(PRCHP,U,2),PRCHCC=$P(PRCHP,U,3),PRCHBOC1=$P(PRCHP,U,4),PRCHDLOC=$P(PRCHP,U,7),PRCHCD=$P(PRCHP,U),PRCHCDNO=PRCHXXX,PRCHHLDR=$P(PRCHP,U,8)
76TST S DR="16////^S X=DUZ;56////^S X=DUZ;.02///^S X=25;48///^S X=PRC48;63///^S X=1;54///^S X=PRC54;31////^S X=PRC31;S SUB=X" D ^DIE
77 I $D(SUB) S PRCX=$O(^PRC(411,SUB,1,0)) S:$G(PRCX)]"" PRCY=$P($G(^PRC(411,SUB,1,PRCX,0)),U) K PRCX
78 S DR="46////^S X=PRCHXXX;61////^S X=PRCHHLDR" D ^DIE
79 S PRCHCDNO=$P($G(^PRC(442,DA,23)),U,8)
80 S DR="55///^S X=PRCHCD;.1///^S X=PRC1;53////^S X=PRCHVEN;5////^S X=PRCHVEN" D ^DIE
81 S TDATE=$$DATE^PRC0C($P($G(^PRC(442,DA,1)),"^",15),"I"),PRC("FY")=$E(TDATE,3,4)
82 S PRCBBFY=$$BBFY^PRCSUT(PRCSITE,PRC("FY"),PRCHFCP,1),PRC("BBFY")=PRCBBFY
83 S DR="1///^S X=PRCHFCP" D ^DIE
84 S PRCHN("SFC")=$P(^PRC(442,DA,0),U,19)
85 S DR="26///^S X=PRCBBFY;2///^S X=PRCHCC;5.4///^S X=PRC5"
86 D ^DIE
87 S PRCPROST=1.9
88 L -^PRC(442,PRC442)
89 K DIE,DA,DLAYGO,DR,PRCBBFY,PRCHCC,PRCHCD,PRCHCDNO,PRCHDLOC,PRCHFCP,PRCHHLDR,PRCHIEN,PRCHNEW,PRCHP,PRCHPONO,PRCHSTN,PRCHX,PRCLO,PRCN,PRCNEXT,PRCNEXT1
90 K PRCPO,PRCY,PRX,PRZ,RMPRCIEN,RMPRFCP,X,PRCSTPO,PRCUPBO,PRC1,PRC442,PRC4426,PRC5,PRC54,PRC48,PRC31,SUB,TDATE,PRCROBL
91 Q
92 ;
93NUM ;check next number and set the PO to 6 places.
94 ;
95 S PRCX="",$P(PRCX,"0",6)="",PRCNEXT1=PRCX_PRCNEXT
96 S PRCNEXT=$E(PRCNEXT1,$L(PRCNEXT)+$L(PRCPO),$L(PRCNEXT1))
97 S PRCROBL=PRCSTPO_PRCNEXT
98 Q
99 ;
100DOCID S PRZ=$P($P(^PRC(442,PRCHPO,0),U,1),"-",2) Q:$L(PRZ)'=6 F I=1:1:6 S PRX=$E(PRZ,I,I) Q:+PRX=PRX
101 I +PRX=PRX S $P(^PRC(442,PRCHPO,18),"^",3)=$S(I=1:$E(PRZ,2,6),1:$E(PRZ,1,I-1)_$E(PRZ,I+1,6))
102 Q
Note: See TracBrowser for help on using the repository browser.