PSGWPI1 ;BHAM ISC/MPH,CML-Print AOU Inventory Sheet - CONTINUED ; 18 Jun 93 / 10:40 AM
;;2.3; Automatic Replenishment/Ward Stock ;;4 JAN 94
EN1 ; PSGWIDA = DA of inventory being edited
K PSGW("PO") S PSGPAGE=1,Y=DT X ^DD("DD") S PSGTODAY=Y,LNCNT=0
I $D(BARFLG) F J=0,1 S @("PSGWBAR"_J)="" I $D(^%ZIS(2,^%ZIS(1,IOS,"SUBTYPE"),"BAR"_J)) S @("PSGWBAR"_J)=^("BAR"_J)
I $D(BARFLG) S PSGWBARS=PSGWBAR1]""&(PSGWBAR0]"")
I $D(AOU) S PSGW("PO",100,AOU)="" G START ; Check for single AOU print
F SK=0:0 S SK=$O(^PSI(58.19,PSGWIDA,1,"C",SK)) Q:SK'>0 F J=0:0 S J=$O(^PSI(58.19,PSGWIDA,1,"C",SK,J)) Q:J'>0 S PSGW("PO",SK,J)=""
START S PSGWIN=$P(^PSI(58.19,PSGWIDA,0),"^",1)
WLOOP F PSGSORTK=0:0 S PSGSORTK=$O(PSGW("PO",PSGSORTK)) Q:PSGSORTK'>0 F PSGDA=0:0 S PSGDA=$O(PSGW("PO",PSGSORTK,PSGDA)) Q:PSGDA'>0 D SIN,WENT
END W:$D(STKCHG) !!,"* Indicates change in stock level"
I $E(IOST)'="C" W @IOF
Q
;
SIN ;Sort the ward item list
K ^PSI(58.19,"AINV",PSGWIDA,PSGDA) S (PSGNT,J)=0,PSGTN="" F I=0:0 S I=$O(^PSI(58.19,PSGWIDA,1,PSGDA,1,I)) Q:I'>0 S PSGTN=PSGTN_I_",",PSGNT=PSGNT+1
SINL S J=$O(^PSI(58.1,PSGDA,1,J)) Q:J'>0 S K=^(J,0)
F I=1:1:PSGNT I $S($D(^PSI(58.1,PSGDA,1,J,2,$P(PSGTN,",",I))):1,$D(^PSI(58.16,$P(PSGTN,",",I),0)):$P(^(0),"^")="ALL",1:0) D CHKINA G:$T SINL
G SINL
;
CHKINA I $S('$D(^PSI(58.1,PSGDA,1,J,"I")):1,$O(^("I",PSGWDT))>0:1,$P(^PSI(58.1,PSGDA,1,J,0),"^",10)="Y":1,1:0) D LOC S ^PSI(58.19,"AINV",PSGWIDA,PSGDA,PSG1,PSG2,PSG3,PSGTYP,PSGDR)=+J_"^"_$P(K,"^",1,2)
Q
;
LOC ;Build item address
S K1=$P(K,"^",8) F NN=1:1:3 S @("PSG"_NN)=$S($P(K1,",",NN)]"":$P(K1,",",NN),1:" ")
S PSGDR=$S($D(^PSDRUG(+K,0))#2:$P(^(0),"^",1),1:+K)
S PSGTYP=$S($D(^PSI(58.16,$P(PSGTN,",",I),0)):$P(^(0),"^"),1:"TYPE HAS BEEN DELETED")
I '$D(^PSI(58.1,PSGDA,1,J,1,PSGWIDA,0)) D EN2^PSGWPI2
Q
;
WENT S PSG1="" I $D(^PSI(58.19,"AINV",PSGWIDA,PSGDA)) D EN1^PSGWPI2
PSG1 S PSG1=$O(^PSI(58.19,"AINV",PSGWIDA,PSGDA,PSG1)) Q:PSG1="" W !,?17,PSG1 S PSG2="",EXP=$O(^PSI(58.17,"B",PSG1,0)) W:EXP>0 " ",$P(^PSI(58.17,EXP,0),"^",3) S LNCNT=LNCNT+1
PSG2 S PSG2=$O(^PSI(58.19,"AINV",PSGWIDA,PSGDA,PSG1,PSG2)) G PSG1:PSG2="" S PSG3=""
PSG3 S PSG3=$O(^PSI(58.19,"AINV",PSGWIDA,PSGDA,PSG1,PSG2,PSG3)) G PSG2:PSG3="" S PSGTYP="" W !,?1,PSG2,$S(PSG3'=" ":","_PSG3,PSG3="":" ",1:"") S LNCNT=LNCNT+1
PSGTYP I $D(^PSI(58.19,"AINV",PSGWIDA,PSGDA,PSG1,PSG2,PSG3,"ALL")) S TYPE="" F Q=0:0 S TYPE=$O(^PSI(58.19,"AINV",PSGWIDA,PSGDA,PSG1,PSG2,PSG3,TYPE)) Q:TYPE="" I TYPE'="ALL" K ^(TYPE)
S PSGTYP=$O(^PSI(58.19,"AINV",PSGWIDA,PSGDA,PSG1,PSG2,PSG3,PSGTYP)) G PSG3:PSGTYP="" S PSGDR="" S LFC=$S($X>7:"!?7",1:"?7") W:PSGTYP'="ALL" @LFC,PSGTYP
PSGDR S PSGDR=$O(^PSI(58.19,"AINV",PSGWIDA,PSGDA,PSG1,PSG2,PSG3,PSGTYP,PSGDR)) G PSGTYP:PSGDR="" S PSGDDA=+^(PSGDR),DRGDA=+$P(^(PSGDR),"^",2),STLEV=$P(^(PSGDR),"^",3),LOC=^PSI(58.1,PSGDA,1,PSGDDA,0)
I $D(BARFLG) D:LNCNT>45 EN1^PSGWPI2 D BARWRT^PSGWPI2 G PSGDR
D:$Y+5>IOSL EN1^PSGWPI2
PNT W !,?10,PSGDR I $P(LOC,"^",5)="Y" W ?50,"*" S STKCHG="Y" S $P(^PSI(58.1,PSGDA,1,PSGDDA,0),"^",5)=""
I (($P(LOC,"^",3)'>PSGWDT)&($P(LOC,"^",10)="Y")) W ?50,"*" S PSGINAD="Y" S $P(^PSI(58.1,PSGDA,1,PSGDDA,0),"^",10)=""
W ?51,$J(STLEV,3)
QCODE F MH=0:0 S MH=$O(^PSDRUG($P(^PSI(58.1,PSGDA,1,PSGDDA,0),"^",1),1,MH)) Q:MH'>0 I $P(^(MH,0),"^",3) W ?58,$E($P(^(0),"^",1),1,8) Q
W ?66,"_____"
I $P(PSGWSITE,"^",5) W ?75,$S($P(LOC,"^",11)]"":$J($P(LOC,"^",11),5),1:" "),?86,$S(+$P(LOC,"^",12):$J($P(LOC,"^",12),5),1:" "),?98,"______"
I $P(PSGWSITE,"^",6) S TAB1=$S($P(PSGWSITE,"^",5):109,1:74),TAB2=$S($P(PSGWSITE,"^",5):118,1:82) W ?TAB1,"______",?TAB2,"E O D C"
I $D(^PSI(58.1,PSGDA,1,PSGDDA,"EXP")) S Y=^("EXP") I Y X ^DD("DD") W !?14,"Expiration Date: ",Y
I $D(PSGINAD) W !?14,"*Inactivated item, pull existing stock" K PSGINAD
G PSGDR
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSGWPI1 3804 printed Apr 09, 2024@20:44:09 Page 2
PSGWPI1 ;BHAM ISC/MPH,CML-Print AOU Inventory Sheet - CONTINUED ; 18 Jun 93 / 10:40 AM
+1 ;;2.3; Automatic Replenishment/Ward Stock ;;4 JAN 94
EN1 ; PSGWIDA = DA of inventory being edited
+1 KILL PSGW("PO")
SET PSGPAGE=1
SET Y=DT
XECUTE ^DD("DD")
SET PSGTODAY=Y
SET LNCNT=0
+2 IF $DATA(BARFLG)
FOR J=0,1
SET @("PSGWBAR"_J)=""
IF $DATA(^%ZIS(2,^%ZIS(1,IOS,"SUBTYPE"),"BAR"_J))
SET @("PSGWBAR"_J)=^("BAR"_J)
+3 IF $DATA(BARFLG)
SET PSGWBARS=PSGWBAR1]""&(PSGWBAR0]"")
+4 ; Check for single AOU print
IF $DATA(AOU)
SET PSGW("PO",100,AOU)=""
GOTO START
+5 FOR SK=0:0
SET SK=$ORDER(^PSI(58.19,PSGWIDA,1,"C",SK))
if SK'>0
QUIT
FOR J=0:0
SET J=$ORDER(^PSI(58.19,PSGWIDA,1,"C",SK,J))
if J'>0
QUIT
SET PSGW("PO",SK,J)=""
START SET PSGWIN=$PIECE(^PSI(58.19,PSGWIDA,0),"^",1)
WLOOP FOR PSGSORTK=0:0
SET PSGSORTK=$ORDER(PSGW("PO",PSGSORTK))
if PSGSORTK'>0
QUIT
FOR PSGDA=0:0
SET PSGDA=$ORDER(PSGW("PO",PSGSORTK,PSGDA))
if PSGDA'>0
QUIT
DO SIN
DO WENT
END if $DATA(STKCHG)
WRITE !!,"* Indicates change in stock level"
+1 IF $EXTRACT(IOST)'="C"
WRITE @IOF
+2 QUIT
+3 ;
SIN ;Sort the ward item list
+1 KILL ^PSI(58.19,"AINV",PSGWIDA,PSGDA)
SET (PSGNT,J)=0
SET PSGTN=""
FOR I=0:0
SET I=$ORDER(^PSI(58.19,PSGWIDA,1,PSGDA,1,I))
if I'>0
QUIT
SET PSGTN=PSGTN_I_","
SET PSGNT=PSGNT+1
SINL SET J=$ORDER(^PSI(58.1,PSGDA,1,J))
if J'>0
QUIT
SET K=^(J,0)
+1 FOR I=1:1:PSGNT
IF $SELECT($DATA(^PSI(58.1,PSGDA,1,J,2,$PIECE(PSGTN,",",I))):1,$DATA(^PSI(58.16,$PIECE(PSGTN,",",I),0)):$PIECE(^(0),"^")="ALL",1:0)
DO CHKINA
if $TEST
GOTO SINL
+2 GOTO SINL
+3 ;
CHKINA IF $SELECT('$DATA(^PSI(58.1,PSGDA,1,J,"I")):1,$ORDER(^("I",PSGWDT))>0:1,$PIECE(^PSI(58.1,PSGDA,1,J,0),"^",10)="Y":1,1:0)
DO LOC
SET ^PSI(58.19,"AINV",PSGWIDA,PSGDA,PSG1,PSG2,PSG3,PSGTYP,PSGDR)=+J_"^"_$PIECE(K,"^",1,2)
+1 QUIT
+2 ;
LOC ;Build item address
+1 SET K1=$PIECE(K,"^",8)
FOR NN=1:1:3
SET @("PSG"_NN)=$SELECT($PIECE(K1,",",NN)]"":$PIECE(K1,",",NN),1:" ")
+2 SET PSGDR=$SELECT($DATA(^PSDRUG(+K,0))#2:$PIECE(^(0),"^",1),1:+K)
+3 SET PSGTYP=$SELECT($DATA(^PSI(58.16,$PIECE(PSGTN,",",I),0)):$PIECE(^(0),"^"),1:"TYPE HAS BEEN DELETED")
+4 IF '$DATA(^PSI(58.1,PSGDA,1,J,1,PSGWIDA,0))
DO EN2^PSGWPI2
+5 QUIT
+6 ;
WENT SET PSG1=""
IF $DATA(^PSI(58.19,"AINV",PSGWIDA,PSGDA))
DO EN1^PSGWPI2
PSG1 SET PSG1=$ORDER(^PSI(58.19,"AINV",PSGWIDA,PSGDA,PSG1))
if PSG1=""
QUIT
WRITE !,?17,PSG1
SET PSG2=""
SET EXP=$ORDER(^PSI(58.17,"B",PSG1,0))
if EXP>0
WRITE " ",$PIECE(^PSI(58.17,EXP,0),"^",3)
SET LNCNT=LNCNT+1
PSG2 SET PSG2=$ORDER(^PSI(58.19,"AINV",PSGWIDA,PSGDA,PSG1,PSG2))
if PSG2=""
GOTO PSG1
SET PSG3=""
PSG3 SET PSG3=$ORDER(^PSI(58.19,"AINV",PSGWIDA,PSGDA,PSG1,PSG2,PSG3))
if PSG3=""
GOTO PSG2
SET PSGTYP=""
WRITE !,?1,PSG2,$SELECT(PSG3'=" ":","_PSG3,PSG3="":" ",1:"")
SET LNCNT=LNCNT+1
PSGTYP IF $DATA(^PSI(58.19,"AINV",PSGWIDA,PSGDA,PSG1,PSG2,PSG3,"ALL"))
SET TYPE=""
FOR Q=0:0
SET TYPE=$ORDER(^PSI(58.19,"AINV",PSGWIDA,PSGDA,PSG1,PSG2,PSG3,TYPE))
if TYPE=""
QUIT
IF TYPE'="ALL"
KILL ^(TYPE)
+1 SET PSGTYP=$ORDER(^PSI(58.19,"AINV",PSGWIDA,PSGDA,PSG1,PSG2,PSG3,PSGTYP))
if PSGTYP=""
GOTO PSG3
SET PSGDR=""
SET LFC=$SELECT($X>7:"!?7",1:"?7")
if PSGTYP'="ALL"
WRITE @LFC,PSGTYP
PSGDR SET PSGDR=$ORDER(^PSI(58.19,"AINV",PSGWIDA,PSGDA,PSG1,PSG2,PSG3,PSGTYP,PSGDR))
if PSGDR=""
GOTO PSGTYP
SET PSGDDA=+^(PSGDR)
SET DRGDA=+$PIECE(^(PSGDR),"^",2)
SET STLEV=$PIECE(^(PSGDR),"^",3)
SET LOC=^PSI(58.1,PSGDA,1,PSGDDA,0)
+1 IF $DATA(BARFLG)
if LNCNT>45
DO EN1^PSGWPI2
DO BARWRT^PSGWPI2
GOTO PSGDR
+2 if $Y+5>IOSL
DO EN1^PSGWPI2
PNT WRITE !,?10,PSGDR
IF $PIECE(LOC,"^",5)="Y"
WRITE ?50,"*"
SET STKCHG="Y"
SET $PIECE(^PSI(58.1,PSGDA,1,PSGDDA,0),"^",5)=""
+1 IF (($PIECE(LOC,"^",3)'>PSGWDT)&($PIECE(LOC,"^",10)="Y"))
WRITE ?50,"*"
SET PSGINAD="Y"
SET $PIECE(^PSI(58.1,PSGDA,1,PSGDDA,0),"^",10)=""
+2 WRITE ?51,$JUSTIFY(STLEV,3)
QCODE FOR MH=0:0
SET MH=$ORDER(^PSDRUG($PIECE(^PSI(58.1,PSGDA,1,PSGDDA,0),"^",1),1,MH))
if MH'>0
QUIT
IF $PIECE(^(MH,0),"^",3)
WRITE ?58,$EXTRACT($PIECE(^(0),"^",1),1,8)
QUIT
+1 WRITE ?66,"_____"
+2 IF $PIECE(PSGWSITE,"^",5)
WRITE ?75,$SELECT($PIECE(LOC,"^",11)]"":$JUSTIFY($PIECE(LOC,"^",11),5),1:" "),?86,$SELECT(+$PIECE(LOC,"^",12):$JUSTIFY($PIECE(LOC,"^",12),5),1:" "),?98,"______"
+3 IF $PIECE(PSGWSITE,"^",6)
SET TAB1=$SELECT($PIECE(PSGWSITE,"^",5):109,1:74)
SET TAB2=$SELECT($PIECE(PSGWSITE,"^",5):118,1:82)
WRITE ?TAB1,"______",?TAB2,"E O D C"
+4 IF $DATA(^PSI(58.1,PSGDA,1,PSGDDA,"EXP"))
SET Y=^("EXP")
IF Y
XECUTE ^DD("DD")
WRITE !?14,"Expiration Date: ",Y
+5 IF $DATA(PSGINAD)
WRITE !?14,"*Inactivated item, pull existing stock"
KILL PSGINAD
+6 GOTO PSGDR
