- 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
