Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PRCPAGSS

PRCPAGSS.m

Go to the documentation of this file. 
  1. PRCPAGSS ;WISC/RFJ-scheduled autogen secondary order build         ;01 Dec 92
  1. V ;;5.1;IFCAP;**1**;Oct 20, 2000
  1.  ;Per VHA Directive 10-93-142, this routine should not be modified.
  1.  Q
  1.  ;
  1.  ; entry point for supply station secondaries
  1. SSS N PRCPSCHE
  1.  S PRCPSCHE=1
  1.  D BUILD
  1.  Q
  1.  ;
  1.  ; entry point for non-supply station secondaries
  1. NSS N PRCPSCHE
  1.  S PRCPSCHE=2
  1.  D BUILD
  1.  Q
  1.  ;
  1. BUILD L +^TMP("PRCPSCHE",PRCPSCHE):0 I $T=0 QUIT  ; process already running
  1.  N PRCP,PRCPDP,PRCPFONE,PRCPFNON,PRCPIP,PRCPSS,PRCPXMY
  1.  N ITEM,XMB,XMDUZ,XMTEXT,XMY
  1.  K ^TMP($J,"PRCPAGSS")
  1.  S PRCPIP=0
  1.  I +$O(^PRCP(445,0))'>0 G QUIT
  1.  F  S PRCPIP=$O(^PRCP(445,PRCPIP)) G BACKORD:+PRCPIP'>0  D
  1.  . I '$D(^PRCP(445,PRCPIP,0)) QUIT
  1.  . I $P($G(^PRCP(445,PRCPIP,0)),"^",3)'="S" QUIT
  1.  . I $P($G(^PRCP(445,PRCPIP,0)),"^",1)["***INACTIVE_" QUIT
  1.  . S PRCPSS=$P($G(^PRCP(445,PRCPIP,5)),"^",1)
  1.  . I PRCPSS]"",PRCPSCHE'=1 QUIT
  1.  . I PRCPSS']"",PRCPSCHE'=2 QUIT
  1.  . S PRCPDP=$$FROMCHEK^PRCPUDPT(PRCPIP,0)
  1.  . I $G(PRCPFNON)!'$G(PRCPFONE) QUIT  ; secondary must have only 1 supplier
  1.  . S PRCP("I")=PRCPIP
  1.  . K ^TMP($J,"PRCPAG")
  1.  . S ^TMP($J,"PRCPAG","V",PRCPDP)=$$INVNAME^PRCPUX1(PRCPDP)
  1.  . D START^PRCPAGS1
  1.  . I $P(PRCPSCHE,"^",2)']"" QUIT  ; successfully processed
  1.  . I $P(PRCPSCHE,"^",2)'=4 D BLDLIST ; No order numbers left or FileMan can't generate record or nothing to be ordered
  1.  . I $P(PRCPSCHE,"^",2)=4 S ^TMP($J,"PRCPAGSS",PRCPIP)="" ; IP in use
  1.  . S PRCPSCHE=+PRCPSCHE ; remove error codes if set
  1.  . QUIT
  1.  ;
  1.  ; process any IP's that were in use, if possible
  1. BACKORD S PRCPIP=0
  1.  I $O(^TMP($J,"PRCPAGSS",0))']"" G QUIT
  1.  F  S PRCPIP=$O(^TMP($J,"PRCPAGSS",PRCPIP)) G QUIT:+PRCPIP'>0 D
  1.  . I '$D(^PRCP(445,PRCPIP,0)) QUIT
  1.  . S PRCPSS=$P($G(^PRCP(445,PRCPIP,5)),"^",1)
  1.  . I PRCPSS]"",PRCPSCHE'=1 QUIT
  1.  . I PRCPSS']"",PRCPSCHE'=2 QUIT
  1.  . S PRCPDP=$$FROMCHEK^PRCPUDPT(PRCPIP,0)
  1.  . I $G(PRCPFNON)!'$G(PRCPFONE) QUIT  ; secondary must have only 1 supplier
  1.  . S PRCP("I")=PRCPIP
  1.  . K ^TMP($J,"PRCPAG")
  1.  . S ^TMP($J,"PRCPAG","V",PRCPDP)=$$INVNAME^PRCPUX1(PRCPDP)
  1.  . D START^PRCPAGS1
  1.  . I $P(PRCPSCHE,"^",2)']"" QUIT  ; successfully processed
  1.  . D BLDLIST
  1.  . S PRCPSCHE=+PRCPSCHE ; remove error codes if set
  1.  . QUIT
  1.  ;
  1. BLDLIST D GETUSER^PRCPXTRM(PRCPIP) Q:'$O(PRCPXMY(""))  ; inventory point users
  1.  S ITEM=0
  1.  ; restrict to managers
  1.  F  S ITEM=$O(PRCPXMY(ITEM)) Q:ITEM'>0  I PRCPXMY(ITEM)=1 S XMY(ITEM)=""
  1.  K ^TMP($J,"PRCPAGSSM")
  1.  I $P(PRCPSCHE,"^",2)=1 S ^TMP($J,"PRCPAGSSM",1,1,0)="There are no available order numbers.  Please delete or post orders."
  1.  I $P(PRCPSCHE,"^",2)=2 S ^TMP($J,"PRCPAGSSM",1,1,0)="The system was unable to add a new order."
  1.  I $P(PRCPSCHE,"^",2)=3 S ^TMP($J,"PRCPAGSSM",1,1,0)="No items needed to be ordered."
  1.  I $P(PRCPSCHE,"^",2)=4 S ^TMP($J,"PRCPAGSSM",1,1,0)="The inventory point was in use."
  1.  S ^TMP($J,"PRCPAGSSM",1,0)=1
  1. SEND S XMTEXT="^TMP($J,""PRCPAGSSM"",1,"
  1.  S XMB="PRCP_ORDER_NOT_GENERATED"
  1.  S XMB(1)=$$INVNAME^PRCPUX1(PRCPIP)
  1.  S XMDUZ="SCHEDULED ORDER BUILDER"
  1.  D EN^XMB
  1.  Q
  1.  ;
  1. QUIT L -^TMP("PRCPSCHE",PRCPSCHE)
  1.  K ^TMP($J,"PRCPAG"),^TMP($J,"PRCPAGSSM")
  1.  QUIT