PRCPEITE ;WISC/RFJ-enter/edit inventory items ; 11/6/06 8:40am
V ;;5.1;IFCAP;**1,98**;Oct 20, 2000;Build 37
;Per VHA Directive 2004-038, this routine should not be modified.
Q
;
ALL(PRCPINPT,ITEMDA) ; edit all fields option (for new items)
I '$D(^PRCP(445,+PRCPINPT,1,+ITEMDA,0)) Q
N %,%H,D,D0,D1,D2,DA,DES,DI,DIC,DIE,DLAYGO,DQ,DR,I
N PRCPINDA,PRCPITEM,PRCPNL,PRCPQUIT,PRCPPRIV,PRCPTYPE,PRCPUI,PRCPUI1,X,Y
D EN^DDIOL("----- Enter Item Descriptive Data -----")
S DES=$P($G(^PRCP(445,PRCPINPT,1,ITEMDA,6)),"^")
I DES="" S DES=$$DESDEF^PRCPEITF(PRCPINPT,ITEMDA) ; get item description default
S PRCPQUIT=0
D DESCRIP^PRCPEITF(PRCPINPT,ITEMDA,.PRCPQUIT)
I PRCPQUIT Q
S DR="[PRCP ITEM ALL FIELDS (NON-SS)]"
I $P(^PRCP(445,PRCPINPT,0),"^",3)="S",$P($G(^PRCP(445,PRCPINPT,5)),"^",1)]"" S DR="[PRCP ITEM ALL FIELDS (SS)]" ; supply station monitors normal level value
S DA=PRCPINPT
S PRCPITEM=$C(96)_ITEMDA
S (DIC,DIE)="^PRCP(445,"
S DIE("NO^")="BACKOUTOK"
S PRCPPRIV=1 D ^DIE
Q
;
;
DESCRIP(PRCPINPT,ITEMDA) ; edit description, category, location fields
I '$D(^PRCP(445,+PRCPINPT,1,+ITEMDA,0)) Q
N %,D,D0,DA,DES,DI,DIC,DIE,DISYS,DQ,DR,DZ,E,PRCPPRIM,PRCPPRIV,PRCPPRNM,PRCPQUIT,TYPE,X,XH,XP,Y
S DES=$P($G(^PRCP(445,PRCPINPT,1,ITEMDA,6)),"^")
I DES="" S DES=$$DESDEF^PRCPEITF(PRCPINPT,ITEMDA) ; get default value
S PRCPQUIT=0
D DESCRIP^PRCPEITF(PRCPINPT,ITEMDA,.PRCPQUIT)
I PRCPQUIT Q
S DA(1)=PRCPINPT,DA=ITEMDA,(DIC,DIE)="^PRCP(445,"_PRCPINPT_",1,"
S DR=".5GROUP CATEGORY;5MAIN STORAGE LOCATION;6"
S PRCPPRIV=1
D ^DIE K PRCPPRIV
Q
;
;
LEVELS(PRCPINPT,ITEMDA) ; edit stock levels
I '$D(^PRCP(445,+PRCPINPT,1,+ITEMDA,0)) Q
N %,D,D0,DA,DI,DIC,DIE,DQ,DR,DZ,PRCPDR,PRCPPRIV,PRCPQUIT,UNIT,X,Y
S UNIT=$$UNIT^PRCPUX1(PRCPINPT,ITEMDA," per ")
S DR="9NORMAL STOCK LEVEL ("_UNIT_")"
S PRCPQUIT=0
;
; if the supply station secondary has unposted regular orders,
; restrict editing a non-zero normal level to zero.
I $P(^PRCP(445,PRCPINPT,0),"^",3)="S",$P($G(^PRCP(445,PRCPINPT,5)),"^",1)]"" D
. D EDNORM(PRCPINPT,ITEMDA,$E(DR,2,99),.PRCPQUIT)
. S DR=""
. I $D(DUOUT)!$D(DTOUT) Q
I PRCPQUIT Q
I DR]"" S DR=DR_";"
S PRCPPRIV=1
S DR=DR_"11EMERGENCY STOCK LEVEL ("_UNIT_");9.5TEMPORARY STOCK LEVEL ("_UNIT_");I 'X S Y=10;9.6;10STANDARD REORDER POINT ("_UNIT_");10.3OPTIONAL REORDER POINT ("_UNIT_");"
S DA(1)=PRCPINPT,DA=ITEMDA,(DIC,DIE)="^PRCP(445,"_PRCPINPT_",1," D ^DIE
Q
;
;
SPECIAL(PRCPINPT,ITEMDA) ; special parameters and flags
I '$D(^PRCP(445,+PRCPINPT,1,+ITEMDA,0)) Q
N %,C,D,D0,D1,DA,DDH,DI,DIC,DIE,DISYS,DIZ,DLAYGO,DQ,DR,I,ISSUE,PRCPITEM,PRCPPRIV,PRCPSET,TYPE,X,Y
S (DIC,DIE)="^PRCP(445,"_PRCPINPT_",1,",PRCPSET="I PRCPITEM'=X,$D(^PRCP(445,PRCPINPT,1,X,0))",DA(1)=PRCPINPT,(PRCPITEM,DA)=ITEMDA
S TYPE=$P($G(^PRCP(445,PRCPINPT,0)),"^",3)
; substitute item multiple
I TYPE="W",'$D(^PRCP(445,PRCPINPT,1,ITEMDA,4,0)) S ^(0)="^445.122PI^^"
I TYPE="P",$P(^PRCP(445,PRCPINPT,0),"^",10)="S" S ISSUE=1
; removal of fields 14;14.3;14.4 if type = "P" (fields not used)
S DR="17;"_$S($G(ISSUE):"14.5;",1:"")_$S(TYPE="W":"22;",1:"")
S PRCPPRIV=1
D ^DIE I $D(DTOUT)!$D(Y) Q
K DIC,DIE,DA,DR
I TYPE'="W" D ODI^PRCPEITG(PRCPINPT,ITEMDA) ; ask On-Demand (PRC*5.1*98)
Q
;
;
DISPUNIT(PRCPINPT,ITEMDA) ; drug accountability dispensing units
N %,D,D0,DA,DD,DDH,DI,DIC,DIE,DISYS,DIX,DIY,DO,DQ,DR,DZ,X,Y
S DA(1)=PRCPINPT,DA=ITEMDA,(DIC,DIE)="^PRCP(445,"_PRCPINPT_",1,",DR="50;51"
S PRCPPRIV=1 D ^DIE K PRCPPRIV
Q
;
;
EDNORM(PRCPINPT,ITEMDA,TEXT,PRCPQUIT) ; editing the normal level on supply station secondaries
; ITEMDA = item number requiring the default description
; PRCPINPT = inventory point
; TEXT = text to display when prompting the user
; PRCPQUIT = flag to signify exit desired
;
N DA,DIC,DIE,DIR,DR,ORD,PRCPNL,PRCPPRIV,VALUE
; because this is sometimes called from templates, new FileMan variables
N D,D0,D1,D2,D3,D4,D5,D6,DB,DC,DD,DE,DG,DH,DI,DIA,DIADD,DICR,DIEC,DIEL
N DIFLD,DIK,DIOV,DK,DL,DLAYGO,DM,DO,DOV,DP,DQ,DU,DV,DW,I,J,X,Y
I $P(^PRCP(445,PRCPINPT,0),"^",3)'="S" QUIT
I '$P($G(^PRCP(445,PRCPINPT,5)),"^",1) QUIT
I '$D(^PRCP(445,PRCPINPT,1,ITEMDA,0)) QUIT
S PRCPNL=+$P(^PRCP(445,PRCPINPT,1,ITEMDA,0),"^",9)
S ORD=0
S ORD=$$ORDCHK^PRCPUITM(ITEMDA,PRCPINPT,"R","")
I ORD D ; this field is also a flag of items on supply station, editing must be restricted if there are outstanding supply station orders.
. N DIR
. S DIR("A")=TEXT
. S DIR("A",1)="There are outstanding regular orders for this item."
. S DIR("A",2)="You cannot delete the normal level or make it 0"
. S DIR(0)="N^1:999999"
. S DIR("B")=PRCPNL
. D ^DIR K DIR
. I $D(DUOUT)!$D(DTOUT) S PRCPQUIT=1 Q
. I X S PRCPNL=X D
. . S DA(1)=PRCPINPT,DA=ITEMDA,PRCPPRIV=1
. . S (DIC,DIE)="^PRCP(445,"_PRCPINPT_",1,"
. . S DR="9///^S X=PRCPNL"
. . D ^DIE
. . K DIC,DIE
I 'ORD D
. I PRCPNL'>0 W !!,"Changing the level from zero will add the item to the supply station."
. I PRCPNL>0 W !!,"Changing the level to zero will delete the item from the supply station."
. I $D(DUOUT)!$D(DTOUT) S PRCPQUIT=1 Q
. S DIR(0)="445.01,9^^",DA(1)=PRCPINPT,DA=ITEMDA
. D ^DIR K DIR
. S VALUE=Y
. I $D(DTOUT)!$D(DUOUT) S PRCPQUIT=1 Q
. S DR="9///^S X=VALUE"
. S DA=ITEMDA,DA(1)=PRCPINPT,PRCPPRIV=1
. S (DIC,DIE)="^PRCP(445,"_PRCPINPT_",1,"
. D ^DIE
. K DIC,DIE
. I PRCPNL,'$P(^PRCP(445,PRCPINPT,1,ITEMDA,0),"^",9) D BLDSEG^PRCPHLFM(2,ITEMDA,PRCPINPT)
. I 'PRCPNL,$P(^PRCP(445,PRCPINPT,1,ITEMDA,0),"^",9) D BLDSEG^PRCPHLFM(1,ITEMDA,PRCPINPT)
QUIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPEITE 5648 printed Dec 13, 2024@02:13:40 Page 2
PRCPEITE ;WISC/RFJ-enter/edit inventory items ; 11/6/06 8:40am
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 ;
ALL(PRCPINPT,ITEMDA) ; edit all fields option (for new items)
+1 IF '$DATA(^PRCP(445,+PRCPINPT,1,+ITEMDA,0))
QUIT
+2 NEW %,%H,D,D0,D1,D2,DA,DES,DI,DIC,DIE,DLAYGO,DQ,DR,I
+3 NEW PRCPINDA,PRCPITEM,PRCPNL,PRCPQUIT,PRCPPRIV,PRCPTYPE,PRCPUI,PRCPUI1,X,Y
+4 DO EN^DDIOL("----- Enter Item Descriptive Data -----")
+5 SET DES=$PIECE($GET(^PRCP(445,PRCPINPT,1,ITEMDA,6)),"^")
+6 ; get item description default
IF DES=""
SET DES=$$DESDEF^PRCPEITF(PRCPINPT,ITEMDA)
+7 SET PRCPQUIT=0
+8 DO DESCRIP^PRCPEITF(PRCPINPT,ITEMDA,.PRCPQUIT)
+9 IF PRCPQUIT
QUIT
+10 SET DR="[PRCP ITEM ALL FIELDS (NON-SS)]"
+11 ; supply station monitors normal level value
IF $PIECE(^PRCP(445,PRCPINPT,0),"^",3)="S"
IF $PIECE($GET(^PRCP(445,PRCPINPT,5)),"^",1)]""
SET DR="[PRCP ITEM ALL FIELDS (SS)]"
+12 SET DA=PRCPINPT
+13 SET PRCPITEM=$CHAR(96)_ITEMDA
+14 SET (DIC,DIE)="^PRCP(445,"
+15 SET DIE("NO^")="BACKOUTOK"
+16 SET PRCPPRIV=1
DO ^DIE
+17 QUIT
+18 ;
+19 ;
DESCRIP(PRCPINPT,ITEMDA) ; edit description, category, location fields
+1 IF '$DATA(^PRCP(445,+PRCPINPT,1,+ITEMDA,0))
QUIT
+2 NEW %,D,D0,DA,DES,DI,DIC,DIE,DISYS,DQ,DR,DZ,E,PRCPPRIM,PRCPPRIV,PRCPPRNM,PRCPQUIT,TYPE,X,XH,XP,Y
+3 SET DES=$PIECE($GET(^PRCP(445,PRCPINPT,1,ITEMDA,6)),"^")
+4 ; get default value
IF DES=""
SET DES=$$DESDEF^PRCPEITF(PRCPINPT,ITEMDA)
+5 SET PRCPQUIT=0
+6 DO DESCRIP^PRCPEITF(PRCPINPT,ITEMDA,.PRCPQUIT)
+7 IF PRCPQUIT
QUIT
+8 SET DA(1)=PRCPINPT
SET DA=ITEMDA
SET (DIC,DIE)="^PRCP(445,"_PRCPINPT_",1,"
+9 SET DR=".5GROUP CATEGORY;5MAIN STORAGE LOCATION;6"
+10 SET PRCPPRIV=1
+11 DO ^DIE
KILL PRCPPRIV
+12 QUIT
+13 ;
+14 ;
LEVELS(PRCPINPT,ITEMDA) ; edit stock levels
+1 IF '$DATA(^PRCP(445,+PRCPINPT,1,+ITEMDA,0))
QUIT
+2 NEW %,D,D0,DA,DI,DIC,DIE,DQ,DR,DZ,PRCPDR,PRCPPRIV,PRCPQUIT,UNIT,X,Y
+3 SET UNIT=$$UNIT^PRCPUX1(PRCPINPT,ITEMDA," per ")
+4 SET DR="9NORMAL STOCK LEVEL ("_UNIT_")"
+5 SET PRCPQUIT=0
+6 ;
+7 ; if the supply station secondary has unposted regular orders,
+8 ; restrict editing a non-zero normal level to zero.
+9 IF $PIECE(^PRCP(445,PRCPINPT,0),"^",3)="S"
IF $PIECE($GET(^PRCP(445,PRCPINPT,5)),"^",1)]""
Begin DoDot:1
+10 DO EDNORM(PRCPINPT,ITEMDA,$EXTRACT(DR,2,99),.PRCPQUIT)
+11 SET DR=""
+12 IF $DATA(DUOUT)!$DATA(DTOUT)
QUIT
End DoDot:1
+13 IF PRCPQUIT
QUIT
+14 IF DR]""
SET DR=DR_";"
+15 SET PRCPPRIV=1
+16 SET DR=DR_"11EMERGENCY STOCK LEVEL ("_UNIT_");9.5TEMPORARY STOCK LEVEL ("_UNIT_");I 'X S Y=10;9.6;10STANDARD REORDER POINT ("_UNIT_");10.3OPTIONAL REORDER POINT ("_UNIT_");"
+17 SET DA(1)=PRCPINPT
SET DA=ITEMDA
SET (DIC,DIE)="^PRCP(445,"_PRCPINPT_",1,"
DO ^DIE
+18 QUIT
+19 ;
+20 ;
SPECIAL(PRCPINPT,ITEMDA) ; special parameters and flags
+1 IF '$DATA(^PRCP(445,+PRCPINPT,1,+ITEMDA,0))
QUIT
+2 NEW %,C,D,D0,D1,DA,DDH,DI,DIC,DIE,DISYS,DIZ,DLAYGO,DQ,DR,I,ISSUE,PRCPITEM,PRCPPRIV,PRCPSET,TYPE,X,Y
+3 SET (DIC,DIE)="^PRCP(445,"_PRCPINPT_",1,"
SET PRCPSET="I PRCPITEM'=X,$D(^PRCP(445,PRCPINPT,1,X,0))"
SET DA(1)=PRCPINPT
SET (PRCPITEM,DA)=ITEMDA
+4 SET TYPE=$PIECE($GET(^PRCP(445,PRCPINPT,0)),"^",3)
+5 ; substitute item multiple
+6 IF TYPE="W"
IF '$DATA(^PRCP(445,PRCPINPT,1,ITEMDA,4,0))
SET ^(0)="^445.122PI^^"
+7 IF TYPE="P"
IF $PIECE(^PRCP(445,PRCPINPT,0),"^",10)="S"
SET ISSUE=1
+8 ; removal of fields 14;14.3;14.4 if type = "P" (fields not used)
+9 SET DR="17;"_$SELECT($GET(ISSUE):"14.5;",1:"")_$SELECT(TYPE="W":"22;",1:"")
+10 SET PRCPPRIV=1
+11 DO ^DIE
IF $DATA(DTOUT)!$DATA(Y)
QUIT
+12 KILL DIC,DIE,DA,DR
+13 ; ask On-Demand (PRC*5.1*98)
IF TYPE'="W"
DO ODI^PRCPEITG(PRCPINPT,ITEMDA)
+14 QUIT
+15 ;
+16 ;
DISPUNIT(PRCPINPT,ITEMDA) ; drug accountability dispensing units
+1 NEW %,D,D0,DA,DD,DDH,DI,DIC,DIE,DISYS,DIX,DIY,DO,DQ,DR,DZ,X,Y
+2 SET DA(1)=PRCPINPT
SET DA=ITEMDA
SET (DIC,DIE)="^PRCP(445,"_PRCPINPT_",1,"
SET DR="50;51"
+3 SET PRCPPRIV=1
DO ^DIE
KILL PRCPPRIV
+4 QUIT
+5 ;
+6 ;
EDNORM(PRCPINPT,ITEMDA,TEXT,PRCPQUIT) ; editing the normal level on supply station secondaries
+1 ; ITEMDA = item number requiring the default description
+2 ; PRCPINPT = inventory point
+3 ; TEXT = text to display when prompting the user
+4 ; PRCPQUIT = flag to signify exit desired
+5 ;
+6 NEW DA,DIC,DIE,DIR,DR,ORD,PRCPNL,PRCPPRIV,VALUE
+7 ; because this is sometimes called from templates, new FileMan variables
+8 NEW D,D0,D1,D2,D3,D4,D5,D6,DB,DC,DD,DE,DG,DH,DI,DIA,DIADD,DICR,DIEC,DIEL
+9 NEW DIFLD,DIK,DIOV,DK,DL,DLAYGO,DM,DO,DOV,DP,DQ,DU,DV,DW,I,J,X,Y
+10 IF $PIECE(^PRCP(445,PRCPINPT,0),"^",3)'="S"
QUIT
+11 IF '$PIECE($GET(^PRCP(445,PRCPINPT,5)),"^",1)
QUIT
+12 IF '$DATA(^PRCP(445,PRCPINPT,1,ITEMDA,0))
QUIT
+13 SET PRCPNL=+$PIECE(^PRCP(445,PRCPINPT,1,ITEMDA,0),"^",9)
+14 SET ORD=0
+15 SET ORD=$$ORDCHK^PRCPUITM(ITEMDA,PRCPINPT,"R","")
+16 ; this field is also a flag of items on supply station, editing must be restricted if there are outstanding supply station orders.
IF ORD
Begin DoDot:1
+17 NEW DIR
+18 SET DIR("A")=TEXT
+19 SET DIR("A",1)="There are outstanding regular orders for this item."
+20 SET DIR("A",2)="You cannot delete the normal level or make it 0"
+21 SET DIR(0)="N^1:999999"
+22 SET DIR("B")=PRCPNL
+23 DO ^DIR
KILL DIR
+24 IF $DATA(DUOUT)!$DATA(DTOUT)
SET PRCPQUIT=1
QUIT
+25 IF X
SET PRCPNL=X
Begin DoDot:2
+26 SET DA(1)=PRCPINPT
SET DA=ITEMDA
SET PRCPPRIV=1
+27 SET (DIC,DIE)="^PRCP(445,"_PRCPINPT_",1,"
+28 SET DR="9///^S X=PRCPNL"
+29 DO ^DIE
+30 KILL DIC,DIE
End DoDot:2
End DoDot:1
+31 IF 'ORD
Begin DoDot:1
+32 IF PRCPNL'>0
WRITE !!,"Changing the level from zero will add the item to the supply station."
+33 IF PRCPNL>0
WRITE !!,"Changing the level to zero will delete the item from the supply station."
+34 IF $DATA(DUOUT)!$DATA(DTOUT)
SET PRCPQUIT=1
QUIT
+35 SET DIR(0)="445.01,9^^"
SET DA(1)=PRCPINPT
SET DA=ITEMDA
+36 DO ^DIR
KILL DIR
+37 SET VALUE=Y
+38 IF $DATA(DTOUT)!$DATA(DUOUT)
SET PRCPQUIT=1
QUIT
+39 SET DR="9///^S X=VALUE"
+40 SET DA=ITEMDA
SET DA(1)=PRCPINPT
SET PRCPPRIV=1
+41 SET (DIC,DIE)="^PRCP(445,"_PRCPINPT_",1,"
+42 DO ^DIE
+43 KILL DIC,DIE
+44 IF PRCPNL
IF '$PIECE(^PRCP(445,PRCPINPT,1,ITEMDA,0),"^",9)
DO BLDSEG^PRCPHLFM(2,ITEMDA,PRCPINPT)
+45 IF 'PRCPNL
IF $PIECE(^PRCP(445,PRCPINPT,1,ITEMDA,0),"^",9)
DO BLDSEG^PRCPHLFM(1,ITEMDA,PRCPINPT)
End DoDot:1
+46 QUIT
