| [613] | 1 | PRCPAGSS ;WISC/RFJ-scheduled autogen secondary order build ;01 Dec 92
|
|---|
| 2 | V ;;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
|
|---|
| 7 | SSS N PRCPSCHE
|
|---|
| 8 | S PRCPSCHE=1
|
|---|
| 9 | D BUILD
|
|---|
| 10 | Q
|
|---|
| 11 | ;
|
|---|
| 12 | ; entry point for non-supply station secondaries
|
|---|
| 13 | NSS N PRCPSCHE
|
|---|
| 14 | S PRCPSCHE=2
|
|---|
| 15 | D BUILD
|
|---|
| 16 | Q
|
|---|
| 17 | ;
|
|---|
| 18 | BUILD 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
|
|---|
| 44 | BACKORD 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 | ;
|
|---|
| 62 | BLDLIST 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
|
|---|
| 72 | SEND 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 | ;
|
|---|
| 79 | QUIT L -^TMP("PRCPSCHE",PRCPSCHE)
|
|---|
| 80 | K ^TMP($J,"PRCPAG"),^TMP($J,"PRCPAGSSM")
|
|---|
| 81 | QUIT
|
|---|
