PRCPAGSS ;WISC/RFJ-scheduled autogen secondary order build ;01 Dec 92
V ;;5.1;IFCAP;**1**;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
Q
;
; entry point for supply station secondaries
SSS N PRCPSCHE
S PRCPSCHE=1
D BUILD
Q
;
; entry point for non-supply station secondaries
NSS N PRCPSCHE
S PRCPSCHE=2
D BUILD
Q
;
BUILD L +^TMP("PRCPSCHE",PRCPSCHE):0 I $T=0 QUIT ; process already running
N PRCP,PRCPDP,PRCPFONE,PRCPFNON,PRCPIP,PRCPSS,PRCPXMY
N ITEM,XMB,XMDUZ,XMTEXT,XMY
K ^TMP($J,"PRCPAGSS")
S PRCPIP=0
I +$O(^PRCP(445,0))'>0 G QUIT
F S PRCPIP=$O(^PRCP(445,PRCPIP)) G BACKORD:+PRCPIP'>0 D
. I '$D(^PRCP(445,PRCPIP,0)) QUIT
. I $P($G(^PRCP(445,PRCPIP,0)),"^",3)'="S" QUIT
. I $P($G(^PRCP(445,PRCPIP,0)),"^",1)["***INACTIVE_" QUIT
. S PRCPSS=$P($G(^PRCP(445,PRCPIP,5)),"^",1)
. I PRCPSS]"",PRCPSCHE'=1 QUIT
. I PRCPSS']"",PRCPSCHE'=2 QUIT
. S PRCPDP=$$FROMCHEK^PRCPUDPT(PRCPIP,0)
. I $G(PRCPFNON)!'$G(PRCPFONE) QUIT ; secondary must have only 1 supplier
. S PRCP("I")=PRCPIP
. K ^TMP($J,"PRCPAG")
. S ^TMP($J,"PRCPAG","V",PRCPDP)=$$INVNAME^PRCPUX1(PRCPDP)
. D START^PRCPAGS1
. I $P(PRCPSCHE,"^",2)']"" QUIT ; successfully processed
. I $P(PRCPSCHE,"^",2)'=4 D BLDLIST ; No order numbers left or FileMan can't generate record or nothing to be ordered
. I $P(PRCPSCHE,"^",2)=4 S ^TMP($J,"PRCPAGSS",PRCPIP)="" ; IP in use
. S PRCPSCHE=+PRCPSCHE ; remove error codes if set
. QUIT
;
; process any IP's that were in use, if possible
BACKORD S PRCPIP=0
I $O(^TMP($J,"PRCPAGSS",0))']"" G QUIT
F S PRCPIP=$O(^TMP($J,"PRCPAGSS",PRCPIP)) G QUIT:+PRCPIP'>0 D
. I '$D(^PRCP(445,PRCPIP,0)) QUIT
. S PRCPSS=$P($G(^PRCP(445,PRCPIP,5)),"^",1)
. I PRCPSS]"",PRCPSCHE'=1 QUIT
. I PRCPSS']"",PRCPSCHE'=2 QUIT
. S PRCPDP=$$FROMCHEK^PRCPUDPT(PRCPIP,0)
. I $G(PRCPFNON)!'$G(PRCPFONE) QUIT ; secondary must have only 1 supplier
. S PRCP("I")=PRCPIP
. K ^TMP($J,"PRCPAG")
. S ^TMP($J,"PRCPAG","V",PRCPDP)=$$INVNAME^PRCPUX1(PRCPDP)
. D START^PRCPAGS1
. I $P(PRCPSCHE,"^",2)']"" QUIT ; successfully processed
. D BLDLIST
. S PRCPSCHE=+PRCPSCHE ; remove error codes if set
. QUIT
;
BLDLIST D GETUSER^PRCPXTRM(PRCPIP) Q:'$O(PRCPXMY("")) ; inventory point users
S ITEM=0
; restrict to managers
F S ITEM=$O(PRCPXMY(ITEM)) Q:ITEM'>0 I PRCPXMY(ITEM)=1 S XMY(ITEM)=""
K ^TMP($J,"PRCPAGSSM")
I $P(PRCPSCHE,"^",2)=1 S ^TMP($J,"PRCPAGSSM",1,1,0)="There are no available order numbers. Please delete or post orders."
I $P(PRCPSCHE,"^",2)=2 S ^TMP($J,"PRCPAGSSM",1,1,0)="The system was unable to add a new order."
I $P(PRCPSCHE,"^",2)=3 S ^TMP($J,"PRCPAGSSM",1,1,0)="No items needed to be ordered."
I $P(PRCPSCHE,"^",2)=4 S ^TMP($J,"PRCPAGSSM",1,1,0)="The inventory point was in use."
S ^TMP($J,"PRCPAGSSM",1,0)=1
SEND S XMTEXT="^TMP($J,""PRCPAGSSM"",1,"
S XMB="PRCP_ORDER_NOT_GENERATED"
S XMB(1)=$$INVNAME^PRCPUX1(PRCPIP)
S XMDUZ="SCHEDULED ORDER BUILDER"
D EN^XMB
Q
;
QUIT L -^TMP("PRCPSCHE",PRCPSCHE)
K ^TMP($J,"PRCPAG"),^TMP($J,"PRCPAGSSM")
QUIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPAGSS 3118 printed Oct 16, 2024@18:13:28 Page 2
PRCPAGSS ;WISC/RFJ-scheduled autogen secondary order build ;01 Dec 92
V ;;5.1;IFCAP;**1**;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 QUIT
+3 ;
+4 ; entry point for supply station secondaries
SSS NEW PRCPSCHE
+1 SET PRCPSCHE=1
+2 DO BUILD
+3 QUIT
+4 ;
+5 ; entry point for non-supply station secondaries
NSS NEW PRCPSCHE
+1 SET PRCPSCHE=2
+2 DO BUILD
+3 QUIT
+4 ;
BUILD ; process already running
LOCK +^TMP("PRCPSCHE",PRCPSCHE):0
IF $TEST=0
QUIT
+1 NEW PRCP,PRCPDP,PRCPFONE,PRCPFNON,PRCPIP,PRCPSS,PRCPXMY
+2 NEW ITEM,XMB,XMDUZ,XMTEXT,XMY
+3 KILL ^TMP($JOB,"PRCPAGSS")
+4 SET PRCPIP=0
+5 IF +$ORDER(^PRCP(445,0))'>0
GOTO QUIT
+6 FOR
SET PRCPIP=$ORDER(^PRCP(445,PRCPIP))
if +PRCPIP'>0
GOTO BACKORD
Begin DoDot:1
+7 IF '$DATA(^PRCP(445,PRCPIP,0))
QUIT
+8 IF $PIECE($GET(^PRCP(445,PRCPIP,0)),"^",3)'="S"
QUIT
+9 IF $PIECE($GET(^PRCP(445,PRCPIP,0)),"^",1)["***INACTIVE_"
QUIT
+10 SET PRCPSS=$PIECE($GET(^PRCP(445,PRCPIP,5)),"^",1)
+11 IF PRCPSS]""
IF PRCPSCHE'=1
QUIT
+12 IF PRCPSS']""
IF PRCPSCHE'=2
QUIT
+13 SET PRCPDP=$$FROMCHEK^PRCPUDPT(PRCPIP,0)
+14 ; secondary must have only 1 supplier
IF $GET(PRCPFNON)!'$GET(PRCPFONE)
QUIT
+15 SET PRCP("I")=PRCPIP
+16 KILL ^TMP($JOB,"PRCPAG")
+17 SET ^TMP($JOB,"PRCPAG","V",PRCPDP)=$$INVNAME^PRCPUX1(PRCPDP)
+18 DO START^PRCPAGS1
+19 ; successfully processed
IF $PIECE(PRCPSCHE,"^",2)']""
QUIT
+20 ; No order numbers left or FileMan can't generate record or nothing to be ordered
IF $PIECE(PRCPSCHE,"^",2)'=4
DO BLDLIST
+21 ; IP in use
IF $PIECE(PRCPSCHE,"^",2)=4
SET ^TMP($JOB,"PRCPAGSS",PRCPIP)=""
+22 ; remove error codes if set
SET PRCPSCHE=+PRCPSCHE
+23 QUIT
End DoDot:1
+24 ;
+25 ; process any IP's that were in use, if possible
BACKORD SET PRCPIP=0
+1 IF $ORDER(^TMP($JOB,"PRCPAGSS",0))']""
GOTO QUIT
+2 FOR
SET PRCPIP=$ORDER(^TMP($JOB,"PRCPAGSS",PRCPIP))
if +PRCPIP'>0
GOTO QUIT
Begin DoDot:1
+3 IF '$DATA(^PRCP(445,PRCPIP,0))
QUIT
+4 SET PRCPSS=$PIECE($GET(^PRCP(445,PRCPIP,5)),"^",1)
+5 IF PRCPSS]""
IF PRCPSCHE'=1
QUIT
+6 IF PRCPSS']""
IF PRCPSCHE'=2
QUIT
+7 SET PRCPDP=$$FROMCHEK^PRCPUDPT(PRCPIP,0)
+8 ; secondary must have only 1 supplier
IF $GET(PRCPFNON)!'$GET(PRCPFONE)
QUIT
+9 SET PRCP("I")=PRCPIP
+10 KILL ^TMP($JOB,"PRCPAG")
+11 SET ^TMP($JOB,"PRCPAG","V",PRCPDP)=$$INVNAME^PRCPUX1(PRCPDP)
+12 DO START^PRCPAGS1
+13 ; successfully processed
IF $PIECE(PRCPSCHE,"^",2)']""
QUIT
+14 DO BLDLIST
+15 ; remove error codes if set
SET PRCPSCHE=+PRCPSCHE
+16 QUIT
End DoDot:1
+17 ;
BLDLIST ; inventory point users
DO GETUSER^PRCPXTRM(PRCPIP)
if '$ORDER(PRCPXMY(""))
QUIT
+1 SET ITEM=0
+2 ; restrict to managers
+3 FOR
SET ITEM=$ORDER(PRCPXMY(ITEM))
if ITEM'>0
QUIT
IF PRCPXMY(ITEM)=1
SET XMY(ITEM)=""
+4 KILL ^TMP($JOB,"PRCPAGSSM")
+5 IF $PIECE(PRCPSCHE,"^",2)=1
SET ^TMP($JOB,"PRCPAGSSM",1,1,0)="There are no available order numbers. Please delete or post orders."
+6 IF $PIECE(PRCPSCHE,"^",2)=2
SET ^TMP($JOB,"PRCPAGSSM",1,1,0)="The system was unable to add a new order."
+7 IF $PIECE(PRCPSCHE,"^",2)=3
SET ^TMP($JOB,"PRCPAGSSM",1,1,0)="No items needed to be ordered."
+8 IF $PIECE(PRCPSCHE,"^",2)=4
SET ^TMP($JOB,"PRCPAGSSM",1,1,0)="The inventory point was in use."
+9 SET ^TMP($JOB,"PRCPAGSSM",1,0)=1
SEND SET XMTEXT="^TMP($J,""PRCPAGSSM"",1,"
+1 SET XMB="PRCP_ORDER_NOT_GENERATED"
+2 SET XMB(1)=$$INVNAME^PRCPUX1(PRCPIP)
+3 SET XMDUZ="SCHEDULED ORDER BUILDER"
+4 DO EN^XMB
+5 QUIT
+6 ;
QUIT LOCK -^TMP("PRCPSCHE",PRCPSCHE)
+1 KILL ^TMP($JOB,"PRCPAG"),^TMP($JOB,"PRCPAGSSM")
+2 QUIT
