source: FOIAVistA/tag/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCPAGSS.m@ 897

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

initial load of FOIAVistA 6/30/08 version

File size: 3.0 KB
Line 
1PRCPAGSS ;WISC/RFJ-scheduled autogen secondary order build ;01 Dec 92
2V ;;5.1;IFCAP;**1**;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 Q
5 ;
6 ; entry point for supply station secondaries
7SSS N PRCPSCHE
8 S PRCPSCHE=1
9 D BUILD
10 Q
11 ;
12 ; entry point for non-supply station secondaries
13NSS N PRCPSCHE
14 S PRCPSCHE=2
15 D BUILD
16 Q
17 ;
18BUILD L +^TMP("PRCPSCHE",PRCPSCHE):0 I $T=0 QUIT ; process already running
19 N PRCP,PRCPDP,PRCPFONE,PRCPFNON,PRCPIP,PRCPSS,PRCPXMY
20 N ITEM,XMB,XMDUZ,XMTEXT,XMY
21 K ^TMP($J,"PRCPAGSS")
22 S PRCPIP=0
23 I +$O(^PRCP(445,0))'>0 G QUIT
24 F S PRCPIP=$O(^PRCP(445,PRCPIP)) G BACKORD:+PRCPIP'>0 D
25 . I '$D(^PRCP(445,PRCPIP,0)) QUIT
26 . I $P($G(^PRCP(445,PRCPIP,0)),"^",3)'="S" QUIT
27 . I $P($G(^PRCP(445,PRCPIP,0)),"^",1)["***INACTIVE_" QUIT
28 . S PRCPSS=$P($G(^PRCP(445,PRCPIP,5)),"^",1)
29 . I PRCPSS]"",PRCPSCHE'=1 QUIT
30 . I PRCPSS']"",PRCPSCHE'=2 QUIT
31 . S PRCPDP=$$FROMCHEK^PRCPUDPT(PRCPIP,0)
32 . I $G(PRCPFNON)!'$G(PRCPFONE) QUIT ; secondary must have only 1 supplier
33 . S PRCP("I")=PRCPIP
34 . K ^TMP($J,"PRCPAG")
35 . S ^TMP($J,"PRCPAG","V",PRCPDP)=$$INVNAME^PRCPUX1(PRCPDP)
36 . D START^PRCPAGS1
37 . I $P(PRCPSCHE,"^",2)']"" QUIT ; successfully processed
38 . I $P(PRCPSCHE,"^",2)'=4 D BLDLIST ; No order numbers left or FileMan can't generate record or nothing to be ordered
39 . I $P(PRCPSCHE,"^",2)=4 S ^TMP($J,"PRCPAGSS",PRCPIP)="" ; IP in use
40 . S PRCPSCHE=+PRCPSCHE ; remove error codes if set
41 . QUIT
42 ;
43 ; process any IP's that were in use, if possible
44BACKORD S PRCPIP=0
45 I $O(^TMP($J,"PRCPAGSS",0))']"" G QUIT
46 F S PRCPIP=$O(^TMP($J,"PRCPAGSS",PRCPIP)) G QUIT:+PRCPIP'>0 D
47 . I '$D(^PRCP(445,PRCPIP,0)) QUIT
48 . S PRCPSS=$P($G(^PRCP(445,PRCPIP,5)),"^",1)
49 . I PRCPSS]"",PRCPSCHE'=1 QUIT
50 . I PRCPSS']"",PRCPSCHE'=2 QUIT
51 . S PRCPDP=$$FROMCHEK^PRCPUDPT(PRCPIP,0)
52 . I $G(PRCPFNON)!'$G(PRCPFONE) QUIT ; secondary must have only 1 supplier
53 . S PRCP("I")=PRCPIP
54 . K ^TMP($J,"PRCPAG")
55 . S ^TMP($J,"PRCPAG","V",PRCPDP)=$$INVNAME^PRCPUX1(PRCPDP)
56 . D START^PRCPAGS1
57 . I $P(PRCPSCHE,"^",2)']"" QUIT ; successfully processed
58 . D BLDLIST
59 . S PRCPSCHE=+PRCPSCHE ; remove error codes if set
60 . QUIT
61 ;
62BLDLIST D GETUSER^PRCPXTRM(PRCPIP) Q:'$O(PRCPXMY("")) ; inventory point users
63 S ITEM=0
64 ; restrict to managers
65 F S ITEM=$O(PRCPXMY(ITEM)) Q:ITEM'>0 I PRCPXMY(ITEM)=1 S XMY(ITEM)=""
66 K ^TMP($J,"PRCPAGSSM")
67 I $P(PRCPSCHE,"^",2)=1 S ^TMP($J,"PRCPAGSSM",1,1,0)="There are no available order numbers. Please delete or post orders."
68 I $P(PRCPSCHE,"^",2)=2 S ^TMP($J,"PRCPAGSSM",1,1,0)="The system was unable to add a new order."
69 I $P(PRCPSCHE,"^",2)=3 S ^TMP($J,"PRCPAGSSM",1,1,0)="No items needed to be ordered."
70 I $P(PRCPSCHE,"^",2)=4 S ^TMP($J,"PRCPAGSSM",1,1,0)="The inventory point was in use."
71 S ^TMP($J,"PRCPAGSSM",1,0)=1
72SEND S XMTEXT="^TMP($J,""PRCPAGSSM"",1,"
73 S XMB="PRCP_ORDER_NOT_GENERATED"
74 S XMB(1)=$$INVNAME^PRCPUX1(PRCPIP)
75 S XMDUZ="SCHEDULED ORDER BUILDER"
76 D EN^XMB
77 Q
78 ;
79QUIT L -^TMP("PRCPSCHE",PRCPSCHE)
80 K ^TMP($J,"PRCPAG"),^TMP($J,"PRCPAGSSM")
81 QUIT
Note: See TracBrowser for help on using the repository browser.