PRCPUITM ;WISC/RFJ-select items utility ;10 Dec 91
V ;;5.1;IFCAP;**1**;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
Q
;
;
ITEM(INVPT,ADDNEW,SCREEN,DEFAULT) ; select item in inventory point
; addnew=1 to add new items
; screen=additional screen
; default=default item master number
; return itemda; 0 no item selected; ^ for ^ entered or timeout
;
I '$D(^PRCP(445,+INVPT,0)) Q 0
N %,C,DA,DG,DISYS,DIC,DTOUT,DUOUT,I,PRCPSET,PRCPX,TYPE,X,Y
S DIC="^PRCP(445,"_INVPT_",1,"
S DIC(0)="QEAM"_$S(ADDNEW:"L",1:"")
S DIC("A")="Select "_$P($$INVNAME^PRCPUX1(INVPT),"-",2,99)_" ITEM: "
S TYPE=$P($G(^PRCP(445,INVPT,0)),"^",3)
S PRCPSET="I 0"
;
; whse screen
I TYPE="W" S PRCPSET="I $$PURCHASE^PRCPU441(+Y),'$$INACTIVE^PRCPU441(+Y),$$MANDSRCE^PRCPU441(+Y)=$O(^PRC(440,""AC"",""S"",0))"_$G(SCREEN)
;
; primary screen
I TYPE="P" S PRCPSET="I '$$INACTIVE^PRCPU441(+Y)"_$G(SCREEN)
;
; secondary screen
I TYPE="S" S PRCPSET="I '$$INACTIVE^PRCPU441(+Y),$O(^PRCP(445,""AB"","_INVPT_",0))"_$G(SCREEN)_" F PRCPX=0:0 S PRCPX=$O(^PRCP(445,""AB"","_INVPT_",PRCPX)) Q:'PRCPX I $D(^PRCP(445,PRCPX,1,+Y,0)) Q"
;
S:'$D(^PRCP(445,INVPT,1,0)) ^(0)="^445.01IP^^"
S DIC("S")=PRCPSET
S DIC("W")="W ?10,$E($$DESCR^PRCPUX1("_INVPT_",+Y),1,20),?35,""NSN: "",$$NSN^PRCPUX1(+Y)"
S DA(1)=INVPT
I DEFAULT S DIC("B")=$$DESCR^PRCPUX1(INVPT,DEFAULT) I DIC("B")="" K DIC("B")
D ^DIC
Q $S($G(DUOUT):"^",$G(DTOUT):"^",Y<1:0,1:+Y)
;
;
MASTITEM(SCREEN) ; select item from master item file
; screen=optional screen
; return itemda; 0 no item selected; ^ for ^ entered or timeout
;
N %,DDH,DIC,DTOUT,DUOUT,PRCPSET,X,Y
I $G(SCREEN)'="" S DIC("S")=SCREEN,PRCPSET=SCREEN
S DIC="^PRC(441,",DIC(0)="QEAM" D ^DIC
Q $S($G(DUOUT):"^",$G(DTOUT):"^",Y<1:0,1:+Y)
;
;
GETITEM(INVPT,ITEMDA) ; get data for item in invpt
; return data in prcpdata array
K PRCPDATA
I '$D(^PRCP(445,+INVPT,1,+ITEMDA,0)) Q
N %,D0,DA,DIC,DIQ,DIQ2,DR
S DIC="^PRCP(445,"
S DR=1,DR(445.01)=".01:99"
S DA=INVPT,DA(445.01)=ITEMDA
S DIQ="PRCPDATA",DIQ(0)="E"
D EN^DIQ1
Q
;
;
DELETE(PRCPINPT,ITEMDA) ; check for deleting item from inventory point
I $G(^PRCP(445,+PRCPINPT,1,+ITEMDA,0))="" Q
N %,%H,%I,DATA,DIC,DISTR,DISYS,DUEIN,DUEOUT,INACTIVE,OUTORD,SITE,STRING,TYPE,X,Y
S DATA=^PRCP(445,PRCPINPT,1,ITEMDA,0)
I $P(DATA,"^",7) W !!,"QUANTITY ON HAND (",$P(DATA,"^",7),") NEEDS TO BE ADJUSTED TO ZERO." Q
I $P(DATA,"^",19) W !!,"QUANTITY NON-ISSUABLE (",$P(DATA,"^",19),") NEEDS TO BE ADJUSTED TO ZERO." Q
S INACTIVE=$P(^PRCP(445,PRCPINPT,0),"^",13)
I INACTIVE D NOW^%DTC S X1=X,X2=-(INACTIVE*30+1) D C^%DTC I $O(^PRCP(445,PRCPINPT,1,ITEMDA,2,$E(X,1,5)-.1))!($O(^PRCP(445,PRCPINPT,1,ITEMDA,3,X))) D Q
. W !!,"ITEM HAS HAD ACTIVITY DURING THE LAST ",INACTIVE," MONTHS."
S DUEIN=$$GETIN^PRCPUDUE(PRCPINPT,ITEMDA)
I DUEIN W !,"ITEM HAS DUE-INS: ",DUEIN
S DUEOUT=$$GETOUT^PRCPUDUE(PRCPINPT,ITEMDA)
I DUEOUT W !,"ITEM HAS DUE-OUTS: ",DUEOUT
W !,"Checking to see if this item is on an outstanding order...."
S OUTORD=$$ORDCHK(ITEMDA,PRCPINPT,"RCE","") I OUTORD D Q
. W !,"This item cannot be deleted. You must first post, delete, or"
. W !,"remove the item from the following order(s):"
. D LISTOO(ITEMDA,PRCPINPT)
S %=$$INVNAME^PRCPUX1(PRCPINPT),SITE=$P(%,"-")
S XP="ARE YOU SURE YOU WANT TO DELETE THIS ITEM"
S XP(1)=" FROM THE "_%_" INVENTORY POINT"
S XH="Enter 'YES' to DELETE this item from the inventory point."
I $$YN^PRCPUYN(2)'=1 Q
W !!?5,"--Deleting Item from Inventory Point ..."
D DELITEM(PRCPINPT,ITEMDA)
I $P($G(^PRCP(445,PRCPINPT,0)),"^",3)="W" D
. D DELETE^PRCPSMS0(ITEMDA)
. I STRING("ID")="" W !," WARNING--UNABLE TO CREATE ISMS CODE SHEET!" Q
. K ^TMP($J,"STRING") S ^TMP($J,"STRING",1)=STRING("ID") D CODESHT^PRCPSMGO(SITE,"IVD","")
W !!,"Checking Distribution Points (you will have the option to delete the item",!,"from the distribution points if the distribution point is NOT keeping a",!,"perpetual inventory) ..."
S DISTR="" F S DISTR=$O(^PRCP(445,PRCPINPT,2,DISTR)) Q:'DISTR I $P($G(^PRCP(445,DISTR,0)),"^",6)="Y",$D(^PRCP(445,DISTR,1,ITEMDA,0)) W !!,"DISTRIBUTION POINT: ",$P($$INVNAME^PRCPUX1(DISTR),"-",2,99) D
. S XP=" OK TO DELETE ITEM FROM THIS DISTRIBUTION POINT",XH=" Enter 'YES' to DELETE the item from the distribution point, '^' to exit."
. S %=$$YN^PRCPUYN(2) I '% S DISTR=999999 Q
. I %=2 Q
. W !!?5,"--Deleting Item from Distribution Point ..." D DELITEM(DISTR,ITEMDA) Q
Q
;
;
DELITEM(PRCPINPT,DA) ; delete item da from inventory point
N %,DIC,DIK,ITEM,X,Y
S ITEM=DA
I $P($G(^PRCP(445,PRCPINPT,5)),"^",1)]"",$P($G(^PRCP(445,PRCPINPT,1,ITEM,0)),"^",9)>0 D BLDSEG^PRCPHLFM(2,ITEM,PRCPINPT) ; send to supply station
S DA(1)=PRCPINPT,DIK="^PRCP(445,"_DA(1)_",1," D ^DIK
Q
;
ORDCHK(ITEMDA,PRCPINPT,ORDTYP,ORDSTA) ; is the item on any outstanding orders
; ITEMDA = DA of item to be deleted, 0 if search is for any order
; for that inventory point.
; PRCPINT = DA of inventory point in the search
; ORDTYP = search for regular, emergency and/or call-in
; ORDSTA = Status of the outstanding order, if search is limited
; returns 0 if no outstanding order is found, 1 it it is
;
N ORD,OUTORD,TYPE,XREF
I '$D(ORDSTA) S ORDSTA=""
S TYPE=$P($G(^PRCP(445,PRCPINPT,0)),"^",3)
S XREF=""
I TYPE="S" S XREF="AD"
I TYPE="P" S XREF="AC"
S OUTORD=0
I XREF]"" D
. S ORD=0
. F S ORD=$O(^PRCP(445.3,XREF,PRCPINPT,ORD)) Q:+ORD'>0!OUTORD D
. . I 'ITEMDA,$P(^PRCP(445.3,ORD,0),"^",6)'="P",ORDTYP[($P(^PRCP(445.3,ORD,0),"^",8)) D
. . . I ORDSTA="" S OUTORD=1
. . . I ORDSTA]"",$P(^PRCP(445.3,ORD,0),"^",6)[ORDSTA S OUTORD=1
. . I ITEMDA,$P(^PRCP(445.3,ORD,0),"^",6)'="P",$D(^PRCP(445.3,ORD,1,ITEMDA)),ORDTYP[($P(^PRCP(445.3,ORD,0),"^",8)) D
. . . I ORDSTA="" S OUTORD=1
. . . I ORDSTA]"",$P(^PRCP(445.3,ORD,0),"^",6)[ORDSTA S OUTORD=1
Q (OUTORD)
;
LISTOO(ITEM,PRCPINPT,ORDSTA) ; list outstanding orders for this item
; ITEM = DA of item to be deleted
; PRCPINT = DA of inventory point housing the item
; ORDSTA = Status of the outstanding order, if search is limited
;
N ORD,OUTORD,TYPE,XREF
I '$D(ORDSTA) S ORDSTA=""
S TYPE=$P($G(^PRCP(445,PRCPINPT,0)),"^",3)
S XREF=""
I TYPE="S" S XREF="AD"
I TYPE="P" S XREF="AC"
S OUTORD=0
I XREF]"" D
. S ORD=0
. F S ORD=$O(^PRCP(445.3,XREF,PRCPINPT,ORD)) Q:+ORD'>0 D
. . I $P(^PRCP(445.3,ORD,0),"^",6)'="P",$D(^PRCP(445.3,ORD,1,ITEM)) D
. . . S OUTORD=$P(^PRCP(445.3,ORD,0),"^",1)
. . . I ORDSTA]"",$P(^PRCP(445.3,ORD,0),"^",6)[ORDSTA W !?5,OUTORD
. . . I ORDSTA="" W !?5,OUTORD
Q ; (OUTORD)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPUITM 6771 printed Oct 16, 2024@18:16:56 Page 2
PRCPUITM ;WISC/RFJ-select items utility ;10 Dec 91
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 ;
ITEM(INVPT,ADDNEW,SCREEN,DEFAULT) ; select item in inventory point
+1 ; addnew=1 to add new items
+2 ; screen=additional screen
+3 ; default=default item master number
+4 ; return itemda; 0 no item selected; ^ for ^ entered or timeout
+5 ;
+6 IF '$DATA(^PRCP(445,+INVPT,0))
QUIT 0
+7 NEW %,C,DA,DG,DISYS,DIC,DTOUT,DUOUT,I,PRCPSET,PRCPX,TYPE,X,Y
+8 SET DIC="^PRCP(445,"_INVPT_",1,"
+9 SET DIC(0)="QEAM"_$SELECT(ADDNEW:"L",1:"")
+10 SET DIC("A")="Select "_$PIECE($$INVNAME^PRCPUX1(INVPT),"-",2,99)_" ITEM: "
+11 SET TYPE=$PIECE($GET(^PRCP(445,INVPT,0)),"^",3)
+12 SET PRCPSET="I 0"
+13 ;
+14 ; whse screen
+15 IF TYPE="W"
SET PRCPSET="I $$PURCHASE^PRCPU441(+Y),'$$INACTIVE^PRCPU441(+Y),$$MANDSRCE^PRCPU441(+Y)=$O(^PRC(440,""AC"",""S"",0))"_$GET(SCREEN)
+16 ;
+17 ; primary screen
+18 IF TYPE="P"
SET PRCPSET="I '$$INACTIVE^PRCPU441(+Y)"_$GET(SCREEN)
+19 ;
+20 ; secondary screen
+21 IF TYPE="S"
SET PRCPSET="I '$$INACTIVE^PRCPU441(+Y),$O(^PRCP(445,""AB"","_INVPT_",0))"_$GET(SCREEN)_" F PRCPX=0:0 S PRCPX=$O(^PRCP(445,""AB"","_INVPT_",PRCPX)) Q:'PRCPX I $D(^PRCP(445,PRCPX,1,+Y,0)) Q"
+22 ;
+23 if '$DATA(^PRCP(445,INVPT,1,0))
SET ^(0)="^445.01IP^^"
+24 SET DIC("S")=PRCPSET
+25 SET DIC("W")="W ?10,$E($$DESCR^PRCPUX1("_INVPT_",+Y),1,20),?35,""NSN: "",$$NSN^PRCPUX1(+Y)"
+26 SET DA(1)=INVPT
+27 IF DEFAULT
SET DIC("B")=$$DESCR^PRCPUX1(INVPT,DEFAULT)
IF DIC("B")=""
KILL DIC("B")
+28 DO ^DIC
+29 QUIT $SELECT($GET(DUOUT):"^",$GET(DTOUT):"^",Y<1:0,1:+Y)
+30 ;
+31 ;
MASTITEM(SCREEN) ; select item from master item file
+1 ; screen=optional screen
+2 ; return itemda; 0 no item selected; ^ for ^ entered or timeout
+3 ;
+4 NEW %,DDH,DIC,DTOUT,DUOUT,PRCPSET,X,Y
+5 IF $GET(SCREEN)'=""
SET DIC("S")=SCREEN
SET PRCPSET=SCREEN
+6 SET DIC="^PRC(441,"
SET DIC(0)="QEAM"
DO ^DIC
+7 QUIT $SELECT($GET(DUOUT):"^",$GET(DTOUT):"^",Y<1:0,1:+Y)
+8 ;
+9 ;
GETITEM(INVPT,ITEMDA) ; get data for item in invpt
+1 ; return data in prcpdata array
+2 KILL PRCPDATA
+3 IF '$DATA(^PRCP(445,+INVPT,1,+ITEMDA,0))
QUIT
+4 NEW %,D0,DA,DIC,DIQ,DIQ2,DR
+5 SET DIC="^PRCP(445,"
+6 SET DR=1
SET DR(445.01)=".01:99"
+7 SET DA=INVPT
SET DA(445.01)=ITEMDA
+8 SET DIQ="PRCPDATA"
SET DIQ(0)="E"
+9 DO EN^DIQ1
+10 QUIT
+11 ;
+12 ;
DELETE(PRCPINPT,ITEMDA) ; check for deleting item from inventory point
+1 IF $GET(^PRCP(445,+PRCPINPT,1,+ITEMDA,0))=""
QUIT
+2 NEW %,%H,%I,DATA,DIC,DISTR,DISYS,DUEIN,DUEOUT,INACTIVE,OUTORD,SITE,STRING,TYPE,X,Y
+3 SET DATA=^PRCP(445,PRCPINPT,1,ITEMDA,0)
+4 IF $PIECE(DATA,"^",7)
WRITE !!,"QUANTITY ON HAND (",$PIECE(DATA,"^",7),") NEEDS TO BE ADJUSTED TO ZERO."
QUIT
+5 IF $PIECE(DATA,"^",19)
WRITE !!,"QUANTITY NON-ISSUABLE (",$PIECE(DATA,"^",19),") NEEDS TO BE ADJUSTED TO ZERO."
QUIT
+6 SET INACTIVE=$PIECE(^PRCP(445,PRCPINPT,0),"^",13)
+7 IF INACTIVE
DO NOW^%DTC
SET X1=X
SET X2=-(INACTIVE*30+1)
DO C^%DTC
IF $ORDER(^PRCP(445,PRCPINPT,1,ITEMDA,2,$EXTRACT(X,1,5)-.1))!($ORDER(^PRCP(445,PRCPINPT,1,ITEMDA,3,X)))
Begin DoDot:1
+8 WRITE !!,"ITEM HAS HAD ACTIVITY DURING THE LAST ",INACTIVE," MONTHS."
End DoDot:1
QUIT
+9 SET DUEIN=$$GETIN^PRCPUDUE(PRCPINPT,ITEMDA)
+10 IF DUEIN
WRITE !,"ITEM HAS DUE-INS: ",DUEIN
+11 SET DUEOUT=$$GETOUT^PRCPUDUE(PRCPINPT,ITEMDA)
+12 IF DUEOUT
WRITE !,"ITEM HAS DUE-OUTS: ",DUEOUT
+13 WRITE !,"Checking to see if this item is on an outstanding order...."
+14 SET OUTORD=$$ORDCHK(ITEMDA,PRCPINPT,"RCE","")
IF OUTORD
Begin DoDot:1
+15 WRITE !,"This item cannot be deleted. You must first post, delete, or"
+16 WRITE !,"remove the item from the following order(s):"
+17 DO LISTOO(ITEMDA,PRCPINPT)
End DoDot:1
QUIT
+18 SET %=$$INVNAME^PRCPUX1(PRCPINPT)
SET SITE=$PIECE(%,"-")
+19 SET XP="ARE YOU SURE YOU WANT TO DELETE THIS ITEM"
+20 SET XP(1)=" FROM THE "_%_" INVENTORY POINT"
+21 SET XH="Enter 'YES' to DELETE this item from the inventory point."
+22 IF $$YN^PRCPUYN(2)'=1
QUIT
+23 WRITE !!?5,"--Deleting Item from Inventory Point ..."
+24 DO DELITEM(PRCPINPT,ITEMDA)
+25 IF $PIECE($GET(^PRCP(445,PRCPINPT,0)),"^",3)="W"
Begin DoDot:1
+26 DO DELETE^PRCPSMS0(ITEMDA)
+27 IF STRING("ID")=""
WRITE !," WARNING--UNABLE TO CREATE ISMS CODE SHEET!"
QUIT
+28 KILL ^TMP($JOB,"STRING")
SET ^TMP($JOB,"STRING",1)=STRING("ID")
DO CODESHT^PRCPSMGO(SITE,"IVD","")
End DoDot:1
+29 WRITE !!,"Checking Distribution Points (you will have the option to delete the item",!,"from the distribution points if the distribution point is NOT keeping a",!,"perpetual inventory) ..."
+30 SET DISTR=""
FOR
SET DISTR=$ORDER(^PRCP(445,PRCPINPT,2,DISTR))
if 'DISTR
QUIT
IF $PIECE($GET(^PRCP(445,DISTR,0)),"^",6)="Y"
IF $DATA(^PRCP(445,DISTR,1,ITEMDA,0))
WRITE !!,"DISTRIBUTION POINT: ",$PIECE($$INVNAME^PRCPUX1(DISTR),"-",2,99)
Begin DoDot:1
+31 SET XP=" OK TO DELETE ITEM FROM THIS DISTRIBUTION POINT"
SET XH=" Enter 'YES' to DELETE the item from the distribution point, '^' to exit."
+32 SET %=$$YN^PRCPUYN(2)
IF '%
SET DISTR=999999
QUIT
+33 IF %=2
QUIT
+34 WRITE !!?5,"--Deleting Item from Distribution Point ..."
DO DELITEM(DISTR,ITEMDA)
QUIT
End DoDot:1
+35 QUIT
+36 ;
+37 ;
DELITEM(PRCPINPT,DA) ; delete item da from inventory point
+1 NEW %,DIC,DIK,ITEM,X,Y
+2 SET ITEM=DA
+3 ; send to supply station
IF $PIECE($GET(^PRCP(445,PRCPINPT,5)),"^",1)]""
IF $PIECE($GET(^PRCP(445,PRCPINPT,1,ITEM,0)),"^",9)>0
DO BLDSEG^PRCPHLFM(2,ITEM,PRCPINPT)
+4 SET DA(1)=PRCPINPT
SET DIK="^PRCP(445,"_DA(1)_",1,"
DO ^DIK
+5 QUIT
+6 ;
ORDCHK(ITEMDA,PRCPINPT,ORDTYP,ORDSTA) ; is the item on any outstanding orders
+1 ; ITEMDA = DA of item to be deleted, 0 if search is for any order
+2 ; for that inventory point.
+3 ; PRCPINT = DA of inventory point in the search
+4 ; ORDTYP = search for regular, emergency and/or call-in
+5 ; ORDSTA = Status of the outstanding order, if search is limited
+6 ; returns 0 if no outstanding order is found, 1 it it is
+7 ;
+8 NEW ORD,OUTORD,TYPE,XREF
+9 IF '$DATA(ORDSTA)
SET ORDSTA=""
+10 SET TYPE=$PIECE($GET(^PRCP(445,PRCPINPT,0)),"^",3)
+11 SET XREF=""
+12 IF TYPE="S"
SET XREF="AD"
+13 IF TYPE="P"
SET XREF="AC"
+14 SET OUTORD=0
+15 IF XREF]""
Begin DoDot:1
+16 SET ORD=0
+17 FOR
SET ORD=$ORDER(^PRCP(445.3,XREF,PRCPINPT,ORD))
if +ORD'>0!OUTORD
QUIT
Begin DoDot:2
+18 IF 'ITEMDA
IF $PIECE(^PRCP(445.3,ORD,0),"^",6)'="P"
IF ORDTYP[($PIECE(^PRCP(445.3,ORD,0),"^",8))
Begin DoDot:3
+19 IF ORDSTA=""
SET OUTORD=1
+20 IF ORDSTA]""
IF $PIECE(^PRCP(445.3,ORD,0),"^",6)[ORDSTA
SET OUTORD=1
End DoDot:3
+21 IF ITEMDA
IF $PIECE(^PRCP(445.3,ORD,0),"^",6)'="P"
IF $DATA(^PRCP(445.3,ORD,1,ITEMDA))
IF ORDTYP[($PIECE(^PRCP(445.3,ORD,0),"^",8))
Begin DoDot:3
+22 IF ORDSTA=""
SET OUTORD=1
+23 IF ORDSTA]""
IF $PIECE(^PRCP(445.3,ORD,0),"^",6)[ORDSTA
SET OUTORD=1
End DoDot:3
End DoDot:2
End DoDot:1
+24 QUIT (OUTORD)
+25 ;
LISTOO(ITEM,PRCPINPT,ORDSTA) ; list outstanding orders for this item
+1 ; ITEM = DA of item to be deleted
+2 ; PRCPINT = DA of inventory point housing the item
+3 ; ORDSTA = Status of the outstanding order, if search is limited
+4 ;
+5 NEW ORD,OUTORD,TYPE,XREF
+6 IF '$DATA(ORDSTA)
SET ORDSTA=""
+7 SET TYPE=$PIECE($GET(^PRCP(445,PRCPINPT,0)),"^",3)
+8 SET XREF=""
+9 IF TYPE="S"
SET XREF="AD"
+10 IF TYPE="P"
SET XREF="AC"
+11 SET OUTORD=0
+12 IF XREF]""
Begin DoDot:1
+13 SET ORD=0
+14 FOR
SET ORD=$ORDER(^PRCP(445.3,XREF,PRCPINPT,ORD))
if +ORD'>0
QUIT
Begin DoDot:2
+15 IF $PIECE(^PRCP(445.3,ORD,0),"^",6)'="P"
IF $DATA(^PRCP(445.3,ORD,1,ITEM))
Begin DoDot:3
+16 SET OUTORD=$PIECE(^PRCP(445.3,ORD,0),"^",1)
+17 IF ORDSTA]""
IF $PIECE(^PRCP(445.3,ORD,0),"^",6)[ORDSTA
WRITE !?5,OUTORD
+18 IF ORDSTA=""
WRITE !?5,OUTORD
End DoDot:3
End DoDot:2
End DoDot:1
+19 ; (OUTORD)
QUIT
