PSJPDRIN ;BIR/MV-MAIN DRIVER PADE INVENTORY REPORT ;11/15/2015
;;5.0;INPATIENT MEDICATIONS;**317,335**;16 DEC 97;Build 6
;
; Reference to ^PS(50.7 is supported by DBIA 2180.
; Reference to DATA^PSN50P68 is supported by DBIA 4545.
; Reference to DIC^PSSDI is supported by DBIA 4551.
; Reference to ^%ZTLOAD is supported by DBIA 10063.
; Reference to CLEAR^VALM1 is supported by DBIA 10116.
; Reference to EN^DDIOL is supported by DBIA 10142.
; Reference to ^%ZIS is supported by DBIA 10086.
;
Q
;
EN ; Main Entry point
N PSJSTOP,PSDRG,PSJINP,DTOUT,DUOUT,DA,DIC,DR,DIR
S PSJSTOP=0
F Q:$G(PSJSTOP)<0 D ENLOOP
Q
;
ENLOOP ; Prompt loop
N PSJINP,ZTSK,ZTDESC,ZTRTN,ZTSAVE
S PSJSTOP=0
D ASK(.PSJINP) G:PSJSTOP EXIT
Q:$G(PSJINP("PSJDEV"))="Q"
START ; Queued entry
N PSJSTOP S PSJSTOP=0
K ^TMP("PSJPDRIN",$J)
D PROCESS(.PSJINP) G:PSJSTOP EXIT
D EN^PSJPDRIP(.PSJINP)
I $G(PSJINP("PSJDELM"))="D" D
.N DIR,X,Y S DIR(0)="EA"
.S DIR("A",1)=""
.S DIR("A",2)="The delimited report is complete."
.S DIR("A")="Please turn logging off, then press return to continue."
.D ^DIR
Q
;
EXIT ; Clean up
K ^TMP("PSJPDRIN",$J),ZTSK
Q
;
ASK(PSJINP) ;Prompt for selection criteria. Quit when PSJSTOP is true
;
N PSJCSUB,PSJSYS,PSJDEV,PSJDIV,PADEV,PSJSUMM,PSJDELIM,PSJDRG,PSDRG
D CLEAR^VALM1 W !!
S PSJSTOP=0
W ?20,"PADE On-Hand Inventory Report",!
S PSJINP("PSJPSYS")=$$PSYS Q:PSJSTOP
D DIV^PSJPDRIP(.PSJDIV,.PSJSTOP) Q:PSJSTOP M PSJINP("PSJDIV")=PSJDIV
D PADEV(.PADEV,.PSJINP) Q:PSJSTOP M PSJINP("PADEV")=PADEV
D PSJCSUB(.PSJINP,.PSJCSUB) Q:PSJSTOP M PSJINP("PSJCSUB")=PSJCSUB
D DRUG(.PSDRG,.PSJINP) Q:PSJSTOP M PSJINP("PSDRG")=PSDRG
S PSJINP("PSJSUM")=$$SUMM Q:PSJSTOP
S PSJINP("PSJDELM")=$$DELIM Q:PSJSTOP
S PSJINP("PSJDEV")=$$SELDEV(,.PSJINP) S:$G(DUOUT)!$G(DTOUT) PSJSTOP=1 Q:PSJSTOP
Q
;
PSYS() ; Get PADE Inventory System
N PSYS
S PSYS=$$PSYS^PSJPDRUT()
Q PSYS
;
DIV() ; Get Division
N PSDIV,DIC,X,Y
S DIC("S")="I $D(^PS(58.63,""D"",+Y))"
S DIC=40.8,DIC(0)="QAE",DIC("A")="Select Division: " D ^DIC
S PSDIV=$S(Y>0:+Y,1:"")
I $G(DUOUT)!$G(DTOUT)!(PSDIV="") S PSJSTOP=1
Q PSDIV
;
PADEV(PADEV,PSJINP) ; Get PADE dispensing device(s), screen for Division and PADE Inventory System
;Requires PSJINP("PSJDIV"),PSJINP("PSJPSYS")
N PADNAM,PADIEN,PADTMP
D PADEV^PSJPDRTR(.PADEV,.PSJINP,1)
Q:($D(PADEV)<10)
M PADTMP=PADEV
K PADEV
S PADNAM=0 F S PADNAM=$O(PADTMP(PADNAM)) Q:PADNAM="" D
.Q:'$G(PADTMP(PADNAM))
.S PADEV(PADTMP(PADNAM))=PADNAM
Q
;
CAB(PSJINP,PADEV) ; Get PADE (cabinets)
N PSCAB,DIC,X,Y,PSJDIV,PSJPSYS,PSJSCR,PSCABHLP,PSJX
S PSJDIV=$G(PSJINP("PSJDIV"))
S PSJPSYS=$G(PSJINP("PSJPSYS"))
S PSCABHLP="Select one or more PADE Dispensing Devices, or enter '^ALL' to select all."
S DIC("S")="I ($D(PSJINP(""PSJDIV"",+$G(^PS(58.63,+Y,2)))))&('$$EMPTY^PSJPADPT(+Y))"
S DIC=58.63,DIC(0)="QABE",DIC("A")="Select PADE Dispensing Device: "_$S($D(PADEV)<10:"^ALL// ",1:"")
S DIC("W")="N PSJPADST S PSJPADST=$P($G(^PS(58.63,+$G(Y),0)),""^"",4),PSJPADST=$S(PSJPADST=""I"":"" (INACTIVE)"",1:"""") W PSJPADST"
D ^DIC S PSJX=X
S:$E(PSJX)="^" Y=$$XALL^PSJPDRIP(PSJX)
I X="",$D(PADEV)<10 S Y="ALL"
S:Y=-1 Y=""
S PSCAB=Y
S:($G(DUOUT)&(PSCAB'="ALL"))!$G(DTOUT) PSJSTOP=1
Q PSCAB
;
PSJCSUB(PSJINP,PSJCSUB) ; Get Controlled Subs (CS) Schedules
N DIR,X,Y,PSJDONE,SCHED,SCHLST
K PSJCSUB
W ! D EN^DDIOL(" Enter '^ALL' to select all Controlled substance")
D EN^DDIOL(" schedules and all non-controlled substances.") W !
S DIR("A")="Enter (C)S or (N)on-CS: ^ALL//",DIR(0)="SAO^C:Controlled Substances;N:Non-Controlled Substances;ALL:All CS Schedules and Non-CS"
D ^DIR S:X="" Y="ALL"
I $E(X)="^" S Y=$$XALL^PSJPDRIP(X)
S PSJCSUB=Y
I PSJCSUB'="ALL"&($G(DUOUT)!$G(DTOUT)!(Y="")) S PSJSTOP=1 Q
S:PSJCSUB="N"!(PSJCSUB="ALL") PSJCSUB(0)="Unscheduled"
Q:PSJCSUB="N"
; If YES to Controlled Subs, get CS Schedule
S SCHLST="1:Schedule I;2:Schedule II;2n:Schedule II Non-Narcotics;3:Schedule III;3n:Schedule III Non-Narcotics;4:Schedule IV;5:Schedule V"
I PSJCSUB="ALL" D ALLSCHED^PSJPDRIP(.PSJCSUB,SCHLST) S PSJCSUB="ALL" Q
K PSJDONE,PSJCSUB
N DIR,X,Y,SCNT
F Q:$G(PSJSTOP)!$G(PSJDONE) D SELCSUB^PSJPDRTR(.PSJCSUB)
Q
;
DRUG(DRUG,PSJINP) ; Allow user to select appropriate subset of drug items
N PSDONE,DIC,X,Y,GETDRG,LSTCNT,PSJCSUB,DRGARAY,PSJPSYS,PADEV,PSJDRC
S PSJCSUB=$G(PSJINP("PSJCSUB"))
S PSJPSYS=$G(PSJINP("PSJPSYS"))
M PADEV=PSJINP("PADEV")
D DRCAB(.PSJINP,.PSJDRC) ; Get drugs linked to cabinet(s)
D DRUGSEL^PSJPDRTR(.PSJINP,.PSJDRC,.DRUG,,.PSJSTOP) ; Prompt for drug items
Q
;
SUMM() ; Prompt user for Detailed or Summary report
N SUMM,DIR,X,Y
S DIR(0)="S^D:Detailed Report;S:Summary Report"
S DIR("A")="Select (D)etail or (S)ummary Report "
S DIR("B")="S",DIR("?")="You may select 'D' for a detailed report or 'S' for a Summary report."
D ^DIR S:$G(DUOUT)!$G(DTOUT) PSJSTOP=1
Q Y
;
DELIM() ; Prompt user for delimited output or formatted report.
N DELIM,DIR,X,Y
S DIR(0)="S^R:Report;D:Delimited Output"
S DIR("A")="Select (R)eport or (D)elimited output "
S DIR("B")="R",DIR("?")="You may select 'R' for a report or 'D' for CSV delimited output (for spreadsheet)"
D ^DIR S:$G(DUOUT)!$G(DTOUT) PSJSTOP=1
S DELIM=Y
Q DELIM
;
GETCLASS(DRGIEN) ; Get Controlled Substance Federal Schedule from VA PRODUCT FILE for DRUG FILE (#50) entry DRGIEN
; Input : pointer to DRUG (#50) file
; Output : Value from CS FEDERAL SCHEDULE field (#19) in VA PRODUCT (#50.68) file
N PSJDPROD,PSJCLASS,PSJNDF S PSJCLASS=0
Q:'$G(DRGIEN) "-1"
K ^TMP($J,"PSJCLASS")
S PSJNDF=$P($G(^PSDRUG(+DRGIEN,"ND")),"^",3) I '$G(PSJNDF) D Q PSJCLASS
. N CS S CS=$P($G(^PSDRUG(+DRGIEN,0)),"^",3)
. S PSJCLASS=$S(+CS>1&(+CS<6):+CS,1:0) I ((PSJCLASS=2)!(PSJCLASS=3))&(CS["C") S PSJCLASS=PSJCLASS_"n"
D DATA^PSN50P68(PSJNDF,,"PSJCLASS")
S PSJCLASS=$P($G(^TMP($J,"PSJCLASS",+PSJNDF,19)),"^")
S PSJCLASS=$S(PSJCLASS]"":PSJCLASS,1:0)
K ^TMP($J,"PSJCLASS")
Q PSJCLASS
;
LISTDRG(SCREEN,DRGARAY) ; Get list of drugs from drug file screened by SCREEN, outpat DRGARAY
K DRGARAY
N DIC,X,Y
D LIST^DIC(50,,,"P",,,,,SCREEN,,"DRGARAY")
Q
;
PROCESS(PSJINP) ; Gather report data, store in ^TMP
I PSJINP("PSJSUM")="S" D PROCSUM(.PSJINP) Q
I PSJINP("PSJSUM")'="S" D PROCDET(.PSJINP)
Q
;
PROCSUM(PSJINP) ; Gather SUMMARY report data
N PSJCAB,PSJDRG,CC,LNCNT,TABMAR,PSJPSYS,PSJCABNM,PSJQTY,PSJDFORM,PSJII,PSJOI,PSJDFIEN,PSJCABST,PSJDRGX,PSJDNAM
S PSJINP("PSPGTOT")=1,LNCNT=1
S $P(TABMAR," ",40)=" "
S PSJPSYS=+PSJINP("PSJPSYS")
M PSJCAB=PSJINP("PADEV")
M PSJDRG=PSJINP("PSDRG")
S PSJCAB=0 F CC=0:1 S PSJCAB=$O(PSJCAB(PSJCAB)) Q:'PSJCAB D
.S PSJCABNM=$P($G(^PS(58.63,PSJCAB,0)),"^"),PSJCABST=$P($G(^PS(58.63,PSJCAB,0)),"^",4),PSJCABST=$S(PSJCABST="I":"(I)",1:"")
.N PSJDRGX D ALPHADRG(PSJPSYS,PSJCAB,.PSJDRG,.PSJDRGX)
.I PSJINP("PSJDELM")="R" D
..Q:'$D(PSJDRGX)
..I $G(CC) S ^TMP("PSJPDRIN",$J,LNCNT)="^",LNCNT=LNCNT+1
..S ^TMP("PSJPDRIN",$J,LNCNT)=PSJCABNM_PSJCABST,LNCNT=LNCNT+1
.S PSJDNAM="" F PSJII=1:1 S PSJDNAM=$O(PSJDRGX(PSJDNAM)) Q:PSJDNAM="" S PSJDRG=0 S PSJDRG=$O(PSJDRGX(PSJDNAM,PSJDRG)) Q:'PSJDRG D
..S PSJCABNM=$S(PSJINP("PSJDELM")="D":PSJCABNM,1:"")
..S PSJQTY=$$QTY(PSJPSYS,PSJCAB,PSJDRG)
..S PSJOI=+$G(^PSDRUG(PSJDRG,2))
..S PSJDFORM=$E($$DFORM(PSJPSYS,PSJCAB,PSJDRG),1,11)
..I PSJDFORM="" S PSJDFIEN=$P($G(^PS(50.7,PSJOI,0)),"^",2) I PSJDFIEN D
...N X,Y,DIC
...S DIC(0)="XN",DIC="^PS(50.606,",X=+PSJDFIEN
...D DIC^PSSDI(50.606,"PSJ",.DIC,.X)
...S PSJDFORM=$P($G(Y),"^",2)
..S ^TMP("PSJPDRIN",$J,LNCNT)=PSJCABNM_"^"_PSJDNAM_" ("_PSJDRG_")"_"^"_PSJDFORM_"^"_$S(PSJINP("PSJDELM")="R":$J(PSJQTY,4),1:PSJQTY),LNCNT=LNCNT+1
Q
;
PROCDET(PSJINP) ; Gather DETAIL report data
N PSJCAB,PSJDRG,CC,LNCNT,TABMAR,PSJPSYS,PSJCABNM,DRGTOT,QTY,PSJDFORM,PSJOI,PSJII,QTY,PSJCOL,PCKNAM
N PSJDFIEN,PSJDRNAM,PSJDRIEN,DRCNTOT
S PSJINP("PSPGTOT")=1,LNCNT=1
S $P(TABMAR," ",40)=" "
S PSJPSYS=+PSJINP("PSJPSYS")
M PSJCAB=PSJINP("PADEV")
M PSJDRG=PSJINP("PSDRG")
D SETCOLS^PSJPDRIP(.PSJINP,.PSJCOL)
S PSJDRIEN=0 F S PSJDRIEN=$O(PSJDRG(PSJDRIEN)) Q:'PSJDRIEN S PSJDRNAM=$P(PSJDRG(PSJDRIEN),"^") D
.S PSJDRNAM(PSJDRNAM_"^"_PSJDRIEN)=""
S PSJDRNAM="" F S PSJDRNAM=$O(PSJDRNAM(PSJDRNAM)) Q:PSJDRNAM="" D
.S PSJDRG=$P(PSJDRNAM,"^",2)
.N DRWPCK,PSBFLAG
.S:PSJINP("PSJDELM")="R" ^TMP("PSJPDRIN",$J,LNCNT)=" ^ ",LNCNT=LNCNT+1
.S DRGTOT=0,DRCNTOT=0
.S PSBFLAG=0 ; If a Patient Specific Bin is included in the list, set flag
.S PSJCAB=0 F S PSJCAB=$O(PSJCAB(PSJCAB)) Q:'PSJCAB I $D(^PS(58.601,"DEV",PSJCAB,PSJDRG)) D
..N PSDRGLEN,PSJCABST,DRWPCK
..S PSJCABST=$P($G(^PS(58.63,PSJCAB,0)),"^",4),PSJCABST=$S(PSJCABST="I":"(I)",1:"")
..S PSJCABNM=$P($G(^PS(58.63,PSJCAB,0)),"^")_PSJCABST
..S PSJQTY=$$QTY(PSJPSYS,PSJCAB,PSJDRG)
..S DRGTOT=$G(DRGTOT)+PSJQTY
..S PSJOI=+$G(^PSDRUG(PSJDRG,2))
..S PSJDFIEN=$P($G(^PS(50.7,PSJOI,0)),"^",2)
..S PSJDFORM=$$DFORM(PSJPSYS,PSJCAB,PSJDRG)
..I PSJDFORM="" S PSJDFIEN=$P($G(^PS(50.7,PSJOI,0)),"^",2) I PSJDFIEN D
...N X,Y,DIC
...S DIC(0)="XN",DIC="^PS(50.606,",X=+PSJDFIEN
...D DIC^PSSDI(50.606,"PSJ",.DIC,.X)
...S PSJDFORM=$P($G(Y),"^",2)
..D POCKDRG^PSJPDRIP(PSJPSYS,PSJCAB,PSJDRG,.DRWPCK)
..N CC D Q
...S PCKNAM="" F CC=1:1 S PCKNAM=$O(DRWPCK(PSJDRG,PCKNAM)) Q:PCKNAM="" D
....N QTY,FMTQTY S QTY=+DRWPCK(PSJDRG,PCKNAM)
....S DRCNTOT=$G(DRCNTOT)+QTY ; *Requires individual pocket balances for multi-pocket drugs*
....N PSJDTRUN ; Handle max length drug names
....S PSJDTRUN=$P($G(^PSDRUG(PSJDRG,0)),"^")
....I $L(PSJDTRUN)>33 S PSJDTRUN=$E(PSJDTRUN,1,33)
....S PSJDTRUN=PSJDTRUN_"("_PSJDRG_")"
....S FMTQTY=$S(PCKNAM["PSB":"*"_QTY,$E(PCKNAM,$L(PCKNAM)-1,$L(PCKNAM))="RB":"*"_QTY,1:QTY)
....I FMTQTY["*" D
.....S PSBFLAG("PSB")=$S($E(PCKNAM,$L(PCKNAM)-2,$L(PCKNAM))["PSB":1,1:$G(PSBFLAG("PSB")))
.....S PSBFLAG("RB")=$S($E(PCKNAM,$L(PCKNAM)-1,$L(PCKNAM))["RB":1,1:$G(PSBFLAG("RB")))
....S ^TMP("PSJPDRIN",$J,LNCNT)=PSJDTRUN_"^"_PSJDFORM_"^"_$S(PSJINP("PSJDELM")="R":$J(FMTQTY,4),1:FMTQTY)_"^"_PSJCABNM_"^"_PCKNAM,LNCNT=LNCNT+1
...I CC=1 N QTY,PSCABIEN,PSDRGIEN S PSCABIEN=$O(^PS(58.601,PSJPSYS,"DEVICE","B",PSJCAB,"")) D
....S QTY="-" I PSCABIEN S PSDRGIEN=$O(^PS(58.601,PSJPSYS,"DEVICE",PSCABIEN,"DRUG","B",PSJDRG,""))
....N PSJDTRUN ; Handle max length drug names
....S PSJDTRUN=$P($G(^PSDRUG(PSJDRG,0)),"^")
....I $L(PSJDTRUN)>33 S PSJDTRUN=$E(PSJDTRUN,1,33) S:$E(PSJDTRUN,$L(PSJDTRUN))=" " PSJDTRUN=$E(PSJDTRUN,1,$L(PSJDTRUN)-1)
....S PSJDTRUN=PSJDTRUN_" ("_PSJDRG_")"
....S ^TMP("PSJPDRIN",$J,LNCNT)=PSJDTRUN_"^"_PSJDFORM_"^"_$S(PSJINP("PSJDELM")="R":$J(QTY,4),1:QTY)_"^"_PSJCABNM_"^UNK",LNCNT=LNCNT+1
.I PSJINP("PSJDELM")="R" D
..S ^TMP("PSJPDRIN",$J,LNCNT)=$E(TABMAR,1,34)_"^^----",LNCNT=LNCNT+1
..S ^TMP("PSJPDRIN",$J,LNCNT)=$E(TABMAR,1,34)_"^SUB TOTAL:^"_$J(DRCNTOT,4),LNCNT=$G(LNCNT)+1
..S ^TMP("PSJPDRIN",$J,LNCNT)=$E(TABMAR,1,24)_" REPORTED CABINET"_"^ TOTAL:^"_$J(DRGTOT,4),LNCNT=$G(LNCNT)+1
..I $G(PSBFLAG("PSB")) S ^TMP("PSJPDRIN",$J,LNCNT)="* Patient Specific Bin counts not included in Reported Cabinet Total.",LNCNT=$G(LNCNT)+1
..I $G(PSBFLAG("RB")) S ^TMP("PSJPDRIN",$J,LNCNT)="* Return Bin counts not included in Reported Cabinet Total.",LNCNT=$G(LNCNT)+1
Q
;
QTY(SYS,PSJCAB,PSJDRG) ; Return quantity of drug PSJDRG in cabinet PSJCAB
N QTY,PSYSIEN,PDEVIEN,PDRGIEN
S PSYSIEN=$O(^PS(58.601,"DEV",PSJCAB,PSJDRG,""))
S PDEVIEN=$O(^PS(58.601,"DEV",PSJCAB,PSJDRG,PSYSIEN,""))
S PDRGIEN=$O(^PS(58.601,"DEV",PSJCAB,PSJDRG,PSYSIEN,PDEVIEN,""))
S QTY=+$P($G(^PS(58.601,PSYSIEN,"DEVICE",PDEVIEN,"DRUG",PDRGIEN,0)),"^",3)
Q QTY
;
DFORM(SYS,PSJCAB,PSJDRG) ; Return Dose Form of drug PSJDRG in cabinet PSJCAB
N FORM,PSYSIEN,PDEVIEN,PDRGIEN
S PSYSIEN=$O(^PS(58.601,"DEV",PSJCAB,PSJDRG,""))
S PDEVIEN=$O(^PS(58.601,"DEV",PSJCAB,PSJDRG,PSYSIEN,""))
S PDRGIEN=$O(^PS(58.601,"DEV",PSJCAB,PSJDRG,PSYSIEN,PDEVIEN,""))
S FORM=$P($G(^PS(58.601,PSYSIEN,"DEVICE",PDEVIEN,"DRUG",PDRGIEN,0)),"^",5)
Q FORM
;
DRCAB(PSJINP,PSJDRCAB) ; Return list of drugs in each cabinet in PSJINP("PADEV")
; Input = PSJINP("PADEV",CABINET IEN) - Cabinet IEN points to PADE DISPENSING DEVICE file 58.63
; Output = PSJDRCAB(DRUG IEN) - Drug IEN points to DRUG file 50
K PSJDRCAB
N CAB,CABDA,PSJPSYS,DRGDA,DRG
S PSJPSYS=$G(PSJINP("PSJPSYS"))
M CAB=PSJINP("PADEV")
S CAB=0 F S CAB=$O(CAB(CAB)) Q:'CAB S CABDA=$O(^PS(58.601,PSJPSYS,"DEVICE","B",CAB,0)) I CABDA D
.S DRGDA=0 F S DRGDA=$O(^PS(58.601,PSJPSYS,"DEVICE",CABDA,"DRUG",DRGDA)) Q:'DRGDA S DRG=+$G(^(DRGDA,0)) I DRG D
..Q:$D(PSJDRCAB(DRG))
..I '($G(PSJINP("PSJCSUB"))="ALL") Q:'$D(PSJINP("PSJCSUB",$$GETCLASS(DRG)))
..S PSJDRCAB(DRG)=$P($G(^PSDRUG(+$G(DRG),0)),"^")
Q
;
LISTALL(DRGLIST) ; Write list of drugs in DRGLIST("IEN",DRUG IEN)
N II,DRGNAME,DRGIEN,TAB
S $P(TAB," ",80)=""
S DRGIEN=0 F S DRGIEN=$O(DRGLIST("IEN",DRGIEN)) Q:'DRGIEN D
.W !,$E(TAB,1,8-$L(DRGIEN))_DRGIEN_" "_DRGLIST("IEN",DRGIEN)
Q
;
DRUGLIST(PSJINP,DRGLIST) ; Return DRGLIST array with "IEN" and "NAME" cross referenced
N I,DRG,DLST
S DRG=0 F I=1:1 S DRG=$O(DRGLIST(DRG)) Q:'DRG D
.N DRGNAME S DRGNAME=$G(DRGLIST(DRG))
.S DRGLIST("IEN",DRG)=DRGNAME
.S DRGLIST("NAME",DRGNAME)=DRG
Q
;
SELDEV(RTN,PSJINP,PSJWIDE,ZTSK) ; Select Device
;
N PSJDONE
;
I $G(PSJINP("PSJDELM"))="D" D
.N DIR,X,Y
.S DIR("A",1)=""
.S DIR("A",2)=" ************************************************************"
.S DIR("A",3)=" ** You selected a Delimited report. Please verify you **"
.S DIR("A",4)=" ** you have turned logging on to capture the output. **"
.S DIR("A",5)=" ** **"
.S DIR("A",6)=" ** To avoid undesired wrapping, please enter '0;512;999' **"
.S DIR("A",7)=" ** at the 'DEVICE:' prompt. You may need to set your **"
.S DIR("A",8)=" ** Terminal Session display settings to 512 columns. **"
.S DIR("A",9)=" ************************************************************"
.S DIR("A",10)=""
.S DIR("A",11)="",DIR("A",12)=""
.S DIR("A")=" Press return to continue"
.S DIR(0)="EA" D ^DIR W !
;
W !,"This report is designed for a "_$S($G(PSJWIDE):132,1:80)_" column format."
W !,"You may queue this report to print at a later time.",!
F Q:$G(PSJSTOP)!$G(PSJDONE) D
.K %ZIS,IOP,POP,ZTSK N I S PSJION=$I,%ZIS="QM"
.D ^%ZIS K %ZIS
.I POP S IOP=PSJION D ^%ZIS K IOP,PSJION D Q
..N DIR,X,Y
..S DIR(0)="YA",DIR("A",1)=" ** No Device Selected **",DIR("A")="Select a different device? (Y/N) " D ^DIR
..S:'Y PSJSTOP=1
.S PSJDONE=1
;
K PSJION I $D(IO("Q")) D Q "Q"
.S ZTDESC="PADE Inventory Report",ZTRTN=$S($G(RTN)]"":$G(RTN),1:"START^PSJPDRIN")
.F I="PSJINP(","IO" S ZTSAVE(I)=""
.K IO("Q") D ^%ZTLOAD W:$D(ZTSK) !,"Report is Queued to print!"
Q ""
;
CONT(PGCNT,PSJQUIT,TMPLN) ; Press return to continue
N DIR
I ($E($G(IOST))="C") W ! D
.S:'$D(DIR("A")) DIR("A")="Press Return to continue or '^' to exit"
.S DIR(0)="FO"
.D ^DIR K DIR
.I $G(DTOUT)!$G(DUOUT) S PSJSTOP=1
Q
;
ALPHADRG(SYS,CAB,DRG,DRGX) ; Alphabetize drug names DRGNAME in DRG(IEN)=DRGNAME, return in DRG(DRGNAME,IEN)=""
N DRGIEN,DRGNAME
S DRGIEN=0 F S DRGIEN=$O(DRG(DRGIEN)) Q:'DRGIEN S DRGNAME=$G(DRG(DRGIEN)) I DRGNAME]"" D
.Q:'$D(^PS(58.601,"DEV",CAB,DRGIEN))
.S DRGX(DRGNAME,DRGIEN)=""
Q
;
POCKET(PSJINP,PSDRG,OUTPOCK) ; Get pocket(s)
;
N DRAWER,POCKET,DRGPCK,PSJPSYS,PADIEN,PADEV,DRGDEV,DRWIEN,DRGDRW,SUB,SUBID
S PSJPSYS=$G(PSJINP("PSJPSYS")),PADEV=$G(PSJINP("PADEV"))
S PADIEN=$O(^PS(58.601,+PSJPSYS,"DEVICE","B",+PADEV,""))
Q:'$G(PSDRG)!'$G(PSJPSYS)!'$G(PADIEN)
;
S OUTPOCK=PSDRG
S DRWIEN=0 F S DRWIEN=$O(^PS(58.601,+PSJPSYS,"DEVICE",+PADIEN,"DRAWER",DRWIEN)) Q:'DRWIEN D
.S SUB=0 F S SUB=$O(^PS(58.601,PSJPSYS,"DEVICE",PADIEN,"DRAWER",DRWIEN,"SUB",SUB)) Q:'SUB D
..S DRGPCK=$P(^PS(58.601,PSJPSYS,"DEVICE",PADIEN,"DRAWER",DRWIEN,"SUB",SUB,0),"^",5),POCKET=$P(^(0),"^",3),SUBID=$P($G(^(0)),"^",4)
..Q:'(DRGPCK=$G(PSDRG))
..S DRAWER=$G(^PS(58.601,+PSJPSYS,"DEVICE",+PADIEN,"DRAWER",DRWIEN,0))
..S:DRAWER="" DRAWER="~~"
..S POCKET=DRAWER_"_"_POCKET
..S DRGDRW=$O(^PS(58.601,PSJPSYS,"DEVICE",PADIEN,"DRAWER",DRWIEN,"DRUG","B",PSDRG,""))
..S OUTPOCK(DRGPCK,DRWIEN,SUB)=POCKET_"^"_DRGDRW_"^"_DRAWER_$S($L(SUBID):"^"_SUBID,1:"")
S DRGDEV=$O(^PS(58.601,PSJPSYS,"DEVICE",PADIEN,"DRUG","B",PSDRG,""))
S OUTPOCK(PSDRG,"DRGDEV")=DRGDEV
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSJPDRIN 16698 printed Apr 09, 2024@21:07:39 Page 2
PSJPDRIN ;BIR/MV-MAIN DRIVER PADE INVENTORY REPORT ;11/15/2015
+1 ;;5.0;INPATIENT MEDICATIONS;**317,335**;16 DEC 97;Build 6
+2 ;
+3 ; Reference to ^PS(50.7 is supported by DBIA 2180.
+4 ; Reference to DATA^PSN50P68 is supported by DBIA 4545.
+5 ; Reference to DIC^PSSDI is supported by DBIA 4551.
+6 ; Reference to ^%ZTLOAD is supported by DBIA 10063.
+7 ; Reference to CLEAR^VALM1 is supported by DBIA 10116.
+8 ; Reference to EN^DDIOL is supported by DBIA 10142.
+9 ; Reference to ^%ZIS is supported by DBIA 10086.
+10 ;
+11 QUIT
+12 ;
EN ; Main Entry point
+1 NEW PSJSTOP,PSDRG,PSJINP,DTOUT,DUOUT,DA,DIC,DR,DIR
+2 SET PSJSTOP=0
+3 FOR
if $GET(PSJSTOP)<0
QUIT
DO ENLOOP
+4 QUIT
+5 ;
ENLOOP ; Prompt loop
+1 NEW PSJINP,ZTSK,ZTDESC,ZTRTN,ZTSAVE
+2 SET PSJSTOP=0
+3 DO ASK(.PSJINP)
if PSJSTOP
GOTO EXIT
+4 if $GET(PSJINP("PSJDEV"))="Q"
QUIT
START ; Queued entry
+1 NEW PSJSTOP
SET PSJSTOP=0
+2 KILL ^TMP("PSJPDRIN",$JOB)
+3 DO PROCESS(.PSJINP)
if PSJSTOP
GOTO EXIT
+4 DO EN^PSJPDRIP(.PSJINP)
+5 IF $GET(PSJINP("PSJDELM"))="D"
Begin DoDot:1
+6 NEW DIR,X,Y
SET DIR(0)="EA"
+7 SET DIR("A",1)=""
+8 SET DIR("A",2)="The delimited report is complete."
+9 SET DIR("A")="Please turn logging off, then press return to continue."
+10 DO ^DIR
End DoDot:1
+11 QUIT
+12 ;
EXIT ; Clean up
+1 KILL ^TMP("PSJPDRIN",$JOB),ZTSK
+2 QUIT
+3 ;
ASK(PSJINP) ;Prompt for selection criteria. Quit when PSJSTOP is true
+1 ;
+2 NEW PSJCSUB,PSJSYS,PSJDEV,PSJDIV,PADEV,PSJSUMM,PSJDELIM,PSJDRG,PSDRG
+3 DO CLEAR^VALM1
WRITE !!
+4 SET PSJSTOP=0
+5 WRITE ?20,"PADE On-Hand Inventory Report",!
+6 SET PSJINP("PSJPSYS")=$$PSYS
if PSJSTOP
QUIT
+7 DO DIV^PSJPDRIP(.PSJDIV,.PSJSTOP)
if PSJSTOP
QUIT
MERGE PSJINP("PSJDIV")=PSJDIV
+8 DO PADEV(.PADEV,.PSJINP)
if PSJSTOP
QUIT
MERGE PSJINP("PADEV")=PADEV
+9 DO PSJCSUB(.PSJINP,.PSJCSUB)
if PSJSTOP
QUIT
MERGE PSJINP("PSJCSUB")=PSJCSUB
+10 DO DRUG(.PSDRG,.PSJINP)
if PSJSTOP
QUIT
MERGE PSJINP("PSDRG")=PSDRG
+11 SET PSJINP("PSJSUM")=$$SUMM
if PSJSTOP
QUIT
+12 SET PSJINP("PSJDELM")=$$DELIM
if PSJSTOP
QUIT
+13 SET PSJINP("PSJDEV")=$$SELDEV(,.PSJINP)
if $GET(DUOUT)!$GET(DTOUT)
SET PSJSTOP=1
if PSJSTOP
QUIT
+14 QUIT
+15 ;
PSYS() ; Get PADE Inventory System
+1 NEW PSYS
+2 SET PSYS=$$PSYS^PSJPDRUT()
+3 QUIT PSYS
+4 ;
DIV() ; Get Division
+1 NEW PSDIV,DIC,X,Y
+2 SET DIC("S")="I $D(^PS(58.63,""D"",+Y))"
+3 SET DIC=40.8
SET DIC(0)="QAE"
SET DIC("A")="Select Division: "
DO ^DIC
+4 SET PSDIV=$SELECT(Y>0:+Y,1:"")
+5 IF $GET(DUOUT)!$GET(DTOUT)!(PSDIV="")
SET PSJSTOP=1
+6 QUIT PSDIV
+7 ;
PADEV(PADEV,PSJINP) ; Get PADE dispensing device(s), screen for Division and PADE Inventory System
+1 ;Requires PSJINP("PSJDIV"),PSJINP("PSJPSYS")
+2 NEW PADNAM,PADIEN,PADTMP
+3 DO PADEV^PSJPDRTR(.PADEV,.PSJINP,1)
+4 if ($DATA(PADEV)<10)
QUIT
+5 MERGE PADTMP=PADEV
+6 KILL PADEV
+7 SET PADNAM=0
FOR
SET PADNAM=$ORDER(PADTMP(PADNAM))
if PADNAM=""
QUIT
Begin DoDot:1
+8 if '$GET(PADTMP(PADNAM))
QUIT
+9 SET PADEV(PADTMP(PADNAM))=PADNAM
End DoDot:1
+10 QUIT
+11 ;
CAB(PSJINP,PADEV) ; Get PADE (cabinets)
+1 NEW PSCAB,DIC,X,Y,PSJDIV,PSJPSYS,PSJSCR,PSCABHLP,PSJX
+2 SET PSJDIV=$GET(PSJINP("PSJDIV"))
+3 SET PSJPSYS=$GET(PSJINP("PSJPSYS"))
+4 SET PSCABHLP="Select one or more PADE Dispensing Devices, or enter '^ALL' to select all."
+5 SET DIC("S")="I ($D(PSJINP(""PSJDIV"",+$G(^PS(58.63,+Y,2)))))&('$$EMPTY^PSJPADPT(+Y))"
+6 SET DIC=58.63
SET DIC(0)="QABE"
SET DIC("A")="Select PADE Dispensing Device: "_$SELECT($DATA(PADEV)<10:"^ALL// ",1:"")
+7 SET DIC("W")="N PSJPADST S PSJPADST=$P($G(^PS(58.63,+$G(Y),0)),""^"",4),PSJPADST=$S(PSJPADST=""I"":"" (INACTIVE)"",1:"""") W PSJPADST"
+8 DO ^DIC
SET PSJX=X
+9 if $EXTRACT(PSJX)="^"
SET Y=$$XALL^PSJPDRIP(PSJX)
+10 IF X=""
IF $DATA(PADEV)<10
SET Y="ALL"
+11 if Y=-1
SET Y=""
+12 SET PSCAB=Y
+13 if ($GET(DUOUT)&(PSCAB'="ALL"))!$GET(DTOUT)
SET PSJSTOP=1
+14 QUIT PSCAB
+15 ;
PSJCSUB(PSJINP,PSJCSUB) ; Get Controlled Subs (CS) Schedules
+1 NEW DIR,X,Y,PSJDONE,SCHED,SCHLST
+2 KILL PSJCSUB
+3 WRITE !
DO EN^DDIOL(" Enter '^ALL' to select all Controlled substance")
+4 DO EN^DDIOL(" schedules and all non-controlled substances.")
WRITE !
+5 SET DIR("A")="Enter (C)S or (N)on-CS: ^ALL//"
SET DIR(0)="SAO^C:Controlled Substances;N:Non-Controlled Substances;ALL:All CS Schedules and Non-CS"
+6 DO ^DIR
if X=""
SET Y="ALL"
+7 IF $EXTRACT(X)="^"
SET Y=$$XALL^PSJPDRIP(X)
+8 SET PSJCSUB=Y
+9 IF PSJCSUB'="ALL"&($GET(DUOUT)!$GET(DTOUT)!(Y=""))
SET PSJSTOP=1
QUIT
+10 if PSJCSUB="N"!(PSJCSUB="ALL")
SET PSJCSUB(0)="Unscheduled"
+11 if PSJCSUB="N"
QUIT
+12 ; If YES to Controlled Subs, get CS Schedule
+13 SET SCHLST="1:Schedule I;2:Schedule II;2n:Schedule II Non-Narcotics;3:Schedule III;3n:Schedule III Non-Narcotics;4:Schedule IV;5:Schedule V"
+14 IF PSJCSUB="ALL"
DO ALLSCHED^PSJPDRIP(.PSJCSUB,SCHLST)
SET PSJCSUB="ALL"
QUIT
+15 KILL PSJDONE,PSJCSUB
+16 NEW DIR,X,Y,SCNT
+17 FOR
if $GET(PSJSTOP)!$GET(PSJDONE)
QUIT
DO SELCSUB^PSJPDRTR(.PSJCSUB)
+18 QUIT
+19 ;
DRUG(DRUG,PSJINP) ; Allow user to select appropriate subset of drug items
+1 NEW PSDONE,DIC,X,Y,GETDRG,LSTCNT,PSJCSUB,DRGARAY,PSJPSYS,PADEV,PSJDRC
+2 SET PSJCSUB=$GET(PSJINP("PSJCSUB"))
+3 SET PSJPSYS=$GET(PSJINP("PSJPSYS"))
+4 MERGE PADEV=PSJINP("PADEV")
+5 ; Get drugs linked to cabinet(s)
DO DRCAB(.PSJINP,.PSJDRC)
+6 ; Prompt for drug items
DO DRUGSEL^PSJPDRTR(.PSJINP,.PSJDRC,.DRUG,,.PSJSTOP)
+7 QUIT
+8 ;
SUMM() ; Prompt user for Detailed or Summary report
+1 NEW SUMM,DIR,X,Y
+2 SET DIR(0)="S^D:Detailed Report;S:Summary Report"
+3 SET DIR("A")="Select (D)etail or (S)ummary Report "
+4 SET DIR("B")="S"
SET DIR("?")="You may select 'D' for a detailed report or 'S' for a Summary report."
+5 DO ^DIR
if $GET(DUOUT)!$GET(DTOUT)
SET PSJSTOP=1
+6 QUIT Y
+7 ;
DELIM() ; Prompt user for delimited output or formatted report.
+1 NEW DELIM,DIR,X,Y
+2 SET DIR(0)="S^R:Report;D:Delimited Output"
+3 SET DIR("A")="Select (R)eport or (D)elimited output "
+4 SET DIR("B")="R"
SET DIR("?")="You may select 'R' for a report or 'D' for CSV delimited output (for spreadsheet)"
+5 DO ^DIR
if $GET(DUOUT)!$GET(DTOUT)
SET PSJSTOP=1
+6 SET DELIM=Y
+7 QUIT DELIM
+8 ;
GETCLASS(DRGIEN) ; Get Controlled Substance Federal Schedule from VA PRODUCT FILE for DRUG FILE (#50) entry DRGIEN
+1 ; Input : pointer to DRUG (#50) file
+2 ; Output : Value from CS FEDERAL SCHEDULE field (#19) in VA PRODUCT (#50.68) file
+3 NEW PSJDPROD,PSJCLASS,PSJNDF
SET PSJCLASS=0
+4 if '$GET(DRGIEN)
QUIT "-1"
+5 KILL ^TMP($JOB,"PSJCLASS")
+6 SET PSJNDF=$PIECE($GET(^PSDRUG(+DRGIEN,"ND")),"^",3)
IF '$GET(PSJNDF)
Begin DoDot:1
+7 NEW CS
SET CS=$PIECE($GET(^PSDRUG(+DRGIEN,0)),"^",3)
+8 SET PSJCLASS=$SELECT(+CS>1&(+CS<6):+CS,1:0)
IF ((PSJCLASS=2)!(PSJCLASS=3))&(CS["C")
SET PSJCLASS=PSJCLASS_"n"
End DoDot:1
QUIT PSJCLASS
+9 DO DATA^PSN50P68(PSJNDF,,"PSJCLASS")
+10 SET PSJCLASS=$PIECE($GET(^TMP($JOB,"PSJCLASS",+PSJNDF,19)),"^")
+11 SET PSJCLASS=$SELECT(PSJCLASS]"":PSJCLASS,1:0)
+12 KILL ^TMP($JOB,"PSJCLASS")
+13 QUIT PSJCLASS
+14 ;
LISTDRG(SCREEN,DRGARAY) ; Get list of drugs from drug file screened by SCREEN, outpat DRGARAY
+1 KILL DRGARAY
+2 NEW DIC,X,Y
+3 DO LIST^DIC(50,,,"P",,,,,SCREEN,,"DRGARAY")
+4 QUIT
+5 ;
PROCESS(PSJINP) ; Gather report data, store in ^TMP
+1 IF PSJINP("PSJSUM")="S"
DO PROCSUM(.PSJINP)
QUIT
+2 IF PSJINP("PSJSUM")'="S"
DO PROCDET(.PSJINP)
+3 QUIT
+4 ;
PROCSUM(PSJINP) ; Gather SUMMARY report data
+1 NEW PSJCAB,PSJDRG,CC,LNCNT,TABMAR,PSJPSYS,PSJCABNM,PSJQTY,PSJDFORM,PSJII,PSJOI,PSJDFIEN,PSJCABST,PSJDRGX,PSJDNAM
+2 SET PSJINP("PSPGTOT")=1
SET LNCNT=1
+3 SET $PIECE(TABMAR," ",40)=" "
+4 SET PSJPSYS=+PSJINP("PSJPSYS")
+5 MERGE PSJCAB=PSJINP("PADEV")
+6 MERGE PSJDRG=PSJINP("PSDRG")
+7 SET PSJCAB=0
FOR CC=0:1
SET PSJCAB=$ORDER(PSJCAB(PSJCAB))
if 'PSJCAB
QUIT
Begin DoDot:1
+8 SET PSJCABNM=$PIECE($GET(^PS(58.63,PSJCAB,0)),"^")
SET PSJCABST=$PIECE($GET(^PS(58.63,PSJCAB,0)),"^",4)
SET PSJCABST=$SELECT(PSJCABST="I":"(I)",1:"")
+9 NEW PSJDRGX
DO ALPHADRG(PSJPSYS,PSJCAB,.PSJDRG,.PSJDRGX)
+10 IF PSJINP("PSJDELM")="R"
Begin DoDot:2
+11 if '$DATA(PSJDRGX)
QUIT
+12 IF $GET(CC)
SET ^TMP("PSJPDRIN",$JOB,LNCNT)="^"
SET LNCNT=LNCNT+1
+13 SET ^TMP("PSJPDRIN",$JOB,LNCNT)=PSJCABNM_PSJCABST
SET LNCNT=LNCNT+1
End DoDot:2
+14 SET PSJDNAM=""
FOR PSJII=1:1
SET PSJDNAM=$ORDER(PSJDRGX(PSJDNAM))
if PSJDNAM=""
QUIT
SET PSJDRG=0
SET PSJDRG=$ORDER(PSJDRGX(PSJDNAM,PSJDRG))
if 'PSJDRG
QUIT
Begin DoDot:2
+15 SET PSJCABNM=$SELECT(PSJINP("PSJDELM")="D":PSJCABNM,1:"")
+16 SET PSJQTY=$$QTY(PSJPSYS,PSJCAB,PSJDRG)
+17 SET PSJOI=+$GET(^PSDRUG(PSJDRG,2))
+18 SET PSJDFORM=$EXTRACT($$DFORM(PSJPSYS,PSJCAB,PSJDRG),1,11)
+19 IF PSJDFORM=""
SET PSJDFIEN=$PIECE($GET(^PS(50.7,PSJOI,0)),"^",2)
IF PSJDFIEN
Begin DoDot:3
+20 NEW X,Y,DIC
+21 SET DIC(0)="XN"
SET DIC="^PS(50.606,"
SET X=+PSJDFIEN
+22 DO DIC^PSSDI(50.606,"PSJ",.DIC,.X)
+23 SET PSJDFORM=$PIECE($GET(Y),"^",2)
End DoDot:3
+24 SET ^TMP("PSJPDRIN",$JOB,LNCNT)=PSJCABNM_"^"_PSJDNAM_" ("_PSJDRG_")"_"^"_PSJDFORM_"^"_$SELECT(PSJINP("PSJDELM")="R":$JUSTIFY(PSJQTY,4),1:PSJQTY)
SET LNCNT=LNCNT+1
End DoDot:2
End DoDot:1
+25 QUIT
+26 ;
PROCDET(PSJINP) ; Gather DETAIL report data
+1 NEW PSJCAB,PSJDRG,CC,LNCNT,TABMAR,PSJPSYS,PSJCABNM,DRGTOT,QTY,PSJDFORM,PSJOI,PSJII,QTY,PSJCOL,PCKNAM
+2 NEW PSJDFIEN,PSJDRNAM,PSJDRIEN,DRCNTOT
+3 SET PSJINP("PSPGTOT")=1
SET LNCNT=1
+4 SET $PIECE(TABMAR," ",40)=" "
+5 SET PSJPSYS=+PSJINP("PSJPSYS")
+6 MERGE PSJCAB=PSJINP("PADEV")
+7 MERGE PSJDRG=PSJINP("PSDRG")
+8 DO SETCOLS^PSJPDRIP(.PSJINP,.PSJCOL)
+9 SET PSJDRIEN=0
FOR
SET PSJDRIEN=$ORDER(PSJDRG(PSJDRIEN))
if 'PSJDRIEN
QUIT
SET PSJDRNAM=$PIECE(PSJDRG(PSJDRIEN),"^")
Begin DoDot:1
+10 SET PSJDRNAM(PSJDRNAM_"^"_PSJDRIEN)=""
End DoDot:1
+11 SET PSJDRNAM=""
FOR
SET PSJDRNAM=$ORDER(PSJDRNAM(PSJDRNAM))
if PSJDRNAM=""
QUIT
Begin DoDot:1
+12 SET PSJDRG=$PIECE(PSJDRNAM,"^",2)
+13 NEW DRWPCK,PSBFLAG
+14 if PSJINP("PSJDELM")="R"
SET ^TMP("PSJPDRIN",$JOB,LNCNT)=" ^ "
SET LNCNT=LNCNT+1
+15 SET DRGTOT=0
SET DRCNTOT=0
+16 ; If a Patient Specific Bin is included in the list, set flag
SET PSBFLAG=0
+17 SET PSJCAB=0
FOR
SET PSJCAB=$ORDER(PSJCAB(PSJCAB))
if 'PSJCAB
QUIT
IF $DATA(^PS(58.601,"DEV",PSJCAB,PSJDRG))
Begin DoDot:2
+18 NEW PSDRGLEN,PSJCABST,DRWPCK
+19 SET PSJCABST=$PIECE($GET(^PS(58.63,PSJCAB,0)),"^",4)
SET PSJCABST=$SELECT(PSJCABST="I":"(I)",1:"")
+20 SET PSJCABNM=$PIECE($GET(^PS(58.63,PSJCAB,0)),"^")_PSJCABST
+21 SET PSJQTY=$$QTY(PSJPSYS,PSJCAB,PSJDRG)
+22 SET DRGTOT=$GET(DRGTOT)+PSJQTY
+23 SET PSJOI=+$GET(^PSDRUG(PSJDRG,2))
+24 SET PSJDFIEN=$PIECE($GET(^PS(50.7,PSJOI,0)),"^",2)
+25 SET PSJDFORM=$$DFORM(PSJPSYS,PSJCAB,PSJDRG)
+26 IF PSJDFORM=""
SET PSJDFIEN=$PIECE($GET(^PS(50.7,PSJOI,0)),"^",2)
IF PSJDFIEN
Begin DoDot:3
+27 NEW X,Y,DIC
+28 SET DIC(0)="XN"
SET DIC="^PS(50.606,"
SET X=+PSJDFIEN
+29 DO DIC^PSSDI(50.606,"PSJ",.DIC,.X)
+30 SET PSJDFORM=$PIECE($GET(Y),"^",2)
End DoDot:3
+31 DO POCKDRG^PSJPDRIP(PSJPSYS,PSJCAB,PSJDRG,.DRWPCK)
+32 NEW CC
Begin DoDot:3
+33 SET PCKNAM=""
FOR CC=1:1
SET PCKNAM=$ORDER(DRWPCK(PSJDRG,PCKNAM))
if PCKNAM=""
QUIT
Begin DoDot:4
+34 NEW QTY,FMTQTY
SET QTY=+DRWPCK(PSJDRG,PCKNAM)
+35 ; *Requires individual pocket balances for multi-pocket drugs*
SET DRCNTOT=$GET(DRCNTOT)+QTY
+36 ; Handle max length drug names
NEW PSJDTRUN
+37 SET PSJDTRUN=$PIECE($GET(^PSDRUG(PSJDRG,0)),"^")
+38 IF $LENGTH(PSJDTRUN)>33
SET PSJDTRUN=$EXTRACT(PSJDTRUN,1,33)
+39 SET PSJDTRUN=PSJDTRUN_"("_PSJDRG_")"
+40 SET FMTQTY=$SELECT(PCKNAM["PSB":"*"_QTY,$EXTRACT(PCKNAM,$LENGTH(PCKNAM)-1,$LENGTH(PCKNAM))="RB":"*"_QTY,1:QTY)
+41 IF FMTQTY["*"
Begin DoDot:5
+42 SET PSBFLAG("PSB")=$SELECT($EXTRACT(PCKNAM,$LENGTH(PCKNAM)-2,$LENGTH(PCKNAM))["PSB":1,1:$GET(PSBFLAG("PSB")))
+43 SET PSBFLAG("RB")=$SELECT($EXTRACT(PCKNAM,$LENGTH(PCKNAM)-1,$LENGTH(PCKNAM))["RB":1,1:$GET(PSBFLAG("RB")))
End DoDot:5
+44 SET ^TMP("PSJPDRIN",$JOB,LNCNT)=PSJDTRUN_"^"_PSJDFORM_"^"_$SELECT(PSJINP("PSJDELM")="R":$JUSTIFY(FMTQTY,4),1:FMTQTY)_"^"_PSJCABNM_"^"_PCKNAM
SET LNCNT=LNCNT+1
End DoDot:4
+45 IF CC=1
NEW QTY,PSCABIEN,PSDRGIEN
SET PSCABIEN=$ORDER(^PS(58.601,PSJPSYS,"DEVICE","B",PSJCAB,""))
Begin DoDot:4
+46 SET QTY="-"
IF PSCABIEN
SET PSDRGIEN=$ORDER(^PS(58.601,PSJPSYS,"DEVICE",PSCABIEN,"DRUG","B",PSJDRG,""))
+47 ; Handle max length drug names
NEW PSJDTRUN
+48 SET PSJDTRUN=$PIECE($GET(^PSDRUG(PSJDRG,0)),"^")
+49 IF $LENGTH(PSJDTRUN)>33
SET PSJDTRUN=$EXTRACT(PSJDTRUN,1,33)
if $EXTRACT(PSJDTRUN,$LENGTH(PSJDTRUN))=" "
SET PSJDTRUN=$EXTRACT(PSJDTRUN,1,$LENGTH(PSJDTRUN)-1)
+50 SET PSJDTRUN=PSJDTRUN_" ("_PSJDRG_")"
+51 SET ^TMP("PSJPDRIN",$JOB,LNCNT)=PSJDTRUN_"^"_PSJDFORM_"^"_$SELECT(PSJINP("PSJDELM")="R":$JUSTIFY(QTY,4),1:QTY)_"^"_PSJCABNM_"^UNK"
SET LNCNT=LNCNT+1
End DoDot:4
End DoDot:3
QUIT
End DoDot:2
+52 IF PSJINP("PSJDELM")="R"
Begin DoDot:2
+53 SET ^TMP("PSJPDRIN",$JOB,LNCNT)=$EXTRACT(TABMAR,1,34)_"^^----"
SET LNCNT=LNCNT+1
+54 SET ^TMP("PSJPDRIN",$JOB,LNCNT)=$EXTRACT(TABMAR,1,34)_"^SUB TOTAL:^"_$JUSTIFY(DRCNTOT,4)
SET LNCNT=$GET(LNCNT)+1
+55 SET ^TMP("PSJPDRIN",$JOB,LNCNT)=$EXTRACT(TABMAR,1,24)_" REPORTED CABINET"_"^ TOTAL:^"_$JUSTIFY(DRGTOT,4)
SET LNCNT=$GET(LNCNT)+1
+56 IF $GET(PSBFLAG("PSB"))
SET ^TMP("PSJPDRIN",$JOB,LNCNT)="* Patient Specific Bin counts not included in Reported Cabinet Total."
SET LNCNT=$GET(LNCNT)+1
+57 IF $GET(PSBFLAG("RB"))
SET ^TMP("PSJPDRIN",$JOB,LNCNT)="* Return Bin counts not included in Reported Cabinet Total."
SET LNCNT=$GET(LNCNT)+1
End DoDot:2
End DoDot:1
+58 QUIT
+59 ;
QTY(SYS,PSJCAB,PSJDRG) ; Return quantity of drug PSJDRG in cabinet PSJCAB
+1 NEW QTY,PSYSIEN,PDEVIEN,PDRGIEN
+2 SET PSYSIEN=$ORDER(^PS(58.601,"DEV",PSJCAB,PSJDRG,""))
+3 SET PDEVIEN=$ORDER(^PS(58.601,"DEV",PSJCAB,PSJDRG,PSYSIEN,""))
+4 SET PDRGIEN=$ORDER(^PS(58.601,"DEV",PSJCAB,PSJDRG,PSYSIEN,PDEVIEN,""))
+5 SET QTY=+$PIECE($GET(^PS(58.601,PSYSIEN,"DEVICE",PDEVIEN,"DRUG",PDRGIEN,0)),"^",3)
+6 QUIT QTY
+7 ;
DFORM(SYS,PSJCAB,PSJDRG) ; Return Dose Form of drug PSJDRG in cabinet PSJCAB
+1 NEW FORM,PSYSIEN,PDEVIEN,PDRGIEN
+2 SET PSYSIEN=$ORDER(^PS(58.601,"DEV",PSJCAB,PSJDRG,""))
+3 SET PDEVIEN=$ORDER(^PS(58.601,"DEV",PSJCAB,PSJDRG,PSYSIEN,""))
+4 SET PDRGIEN=$ORDER(^PS(58.601,"DEV",PSJCAB,PSJDRG,PSYSIEN,PDEVIEN,""))
+5 SET FORM=$PIECE($GET(^PS(58.601,PSYSIEN,"DEVICE",PDEVIEN,"DRUG",PDRGIEN,0)),"^",5)
+6 QUIT FORM
+7 ;
DRCAB(PSJINP,PSJDRCAB) ; Return list of drugs in each cabinet in PSJINP("PADEV")
+1 ; Input = PSJINP("PADEV",CABINET IEN) - Cabinet IEN points to PADE DISPENSING DEVICE file 58.63
+2 ; Output = PSJDRCAB(DRUG IEN) - Drug IEN points to DRUG file 50
+3 KILL PSJDRCAB
+4 NEW CAB,CABDA,PSJPSYS,DRGDA,DRG
+5 SET PSJPSYS=$GET(PSJINP("PSJPSYS"))
+6 MERGE CAB=PSJINP("PADEV")
+7 SET CAB=0
FOR
SET CAB=$ORDER(CAB(CAB))
if 'CAB
QUIT
SET CABDA=$ORDER(^PS(58.601,PSJPSYS,"DEVICE","B",CAB,0))
IF CABDA
Begin DoDot:1
+8 SET DRGDA=0
FOR
SET DRGDA=$ORDER(^PS(58.601,PSJPSYS,"DEVICE",CABDA,"DRUG",DRGDA))
if 'DRGDA
QUIT
SET DRG=+$GET(^(DRGDA,0))
IF DRG
Begin DoDot:2
+9 if $DATA(PSJDRCAB(DRG))
QUIT
+10 IF '($GET(PSJINP("PSJCSUB"))="ALL")
if '$DATA(PSJINP("PSJCSUB",$$GETCLASS(DRG)))
QUIT
+11 SET PSJDRCAB(DRG)=$PIECE($GET(^PSDRUG(+$GET(DRG),0)),"^")
End DoDot:2
End DoDot:1
+12 QUIT
+13 ;
LISTALL(DRGLIST) ; Write list of drugs in DRGLIST("IEN",DRUG IEN)
+1 NEW II,DRGNAME,DRGIEN,TAB
+2 SET $PIECE(TAB," ",80)=""
+3 SET DRGIEN=0
FOR
SET DRGIEN=$ORDER(DRGLIST("IEN",DRGIEN))
if 'DRGIEN
QUIT
Begin DoDot:1
+4 WRITE !,$EXTRACT(TAB,1,8-$LENGTH(DRGIEN))_DRGIEN_" "_DRGLIST("IEN",DRGIEN)
End DoDot:1
+5 QUIT
+6 ;
DRUGLIST(PSJINP,DRGLIST) ; Return DRGLIST array with "IEN" and "NAME" cross referenced
+1 NEW I,DRG,DLST
+2 SET DRG=0
FOR I=1:1
SET DRG=$ORDER(DRGLIST(DRG))
if 'DRG
QUIT
Begin DoDot:1
+3 NEW DRGNAME
SET DRGNAME=$GET(DRGLIST(DRG))
+4 SET DRGLIST("IEN",DRG)=DRGNAME
+5 SET DRGLIST("NAME",DRGNAME)=DRG
End DoDot:1
+6 QUIT
+7 ;
SELDEV(RTN,PSJINP,PSJWIDE,ZTSK) ; Select Device
+1 ;
+2 NEW PSJDONE
+3 ;
+4 IF $GET(PSJINP("PSJDELM"))="D"
Begin DoDot:1
+5 NEW DIR,X,Y
+6 SET DIR("A",1)=""
+7 SET DIR("A",2)=" ************************************************************"
+8 SET DIR("A",3)=" ** You selected a Delimited report. Please verify you **"
+9 SET DIR("A",4)=" ** you have turned logging on to capture the output. **"
+10 SET DIR("A",5)=" ** **"
+11 SET DIR("A",6)=" ** To avoid undesired wrapping, please enter '0;512;999' **"
+12 SET DIR("A",7)=" ** at the 'DEVICE:' prompt. You may need to set your **"
+13 SET DIR("A",8)=" ** Terminal Session display settings to 512 columns. **"
+14 SET DIR("A",9)=" ************************************************************"
+15 SET DIR("A",10)=""
+16 SET DIR("A",11)=""
SET DIR("A",12)=""
+17 SET DIR("A")=" Press return to continue"
+18 SET DIR(0)="EA"
DO ^DIR
WRITE !
End DoDot:1
+19 ;
+20 WRITE !,"This report is designed for a "_$SELECT($GET(PSJWIDE):132,1:80)_" column format."
+21 WRITE !,"You may queue this report to print at a later time.",!
+22 FOR
if $GET(PSJSTOP)!$GET(PSJDONE)
QUIT
Begin DoDot:1
+23 KILL %ZIS,IOP,POP,ZTSK
NEW I
SET PSJION=$IO
SET %ZIS="QM"
+24 DO ^%ZIS
KILL %ZIS
+25 IF POP
SET IOP=PSJION
DO ^%ZIS
KILL IOP,PSJION
Begin DoDot:2
+26 NEW DIR,X,Y
+27 SET DIR(0)="YA"
SET DIR("A",1)=" ** No Device Selected **"
SET DIR("A")="Select a different device? (Y/N) "
DO ^DIR
+28 if 'Y
SET PSJSTOP=1
End DoDot:2
QUIT
+29 SET PSJDONE=1
End DoDot:1
+30 ;
+31 KILL PSJION
IF $DATA(IO("Q"))
Begin DoDot:1
+32 SET ZTDESC="PADE Inventory Report"
SET ZTRTN=$SELECT($GET(RTN)]"":$GET(RTN),1:"START^PSJPDRIN")
+33 FOR I="PSJINP(","IO"
SET ZTSAVE(I)=""
+34 KILL IO("Q")
DO ^%ZTLOAD
if $DATA(ZTSK)
WRITE !,"Report is Queued to print!"
End DoDot:1
QUIT "Q"
+35 QUIT ""
+36 ;
CONT(PGCNT,PSJQUIT,TMPLN) ; Press return to continue
+1 NEW DIR
+2 IF ($EXTRACT($GET(IOST))="C")
WRITE !
Begin DoDot:1
+3 if '$DATA(DIR("A"))
SET DIR("A")="Press Return to continue or '^' to exit"
+4 SET DIR(0)="FO"
+5 DO ^DIR
KILL DIR
+6 IF $GET(DTOUT)!$GET(DUOUT)
SET PSJSTOP=1
End DoDot:1
+7 QUIT
+8 ;
ALPHADRG(SYS,CAB,DRG,DRGX) ; Alphabetize drug names DRGNAME in DRG(IEN)=DRGNAME, return in DRG(DRGNAME,IEN)=""
+1 NEW DRGIEN,DRGNAME
+2 SET DRGIEN=0
FOR
SET DRGIEN=$ORDER(DRG(DRGIEN))
if 'DRGIEN
QUIT
SET DRGNAME=$GET(DRG(DRGIEN))
IF DRGNAME]""
Begin DoDot:1
+3 if '$DATA(^PS(58.601,"DEV",CAB,DRGIEN))
QUIT
+4 SET DRGX(DRGNAME,DRGIEN)=""
End DoDot:1
+5 QUIT
+6 ;
POCKET(PSJINP,PSDRG,OUTPOCK) ; Get pocket(s)
+1 ;
+2 NEW DRAWER,POCKET,DRGPCK,PSJPSYS,PADIEN,PADEV,DRGDEV,DRWIEN,DRGDRW,SUB,SUBID
+3 SET PSJPSYS=$GET(PSJINP("PSJPSYS"))
SET PADEV=$GET(PSJINP("PADEV"))
+4 SET PADIEN=$ORDER(^PS(58.601,+PSJPSYS,"DEVICE","B",+PADEV,""))
+5 if '$GET(PSDRG)!'$GET(PSJPSYS)!'$GET(PADIEN)
QUIT
+6 ;
+7 SET OUTPOCK=PSDRG
+8 SET DRWIEN=0
FOR
SET DRWIEN=$ORDER(^PS(58.601,+PSJPSYS,"DEVICE",+PADIEN,"DRAWER",DRWIEN))
if 'DRWIEN
QUIT
Begin DoDot:1
+9 SET SUB=0
FOR
SET SUB=$ORDER(^PS(58.601,PSJPSYS,"DEVICE",PADIEN,"DRAWER",DRWIEN,"SUB",SUB))
if 'SUB
QUIT
Begin DoDot:2
+10 SET DRGPCK=$PIECE(^PS(58.601,PSJPSYS,"DEVICE",PADIEN,"DRAWER",DRWIEN,"SUB",SUB,0),"^",5)
SET POCKET=$PIECE(^(0),"^",3)
SET SUBID=$PIECE($GET(^(0)),"^",4)
+11 if '(DRGPCK=$GET(PSDRG))
QUIT
+12 SET DRAWER=$GET(^PS(58.601,+PSJPSYS,"DEVICE",+PADIEN,"DRAWER",DRWIEN,0))
+13 if DRAWER=""
SET DRAWER="~~"
+14 SET POCKET=DRAWER_"_"_POCKET
+15 SET DRGDRW=$ORDER(^PS(58.601,PSJPSYS,"DEVICE",PADIEN,"DRAWER",DRWIEN,"DRUG","B",PSDRG,""))
+16 SET OUTPOCK(DRGPCK,DRWIEN,SUB)=POCKET_"^"_DRGDRW_"^"_DRAWER_$SELECT($LENGTH(SUBID):"^"_SUBID,1:"")
End DoDot:2
End DoDot:1
+17 SET DRGDEV=$ORDER(^PS(58.601,PSJPSYS,"DEVICE",PADIEN,"DRUG","B",PSDRG,""))
+18 SET OUTPOCK(PSDRG,"DRGDEV")=DRGDEV
+19 QUIT
