PSALEVRP ;BIR/LTL,JMB-Stock and Reorder Report ;7/23/97
;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**15**; 10/24/97
;This routine prints a report of all drugs with their stock and reorder
;levels in a pharmacy location.
;
;References to ^PSDRUG( are covered by IA #2095
;
D LOC G MASTER
;
;Gets locations
LOC S PSAOUT=0,PSALOC=+$O(^PSD(58.8,"ADISP","P",0))
I 'PSALOC W !!?5,"No Drug Accountability location has been created yet." S PSAOUT=1 G MASTER
;
;Collect locations in alpha order
S (PSACNT,PSALOC)=0 W !
F S PSALOC=+$O(^PSD(58.8,"ADISP","P",PSALOC)) Q:'PSALOC D
.Q:'$D(^PSD(58.8,PSALOC,0))!($P($G(^PSD(58.8,PSALOC,0)),"^")="")
.I +$G(^PSD(58.8,PSALOC,"I")),+^PSD(58.8,PSALOC,"I")'>DT Q
.Q:'$O(^PSD(58.8,PSALOC,1,0)) D SITES^PSAUTL1
.S PSACNT=PSACNT+1
.S PSALOCA($P(^PSD(58.8,PSALOC,0),"^")_PSACOMB,PSALOC)=$P(^(0),"^",3)_"^"_$P(^(0),"^",10)_"^"_+$G(^PSD(58.8,PSALOC,"I"))
S PSACHK=$O(PSALOCA("")) I PSACHK="" G MASTER
Q:$G(PSAHIS)&(PSACNT=1)
;
DISPLOC ;Displays the available pharmacy locations.
W @IOF,!,"Choose one or many pharmacy locations:",!
S PSACNT=0,PSALOCN=""
F S PSALOCN=$O(PSALOCA(PSALOCN)) Q:PSALOCN="" D
.S PSALOC=0 F S PSALOC=$O(PSALOCA(PSALOCN,PSALOC)) Q:'PSALOC D
..S PSACNT=PSACNT+1,PSAMENU(PSACNT,PSALOCN,PSALOC)=""
..W !,$J(PSACNT,2)
..W:$L(PSALOCN)>76 ?4,$P(PSALOCN,"(IP)",1)_"(IP)",!?21,$P(PSALOCN,"(IP)",2) W:$L(PSALOCN)<77 ?4,PSALOCN
;
SELLOC W ! S DIR(0)="LO^1:"_PSACNT,DIR("A")="Select PHARMACY LOCATION",DIR("?")="Enter the number(s) of the Pharmacy Location",DIR("??")="^D HELP^PSAUTL3"
D ^DIR K DIR I $G(DTOUT)!($G(DUOUT)) S PSAOUT=1 G EXIT
Q:Y=""&('$G(PSAHIS)) I Y="",$G(PSAHIS) S PSAOUT=1 Q
S PSASEL=Y
F PSAPC=1:1 S PSANUM=+$P(PSASEL,",",PSAPC) Q:'PSANUM D
.S PSALOCN=$O(PSAMENU(PSANUM,"")),PSALOC=$O(PSAMENU(PSANUM,PSALOCN,0))
.S PSALOC(PSALOCN,PSALOC)=PSALOCA(PSALOCN,PSALOC)
;
S PSACHK=$O(PSALOC(""))
I PSACHK="",'PSALOC W !,"There are no active pharmacy locations." G EXIT1
W ! S PSALOCN="" F S PSALOCN=$O(PSALOC(PSALOCN)) Q:PSALOCN=""!(PSAOUT) S PSALOC=0 F S PSALOC=$O(PSALOC(PSALOCN,PSALOC)) Q:'PSALOC!(PSAOUT) D
.I '$O(^PSD(58.8,PSALOC,1,0)) D
..W:$L(PSALOCN)>79 !!,$P(PSALOCN,"(IP)",1)_"(IP)",!!?17,$P(PSALOCN,"(IP)",2) W:$L(PSALOCN)<80 !!,PSALOCN
..W !,"There are no drugs in the pharmacy location."
Q
;
MASTER G:'$D(^XUSEC("PSA ORDERS",DUZ)) TEST S (PSAMVN,PSAMV)=0
F S PSAMV=+$O(^PSD(58.8,"ADISP","M",PSAMV)) Q:'PSAMV D
.I +$G(^PSD(58.8,PSAMV,"I")),+^PSD(58.8,PSAMV,"I")'>DT Q
.S PSAMVN=PSAMVN+1,PSAMV($P(^PSD(58.8,PSAMV,0),"^"),PSAMV)=""
G:'PSAMVN TEST
;
DISPMV ;Displays active master vaults
W @IOF,!,"Choose one or many master vaults:",!
S PSA=0,PSAMVA="" F S PSAMVA=$O(PSAMV(PSAMVA)) Q:PSAMVA="" D
.S PSAMV=0 F S PSAMV=$O(PSAMV(PSAMVA,PSAMV)) Q:'PSAMV D
..S PSA=PSA+1,PSAVAULT(PSA,PSAMVA,PSAMV)="" W !,$J(PSA,2)_".",?4,PSAMVA
K PSAMV
;
SELMV ;Select displayed master vaults
W ! S DIR(0)="LO^1:"_PSA,DIR("A")="Select Master Vault",DIR("?")="Select the Master Vault that received the invoice's drugs",DIR("??")="^D MV^PSAPROC"
D ^DIR K DIR I $G(DTOUT)!($G(DUOUT)) S PSAOUT=1 Q
G:Y="" TEST S PSASEL=Y
F PSAPC=1:1 S PSA=+$P(PSASEL,",",PSAPC) Q:'PSA D
.S PSAMVA="",PSAMVA=$O(PSAVAULT(PSA,PSAMVA)) Q:PSAMVA=""
.S PSAMVIEN=+$O(PSAVAULT(PSA,PSAMVA,0)) Q:'PSAMVIEN
.S PSAMAST(PSAMVA,PSAMVIEN)=""
K PSAVAULT
;
TEST G:PSAOUT EXIT
S PSA=$O(PSALOC("")),PSAMV=$O(PSAMAST(""))
I PSA="",PSAMV="" G EXIT
;
DEV ;Asks device & queueing info
W !!,"Each pharmacy location can contain all drugs in the DRUG file. Therefore,",!,"this report could be very long. It is advised to queue the report to run",!,"during non-critical hours.",!
K IO("Q") K %ZIS,IOP,POP S %ZIS="Q",%ZIS("B")=""
D ^%ZIS I POP W !,"NO DEVICE SELECTED OR OUTPUT PRINTED!" Q
I $D(IO("Q")) D G EXIT
.N ZTDESC,ZTIO,ZTRTN,ZTSAVE,ZTDTH,ZTSK
.S ZTRTN="COMPILE^PSALEVRP",ZTDESC="Drug Acct. - Stock and Reorder Report"
.S:PSA'="" ZTSAVE("PSALOC(")="" S:PSAMV'="" ZTSAVE("PSAMAST(")=""
.D ^%ZTLOAD
;
COMPILE ;Compiles data
S PSA=$O(PSALOC("")) G:PSA="" MV
S PSALOCN="" F S PSALOCN=$O(PSALOC(PSALOCN)) Q:PSALOCN="" D
.S PSALOC=0 F S PSALOC=$O(PSALOC(PSALOCN,PSALOC)) Q:'PSALOC D
..S PSADRG=0 F S PSADRG=+$O(^PSD(58.8,PSALOC,1,PSADRG)) Q:'PSADRG D
...Q:'$D(^PSD(58.8,PSALOC,1,PSADRG,0))!($P($G(^PSDRUG(PSADRG,0)),"^")="")
...S ^TMP("PSALEV",$J,1,PSALOC,$P(^PSDRUG(PSADRG,0),"^"))=+$P(^PSD(58.8,PSALOC,1,PSADRG,0),"^",3)_"^"_+$P(^(0),"^",5)
;
MV S PSA=$O(PSAMAST("")) G:PSA="" PRINT
S PSAMVN="" F S PSAMVN=$O(PSAMAST(PSAMVN)) Q:PSAMVN="" D
.S PSAMV=0 F S PSAMV=$O(PSAMAST(PSAMVN,PSAMV)) Q:'PSAMV D
..S PSADRG=0 F S PSADRG=+$O(^PSD(58.8,PSAMV,1,PSADRG)) Q:'PSADRG D
...Q:'$D(^PSD(58.8,PSAMV,1,PSADRG,0))!($P($G(^PSDRUG(PSADRG,0)),"^")="")
...S ^TMP("PSALEV",$J,2,PSAMV,$P(^PSDRUG(PSADRG,0),"^"))=+$P(^PSD(58.8,PSAMV,1,PSADRG,0),"^",3)_"^"_+$P(^(0),"^",5)
;
PRINT ;Prints report
D NOW^%DTC S PSARUN=%,PSARUN=$E(PSARUN,4,5)_"/"_$E(PSARUN,6,7)_"/"_$E(PSARUN,2,3)_"@"_$E($P(PSARUN,".",2),1,2)_":"_$E($P(PSARUN,".",2),3,4)
S PSAPG=0,PSASLN="",$P(PSASLN,"-",80)="",PSAOUT=0 K Y
S PSAFIRST=1,PSALOC=0 F S PSALOC=+$O(^TMP("PSALEV",$J,1,PSALOC)) Q:'PSALOC!(PSAOUT) D
.D SITES^PSAUTL1 S PSALOCN=$P(^PSD(58.8,PSALOC,0),"^")_PSACOMB
.I PSAFIRST D HDR Q:PSAOUT S PSAFIRST=0
.S PSADRG="" F S PSADRG=$O(^TMP("PSALEV",$J,1,PSALOC,PSADRG)) Q:PSADRG=""!(PSAOUT) D
..I $Y+5>IOSL D HDR Q:PSAOUT
..S PSASTOCK=$P(^TMP("PSALEV",$J,1,PSALOC,PSADRG),"^"),PSAREORD=$P(^(PSADRG),"^",2)
..W !,PSADRG
..W ?(45-$L($P(PSASTOCK,".",2))),$J(PSASTOCK,9,+$L($P(PSASTOCK,".",2)))
..W ?(67-$L($P(PSAREORD,".",2))),$J(PSAREORD,9,+$L($P(PSAREORD,".",2)))
;
S PSA=$O(^TMP("PSALEV",$J,2,"")) G:PSA="" EXIT
S PSAFIRST=1,PSAMV=0
F S PSAMV=+$O(^TMP("PSALEV",$J,2,PSAMV)) Q:'PSAMV!(PSAOUT) D S PSAFIRST=1
.I PSAFIRST D HDR Q:PSAOUT S PSAFIRST=0
.S PSADRG="" F S PSADRG=$O(^TMP("PSALEV",$J,2,PSAMV,PSADRG)) Q:PSADRG=""!(PSAOUT) D
..I $Y+5>IOSL D HDR Q:PSAOUT
..S PSASTOCK=$P(^TMP("PSALEV",$J,2,PSAMV,PSADRG),"^"),PSAREORD=$P(^(PSADRG),"^",2)
..W !,PSADRG
..W ?(45-$L($P(PSASTOCK,".",2))),$J(PSASTOCK,9,+$L($P(PSASTOCK,".",2)))
..W ?(67-$L($P(PSAREORD,".",2))),$J(PSAREORD,9,+$L($P(PSAREORD,".",2)))
I 'PSAOUT,$E(IOST,1,2)="C-" S PSAOUT=1 D END^PSAPROC G:PSAOUT EXIT1
;
EXIT W:$E(IOST,1,2)="C-" @IOF D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@"
EXIT1 K IO("Q"),^TMP("PSALEV",$J)
K %,%ZIS,DIR,DTOUT,DUOUT,PSA,PSACHK,PSACNT,PSACOMB,PSADRG,PSAFIRST,PSAISIT,PSAISITN,PSALOC,PSALOCA,PSALOCN,PSAMAST,PSAMENU,PSAMV,PSAMVA,PSAMVIEN,PSAMVN
K PSANUM,PSAOSIT,PSAOSITN,PSAOUT,PSAPC,PSAPG,PSAREORD,PSARUN,PSASEL,PSASLN,PSASTOCK,PSAVAULT,Y,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTSK
Q
;
HDR ;Report header
I $E(IOST,1,2)="C-" W:'PSAPG @IOF D:+PSAPG END^PSAPROC Q:PSAOUT
I $E(IOST)'="C",+PSAPG W @IOF
S PSAPG=PSAPG+1
W !?20,"DRUG ACCOUNTABILITY/INVENTORY INTERFACE",?72,"PAGE "_PSAPG
W !?25,"STOCK AND REORDER LEVEL REPORT",!
I $E(IOST)'="C" W "RUN: "_PSARUN
I $G(PSALOC) W ?31,"PHARMACY LOCATION" W:$L(PSALOCN)>79 !!,$P(PSALOCN,"(IP)",1)_"(IP)",!!?17,$P(PSALOCN,"(IP)",2) W:$L(PSALOCN)<80 !!,PSALOCN
I $G(PSAMV) W !,"MASTER VAULT: "_$P($G(^PSD(58.8,PSAMV,0)),"^")
W !!,"DRUG",?43,"STOCK LEVEL",?63,"REORDER LEVEL",!,PSASLN
Q
PSALEVRP ;BIR/LTL,JMB-Stock and Reorder Report ;7/23/97
+1 ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**15**; 10/24/97
+2 ;This routine prints a report of all drugs with their stock and reorder
+3 ;levels in a pharmacy location.
+4 ;
+5 ;References to ^PSDRUG( are covered by IA #2095
+6 ;
+7 DO LOC
GOTO MASTER
+8 ;
+9 ;Gets locations
LOC SET PSAOUT=0
SET PSALOC=+$ORDER(^PSD(58.8,"ADISP","P",0))
+1 IF 'PSALOC
WRITE !!?5,"No Drug Accountability location has been created yet."
SET PSAOUT=1
GOTO MASTER
+2 ;
+3 ;Collect locations in alpha order
+4 SET (PSACNT,PSALOC)=0
WRITE !
+5 FOR
SET PSALOC=+$ORDER(^PSD(58.8,"ADISP","P",PSALOC))
IF 'PSALOC
QUIT
Begin DoDot:1
+6 IF '$DATA(^PSD(58.8,PSALOC,0))!($PIECE($GET(^PSD(58.8,PSALOC,0)),"^")="")
QUIT
+7 IF +$GET(^PSD(58.8,PSALOC,"I"))
IF +^PSD(58.8,PSALOC,"I")'>DT
QUIT
+8 IF '$ORDER(^PSD(58.8,PSALOC,1,0))
QUIT
DO SITES^PSAUTL1
+9 SET PSACNT=PSACNT+1
+10 SET PSALOCA($PIECE(^PSD(58.8,PSALOC,0),"^")_PSACOMB,PSALOC)=$PIECE(^(0),"^",3)_"^"_$PIECE(^(0),"^",10)_"^"_+$GET(^PSD(58.8,PSALOC,"I"))
End DoDot:1
+11 SET PSACHK=$ORDER(PSALOCA(""))
IF PSACHK=""
GOTO MASTER
+12 IF $GET(PSAHIS)&(PSACNT=1)
QUIT
+13 ;
DISPLOC ;Displays the available pharmacy locations.
+1 WRITE @IOF,!,"Choose one or many pharmacy locations:",!
+2 SET PSACNT=0
SET PSALOCN=""
+3 FOR
SET PSALOCN=$ORDER(PSALOCA(PSALOCN))
IF PSALOCN=""
QUIT
Begin DoDot:1
+4 SET PSALOC=0
FOR
SET PSALOC=$ORDER(PSALOCA(PSALOCN,PSALOC))
IF 'PSALOC
QUIT
Begin DoDot:2
+5 SET PSACNT=PSACNT+1
SET PSAMENU(PSACNT,PSALOCN,PSALOC)=""
+6 WRITE !,$JUSTIFY(PSACNT,2)
+7 IF $LENGTH(PSALOCN)>76
WRITE ?4,$PIECE(PSALOCN,"(IP)",1)_"(IP)",!?21,$PIECE(PSALOCN,"(IP)",2)
IF $LENGTH(PSALOCN)<77
WRITE ?4,PSALOCN
End DoDot:2
End DoDot:1
+8 ;
SELLOC WRITE !
SET DIR(0)="LO^1:"_PSACNT
SET DIR("A")="Select PHARMACY LOCATION"
SET DIR("?")="Enter the number(s) of the Pharmacy Location"
SET DIR("??")="^D HELP^PSAUTL3"
+1 DO ^DIR
KILL DIR
IF $GET(DTOUT)!($GET(DUOUT))
SET PSAOUT=1
GOTO EXIT
+2 IF Y=""&('$GET(PSAHIS))
QUIT
IF Y=""
IF $GET(PSAHIS)
SET PSAOUT=1
QUIT
+3 SET PSASEL=Y
+4 FOR PSAPC=1:1
SET PSANUM=+$PIECE(PSASEL,",",PSAPC)
IF 'PSANUM
QUIT
Begin DoDot:1
+5 SET PSALOCN=$ORDER(PSAMENU(PSANUM,""))
SET PSALOC=$ORDER(PSAMENU(PSANUM,PSALOCN,0))
+6 SET PSALOC(PSALOCN,PSALOC)=PSALOCA(PSALOCN,PSALOC)
End DoDot:1
+7 ;
+8 SET PSACHK=$ORDER(PSALOC(""))
+9 IF PSACHK=""
IF 'PSALOC
WRITE !,"There are no active pharmacy locations."
GOTO EXIT1
+10 WRITE !
SET PSALOCN=""
FOR
SET PSALOCN=$ORDER(PSALOC(PSALOCN))
IF PSALOCN=""!(PSAOUT)
QUIT
SET PSALOC=0
FOR
SET PSALOC=$ORDER(PSALOC(PSALOCN,PSALOC))
IF 'PSALOC!(PSAOUT)
QUIT
Begin DoDot:1
+11 IF '$ORDER(^PSD(58.8,PSALOC,1,0))
Begin DoDot:2
+12 IF $LENGTH(PSALOCN)>79
WRITE !!,$PIECE(PSALOCN,"(IP)",1)_"(IP)",!!?17,$PIECE(PSALOCN,"(IP)",2)
IF $LENGTH(PSALOCN)<80
WRITE !!,PSALOCN
+13 WRITE !,"There are no drugs in the pharmacy location."
End DoDot:2
End DoDot:1
+14 QUIT
+15 ;
MASTER IF '$DATA(^XUSEC("PSA ORDERS",DUZ))
GOTO TEST
SET (PSAMVN,PSAMV)=0
+1 FOR
SET PSAMV=+$ORDER(^PSD(58.8,"ADISP","M",PSAMV))
IF 'PSAMV
QUIT
Begin DoDot:1
+2 IF +$GET(^PSD(58.8,PSAMV,"I"))
IF +^PSD(58.8,PSAMV,"I")'>DT
QUIT
+3 SET PSAMVN=PSAMVN+1
SET PSAMV($PIECE(^PSD(58.8,PSAMV,0),"^"),PSAMV)=""
End DoDot:1
+4 IF 'PSAMVN
GOTO TEST
+5 ;
DISPMV ;Displays active master vaults
+1 WRITE @IOF,!,"Choose one or many master vaults:",!
+2 SET PSA=0
SET PSAMVA=""
FOR
SET PSAMVA=$ORDER(PSAMV(PSAMVA))
IF PSAMVA=""
QUIT
Begin DoDot:1
+3 SET PSAMV=0
FOR
SET PSAMV=$ORDER(PSAMV(PSAMVA,PSAMV))
IF 'PSAMV
QUIT
Begin DoDot:2
+4 SET PSA=PSA+1
SET PSAVAULT(PSA,PSAMVA,PSAMV)=""
WRITE !,$JUSTIFY(PSA,2)_".",?4,PSAMVA
End DoDot:2
End DoDot:1
+5 KILL PSAMV
+6 ;
SELMV ;Select displayed master vaults
+1 WRITE !
SET DIR(0)="LO^1:"_PSA
SET DIR("A")="Select Master Vault"
SET DIR("?")="Select the Master Vault that received the invoice's drugs"
SET DIR("??")="^D MV^PSAPROC"
+2 DO ^DIR
KILL DIR
IF $GET(DTOUT)!($GET(DUOUT))
SET PSAOUT=1
QUIT
+3 IF Y=""
GOTO TEST
SET PSASEL=Y
+4 FOR PSAPC=1:1
SET PSA=+$PIECE(PSASEL,",",PSAPC)
IF 'PSA
QUIT
Begin DoDot:1
+5 SET PSAMVA=""
SET PSAMVA=$ORDER(PSAVAULT(PSA,PSAMVA))
IF PSAMVA=""
QUIT
+6 SET PSAMVIEN=+$ORDER(PSAVAULT(PSA,PSAMVA,0))
IF 'PSAMVIEN
QUIT
+7 SET PSAMAST(PSAMVA,PSAMVIEN)=""
End DoDot:1
+8 KILL PSAVAULT
+9 ;
TEST IF PSAOUT
GOTO EXIT
+1 SET PSA=$ORDER(PSALOC(""))
SET PSAMV=$ORDER(PSAMAST(""))
+2 IF PSA=""
IF PSAMV=""
GOTO EXIT
+3 ;
DEV ;Asks device & queueing info
+1 WRITE !!,"Each pharmacy location can contain all drugs in the DRUG file. Therefore,",!,"this report could be very long. It is advised to queue the report to run",!,"during non-critical hours.",!
+2 KILL IO("Q")
KILL %ZIS,IOP,POP
SET %ZIS="Q"
SET %ZIS("B")=""
+3 DO ^%ZIS
IF POP
WRITE !,"NO DEVICE SELECTED OR OUTPUT PRINTED!"
QUIT
+4 IF $DATA(IO("Q"))
Begin DoDot:1
+5 NEW ZTDESC,ZTIO,ZTRTN,ZTSAVE,ZTDTH,ZTSK
+6 SET ZTRTN="COMPILE^PSALEVRP"
SET ZTDESC="Drug Acct. - Stock and Reorder Report"
+7 IF PSA'=""
SET ZTSAVE("PSALOC(")=""
IF PSAMV'=""
SET ZTSAVE("PSAMAST(")=""
+8 DO ^%ZTLOAD
End DoDot:1
GOTO EXIT
+9 ;
COMPILE ;Compiles data
+1 SET PSA=$ORDER(PSALOC(""))
IF PSA=""
GOTO MV
+2 SET PSALOCN=""
FOR
SET PSALOCN=$ORDER(PSALOC(PSALOCN))
IF PSALOCN=""
QUIT
Begin DoDot:1
+3 SET PSALOC=0
FOR
SET PSALOC=$ORDER(PSALOC(PSALOCN,PSALOC))
IF 'PSALOC
QUIT
Begin DoDot:2
+4 SET PSADRG=0
FOR
SET PSADRG=+$ORDER(^PSD(58.8,PSALOC,1,PSADRG))
IF 'PSADRG
QUIT
Begin DoDot:3
+5 IF '$DATA(^PSD(58.8,PSALOC,1,PSADRG,0))!($PIECE($GET(^PSDRUG(PSADRG,0)),"^")="")
QUIT
+6 SET ^TMP("PSALEV",$JOB,1,PSALOC,$PIECE(^PSDRUG(PSADRG,0),"^"))=+$PIECE(^PSD(58.8,PSALOC,1,PSADRG,0),"^",3)_"^"_+$PIECE(^(0),"^",5)
End DoDot:3
End DoDot:2
End DoDot:1
+7 ;
MV SET PSA=$ORDER(PSAMAST(""))
IF PSA=""
GOTO PRINT
+1 SET PSAMVN=""
FOR
SET PSAMVN=$ORDER(PSAMAST(PSAMVN))
IF PSAMVN=""
QUIT
Begin DoDot:1
+2 SET PSAMV=0
FOR
SET PSAMV=$ORDER(PSAMAST(PSAMVN,PSAMV))
IF 'PSAMV
QUIT
Begin DoDot:2
+3 SET PSADRG=0
FOR
SET PSADRG=+$ORDER(^PSD(58.8,PSAMV,1,PSADRG))
IF 'PSADRG
QUIT
Begin DoDot:3
+4 IF '$DATA(^PSD(58.8,PSAMV,1,PSADRG,0))!($PIECE($GET(^PSDRUG(PSADRG,0)),"^")="")
QUIT
+5 SET ^TMP("PSALEV",$JOB,2,PSAMV,$PIECE(^PSDRUG(PSADRG,0),"^"))=+$PIECE(^PSD(58.8,PSAMV,1,PSADRG,0),"^",3)_"^"_+$PIECE(^(0),"^",5)
End DoDot:3
End DoDot:2
End DoDot:1
+6 ;
PRINT ;Prints report
+1 DO NOW^%DTC
SET PSARUN=%
SET PSARUN=$EXTRACT(PSARUN,4,5)_"/"_$EXTRACT(PSARUN,6,7)_"/"_$EXTRACT(PSARUN,2,3)_"@"_$EXTRACT($PIECE(PSARUN,".",2),1,2)_":"_$EXTRACT($PIECE(PSARUN,".",2),3,4)
+2 SET PSAPG=0
SET PSASLN=""
SET $PIECE(PSASLN,"-",80)=""
SET PSAOUT=0
KILL Y
+3 SET PSAFIRST=1
SET PSALOC=0
FOR
SET PSALOC=+$ORDER(^TMP("PSALEV",$JOB,1,PSALOC))
IF 'PSALOC!(PSAOUT)
QUIT
Begin DoDot:1
+4 DO SITES^PSAUTL1
SET PSALOCN=$PIECE(^PSD(58.8,PSALOC,0),"^")_PSACOMB
+5 IF PSAFIRST
DO HDR
IF PSAOUT
QUIT
SET PSAFIRST=0
+6 SET PSADRG=""
FOR
SET PSADRG=$ORDER(^TMP("PSALEV",$JOB,1,PSALOC,PSADRG))
IF PSADRG=""!(PSAOUT)
QUIT
Begin DoDot:2
+7 IF $Y+5>IOSL
DO HDR
IF PSAOUT
QUIT
+8 SET PSASTOCK=$PIECE(^TMP("PSALEV",$JOB,1,PSALOC,PSADRG),"^")
SET PSAREORD=$PIECE(^(PSADRG),"^",2)
+9 WRITE !,PSADRG
+10 WRITE ?(45-$LENGTH($PIECE(PSASTOCK,".",2))),$JUSTIFY(PSASTOCK,9,+$LENGTH($PIECE(PSASTOCK,".",2)))
+11 WRITE ?(67-$LENGTH($PIECE(PSAREORD,".",2))),$JUSTIFY(PSAREORD,9,+$LENGTH($PIECE(PSAREORD,".",2)))
End DoDot:2
End DoDot:1
+12 ;
+13 SET PSA=$ORDER(^TMP("PSALEV",$JOB,2,""))
IF PSA=""
GOTO EXIT
+14 SET PSAFIRST=1
SET PSAMV=0
+15 FOR
SET PSAMV=+$ORDER(^TMP("PSALEV",$JOB,2,PSAMV))
IF 'PSAMV!(PSAOUT)
QUIT
Begin DoDot:1
+16 IF PSAFIRST
DO HDR
IF PSAOUT
QUIT
SET PSAFIRST=0
+17 SET PSADRG=""
FOR
SET PSADRG=$ORDER(^TMP("PSALEV",$JOB,2,PSAMV,PSADRG))
IF PSADRG=""!(PSAOUT)
QUIT
Begin DoDot:2
+18 IF $Y+5>IOSL
DO HDR
IF PSAOUT
QUIT
+19 SET PSASTOCK=$PIECE(^TMP("PSALEV",$JOB,2,PSAMV,PSADRG),"^")
SET PSAREORD=$PIECE(^(PSADRG),"^",2)
+20 WRITE !,PSADRG
+21 WRITE ?(45-$LENGTH($PIECE(PSASTOCK,".",2))),$JUSTIFY(PSASTOCK,9,+$LENGTH($PIECE(PSASTOCK,".",2)))
+22 WRITE ?(67-$LENGTH($PIECE(PSAREORD,".",2))),$JUSTIFY(PSAREORD,9,+$LENGTH($PIECE(PSAREORD,".",2)))
End DoDot:2
End DoDot:1
SET PSAFIRST=1
+23 IF 'PSAOUT
IF $EXTRACT(IOST,1,2)="C-"
SET PSAOUT=1
DO END^PSAPROC
IF PSAOUT
GOTO EXIT1
+24 ;
EXIT IF $EXTRACT(IOST,1,2)="C-"
WRITE @IOF
DO ^%ZISC
IF $DATA(ZTQUEUED)
SET ZTREQ="@"
EXIT1 KILL IO("Q"),^TMP("PSALEV",$JOB)
+1 KILL %,%ZIS,DIR,DTOUT,DUOUT,PSA,PSACHK,PSACNT,PSACOMB,PSADRG,PSAFIRST,PSAISIT,PSAISITN,PSALOC,PSALOCA,PSALOCN,PSAMAST,PSAMENU,PSAMV,PSAMVA,PSAMVIEN,PSAMVN
+2 KILL PSANUM,PSAOSIT,PSAOSITN,PSAOUT,PSAPC,PSAPG,PSAREORD,PSARUN,PSASEL,PSASLN,PSASTOCK,PSAVAULT,Y,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTSK
+3 QUIT
+4 ;
HDR ;Report header
+1 IF $EXTRACT(IOST,1,2)="C-"
IF 'PSAPG
WRITE @IOF
IF +PSAPG
DO END^PSAPROC
IF PSAOUT
QUIT
+2 IF $EXTRACT(IOST)'="C"
IF +PSAPG
WRITE @IOF
+3 SET PSAPG=PSAPG+1
+4 WRITE !?20,"DRUG ACCOUNTABILITY/INVENTORY INTERFACE",?72,"PAGE "_PSAPG
+5 WRITE !?25,"STOCK AND REORDER LEVEL REPORT",!
+6 IF $EXTRACT(IOST)'="C"
WRITE "RUN: "_PSARUN
+7 IF $GET(PSALOC)
WRITE ?31,"PHARMACY LOCATION"
IF $LENGTH(PSALOCN)>79
WRITE !!,$PIECE(PSALOCN,"(IP)",1)_"(IP)",!!?17,$PIECE(PSALOCN,"(IP)",2)
IF $LENGTH(PSALOCN)<80
WRITE !!,PSALOCN
+8 IF $GET(PSAMV)
WRITE !,"MASTER VAULT: "_$PIECE($GET(^PSD(58.8,PSAMV,0)),"^")
+9 WRITE !!,"DRUG",?43,"STOCK LEVEL",?63,"REORDER LEVEL",!,PSASLN
+10 QUIT
