- PRCPAGS1 ;WISC/RFJ-autogenerate secondary order ; 10/30/06 12:32pm
- V ;;5.1;IFCAP;**1,98**;Oct 20, 2000;Build 37
- ;Per VHA Directive 2004-038, this routine should not be modified.
- Q
- ;
- ; PRCPSCHE is a flag passed by the Scheduler
- ; PRCPFBAR is a flag passed by the barcode upload
- ;
- START ; start autogenerating items
- N %,CONV,COST,DESCNSN,EACHONE,ERROR,EXIT,GROUP,GROUPNM
- N INACTIVE,ISSMULT,ITEMDA,ITEMDATA,LASTONE,LEVEL,MINISS,NOWDT,NUMBER
- N ORDER,PRIMDATA,QTY,QTYAVAIL,TEMPLVL,TOTITEMS,TYPE
- N UNITI,UNITR,VENDATA,VENDOR,VENDORNM,X,Y
- D NOW^%DTC S NOWDT=%
- L +^PRCP(445,PRCP("I"),1):5 I '$T D Q
- . I '$D(PRCPSCHE) D SHOWWHO^PRCPULOC(445,PRCP("I")_"-1",0)
- . I $D(PRCPSCHE) S $P(PRCPSCHE,"^",2)=4
- D ADD^PRCPULOC(445,PRCP("I")_"-1",0,"Autogeneration")
- W !!,"<<< Starting Auto-generation ...",!
- I '$D(PRCPSCHE) S EACHONE=$$INPERCNT^PRCPUX2(+$P($G(^PRCP(445,PRCP("I"),1,0)),"^",4),"*",PRCP("RV1"),PRCP("RV0"))
- S (TOTITEMS,ITEMDA)=0
- F NUMBER=1:1 S ITEMDA=$O(^PRCP(445,PRCP("I"),1,ITEMDA)) Q:'ITEMDA S ITEMDATA=$G(^(ITEMDA,0)) I ITEMDATA'="" D
- . I '$D(PRCPSCHE) S LASTONE=$$SHPERCNT^PRCPUX2(NUMBER,EACHONE,"*",PRCP("RV1"),PRCP("RV0"))
- . S DESCNSN=$E($$DESCR^PRCPUX1(PRCP("I"),ITEMDA),1,16)
- . S:DESCNSN="" DESCNSN=" "
- . S GROUP=+$P(ITEMDATA,"^",21)
- . S GROUPNM=$$GROUPNM^PRCPEGRP(GROUP)
- . I GROUPNM'="" S GROUPNM=$E(GROUPNM,1,20)_"(#"_GROUP_")"
- . S:GROUPNM="" GROUPNM=" "
- . ; remove temp stock level if greater than date
- . I $P(ITEMDATA,"^",23)>0,NOWDT>$P(ITEMDATA,"^",24) D
- . . D DELTEMP^PRCPAGU1(PRCP("I"),ITEMDA)
- . . S $P(ITEMDATA,"^",23,24)="^"
- . ; check for 'delete item when inventory 0'
- . I $P(ITEMDATA,"^",26)="Y" D Q
- . . I $P(ITEMDATA,"^",7)!($P(ITEMDATA,"^",19))!($P(ITEMDATA,"^",27)) Q
- . . S INACTIVE=$P(^PRCP(445,PRCP("I"),0),"^",13)
- . . I INACTIVE D I EXIT Q
- . . . N X1,X2 ; initialization of X1,X2 added with PRC*5.1*98
- . . . S EXIT=0
- . . . D NOW^%DTC
- . . . S X1=X,X2=-(INACTIVE*30+1)
- . . . D C^%DTC
- . . . I $O(^PRCP(445,PRCP("I"),1,ITEMDA,2,$E(X,1,5)-.1)) S EXIT=1 Q
- . . . I $O(^PRCP(445,PRCP("I"),1,ITEMDA,3,X)) S EXIT=1 Q
- . . I $$ORDCHK^PRCPUITM(ITEMDA,PRCP("I"),"RCE","") D D ERROR Q
- . . . S ERROR="INACTIVE ITEM ON ORDER - can't delete from inventory point (KWZ)"
- . . S ERROR="DELETING ITEM from inventory point (KWZ)"
- . . D ERROR
- . . D DELITEM^PRCPUITM(PRCP("I"),ITEMDA)
- . ;
- . ; primary vendor not selected
- . S VENDOR=$P(ITEMDATA,"^",12)
- . I 'VENDOR D D ERROR Q
- . . S ERROR="MANDATORY OR REQUESTED SOURCE is missing for item"
- . I VENDOR["PRC(440" D D ERROR Q
- . . S ERROR="MANDATORY OR REQUESTED SOURCE should be a primary distribution point"
- . S VENDOR=+VENDOR
- . I '$D(^TMP($J,"PRCPAG","V",VENDOR)) D Q
- . . S %=$S('VENDOR:" ",1:$$INVNAME^PRCPUX1(VENDOR))
- . . S:%="" %=" "
- . . S ^TMP($J,"PRCPAG","NOV",%,VENDOR,DESCNSN,ITEMDA)=""
- . I $P(ITEMDATA,"^",26)="Y" D D ERROR Q
- . . S ERROR="KWZ is set to YES, item not ordered"
- . ; check normal stock level (O allowed for ODI per PRC*5.1*98)
- . I $P(ITEMDATA,"^",9)=0&($P(ITEMDATA,"^",30)'="Y")!($P(ITEMDATA,"^",9)']"") D D ERROR Q
- . . S ERROR="NORMAL STOCK LEVEL missing for item"
- . ; check standard re-order point (no nils, 0 valid with PRC*5.1*1)
- . I $P(ITEMDATA,"^",10)']"" D D ERROR Q
- . . S ERROR="STANDARD REORDER POINT missing for item"
- . S VENDORNM=$$INVNAME^PRCPUX1(VENDOR)
- . S VENDATA=$$GETVEN^PRCPUVEN(PRCP("I"),ITEMDA,VENDOR_";PRCP(445,",1)
- . I 'VENDATA D D ERROR Q
- . . S ERROR="Primary '"_VENDORNM_" is NOT a procurement source"
- . S PRIMDATA=$G(^PRCP(445,VENDOR,1,ITEMDA,0))
- . I PRIMDATA="" D D ERROR Q
- . . S ERROR="Item NOT stored in primary inventory point: "_VENDORNM
- . S UNITI=$$UNIT^PRCPUX1(VENDOR,ITEMDA,"/")
- . S UNITR=$$UNITVAL^PRCPUX1($P(VENDATA,"^",3),$P(VENDATA,"^",2),"/")
- . I UNITI'=UNITR D D ERROR Q
- . . S ERROR="UNIT/REC: "_UNITR_" does not equal UNIT/ISS: "_UNITI_" for primary inventory point: "_VENDORNM
- . S CONV=+$P(VENDATA,"^",4) S:CONV<1 CONV=1
- . S COST=$P(PRIMDATA,"^",22)
- . I $P(PRIMDATA,"^",15)>COST S COST=$P(PRIMDATA,"^",15)
- . S MINISS=$P(PRIMDATA,"^",17)
- . S ISSMULT=$P(PRIMDATA,"^",25)
- . D QTYORD^PRCPAGU2
- D CLEAR^PRCPULOC(445,PRCP("I")_"-1",0)
- L -^PRCP(445,PRCP("I"),1)
- ;
- I '$D(PRCPSCHE) D QPERCNT^PRCPUX2(+$G(LASTONE),"*",PRCP("RV1"),PRCP("RV0"))
- W !!,"<<< Finished !"
- D CONT^PRCPAGS2
- Q
- ;
- ;
- ERROR ; set tmp with error message
- S ^TMP($J,"PRCPAG","ER",DESCNSN,ITEMDA)=ERROR Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPAGS1 4477 printed Feb 18, 2025@23:39:04 Page 2
- PRCPAGS1 ;WISC/RFJ-autogenerate secondary order ; 10/30/06 12:32pm
- V ;;5.1;IFCAP;**1,98**;Oct 20, 2000;Build 37
- +1 ;Per VHA Directive 2004-038, this routine should not be modified.
- +2 QUIT
- +3 ;
- +4 ; PRCPSCHE is a flag passed by the Scheduler
- +5 ; PRCPFBAR is a flag passed by the barcode upload
- +6 ;
- START ; start autogenerating items
- +1 NEW %,CONV,COST,DESCNSN,EACHONE,ERROR,EXIT,GROUP,GROUPNM
- +2 NEW INACTIVE,ISSMULT,ITEMDA,ITEMDATA,LASTONE,LEVEL,MINISS,NOWDT,NUMBER
- +3 NEW ORDER,PRIMDATA,QTY,QTYAVAIL,TEMPLVL,TOTITEMS,TYPE
- +4 NEW UNITI,UNITR,VENDATA,VENDOR,VENDORNM,X,Y
- +5 DO NOW^%DTC
- SET NOWDT=%
- +6 LOCK +^PRCP(445,PRCP("I"),1):5
- IF '$TEST
- Begin DoDot:1
- +7 IF '$DATA(PRCPSCHE)
- DO SHOWWHO^PRCPULOC(445,PRCP("I")_"-1",0)
- +8 IF $DATA(PRCPSCHE)
- SET $PIECE(PRCPSCHE,"^",2)=4
- End DoDot:1
- QUIT
- +9 DO ADD^PRCPULOC(445,PRCP("I")_"-1",0,"Autogeneration")
- +10 WRITE !!,"<<< Starting Auto-generation ...",!
- +11 IF '$DATA(PRCPSCHE)
- SET EACHONE=$$INPERCNT^PRCPUX2(+$PIECE($GET(^PRCP(445,PRCP("I"),1,0)),"^",4),"*",PRCP("RV1"),PRCP("RV0"))
- +12 SET (TOTITEMS,ITEMDA)=0
- +13 FOR NUMBER=1:1
- SET ITEMDA=$ORDER(^PRCP(445,PRCP("I"),1,ITEMDA))
- if 'ITEMDA
- QUIT
- SET ITEMDATA=$GET(^(ITEMDA,0))
- IF ITEMDATA'=""
- Begin DoDot:1
- +14 IF '$DATA(PRCPSCHE)
- SET LASTONE=$$SHPERCNT^PRCPUX2(NUMBER,EACHONE,"*",PRCP("RV1"),PRCP("RV0"))
- +15 SET DESCNSN=$EXTRACT($$DESCR^PRCPUX1(PRCP("I"),ITEMDA),1,16)
- +16 if DESCNSN=""
- SET DESCNSN=" "
- +17 SET GROUP=+$PIECE(ITEMDATA,"^",21)
- +18 SET GROUPNM=$$GROUPNM^PRCPEGRP(GROUP)
- +19 IF GROUPNM'=""
- SET GROUPNM=$EXTRACT(GROUPNM,1,20)_"(#"_GROUP_")"
- +20 if GROUPNM=""
- SET GROUPNM=" "
- +21 ; remove temp stock level if greater than date
- +22 IF $PIECE(ITEMDATA,"^",23)>0
- IF NOWDT>$PIECE(ITEMDATA,"^",24)
- Begin DoDot:2
- +23 DO DELTEMP^PRCPAGU1(PRCP("I"),ITEMDA)
- +24 SET $PIECE(ITEMDATA,"^",23,24)="^"
- End DoDot:2
- +25 ; check for 'delete item when inventory 0'
- +26 IF $PIECE(ITEMDATA,"^",26)="Y"
- Begin DoDot:2
- +27 IF $PIECE(ITEMDATA,"^",7)!($PIECE(ITEMDATA,"^",19))!($PIECE(ITEMDATA,"^",27))
- QUIT
- +28 SET INACTIVE=$PIECE(^PRCP(445,PRCP("I"),0),"^",13)
- +29 IF INACTIVE
- Begin DoDot:3
- +30 ; initialization of X1,X2 added with PRC*5.1*98
- NEW X1,X2
- +31 SET EXIT=0
- +32 DO NOW^%DTC
- +33 SET X1=X
- SET X2=-(INACTIVE*30+1)
- +34 DO C^%DTC
- +35 IF $ORDER(^PRCP(445,PRCP("I"),1,ITEMDA,2,$EXTRACT(X,1,5)-.1))
- SET EXIT=1
- QUIT
- +36 IF $ORDER(^PRCP(445,PRCP("I"),1,ITEMDA,3,X))
- SET EXIT=1
- QUIT
- End DoDot:3
- IF EXIT
- QUIT
- +37 IF $$ORDCHK^PRCPUITM(ITEMDA,PRCP("I"),"RCE","")
- Begin DoDot:3
- +38 SET ERROR="INACTIVE ITEM ON ORDER - can't delete from inventory point (KWZ)"
- End DoDot:3
- DO ERROR
- QUIT
- +39 SET ERROR="DELETING ITEM from inventory point (KWZ)"
- +40 DO ERROR
- +41 DO DELITEM^PRCPUITM(PRCP("I"),ITEMDA)
- End DoDot:2
- QUIT
- +42 ;
- +43 ; primary vendor not selected
- +44 SET VENDOR=$PIECE(ITEMDATA,"^",12)
- +45 IF 'VENDOR
- Begin DoDot:2
- +46 SET ERROR="MANDATORY OR REQUESTED SOURCE is missing for item"
- End DoDot:2
- DO ERROR
- QUIT
- +47 IF VENDOR["PRC(440"
- Begin DoDot:2
- +48 SET ERROR="MANDATORY OR REQUESTED SOURCE should be a primary distribution point"
- End DoDot:2
- DO ERROR
- QUIT
- +49 SET VENDOR=+VENDOR
- +50 IF '$DATA(^TMP($JOB,"PRCPAG","V",VENDOR))
- Begin DoDot:2
- +51 SET %=$SELECT('VENDOR:" ",1:$$INVNAME^PRCPUX1(VENDOR))
- +52 if %=""
- SET %=" "
- +53 SET ^TMP($JOB,"PRCPAG","NOV",%,VENDOR,DESCNSN,ITEMDA)=""
- End DoDot:2
- QUIT
- +54 IF $PIECE(ITEMDATA,"^",26)="Y"
- Begin DoDot:2
- +55 SET ERROR="KWZ is set to YES, item not ordered"
- End DoDot:2
- DO ERROR
- QUIT
- +56 ; check normal stock level (O allowed for ODI per PRC*5.1*98)
- +57 IF $PIECE(ITEMDATA,"^",9)=0&($PIECE(ITEMDATA,"^",30)'="Y")!($PIECE(ITEMDATA,"^",9)']"")
- Begin DoDot:2
- +58 SET ERROR="NORMAL STOCK LEVEL missing for item"
- End DoDot:2
- DO ERROR
- QUIT
- +59 ; check standard re-order point (no nils, 0 valid with PRC*5.1*1)
- +60 IF $PIECE(ITEMDATA,"^",10)']""
- Begin DoDot:2
- +61 SET ERROR="STANDARD REORDER POINT missing for item"
- End DoDot:2
- DO ERROR
- QUIT
- +62 SET VENDORNM=$$INVNAME^PRCPUX1(VENDOR)
- +63 SET VENDATA=$$GETVEN^PRCPUVEN(PRCP("I"),ITEMDA,VENDOR_";PRCP(445,",1)
- +64 IF 'VENDATA
- Begin DoDot:2
- +65 SET ERROR="Primary '"_VENDORNM_" is NOT a procurement source"
- End DoDot:2
- DO ERROR
- QUIT
- +66 SET PRIMDATA=$GET(^PRCP(445,VENDOR,1,ITEMDA,0))
- +67 IF PRIMDATA=""
- Begin DoDot:2
- +68 SET ERROR="Item NOT stored in primary inventory point: "_VENDORNM
- End DoDot:2
- DO ERROR
- QUIT
- +69 SET UNITI=$$UNIT^PRCPUX1(VENDOR,ITEMDA,"/")
- +70 SET UNITR=$$UNITVAL^PRCPUX1($PIECE(VENDATA,"^",3),$PIECE(VENDATA,"^",2),"/")
- +71 IF UNITI'=UNITR
- Begin DoDot:2
- +72 SET ERROR="UNIT/REC: "_UNITR_" does not equal UNIT/ISS: "_UNITI_" for primary inventory point: "_VENDORNM
- End DoDot:2
- DO ERROR
- QUIT
- +73 SET CONV=+$PIECE(VENDATA,"^",4)
- if CONV<1
- SET CONV=1
- +74 SET COST=$PIECE(PRIMDATA,"^",22)
- +75 IF $PIECE(PRIMDATA,"^",15)>COST
- SET COST=$PIECE(PRIMDATA,"^",15)
- +76 SET MINISS=$PIECE(PRIMDATA,"^",17)
- +77 SET ISSMULT=$PIECE(PRIMDATA,"^",25)
- +78 DO QTYORD^PRCPAGU2
- End DoDot:1
- +79 DO CLEAR^PRCPULOC(445,PRCP("I")_"-1",0)
- +80 LOCK -^PRCP(445,PRCP("I"),1)
- +81 ;
- +82 IF '$DATA(PRCPSCHE)
- DO QPERCNT^PRCPUX2(+$GET(LASTONE),"*",PRCP("RV1"),PRCP("RV0"))
- +83 WRITE !!,"<<< Finished !"
- +84 DO CONT^PRCPAGS2
- +85 QUIT
- +86 ;
- +87 ;
- ERROR ; set tmp with error message
- +1 SET ^TMP($JOB,"PRCPAG","ER",DESCNSN,ITEMDA)=ERROR
- QUIT
