PSGWVW ;BHAM ISC/PTD,CML-Lookup Item and List Wards/AOUs Which Stock It ; 29 Dec 93 / 2:31 PM
;;2.3; Automatic Replenishment/Ward Stock ;;4 JAN 94
W !!,"Using this option, you may look up the wards and/or Areas of Use",!,"which stock the item you select.",!!,"The right margin for this report is 80.",!,"You may queue the report to print at a later time.",!!
DIC S DIC="^PSDRUG(",DIC(0)="QEAOM",DIC("A")="Select ITEM Name: " D ^DIC K DIC G:Y<0 END S DRGNUM=+Y
K %ZIS,IOP S %ZIS="QM",%ZIS("B")="" D ^%ZIS I POP W !,"NO DEVICE SELECTED OR REPORT PRINTED." G END
DEV I $D(IO("Q")) K IO("Q") S ZTRTN="ENQ^PSGWVW",ZTDESC="Print Ward/AOU List for Item" S ZTSAVE("DRGNUM")=""
I D ^%ZTLOAD,HOME^%ZIS K ZTSK G END
U IO
ENQ ;ENTRY POINT WHEN QUEUED
S AOU=0 K ^TMP("PSGWITEM",$J) S $P(LN,"-",80)=""
AOULP S AOU=$O(^PSI(58.1,AOU)) G:'AOU PRINT S AOUN=$P(^PSI(58.1,AOU,0),"^") I $D(^PSI(58.1,AOU,"I")),^("I")]"",^("I")'>DT S AOUN=AOUN_"^"_"I"
DRGLP I $D(^PSI(58.1,AOU,1,"B",DRGNUM)) D CHKDRG
G AOULP
;
CHKDRG S DRGDA=0,DRGDA=$O(^PSI(58.1,AOU,1,"B",DRGNUM,DRGDA))
I $P(^PSI(58.1,AOU,1,DRGDA,0),"^",10)="Y",$P(^(0),"^",3)="" S $P(^(0),"^",10)=""
Q:$P(^PSI(58.1,AOU,1,DRGDA,0),"^",3)'=""
S LOCN=$S($P(^PSI(58.1,AOU,1,DRGDA,0),"^",8)'="":$P(^(0),"^",8),1:"NOT LISTED") S STLEV=$S($P(^PSI(58.1,AOU,1,DRGDA,0),"^",2)'="":$P(^(0),"^",2),1:"NOT LISTED")
I '$O(^PSI(58.1,AOU,1,DRGDA,4,0)) S WARD=" ",^TMP("PSGWITEM",$J,DRGNUM,WARD,AOUN,LOCN,STLEV)="" Q
S WRD=0 F J=0:0 S WRD=$O(^PSI(58.1,AOU,1,DRGDA,4,WRD)) Q:'WRD S WARD=$S($D(^DIC(42,WRD,0)):$P(^(0),"^"),1:"NOT FOUND") S ^TMP("PSGWITEM",$J,DRGNUM,WARD,AOUN,LOCN,STLEV)=""
Q
;
PRINT ;
S DRG=0,QFLG="" D HDR1 I '$O(^TMP("PSGWITEM",$J,0)) W !!,$P(^PSDRUG(DRGNUM,0),"^")," is not a Ward Stock/Auto Replenishment item." G DONE
LOOP S DRG=$O(^TMP("PSGWITEM",$J,DRG)) G:'DRG MSG G:QFLG END S DRGNAM=$P(^PSDRUG(DRG,0),"^"),WARD="" D HDR2
WD S WARD=$O(^TMP("PSGWITEM",$J,DRG,WARD)),AOUN="" G:WARD="" LOOP I $Y+5>IOSL D PRTCHK G:QFLG END W !
W WARD
AOU S AOUN=$O(^TMP("PSGWITEM",$J,DRG,WARD,AOUN)),LOCN="" G:AOUN="" WD W ?28,$P(AOUN,"^") I $P(AOUN,"^",2)="I" S INACT=1 W " *"
LOC S LOCN=$O(^TMP("PSGWITEM",$J,DRG,WARD,AOUN,LOCN)),STLEV="" G:LOCN="" AOU W ?56,LOCN
STK S STLEV=$O(^TMP("PSGWITEM",$J,DRG,WARD,AOUN,LOCN,STLEV)) G:STLEV="" LOC W ?70,$S(STLEV'="NOT LISTED":$J(STLEV,4),1:STLEV),!
G STK
;
MSG I INACT W !!!,"* Indicates AOU is currently Inactive"
DONE I $E(IOST)'="C" W @IOF
I $E(IOST)="C" D:'QFLG SS^PSGWUTL1
END K ANS,QFLG,Y,LN,ZTSK,AOU,AOUN,DRG,DRGDA,DRGNAM,DRGNUM,INACT,J,LOCN,WARD,STLEV,WRD,^TMP("PSGWITEM",$J),IO("Q")
D ^%ZISC
S:$D(ZTQUEUED) ZTREQ="@" Q
HDR1 ;
S INACT=0
W:$Y @IOF W !,"WARD/AOU LIST FOR AN ITEM",?60,"DATE: " S Y=DT X ^DD("DD") W Y,!,"ITEM NAME",!?70,"STOCK",!?10,"WARD",?35,"AREA OF USE",?56,"LOCATION",?70,"LEVEL",!,LN Q
HDR2 W !!,"==>",DRGNAM,!! Q
PRTCHK ;
I INACT W !!,"* Indicates AOU is currently Inactive"
I $E(IOST)="C" W !!,"Press <RETURN> to Continue or ""^"" to Exit: " R ANS:DTIME S:'$T ANS="^" D:ANS?1."?" HELP^PSGWUTL1 I ANS="^" S QFLG=1 Q
D HDR1,HDR2 Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSGWVW 3099 printed Apr 09, 2024@20:44:22 Page 2
PSGWVW ;BHAM ISC/PTD,CML-Lookup Item and List Wards/AOUs Which Stock It ; 29 Dec 93 / 2:31 PM
+1 ;;2.3; Automatic Replenishment/Ward Stock ;;4 JAN 94
+2 WRITE !!,"Using this option, you may look up the wards and/or Areas of Use",!,"which stock the item you select.",!!,"The right margin for this report is 80.",!,"You may queue the report to print at a later time.",!!
DIC SET DIC="^PSDRUG("
SET DIC(0)="QEAOM"
SET DIC("A")="Select ITEM Name: "
DO ^DIC
KILL DIC
if Y<0
GOTO END
SET DRGNUM=+Y
+1 KILL %ZIS,IOP
SET %ZIS="QM"
SET %ZIS("B")=""
DO ^%ZIS
IF POP
WRITE !,"NO DEVICE SELECTED OR REPORT PRINTED."
GOTO END
DEV IF $DATA(IO("Q"))
KILL IO("Q")
SET ZTRTN="ENQ^PSGWVW"
SET ZTDESC="Print Ward/AOU List for Item"
SET ZTSAVE("DRGNUM")=""
+1 IF $TEST
DO ^%ZTLOAD
DO HOME^%ZIS
KILL ZTSK
GOTO END
+2 USE IO
ENQ ;ENTRY POINT WHEN QUEUED
+1 SET AOU=0
KILL ^TMP("PSGWITEM",$JOB)
SET $PIECE(LN,"-",80)=""
AOULP SET AOU=$ORDER(^PSI(58.1,AOU))
if 'AOU
GOTO PRINT
SET AOUN=$PIECE(^PSI(58.1,AOU,0),"^")
IF $DATA(^PSI(58.1,AOU,"I"))
IF ^("I")]""
IF ^("I")'>DT
SET AOUN=AOUN_"^"_"I"
DRGLP IF $DATA(^PSI(58.1,AOU,1,"B",DRGNUM))
DO CHKDRG
+1 GOTO AOULP
+2 ;
CHKDRG SET DRGDA=0
SET DRGDA=$ORDER(^PSI(58.1,AOU,1,"B",DRGNUM,DRGDA))
+1 IF $PIECE(^PSI(58.1,AOU,1,DRGDA,0),"^",10)="Y"
IF $PIECE(^(0),"^",3)=""
SET $PIECE(^(0),"^",10)=""
+2 if $PIECE(^PSI(58.1,AOU,1,DRGDA,0),"^",3)'=""
QUIT
+3 SET LOCN=$SELECT($PIECE(^PSI(58.1,AOU,1,DRGDA,0),"^",8)'="":$PIECE(^(0),"^",8),1:"NOT LISTED")
SET STLEV=$SELECT($PIECE(^PSI(58.1,AOU,1,DRGDA,0),"^",2)'="":$PIECE(^(0),"^",2),1:"NOT LISTED")
+4 IF '$ORDER(^PSI(58.1,AOU,1,DRGDA,4,0))
SET WARD=" "
SET ^TMP("PSGWITEM",$JOB,DRGNUM,WARD,AOUN,LOCN,STLEV)=""
QUIT
+5 SET WRD=0
FOR J=0:0
SET WRD=$ORDER(^PSI(58.1,AOU,1,DRGDA,4,WRD))
if 'WRD
QUIT
SET WARD=$SELECT($DATA(^DIC(42,WRD,0)):$PIECE(^(0),"^"),1:"NOT FOUND")
SET ^TMP("PSGWITEM",$JOB,DRGNUM,WARD,AOUN,LOCN,STLEV)=""
+6 QUIT
+7 ;
PRINT ;
+1 SET DRG=0
SET QFLG=""
DO HDR1
IF '$ORDER(^TMP("PSGWITEM",$JOB,0))
WRITE !!,$PIECE(^PSDRUG(DRGNUM,0),"^")," is not a Ward Stock/Auto Replenishment item."
GOTO DONE
LOOP SET DRG=$ORDER(^TMP("PSGWITEM",$JOB,DRG))
if 'DRG
GOTO MSG
if QFLG
GOTO END
SET DRGNAM=$PIECE(^PSDRUG(DRG,0),"^")
SET WARD=""
DO HDR2
WD SET WARD=$ORDER(^TMP("PSGWITEM",$JOB,DRG,WARD))
SET AOUN=""
if WARD=""
GOTO LOOP
IF $Y+5>IOSL
DO PRTCHK
if QFLG
GOTO END
WRITE !
+1 WRITE WARD
AOU SET AOUN=$ORDER(^TMP("PSGWITEM",$JOB,DRG,WARD,AOUN))
SET LOCN=""
if AOUN=""
GOTO WD
WRITE ?28,$PIECE(AOUN,"^")
IF $PIECE(AOUN,"^",2)="I"
SET INACT=1
WRITE " *"
LOC SET LOCN=$ORDER(^TMP("PSGWITEM",$JOB,DRG,WARD,AOUN,LOCN))
SET STLEV=""
if LOCN=""
GOTO AOU
WRITE ?56,LOCN
STK SET STLEV=$ORDER(^TMP("PSGWITEM",$JOB,DRG,WARD,AOUN,LOCN,STLEV))
if STLEV=""
GOTO LOC
WRITE ?70,$SELECT(STLEV'="NOT LISTED":$JUSTIFY(STLEV,4),1:STLEV),!
+1 GOTO STK
+2 ;
MSG IF INACT
WRITE !!!,"* Indicates AOU is currently Inactive"
DONE IF $EXTRACT(IOST)'="C"
WRITE @IOF
+1 IF $EXTRACT(IOST)="C"
if 'QFLG
DO SS^PSGWUTL1
END KILL ANS,QFLG,Y,LN,ZTSK,AOU,AOUN,DRG,DRGDA,DRGNAM,DRGNUM,INACT,J,LOCN,WARD,STLEV,WRD,^TMP("PSGWITEM",$JOB),IO("Q")
+1 DO ^%ZISC
+2 if $DATA(ZTQUEUED)
SET ZTREQ="@"
QUIT
HDR1 ;
+1 SET INACT=0
+2 if $Y
WRITE @IOF
WRITE !,"WARD/AOU LIST FOR AN ITEM",?60,"DATE: "
SET Y=DT
XECUTE ^DD("DD")
WRITE Y,!,"ITEM NAME",!?70,"STOCK",!?10,"WARD",?35,"AREA OF USE",?56,"LOCATION",?70,"LEVEL",!,LN
QUIT
HDR2 WRITE !!,"==>",DRGNAM,!!
QUIT
PRTCHK ;
+1 IF INACT
WRITE !!,"* Indicates AOU is currently Inactive"
+2 IF $EXTRACT(IOST)="C"
WRITE !!,"Press <RETURN> to Continue or ""^"" to Exit: "
READ ANS:DTIME
if '$TEST
SET ANS="^"
if ANS?1."?"
DO HELP^PSGWUTL1
IF ANS="^"
SET QFLG=1
QUIT
+3 DO HDR1
DO HDR2
QUIT
