PSGWBO1 ;BHAM ISC/CML-Enter/Edit Actual Dispensed/Backorder Values - CONTINUED ; 09/27/89 13:57
;;2.3; Automatic Replenishment/Ward Stock ;;4 JAN 94
;
CHKQTY ;Check Qty. Dispensed for reasonable amount (2 X Stock Level)
K QTYFLG Q:'$D(^PSI(58.1,PSGWDA,1,PSGDDA,0)) S STKLEV=$P(^(0),"^",2) I 'STKLEV K STKLEV Q
I X'>(2*STKLEV) K STKLEV Q
W *7,!!,"This quantity seems too high! The normal Stock Level for this item is ",STKLEV
ASK W !?5,"Are you sure of this amount " S %=2 D YN^DICN I %=1 K STKLEV Q
I %=0 W " Enter 'YES' or 'NO'" G ASK
S QTYFLG=1 K STKLEV Q
GETVAL S DIC("W")="W $P(^(0),""^"",8)"
I $L(X)>1 S DIC(0)="QEM",X=$E(X,2,$L(X))
E S DIC(0)="QEAM"
S DIC="^PSI(58.1,"_PSGWDA_",1," D ^DIC S DA=+Y K DIC Q:Y<0 D ALIGN Q
ALIGN ;Align on this item
Q:'$D(^PSI(58.1,PSGWDA,1,+Y,0)) S K=^(0) D LOC S TYP=""
TYP S TYP=$O(^PSI(58.19,"AINV",PSGWIDA,PSGWDA,TPSG1,TPSG2,TPSG3,TYP)) I TYP="" W *7,"??",!!,"You may only 'up-arrow' to Items from this AOU",!,"that are included in this Inventory Date/Time!!",!!,"ITEM: ",TEMPDR S DA=-1,PSGDR=TEMPDR Q
S PSG1=TPSG1,PSG2=TPSG2,PSG3=TPSG3
I $D(^PSI(58.19,"AINV",PSGWIDA,PSGWDA,PSG1,PSG2,PSG3,TYP,PSGDR)) S PSGTYP=TYP,PSGDR=$E(PSGDR,1,$L(PSGDR)-1)_$E(" ",$E(PSGDR,$L(PSGDR))'=" ") Q
E G TYP
LOC ;Build item address
S K1=$P(K,"^",8) F I=1:1:3 S @("TPSG"_I)=$S($P(K1,",",I)]"":$P(K1,",",I),1:" ")
S PSGDR=$S($D(^PSDRUG(+K,0))#2:$P(^(0),"^",1),1:+K)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSGWBO1 1435 printed Oct 16, 2024@17:39:46 Page 2
PSGWBO1 ;BHAM ISC/CML-Enter/Edit Actual Dispensed/Backorder Values - CONTINUED ; 09/27/89 13:57
+1 ;;2.3; Automatic Replenishment/Ward Stock ;;4 JAN 94
+2 ;
CHKQTY ;Check Qty. Dispensed for reasonable amount (2 X Stock Level)
+1 KILL QTYFLG
if '$DATA(^PSI(58.1,PSGWDA,1,PSGDDA,0))
QUIT
SET STKLEV=$PIECE(^(0),"^",2)
IF 'STKLEV
KILL STKLEV
QUIT
+2 IF X'>(2*STKLEV)
KILL STKLEV
QUIT
+3 WRITE *7,!!,"This quantity seems too high! The normal Stock Level for this item is ",STKLEV
ASK WRITE !?5,"Are you sure of this amount "
SET %=2
DO YN^DICN
IF %=1
KILL STKLEV
QUIT
+1 IF %=0
WRITE " Enter 'YES' or 'NO'"
GOTO ASK
+2 SET QTYFLG=1
KILL STKLEV
QUIT
GETVAL SET DIC("W")="W $P(^(0),""^"",8)"
+1 IF $LENGTH(X)>1
SET DIC(0)="QEM"
SET X=$EXTRACT(X,2,$LENGTH(X))
+2 IF '$TEST
SET DIC(0)="QEAM"
+3 SET DIC="^PSI(58.1,"_PSGWDA_",1,"
DO ^DIC
SET DA=+Y
KILL DIC
if Y<0
QUIT
DO ALIGN
QUIT
ALIGN ;Align on this item
+1 if '$DATA(^PSI(58.1,PSGWDA,1,+Y,0))
QUIT
SET K=^(0)
DO LOC
SET TYP=""
TYP SET TYP=$ORDER(^PSI(58.19,"AINV",PSGWIDA,PSGWDA,TPSG1,TPSG2,TPSG3,TYP))
IF TYP=""
WRITE *7,"??",!!,"You may only 'up-arrow' to Items from this AOU",!,"that are included in this Inventory Date/Time!!",!!,"ITEM: ",TEMPDR
SET DA=-1
SET PSGDR=TEMPDR
QUIT
+1 SET PSG1=TPSG1
SET PSG2=TPSG2
SET PSG3=TPSG3
+2 IF $DATA(^PSI(58.19,"AINV",PSGWIDA,PSGWDA,PSG1,PSG2,PSG3,TYP,PSGDR))
SET PSGTYP=TYP
SET PSGDR=$EXTRACT(PSGDR,1,$LENGTH(PSGDR)-1)_$EXTRACT(" ",$EXTRACT(PSGDR,$LENGTH(PSGDR))'=" ")
QUIT
+3 IF '$TEST
GOTO TYP
LOC ;Build item address
+1 SET K1=$PIECE(K,"^",8)
FOR I=1:1:3
SET @("TPSG"_I)=$SELECT($PIECE(K1,",",I)]"":$PIECE(K1,",",I),1:" ")
+2 SET PSGDR=$SELECT($DATA(^PSDRUG(+K,0))#2:$PIECE(^(0),"^",1),1:+K)
+3 QUIT
