PSADAI ;BIR/LTL/,JMB/PDW-Drug Balances by Location ;7/23/97
;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**15,53**; 10/24/97
;
;Reference to ^PS(59.4 are covered by IA #2505
;References to ^PSDRUG( are covered by IA #2095
;References to ^PRCP( are covered by IA #214
;References to ^PS(59 are covered by IA #212
;
LOC S (PSACNT,PSAOUT)=0 D ^PSAUTL3 G:PSAOUT EXIT1
S PSACNT=0,PSACHK=$O(PSALOC(""))
I PSACHK="",'PSALOC W !,"There are no active pharmacy locations." G EXIT1
I PSACHK'="",$G(PSASEL)="",PSALOC W !!,PSALOCN
;
DEVICE W ! K IO("Q") S %ZIS="Q" D ^%ZIS I POP S DTOUT=1,Y=-1 W !,"No Device was selected or output printed." G EXIT1
I $D(IO("Q")) S ZTRTN="START^PSADAI",ZTDESC="Drug Accountability - Drug Location Report",ZTSAVE("PSALOC(")="" D ^%ZTLOAD,HOME^%ZIS S Y=1 G EXIT1
START S PSAOUT=0,PSALOCN="",$P(PSASLN,"-",80)=""
S PSARPDT=$E($$HTFM^XLFDT($H),1,12),PSADT=$P(PSARPDT,".")
S PSARPDT=$E(PSADT,4,5)_"/"_$E(PSADT,6,7)_"/"_$E(PSADT,2,3)_"@"_$P(PSARPDT,".",2)
F S PSALOCN=$O(PSALOC(PSALOCN)) Q:PSALOCN="" D Q:PSAOUT
.S PSAIEN=0 F S PSAIEN=+$O(PSALOC(PSALOCN,PSAIEN)) Q:'PSAIEN D Q:PSAOUT
..S PSAISIT=+$P(PSALOC(PSALOCN,PSAIEN),"^"),PSAOSIT=+$P(PSALOC(PSALOCN,PSAIEN),"^",2)
..S PSAISITN=$S($P($G(^PS(59.4,PSAISIT,0)),"^")'="":$P($G(^PS(59.4,PSAISIT,0)),"^"),1:"UNKNOWN")
..S PSAOSITN=$S($P($G(^PS(59,PSAOSIT,0)),"^")'="":$P($G(^PS(59,PSAOSIT,0)),"^"),1:"UNKNOWN")
..S PSASITES=$S(PSAISIT&(PSAOSIT):PSAISITN_" (IP) "_PSAOSITN_" (OP)",PSAISIT:PSAISITN_" (IP)",1:PSAOSITN_" (OP)")
..D COMPILE D:'PSAOUT DONE
EXIT D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@" K IO("Q") W:$E(IOST,1,2)="C-" @IOF
EXIT1 K ^TMP($J,"PSADRG"),%ZIS,DIR,DIRUT,DTOUT
K PSACHK,PSACNT,PSADRG,PSADT,PSAIEN,PSAINV,PSAISIT,PSAISITN,PSALEN,PSALINK,PSALNK,PSALOC,PSALOCA,PSALOCN,PSAOSIT,PSAOSITN
K PSAOUT,PSAPG,PSARPDT,PSAS,PSASEL,PSASITES,PSASLN,PSASS,PSATMP,X,Y,ZTDESC,ZTIO,ZTRTN,ZTSAVE,ZTDTH,ZTSK
Q
COMPILE ;Creates ^TMP(Drug Name)= current balance ^ dispense unit ^ total inventory (current balance in 50)
K ^TMP($J,"PSADRG")
S PSADRG=0 F S PSADRG=+$O(^PSD(58.8,PSAIEN,1,PSADRG)) Q:'PSADRG D
.Q:'$D(^PSDRUG(PSADRG,0))
.I $P($G(^PSD(58.8,PSAIEN,1,PSADRG,0)),"^",4)=0,$P($G(^PSD(58.8,PSAIEN,1,PSADRG,0)),"^",14)<DT Q ;*53 0 QT & inactive
.S ^TMP($J,"PSADRG",$P(^PSDRUG(PSADRG,0),"^"))=$P($G(^PSD(58.8,PSAIEN,1,PSADRG,0)),"^",4)_"^"_$P($G(^PSDRUG(PSADRG,660)),"^",8)_"^"_$P($G(^PSDRUG(PSADRG,660.1)),"^")
PRINT ;Prints body of report
;Finds longest length of inventory link(s).
S (PSALNK,PSALEN)=0 F S PSALNK=+$O(^PSD(58.8,PSAIEN,4,PSALNK)) Q:'PSALNK D
.S PSALINK(+$P($G(^PSD(58.8,PSAIEN,4,PSALNK,0)),"^"))=""
.S PSAINV="INVENTORY LINK: "_$S($P($G(^PRCP(445,PSALNK,0)),"^")'="":$P($G(^PRCP(445,PSALNK,0)),"^"),1:"NONE")
.S:PSALEN<$L(PSAINV) PSALEN=$L(PSAINV)
S PSAPG=0,PSADRG="" D HDR
;If no data in ^TMP, prints message & exit routine.
S PSATMP=$O(^TMP($J,"PSADRG","")) I PSATMP="" W !!,"<< NO DRUGS WERE FOUND. >>",! G DONE
;If data is found, prints drug name, current balance, & dispense unit
F S PSADRG=$O(^TMP($J,"PSADRG",PSADRG)) Q:PSADRG="" D I PSAOUT W:$E(IOST,1,2)="C-" @IOF Q
.D:$Y+4>IOSL HDR Q:PSAOUT
.W !,PSADRG
.S PSALEN=$L($P($P(^TMP($J,"PSADRG",PSADRG),"^"),".",2))
.W ?(44+PSALEN),$J($FN($P(^TMP($J,"PSADRG",PSADRG),"^"),",",PSALEN),(10+PSALEN))
.W:$P(^TMP($J,"PSADRG",PSADRG),"^",2)'="" ?61,$P(^TMP($J,"PSADRG",PSADRG),"^",2)
.W ?69,$J($FN($P(^TMP($J,"PSADRG",PSADRG),"^",3),",",0),9)
Q
DONE ;Holds screen or ejects paper if sent to printer
I $E(IOST,1,2)="C-" D
.S PSAS=22-$Y F PSASS=1:1:PSAS W !
.S DIR(0)="EA",DIR("A")="End of display! Enter RETURN to continue or '^' to exit:" D ^DIR K DIR S:'Y PSAOUT=1
W:$E(IOST)'="C" @IOF
Q
HDR ;Print header
S PSAPG=PSAPG+1
I PSAPG=1,$E(IOST,1,2)="C-" W @IOF
I PSAPG>1,$E(IOST)'="C" W @IOF
I $E(IOST,1,2)="C-",PSAPG>1 D Q:PSAOUT
.S PSAS=22-$Y F PSASS=1:1:PSAS W !
.S DIR(0)="E" D ^DIR K DIR W:'$G(DIRUT) @IOF S:'Y PSAOUT=1
W:$E(IOST)'="C" !!,PSARPDT W:$E(IOST,1,2)="C-" !
W ?21,"D R U G A C C O U N T A B I L I T Y",?71,"Page ",$J(PSAPG,2)
W !?24,"DRUG BALANCES BY LOCATION REPORT"
W !?((80-$L(PSALOCN))/2),PSALOCN
S PSALNK=0 F S PSALNK=$O(PSALINK(PSALNK)) Q:'PSALNK D
.S PSAINV="INVENTORY LINK: "_$S($P($G(^PRCP(445,PSALNK,0)),"^")'="":$P($G(^PRCP(445,PSALNK,0)),"^"),1:"NONE")
.W !?((80-$L(PSAINV))/2),PSAINV
W !!?47,"CURRENT",?58,"DISPENSE",?72,"TOTAL"
W !,"DRUG NAME",?47,"BALANCE",?60,"UNIT",?70,"INVENTORY",!,PSASLN
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSADAI 4512 printed Sep 23, 2025@19:25:10 Page 2
PSADAI ;BIR/LTL/,JMB/PDW-Drug Balances by Location ;7/23/97
+1 ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**15,53**; 10/24/97
+2 ;
+3 ;Reference to ^PS(59.4 are covered by IA #2505
+4 ;References to ^PSDRUG( are covered by IA #2095
+5 ;References to ^PRCP( are covered by IA #214
+6 ;References to ^PS(59 are covered by IA #212
+7 ;
LOC SET (PSACNT,PSAOUT)=0
DO ^PSAUTL3
if PSAOUT
GOTO EXIT1
+1 SET PSACNT=0
SET PSACHK=$ORDER(PSALOC(""))
+2 IF PSACHK=""
IF 'PSALOC
WRITE !,"There are no active pharmacy locations."
GOTO EXIT1
+3 IF PSACHK'=""
IF $GET(PSASEL)=""
IF PSALOC
WRITE !!,PSALOCN
+4 ;
DEVICE WRITE !
KILL IO("Q")
SET %ZIS="Q"
DO ^%ZIS
IF POP
SET DTOUT=1
SET Y=-1
WRITE !,"No Device was selected or output printed."
GOTO EXIT1
+1 IF $DATA(IO("Q"))
SET ZTRTN="START^PSADAI"
SET ZTDESC="Drug Accountability - Drug Location Report"
SET ZTSAVE("PSALOC(")=""
DO ^%ZTLOAD
DO HOME^%ZIS
SET Y=1
GOTO EXIT1
START SET PSAOUT=0
SET PSALOCN=""
SET $PIECE(PSASLN,"-",80)=""
+1 SET PSARPDT=$EXTRACT($$HTFM^XLFDT($HOROLOG),1,12)
SET PSADT=$PIECE(PSARPDT,".")
+2 SET PSARPDT=$EXTRACT(PSADT,4,5)_"/"_$EXTRACT(PSADT,6,7)_"/"_$EXTRACT(PSADT,2,3)_"@"_$PIECE(PSARPDT,".",2)
+3 FOR
SET PSALOCN=$ORDER(PSALOC(PSALOCN))
if PSALOCN=""
QUIT
Begin DoDot:1
+4 SET PSAIEN=0
FOR
SET PSAIEN=+$ORDER(PSALOC(PSALOCN,PSAIEN))
if 'PSAIEN
QUIT
Begin DoDot:2
+5 SET PSAISIT=+$PIECE(PSALOC(PSALOCN,PSAIEN),"^")
SET PSAOSIT=+$PIECE(PSALOC(PSALOCN,PSAIEN),"^",2)
+6 SET PSAISITN=$SELECT($PIECE($GET(^PS(59.4,PSAISIT,0)),"^")'="":$PIECE($GET(^PS(59.4,PSAISIT,0)),"^"),1:"UNKNOWN")
+7 SET PSAOSITN=$SELECT($PIECE($GET(^PS(59,PSAOSIT,0)),"^")'="":$PIECE($GET(^PS(59,PSAOSIT,0)),"^"),1:"UNKNOWN")
+8 SET PSASITES=$SELECT(PSAISIT&(PSAOSIT):PSAISITN_" (IP) "_PSAOSITN_" (OP)",PSAISIT:PSAISITN_" (IP)",1:PSAOSITN_" (OP)")
+9 DO COMPILE
if 'PSAOUT
DO DONE
End DoDot:2
if PSAOUT
QUIT
End DoDot:1
if PSAOUT
QUIT
EXIT DO ^%ZISC
if $DATA(ZTQUEUED)
SET ZTREQ="@"
KILL IO("Q")
if $EXTRACT(IOST,1,2)="C-"
WRITE @IOF
EXIT1 KILL ^TMP($JOB,"PSADRG"),%ZIS,DIR,DIRUT,DTOUT
+1 KILL PSACHK,PSACNT,PSADRG,PSADT,PSAIEN,PSAINV,PSAISIT,PSAISITN,PSALEN,PSALINK,PSALNK,PSALOC,PSALOCA,PSALOCN,PSAOSIT,PSAOSITN
+2 KILL PSAOUT,PSAPG,PSARPDT,PSAS,PSASEL,PSASITES,PSASLN,PSASS,PSATMP,X,Y,ZTDESC,ZTIO,ZTRTN,ZTSAVE,ZTDTH,ZTSK
+3 QUIT
COMPILE ;Creates ^TMP(Drug Name)= current balance ^ dispense unit ^ total inventory (current balance in 50)
+1 KILL ^TMP($JOB,"PSADRG")
+2 SET PSADRG=0
FOR
SET PSADRG=+$ORDER(^PSD(58.8,PSAIEN,1,PSADRG))
if 'PSADRG
QUIT
Begin DoDot:1
+3 if '$DATA(^PSDRUG(PSADRG,0))
QUIT
+4 ;*53 0 QT & inactive
IF $PIECE($GET(^PSD(58.8,PSAIEN,1,PSADRG,0)),"^",4)=0
IF $PIECE($GET(^PSD(58.8,PSAIEN,1,PSADRG,0)),"^",14)<DT
QUIT
+5 SET ^TMP($JOB,"PSADRG",$PIECE(^PSDRUG(PSADRG,0),"^"))=$PIECE($GET(^PSD(58.8,PSAIEN,1,PSADRG,0)),"^",4)_"^"_$PIECE($GET(^PSDRUG(PSADRG,660)),"^",8)_"^"_$PIECE($GET(^PSDRUG(PSADRG,660.1)),"^")
End DoDot:1
PRINT ;Prints body of report
+1 ;Finds longest length of inventory link(s).
+2 SET (PSALNK,PSALEN)=0
FOR
SET PSALNK=+$ORDER(^PSD(58.8,PSAIEN,4,PSALNK))
if 'PSALNK
QUIT
Begin DoDot:1
+3 SET PSALINK(+$PIECE($GET(^PSD(58.8,PSAIEN,4,PSALNK,0)),"^"))=""
+4 SET PSAINV="INVENTORY LINK: "_$SELECT($PIECE($GET(^PRCP(445,PSALNK,0)),"^")'="":$PIECE($GET(^PRCP(445,PSALNK,0)),"^"),1:"NONE")
+5 if PSALEN<$LENGTH(PSAINV)
SET PSALEN=$LENGTH(PSAINV)
End DoDot:1
+6 SET PSAPG=0
SET PSADRG=""
DO HDR
+7 ;If no data in ^TMP, prints message & exit routine.
+8 SET PSATMP=$ORDER(^TMP($JOB,"PSADRG",""))
IF PSATMP=""
WRITE !!,"<< NO DRUGS WERE FOUND. >>",!
GOTO DONE
+9 ;If data is found, prints drug name, current balance, & dispense unit
+10 FOR
SET PSADRG=$ORDER(^TMP($JOB,"PSADRG",PSADRG))
if PSADRG=""
QUIT
Begin DoDot:1
+11 if $Y+4>IOSL
DO HDR
if PSAOUT
QUIT
+12 WRITE !,PSADRG
+13 SET PSALEN=$LENGTH($PIECE($PIECE(^TMP($JOB,"PSADRG",PSADRG),"^"),".",2))
+14 WRITE ?(44+PSALEN),$JUSTIFY($FNUMBER($PIECE(^TMP($JOB,"PSADRG",PSADRG),"^"),",",PSALEN),(10+PSALEN))
+15 if $PIECE(^TMP($JOB,"PSADRG",PSADRG),"^",2)'=""
WRITE ?61,$PIECE(^TMP($JOB,"PSADRG",PSADRG),"^",2)
+16 WRITE ?69,$JUSTIFY($FNUMBER($PIECE(^TMP($JOB,"PSADRG",PSADRG),"^",3),",",0),9)
End DoDot:1
IF PSAOUT
if $EXTRACT(IOST,1,2)="C-"
WRITE @IOF
QUIT
+17 QUIT
DONE ;Holds screen or ejects paper if sent to printer
+1 IF $EXTRACT(IOST,1,2)="C-"
Begin DoDot:1
+2 SET PSAS=22-$Y
FOR PSASS=1:1:PSAS
WRITE !
+3 SET DIR(0)="EA"
SET DIR("A")="End of display! Enter RETURN to continue or '^' to exit:"
DO ^DIR
KILL DIR
if 'Y
SET PSAOUT=1
End DoDot:1
+4 if $EXTRACT(IOST)'="C"
WRITE @IOF
+5 QUIT
HDR ;Print header
+1 SET PSAPG=PSAPG+1
+2 IF PSAPG=1
IF $EXTRACT(IOST,1,2)="C-"
WRITE @IOF
+3 IF PSAPG>1
IF $EXTRACT(IOST)'="C"
WRITE @IOF
+4 IF $EXTRACT(IOST,1,2)="C-"
IF PSAPG>1
Begin DoDot:1
+5 SET PSAS=22-$Y
FOR PSASS=1:1:PSAS
WRITE !
+6 SET DIR(0)="E"
DO ^DIR
KILL DIR
if '$GET(DIRUT)
WRITE @IOF
if 'Y
SET PSAOUT=1
End DoDot:1
if PSAOUT
QUIT
+7 if $EXTRACT(IOST)'="C"
WRITE !!,PSARPDT
if $EXTRACT(IOST,1,2)="C-"
WRITE !
+8 WRITE ?21,"D R U G A C C O U N T A B I L I T Y",?71,"Page ",$JUSTIFY(PSAPG,2)
+9 WRITE !?24,"DRUG BALANCES BY LOCATION REPORT"
+10 WRITE !?((80-$LENGTH(PSALOCN))/2),PSALOCN
+11 SET PSALNK=0
FOR
SET PSALNK=$ORDER(PSALINK(PSALNK))
if 'PSALNK
QUIT
Begin DoDot:1
+12 SET PSAINV="INVENTORY LINK: "_$SELECT($PIECE($GET(^PRCP(445,PSALNK,0)),"^")'="":$PIECE($GET(^PRCP(445,PSALNK,0)),"^"),1:"NONE")
+13 WRITE !?((80-$LENGTH(PSAINV))/2),PSAINV
End DoDot:1
+14 WRITE !!?47,"CURRENT",?58,"DISPENSE",?72,"TOTAL"
+15 WRITE !,"DRUG NAME",?47,"BALANCE",?60,"UNIT",?70,"INVENTORY",!,PSASLN
+16 QUIT
