- 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 Jan 18, 2025@03:10 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