PSDLSTK1 ;BIR/JPW-Print Stock Drugs by Type/Location ; 2 Aug 94
;;3.0; CONTROLLED SUBSTANCES ;;13 Feb 97
START ;entry point for report
K ^TMP("PSDLSTK",$J)
F PSD=0:0 S PSD=$O(NAOU(PSD)) G:'PSD PRINT I $D(^PSD(58.8,PSD,0)) F DRUG=0:0 S DRUG=$O(^PSD(58.8,PSD,1,DRUG)) Q:'DRUG D
.Q:'$D(^PSD(58.8,PSD,1,DRUG,0)) I +$P(^PSD(58.8,PSD,1,DRUG,0),"^",14) D NOW^%DTC I $P(^PSD(58.8,PSD,1,DRUG,0),"^",14)'>X Q
.Q:'$D(^PSDRUG(DRUG,0)) I $D(^PSDRUG(DRUG,0)) S DRUGN=$S($P(^PSDRUG(DRUG,0),"^")]"":$P(^(0),"^"),1:"ZZ/"_DRUG)
.I '$D(^PSD(58.8,PSD,1,DRUG,2,0)) S TYPE="9999" D SET Q
.F TYP=0:0 S TYP=$O(^PSD(58.8,PSD,1,DRUG,2,TYP)) Q:'TYP S TYPE=TYP D SET
PRINT ;print data for stock drugs
K LN S $P(LN,"-",132)="",(PG,PSDOUT)=0,%DT="",X="T" D ^%DT X ^DD("DD") S RPDT=Y D HDR Q:PSDOUT
I '$D(^TMP("PSDLSTK",$J)) W !!,?45,"***** NO DATA FOR THIS REPORT *****" G DONE
F NAOU=0:0 S NAOU=$O(^TMP("PSDLSTK",$J,NAOU)) Q:'NAOU!(PSDOUT) D:$Y+5>IOSL HDR W !,"=>",$S($P(^PSD(58.8,NAOU,0),"^")]"":$P(^(0),"^"),1:"#"_NAOU_" NAME MISSING") D
.F TYP=0:0 S TYP=$O(^TMP("PSDLSTK",$J,NAOU,TYP)) Q:'TYP!(PSDOUT) S TYPE=$S(TYP=9999:"UNCLASSIFIED BY TYPE",$D(^PSI(58.16,TYP,0)):$P(^(0),"^"),1:"TYPE NAME MISSING") D:$Y+5>IOSL HDR Q:PSDOUT W !,?5,"TYPE: "_TYPE,! D
..S LOC="" F S LOC=$O(^TMP("PSDLSTK",$J,NAOU,TYP,LOC)) Q:LOC=""!(PSDOUT) S LOCN=$S(LOC["Z":"NOT LISTED",1:LOC) S DRUG="" F S DRUG=$O(^TMP("PSDLSTK",$J,NAOU,TYP,LOC,DRUG)) Q:DRUG=""!(PSDOUT) D:$Y+5>IOSL HDR Q:PSDOUT D
...W ?8,LOCN,?30,$S(DRUG["ZZ/":"#"_$P(DRUG,"/",2)_" NAME MISSING",1:DRUG),?81,$J($P(^TMP("PSDLSTK",$J,NAOU,TYP,LOC,DRUG),"^"),6),?116,$J($P(^(DRUG),"^",2),6),!
DONE I $E(IOST)'="C" W @IOF
I $E(IOST,1,2)="C-",'PSDOUT W ! K DIR,DIRUT S DIR(0)="EA",DIR("A")="END OF REPORT! Press <RET> to return to the menu" D ^DIR K DIR
END ;
K %,%DT,%H,%I,%ZIS,ANS,DA,DIR,DIROUT,DIRUT,DRUG,DRUGN,DTOUT,DUOUT,IO("Q"),LN,LOC,LOCN,NAOU,NODE,PG,POP,PSD,PSDOUT,PSDT,RPDT,RSTK,STK,TYP,TYPE,X,Y,^TMP("PSDLSTK",$J)
K ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTSK
D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@"
Q
HDR ;lists header information
I $E(IOST,1,2)="C-",PG K DA,DIR S DIR(0)="E" D ^DIR K DIR I 'Y S PSDOUT=1 Q
W:$Y @IOF S PG=PG+1 W !,"NAOU STOCK LIST BY TYPE/LOCATION - DATE: "_RPDT,?121,"PAGE: "_PG,!!,?2,"NARCOTIC AREA OF USE"
W !,?5,"TYPE",!,?8,"LOCATION",?44,"DRUG",?80,"STOCK LEVEL",?115,"REORDER LEVEL",!,LN,!
Q
SET ;sets data in ^TMP global
S NODE=^PSD(58.8,PSD,1,DRUG,0)
S LOC=$S($P(NODE,"^",2)]"":$P(NODE,"^",2),1:"Z"),STK=$S($P(NODE,"^",3)]"":$P(NODE,"^",3),1:"NOT LISTED")
S RSTK=$S($P(NODE,"^",5)]"":$P(NODE,"^",5),1:"NOT LISTED")
S ^TMP("PSDLSTK",$J,PSD,TYPE,LOC,DRUGN)=STK_"^"_RSTK
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSDLSTK1 2679 printed Dec 13, 2024@01:46:42 Page 2
PSDLSTK1 ;BIR/JPW-Print Stock Drugs by Type/Location ; 2 Aug 94
+1 ;;3.0; CONTROLLED SUBSTANCES ;;13 Feb 97
START ;entry point for report
+1 KILL ^TMP("PSDLSTK",$JOB)
+2 FOR PSD=0:0
SET PSD=$ORDER(NAOU(PSD))
if 'PSD
GOTO PRINT
IF $DATA(^PSD(58.8,PSD,0))
FOR DRUG=0:0
SET DRUG=$ORDER(^PSD(58.8,PSD,1,DRUG))
if 'DRUG
QUIT
Begin DoDot:1
+3 if '$DATA(^PSD(58.8,PSD,1,DRUG,0))
QUIT
IF +$PIECE(^PSD(58.8,PSD,1,DRUG,0),"^",14)
DO NOW^%DTC
IF $PIECE(^PSD(58.8,PSD,1,DRUG,0),"^",14)'>X
QUIT
+4 if '$DATA(^PSDRUG(DRUG,0))
QUIT
IF $DATA(^PSDRUG(DRUG,0))
SET DRUGN=$SELECT($PIECE(^PSDRUG(DRUG,0),"^")]"":$PIECE(^(0),"^"),1:"ZZ/"_DRUG)
+5 IF '$DATA(^PSD(58.8,PSD,1,DRUG,2,0))
SET TYPE="9999"
DO SET
QUIT
+6 FOR TYP=0:0
SET TYP=$ORDER(^PSD(58.8,PSD,1,DRUG,2,TYP))
if 'TYP
QUIT
SET TYPE=TYP
DO SET
End DoDot:1
PRINT ;print data for stock drugs
+1 KILL LN
SET $PIECE(LN,"-",132)=""
SET (PG,PSDOUT)=0
SET %DT=""
SET X="T"
DO ^%DT
XECUTE ^DD("DD")
SET RPDT=Y
DO HDR
if PSDOUT
QUIT
+2 IF '$DATA(^TMP("PSDLSTK",$JOB))
WRITE !!,?45,"***** NO DATA FOR THIS REPORT *****"
GOTO DONE
+3 FOR NAOU=0:0
SET NAOU=$ORDER(^TMP("PSDLSTK",$JOB,NAOU))
if 'NAOU!(PSDOUT)
QUIT
if $Y+5>IOSL
DO HDR
WRITE !,"=>",$SELECT($PIECE(^PSD(58.8,NAOU,0),"^")]"":$PIECE(^(0),"^"),1:"#"_NAOU_" NAME MISSING")
Begin DoDot:1
+4 FOR TYP=0:0
SET TYP=$ORDER(^TMP("PSDLSTK",$JOB,NAOU,TYP))
if 'TYP!(PSDOUT)
QUIT
SET TYPE=$SELECT(TYP=9999:"UNCLASSIFIED BY TYPE",$DATA(^PSI(58.16,TYP,0)):$PIECE(^(0),"^"),1:"TYPE NAME MISSING")
if $Y+5>IOSL
DO HDR
if PSDOUT
QUIT
WRITE !,?5,"TYPE: "_TYPE,!
Begin DoDot:2
+5 SET LOC=""
FOR
SET LOC=$ORDER(^TMP("PSDLSTK",$JOB,NAOU,TYP,LOC))
if LOC=""!(PSDOUT)
QUIT
SET LOCN=$SELECT(LOC["Z":"NOT LISTED",1:LOC)
SET DRUG=""
FOR
SET DRUG=$ORDER(^TMP("PSDLSTK",$JOB,NAOU,TYP,LOC,DRUG))
if DRUG=""!(PSDOUT)
QUIT
if $Y+5>IOSL
DO HDR
if PSDOUT
QUIT
Begin DoDot:3
+6 WRITE ?8,LOCN,?30,$SELECT(DRUG["ZZ/":"#"_$PIECE(DRUG,"/",2)_" NAME MISSING",1:DRUG),?81,$JUSTIFY($PIECE(^TMP("PSDLSTK",$JOB,NAOU,TYP,LOC,DRUG),"^"),6),?116,$JUSTIFY($PIECE(^(DRUG),"^",2),6),!
End DoDot:3
End DoDot:2
End DoDot:1
DONE IF $EXTRACT(IOST)'="C"
WRITE @IOF
+1 IF $EXTRACT(IOST,1,2)="C-"
IF 'PSDOUT
WRITE !
KILL DIR,DIRUT
SET DIR(0)="EA"
SET DIR("A")="END OF REPORT! Press <RET> to return to the menu"
DO ^DIR
KILL DIR
END ;
+1 KILL %,%DT,%H,%I,%ZIS,ANS,DA,DIR,DIROUT,DIRUT,DRUG,DRUGN,DTOUT,DUOUT,IO("Q"),LN,LOC,LOCN,NAOU,NODE,PG,POP,PSD,PSDOUT,PSDT,RPDT,RSTK,STK,TYP,TYPE,X,Y,^TMP("PSDLSTK",$JOB)
+2 KILL ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTSK
+3 DO ^%ZISC
if $DATA(ZTQUEUED)
SET ZTREQ="@"
+4 QUIT
HDR ;lists header information
+1 IF $EXTRACT(IOST,1,2)="C-"
IF PG
KILL DA,DIR
SET DIR(0)="E"
DO ^DIR
KILL DIR
IF 'Y
SET PSDOUT=1
QUIT
+2 if $Y
WRITE @IOF
SET PG=PG+1
WRITE !,"NAOU STOCK LIST BY TYPE/LOCATION - DATE: "_RPDT,?121,"PAGE: "_PG,!!,?2,"NARCOTIC AREA OF USE"
+3 WRITE !,?5,"TYPE",!,?8,"LOCATION",?44,"DRUG",?80,"STOCK LEVEL",?115,"REORDER LEVEL",!,LN,!
+4 QUIT
SET ;sets data in ^TMP global
+1 SET NODE=^PSD(58.8,PSD,1,DRUG,0)
+2 SET LOC=$SELECT($PIECE(NODE,"^",2)]"":$PIECE(NODE,"^",2),1:"Z")
SET STK=$SELECT($PIECE(NODE,"^",3)]"":$PIECE(NODE,"^",3),1:"NOT LISTED")
+3 SET RSTK=$SELECT($PIECE(NODE,"^",5)]"":$PIECE(NODE,"^",5),1:"NOT LISTED")
+4 SET ^TMP("PSDLSTK",$JOB,PSD,TYPE,LOC,DRUGN)=STK_"^"_RSTK
+5 QUIT
