PSGWLSI1 ;BHAM ISC/PTD,CML-Print Stock Items in Order by Type/Location ; 03 Sep 93 / 9:35 AM
;;2.3; Automatic Replenishment/Ward Stock ;;4 JAN 94
ENQ ;ENTRY POINT WHEN QUEUED
K ^TMP("PSGWSTK",$J) S PGCT=1,$P(LN,"-",132)="",AOU=0,OUT=0
AOU S AOU=$O(AOULP(AOU)) G:'AOU PRINT
;
XREF F DRGNM=0:0 S DRGNM=$O(^PSI(58.1,AOU,1,"B",DRGNM)) G:'DRGNM AOU F DRGDA=0:0 S DRGDA=$O(^PSI(58.1,AOU,1,"B",DRGNM,DRGDA)) Q:'DRGDA D BUILD
;
BUILD I $P(^PSI(58.1,AOU,1,DRGDA,0),"^",10)="Y",$P(^(0),"^",3)="" S $P(^(0),"^",10)=""
I $P(^PSI(58.1,AOU,1,DRGDA,0),"^",3)'="" D NOW^%DTC S Y=$P(%,".") Q:$P(^(0),"^",3)'>Y
I '$O(^PSI(58.1,AOU,1,DRGDA,2,0)) S K=9999 D SETGL Q
F TYP=0:0 S TYP=$O(^PSI(58.1,AOU,1,DRGDA,2,TYP)) Q:'TYP S K=TYP D SETGL
Q
;
SETGL I '$O(^PSDRUG(DRGNM,0)) S DIK="^PSI(58.1,"_AOU_",1,",DA=DRGDA,DA(1)=AOU D ^DIK K DIK Q
I $O(^PSDRUG(DRGNM,0)) S DRGNAME=$S($P(^PSDRUG(DRGNM,0),"^")'="":$P(^(0),"^"),1:"Z")
S LOCN=$S($P(^PSI(58.1,AOU,1,DRGDA,0),"^",8)'="":$P(^(0),"^",8),1:"Z"),STLEV=$S($P(^(0),"^",2)'="":$P(^(0),"^",2),1:"Z")
S RELEV=$S($P(^PSI(58.1,AOU,1,DRGDA,0),"^",11)'="":$P(^(0),"^",11),1:"Z"),MIN=$S(+$P(^(0),"^",12):$P(^(0),"^",12),1:"Z"),EXP="Z" I $D(^PSI(58.1,AOU,1,DRGDA,"EXP")),^("EXP") S EXP=^("EXP")
S ^TMP("PSGWSTK",$J,AOU,K,LOCN,DRGNAME,STLEV,RELEV,MIN,EXP)=""
Q
;
PRINT S AOU=0
AOULP S AOU=$O(^TMP("PSGWSTK",$J,AOU)),TYP=0 G:'AOU DONE D HDR G:OUT END W !,"==> ",$P(^PSI(58.1,AOU,0),"^")
TYPLP S TYP=$O(^TMP("PSGWSTK",$J,AOU,TYP)),LOCN="" G:'TYP AOULP D:$Y+5>IOSL HDR G:OUT END W !?6,"TYPE: ",$S(TYP=9999:"UNCLASSIFIED BY TYPE",$D(^PSI(58.16,TYP,0)):$P(^(0),"^"),1:"TYPE NAME HAS BEEN DELETED IN FILE 58.16")
LOCNLP S LOCN=$O(^TMP("PSGWSTK",$J,AOU,TYP,LOCN)),DRGNAME="" G:LOCN="" TYPLP
DRGLP S DRGNAME=$O(^TMP("PSGWSTK",$J,AOU,TYP,LOCN,DRGNAME)),STLEV="" G:DRGNAME="" LOCNLP
STLP S STLEV=$O(^TMP("PSGWSTK",$J,AOU,TYP,LOCN,DRGNAME,STLEV)),RELEV="" G:STLEV="" DRGLP
RELP S RELEV=$O(^TMP("PSGWSTK",$J,AOU,TYP,LOCN,DRGNAME,STLEV,RELEV)),MIN="" G:RELEV="" STLP
MINLP S MIN=$O(^TMP("PSGWSTK",$J,AOU,TYP,LOCN,DRGNAME,STLEV,RELEV,MIN)),EXP="" G:MIN="" RELP
EXPLP S EXP=$O(^TMP("PSGWSTK",$J,AOU,TYP,LOCN,DRGNAME,STLEV,RELEV,MIN,EXP)) G:MIN="" MINLP D:$Y+5>IOSL HDR G:OUT END
W !?15,$S(LOCN'="Z":LOCN,1:"NOT LISTED"),?30,$S(DRGNAME'="Z":DRGNAME,1:"NAME MISSING"),?74,$S(STLEV'="Z":$J(STLEV,6),1:"NOT LISTED")
W ?89,$S(RELEV'="Z":$J(RELEV,6),1:"NOT LISTED"),?106,$S(MIN'="Z":$J(MIN,6),1:"NOT LISTED") I EXP'="Z" S Y=EXP X ^DD("DD")
W ?119,$S(EXP'="Z":Y,1:"NOT LISTED") G STLP
;
DONE I $E(IOST)'="C" W @IOF
I $E(IOST)="C" W !!,"Press RETURN to continue: " R AUTO:DTIME
END K G,IO("Q"),X,Y,ZTSK,^TMP("PSGWSTK",$J),AOU,EXP,DRGDA,DRGNAME,DRGNM,J,JJ,SEL,IGDA,K,LOCN,LN,MIN,PGCT,AOULP,ANS,AOU,RELEV,STLEV,TYP,%,%I,%H,DA,AUTO,OUT D ^%ZISC
S:$D(ZTQUEUED) ZTREQ="@" Q
;
HDR ;PRINT REPORT HEADER
I $E(IOST)="C"&(PGCT>1) S DIR(0)="E" D ^DIR K DIR I Y'=1 S OUT=1 Q
D NOW^%DTC S Y=$P(%,".") X ^DD("DD") W:$Y @IOF W !,"AOU STOCK LIST BY TYPE/LOCATION"," - DATE: ",Y,?121,"PAGE: ",PGCT I $D(SEL),SEL="I",$D(IGDA) W !,"FOR INVENTORY GROUP - ",$P(^PSI(58.2,IGDA,0),"^")
W !!?2,"AREA OF USE",!?10,"TYPE",?104,"MINIMUM QTY",?119,"EXPIRATION",!?15,"LOCATION",?44,"ITEM",?72,"STOCK LEVEL",?87,"REORDER LEVEL",?104,"TO DISPENSE",?122,"DATE",!,LN S PGCT=PGCT+1 Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSGWLSI1 3312 printed Nov 22, 2024@16:49:46 Page 2
PSGWLSI1 ;BHAM ISC/PTD,CML-Print Stock Items in Order by Type/Location ; 03 Sep 93 / 9:35 AM
+1 ;;2.3; Automatic Replenishment/Ward Stock ;;4 JAN 94
ENQ ;ENTRY POINT WHEN QUEUED
+1 KILL ^TMP("PSGWSTK",$JOB)
SET PGCT=1
SET $PIECE(LN,"-",132)=""
SET AOU=0
SET OUT=0
AOU SET AOU=$ORDER(AOULP(AOU))
if 'AOU
GOTO PRINT
+1 ;
XREF FOR DRGNM=0:0
SET DRGNM=$ORDER(^PSI(58.1,AOU,1,"B",DRGNM))
if 'DRGNM
GOTO AOU
FOR DRGDA=0:0
SET DRGDA=$ORDER(^PSI(58.1,AOU,1,"B",DRGNM,DRGDA))
if 'DRGDA
QUIT
DO BUILD
+1 ;
BUILD IF $PIECE(^PSI(58.1,AOU,1,DRGDA,0),"^",10)="Y"
IF $PIECE(^(0),"^",3)=""
SET $PIECE(^(0),"^",10)=""
+1 IF $PIECE(^PSI(58.1,AOU,1,DRGDA,0),"^",3)'=""
DO NOW^%DTC
SET Y=$PIECE(%,".")
if $PIECE(^(0),"^",3)'>Y
QUIT
+2 IF '$ORDER(^PSI(58.1,AOU,1,DRGDA,2,0))
SET K=9999
DO SETGL
QUIT
+3 FOR TYP=0:0
SET TYP=$ORDER(^PSI(58.1,AOU,1,DRGDA,2,TYP))
if 'TYP
QUIT
SET K=TYP
DO SETGL
+4 QUIT
+5 ;
SETGL IF '$ORDER(^PSDRUG(DRGNM,0))
SET DIK="^PSI(58.1,"_AOU_",1,"
SET DA=DRGDA
SET DA(1)=AOU
DO ^DIK
KILL DIK
QUIT
+1 IF $ORDER(^PSDRUG(DRGNM,0))
SET DRGNAME=$SELECT($PIECE(^PSDRUG(DRGNM,0),"^")'="":$PIECE(^(0),"^"),1:"Z")
+2 SET LOCN=$SELECT($PIECE(^PSI(58.1,AOU,1,DRGDA,0),"^",8)'="":$PIECE(^(0),"^",8),1:"Z")
SET STLEV=$SELECT($PIECE(^(0),"^",2)'="":$PIECE(^(0),"^",2),1:"Z")
+3 SET RELEV=$SELECT($PIECE(^PSI(58.1,AOU,1,DRGDA,0),"^",11)'="":$PIECE(^(0),"^",11),1:"Z")
SET MIN=$SELECT(+$PIECE(^(0),"^",12):$PIECE(^(0),"^",12),1:"Z")
SET EXP="Z"
IF $DATA(^PSI(58.1,AOU,1,DRGDA,"EXP"))
IF ^("EXP")
SET EXP=^("EXP")
+4 SET ^TMP("PSGWSTK",$JOB,AOU,K,LOCN,DRGNAME,STLEV,RELEV,MIN,EXP)=""
+5 QUIT
+6 ;
PRINT SET AOU=0
AOULP SET AOU=$ORDER(^TMP("PSGWSTK",$JOB,AOU))
SET TYP=0
if 'AOU
GOTO DONE
DO HDR
if OUT
GOTO END
WRITE !,"==> ",$PIECE(^PSI(58.1,AOU,0),"^")
TYPLP SET TYP=$ORDER(^TMP("PSGWSTK",$JOB,AOU,TYP))
SET LOCN=""
if 'TYP
GOTO AOULP
if $Y+5>IOSL
DO HDR
if OUT
GOTO END
WRITE !?6,"TYPE: ",$SELECT(TYP=9999:"UNCLASSIFIED BY TYPE",$DATA(^PSI(58.16,TYP,0)):$PIECE(^(0),"^"),1:"TYPE NAME HAS BEEN DELETED IN FILE 58.16")
LOCNLP SET LOCN=$ORDER(^TMP("PSGWSTK",$JOB,AOU,TYP,LOCN))
SET DRGNAME=""
if LOCN=""
GOTO TYPLP
DRGLP SET DRGNAME=$ORDER(^TMP("PSGWSTK",$JOB,AOU,TYP,LOCN,DRGNAME))
SET STLEV=""
if DRGNAME=""
GOTO LOCNLP
STLP SET STLEV=$ORDER(^TMP("PSGWSTK",$JOB,AOU,TYP,LOCN,DRGNAME,STLEV))
SET RELEV=""
if STLEV=""
GOTO DRGLP
RELP SET RELEV=$ORDER(^TMP("PSGWSTK",$JOB,AOU,TYP,LOCN,DRGNAME,STLEV,RELEV))
SET MIN=""
if RELEV=""
GOTO STLP
MINLP SET MIN=$ORDER(^TMP("PSGWSTK",$JOB,AOU,TYP,LOCN,DRGNAME,STLEV,RELEV,MIN))
SET EXP=""
if MIN=""
GOTO RELP
EXPLP SET EXP=$ORDER(^TMP("PSGWSTK",$JOB,AOU,TYP,LOCN,DRGNAME,STLEV,RELEV,MIN,EXP))
if MIN=""
GOTO MINLP
if $Y+5>IOSL
DO HDR
if OUT
GOTO END
+1 WRITE !?15,$SELECT(LOCN'="Z":LOCN,1:"NOT LISTED"),?30,$SELECT(DRGNAME'="Z":DRGNAME,1:"NAME MISSING"),?74,$SELECT(STLEV'="Z":$JUSTIFY(STLEV,6),1:"NOT LISTED")
+2 WRITE ?89,$SELECT(RELEV'="Z":$JUSTIFY(RELEV,6),1:"NOT LISTED"),?106,$SELECT(MIN'="Z":$JUSTIFY(MIN,6),1:"NOT LISTED")
IF EXP'="Z"
SET Y=EXP
XECUTE ^DD("DD")
+3 WRITE ?119,$SELECT(EXP'="Z":Y,1:"NOT LISTED")
GOTO STLP
+4 ;
DONE IF $EXTRACT(IOST)'="C"
WRITE @IOF
+1 IF $EXTRACT(IOST)="C"
WRITE !!,"Press RETURN to continue: "
READ AUTO:DTIME
END KILL G,IO("Q"),X,Y,ZTSK,^TMP("PSGWSTK",$JOB),AOU,EXP,DRGDA,DRGNAME,DRGNM,J,JJ,SEL,IGDA,K,LOCN,LN,MIN,PGCT,AOULP,ANS,AOU,RELEV,STLEV,TYP,%,%I,%H,DA,AUTO,OUT
DO ^%ZISC
+1 if $DATA(ZTQUEUED)
SET ZTREQ="@"
QUIT
+2 ;
HDR ;PRINT REPORT HEADER
+1 IF $EXTRACT(IOST)="C"&(PGCT>1)
SET DIR(0)="E"
DO ^DIR
KILL DIR
IF Y'=1
SET OUT=1
QUIT
+2 DO NOW^%DTC
SET Y=$PIECE(%,".")
XECUTE ^DD("DD")
if $Y
WRITE @IOF
WRITE !,"AOU STOCK LIST BY TYPE/LOCATION"," - DATE: ",Y,?121,"PAGE: ",PGCT
IF $DATA(SEL)
IF SEL="I"
IF $DATA(IGDA)
WRITE !,"FOR INVENTORY GROUP - ",$PIECE(^PSI(58.2,IGDA,0),"^")
+3 WRITE !!?2,"AREA OF USE",!?10,"TYPE",?104,"MINIMUM QTY",?119,"EXPIRATION",!?15,"LOCATION",?44,"ITEM",?72,"STOCK LEVEL",?87,"REORDER LEVEL",?104,"TO DISPENSE",?122,"DATE",!,LN
SET PGCT=PGCT+1
QUIT
