PSJPDRTR ;BIR/JH-MAIN DRIVER PADE TRANSACTION REPORT ;18 JUN 96 / 2:58 PM
;;5.0;INPATIENT MEDICATIONS;**317**;16 DEC 97;Build 130
;
; Reference to ^%DT is supported by DBIA 10003.
; Reference to CLEAR^VALM1 is supported by DBIA 10116.
; Reference to ^XLFDT is supported by DBIA 10103.
; Reference to ^DPT supported by DBIA 10035
; Reference to ^PSDRUG supported by DBIA 2192
Q
;
EN ; Main Entry point
N PSJSTOP,PSDRG,PSJINP,DTOUT,DUOUT
S PSJSTOP=0
F Q:$G(PSJSTOP)<0 D ENLOOP
Q
;
ENLOOP ; Prompt loop
N PSJINP,ZTSK,DIR,DIC,ZTSK,PSJTSK
K ^TMP($J,"PSJPTLST"),^TMP($J,"PSJPAT")
S PSJSTOP=0
D ASK(.PSJINP) G:PSJSTOP EXIT
Q:$G(PSJINP("PSJDEV"))="Q"
START ; Queued entry
N PSJSTOP,PSJDLRJ S PSJSTOP=0
S PSJDLRJ=$J
I $G(ZTSK) S (PSJDLRJ,PSJINP("PSJTSK"))=ZTSK
K ^TMP($J,"PSJPDRTR"),^TMP($J,"TSCREEN")
D PROCESS(.PSJINP) G:PSJSTOP EXIT
D EN^PSJPDRTP(.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($J,"TSCREEN")
K ^TMP($J,"PSJPDRTR")
K ^TMP($J,"PSJPTLST")
K ^TMP($J,"PSJPAT")
Q
;
ASK(PSJINP) ;Prompt for selection criteria. Quit if PSJSTOP is true
N PSJCSUB,PSJSYS,PSJDEV,PSJDIV,PADEV,PSJSUMM,PSJDELIM,PSJDRG,PSDRG,PSJUSER,PSJTRANS,PSJOVR,PSJDONE,PSJSYSE,PSJPAT,PSJPSYSE,PSJTRX
D CLEAR^VALM1 W !!
S PSJSTOP=0
W ?20,"PADE Transaction Report",!
S PSJINP("PSJPSYS")=$$PSYS^PSJPDRIN() Q:PSJSTOP
S PSJINP("PSJPSYSE")=$P($G(^PS(58.601,+$G(PSJINP("PSJPSYS")),0)),"^")
D DIV^PSJPDRIP(.PSJDIV,.PSJSTOP) Q:PSJSTOP M PSJINP("PSJDIV")=PSJDIV
S PSJINP("PSJBDT")=$$DATE^PSJPDRUT("B",.PSJSTOP) Q:PSJSTOP
S PSJINP("PSJEDT")=$$DATE^PSJPDRUT("E",.PSJSTOP,.PSJINP) Q:PSJSTOP
D PADEV(.PADEV,.PSJINP) Q:PSJSTOP M PSJINP("PADEV")=PADEV
D PSJCSUB^PSJPDRIN(.PSJINP,.PSJCSUB) Q:PSJSTOP M PSJINP("PSJCSUB")=PSJCSUB
D DRUG(.PSDRG,.PSJINP) Q:PSJSTOP M PSJINP("PSDRG")=PSDRG
D PATIENT(.PSJINP,.PSJPAT) Q:PSJSTOP M PSJINP("PSJPAT")=PSJPAT M ^TMP($J,"PSJPAT")=^TMP($J,"PSJPTLST","SELPAT") K ^TMP($J,"PSJPTLST")
D TRANS(.PSJINP,.PSJTRANS,.PSJOVR) Q:PSJSTOP M PSJINP("PSJTRANS")=PSJTRANS S PSJINP("PSJOVR")=$G(PSJOVR)
D USER(.PSJINP,.PSJUSER) Q:PSJSTOP M PSJINP("PSJUSER")=PSJUSER
S PSJINP("PSJDELM")=$$DELIM^PSJPDRIN Q:PSJSTOP
S PSJINP("PSJDEV")=$$SELDEV^PSJPDRIN("START^PSJPDRTR",.PSJINP,1,.PSJTSK) D Q:PSJSTOP
.I $G(PSJTSK) S PSJINP("PSJTSK")=PSJTSK M ^TMP(PSJTSK,"PSJPAT")=^TMP($J,"PSJPAT")
.S:$G(DUOUT)!$G(DTOUT) PSJSTOP=1
Q
;
PADEV(PADEV,PSJINP,PSJ58601) ; Get list of PADE device(s)
N PADE,PSJI,PSJPSYS,BDT,EDT,PADEDT,PSJDONE,PADEX,PSJPSYSI,PADEVTMP
S BDT=$G(PSJINP("PSJBDT")),EDT=$G(PSJINP("PSJEDT"))
S PSJPSYS=$P($G(^PS(58.601,+$G(PSJINP("PSJPSYS")),0)),"^")
S PSJPSYSI=$G(PSJINP("PSJPSYS"))
D PADELST(.PSJINP,.PADE,.PADEX,$G(PSJ58601))
;
I $D(PADE)<10 D Q
.S PSJSTOP=1
.W !!,"PADE Dispensing Device: "
.W !," No PADE dispensing device available for selection..",!
.S DIR(0)="E" D ^DIR
W ! D EN^DDIOL(" Enter '^ALL' to select all PADE dispensing devices.") W !
S PSJPSYS=PSJPSYSI
F Q:$G(PSJDONE)!$G(PSJSTOP) D SELPADE(.PADE,.PADEV,.PADEX,$G(PSJ58601))
Q:$G(PSJSTOP)
S PADE="" F S PADE=$O(PADEV(PADE)) Q:PADE="" D
.N PADVALS S PADVALS(1)=PADE,PADVALS(2)=PSJPSYS
.S PADEV(PADE)=$$FIND1^DIC(58.63,,"X",PADE)
Q
;
PADELST(PSJINP,PADE,PADEX,PSJ58601) ; Find selectable PADE devices for PADE Inbound System PSJPSYS
; and PADE transactions between PSJINP("PSJBDT") and PSJINP("EDT")
; INPUT: PSJINP("PSJPSYS")
; PSJINP("PSJBDT")
; PSJINP("PSJEDT")
; OUPUT: PADE(PADE NAME)=n
; PADE(n)=PADE NAME
;
N PSJDIV,PSJHTM,PSJDOTS,PSPDIEN,PADETMP,PADETMPX,II
S PSJHTM=$P($H,",",2),PSJDOTS=""
S BDT=$G(PSJINP("PSJBDT")),EDT=$G(PSJINP("PSJEDT"))
S PSJPSYS=$P($G(^PS(58.601,+$G(PSJINP("PSJPSYS")),0)),"^")
S PSJPSYSI=$G(PSJINP("PSJPSYS"))
S PSJI=1
I '$G(PSJ58601) S PADE="" F S PADE=$O(^PS(58.6,"DEV",PSJPSYS,PADE)) Q:PADE="" D
.Q:$D(PADE(PADE))
.S PADEDT=BDT F S PADEDT=$O(^PS(58.6,"DEV",PSJPSYS,PADE,PADEDT)) Q:'PADEDT D
..D DISPDOTS^PSJPDRUT(.PSJHTM,.PSJDOTS,1)
..Q:PADEDT>EDT
..D PADELST2(.PSJINP,.PADE,.PADEX)
I $G(PSJ58601) S PSPDIEN=0 F S PSPDIEN=$O(^PS(58.601,+PSJPSYSI,"DEVICE","B",PSPDIEN)) Q:'PSPDIEN D
.S PADE=$P($G(^PS(58.63,+PSPDIEN,0)),"^")
.Q:PADE=""!'$$DEVSCRN^PSJPDRUT(.PSJINP,PSPDIEN)
.D PADELST2(.PSJINP,.PADE,.PADEX)
I $D(PADEX)>1 N PADETMP,PADETMPX M PADETMP=PADE,PADETMPX=PADEX K PADE,PADEX D
.N PADNAME,PADIEN
.S PADNAME="" F II=1:1 S PADNAME=$O(PADETMP(PADNAME)) Q:PADNAME="" S PADE(PADNAME)=II,PADEX(II)=PADNAME
Q
;
PADELST2(PSJINP,PADE,PADEX) ; Continue building PADE device list
Q:$D(PADE(PADE))
N PADIEN,PADESTAT,PSJPSYS
S PSJPSYS=PSJPSYSI
S PADIEN=$$FIND1^DIC(58.63,,"O",PADE) I PADIEN S PADESTAT=$P($G(^PS(58.63,+PADIEN,0)),"^",4),PADESTAT=$S(PADESTAT="I":" (INACTIVE)",1:"")
K PSJDIV D GETS^DIQ(58.63,PADIEN,"2","I","PSJDIV")
S PSJDIV=+$G(PSJDIV("58.63",PADIEN_",",2,"I"))
Q:'$D(PSJINP("PSJDIV",PSJDIV))
S PADE(PADE)=PSJI
S PADEX(PSJI)=PADE_"^"_$G(PADESTAT),PSJI=PSJI+1
Q
;
SELPADE(PADE,PADEV,PADEX,PS58601) ; Prompt for one PADE device (or ALL)
N DIR,X,Y,DEVNAME,PSJY,PSJLSTA,PSFOUND,PADEUP,NOXREF
N PSJPART,II,PSELMSG,PLSTMSG,PADXDATA,PSALLPC
S PLSTMSG(1)="Transactions matching the entered Date Range and Division "
S PLSTMSG(2)="exist for the PADE Dispensing devices listed below."
S DIR(0)="FAO^1:30",DIR("?")="^D LIST^PSJPDRTR(.PADEX,.PLSTMSG,15,.PSJLSTA)"
S DIR("A")="Select PADE Dispensing Device: "_$S($D(PADEV)>1:"",1:" ^ALL// ")
D ^DIR
I X="",($D(PADEV)<10) S Y="ALL"
I $E(X)="^" S Y=$$XALL^PSJPDRIP(X)
I $G(DUOUT)!$G(DTOUT) S PSJSTOP=1 Q
I Y="ALL" M PADEV=PADE S PADEV="ALL",PSJDONE=1 Q
I Y="" D Q
.I $D(PADEV)>1 S PSJDONE=1 Q
.W !!?2,"Select a single Item, several Items or enter ^ALL to select all Items."
S PSJY=Y
D PADEUP^PSJPDRUT(.PADE,.PADEUP)
I $D(PADE(PSJY))&$$UNIQUE^PSJPDRUT(PSJY,.PADE) D Q
.W " ",PSJY,$P($G(PADEX(PADE(PSJY))),"^",2) S PADEV(PSJY)=""
I $D(PADEUP($$UPPER^HLFNC(PSJY)))&$$UNIQUE^PSJPDRUT($$UPPER^HLFNC(PSJY),.PADE) D Q:($P($G(PADXDATA),"^")]"")
.S PADXDATA=$G(PADEX(PADEUP($$UPPER^HLFNC(PSJY))))
.W " ",$P(PADXDATA,"^"),$P(PADXDATA,"^",2) I $P(PADXDATA,"^")]"" S PADEV($P(PADXDATA,"^"))=""
; If "?" list executed, check integers in PADEX list
I $G(PSJLSTA) I $D(PADEX(PSJY)) D Q
.N PADENAME S PADENAME=$P($G(PADEX(PSJY)),"^") I PADENAME="" W " ???" Q ; Null cabinet/device name? (impossible?!?!)
.W " ",$P($G(PADEX(PSJY)),"^") S PADEV(PADENAME)=""
S PSELMSG="Select a PADE device"
S NOXREF=1,PSALLPC=1 ; don't use cross refs, return all data from partial lookup
D PARTIAL^PSJPADPT(PSJY,.PADE,.PADEV,,PSELMSG,.PADEX,.PSFOUND,NOXREF,PSALLPC)
Q:$G(PSFOUND)
W " ?? (No match found)"
Q
;
SELCSUB(PSJCSUB) ; Prompt for one controlled subs schedule or (ALL)
N X,Y,SCHED,SCHLST,SCNT,I,PSJPAD,PSJTMP
S $P(PSJPAD," ",80)=""
W ! D EN^DDIOL(" Enter '^ALL' to select all Controlled substance schedules.") W !
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;ALL:All CS Schedules"
F I=1:1:$L(SCHLST,";") S PSJTMP=$L($P($P(SCHLST,";",I),":")) D
.S DIR("A",I)=$E(PSJPAD,1,12-PSJTMP)_$P($P(SCHLST,";",I),":",1)_$E(PSJPAD,1,6)_$P($P(SCHLST,";",I),":",2)
S DIR(0)="SAO^"_SCHLST
S DIR("A")="Select CS Schedule: "_$S($D(PSJCSUB)<10:"^ALL//",1:"")
D ^DIR I X="",$D(PSJCSUB)<10 S Y="ALL"
I $E(X)="^" S Y=$$XALL^PSJPDRIP(X)
S SCHED=Y
I $G(DUOUT)!$G(DTOUT) S PSJSTOP=1 Q
I SCHED="ALL" D ALLSCHED^PSJPDRIP(.PSJCSUB,SCHLST) S PSJCSUB="CS (ALL)",PSJDONE=1 Q
I SCHED="" D Q
.I $D(PSJCSUB)>1 S PSJDONE=1 Q
.W " Select a CS Schedule"
S PSJCSUB(SCHED)=""
Q
;
DRUG(DRUG,PSJINP) ; Allow user to select appropriate subset of drug items
N PSDONE,DIC,X,Y,GETDRG,LSTCNT,DRGARAY,PSJPSYS,PADEV,PSJDRC
M PADEV=PSJINP("PADEV")
D DRCAB(.PSJINP,.PSJDRC) ; Get drugs linked to cabinet(s)
D DRUGSEL^PSJPDRTR(.PSJINP,.PSJDRC,.DRUG,,.PSJSTOP) ; Prompt fo drug item, allow drugs not on file
Q
;
DRCAB(PSJINP,PSJDRCAB) ; Return list of drugs in each cabinet in PSJINP("PADEV")
; Input = PSJINP("PADEV",CABINET NAME) - 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,DRGDT,BDT,EDT,PSJPSYSE,PSDRGIEN,PSJHTM,PSJDOTS
S PSJHTM=$P($H,",",2),PSJDOTS=""
S PSJPSYS=$G(PSJINP("PSJPSYS"))
S PSJPSYSE=$G(PSJINP("PSJPSYSE"))
I PSJPSYSE="" S PSJPSYSE=$P($G(^PS(58.601,+PSJPSYS,0)),"^"),PSJINP("PSJPSYSE")=PSJPSYSE
S BDT=$G(PSJINP("PSJBDT")),EDT=$G(PSJINP("PSJEDT"))
M CAB=PSJINP("PADEV")
S CAB="" F S CAB=$O(CAB(CAB)) Q:CAB="" D
.S DRG=0 F S DRG=$O(^PS(58.6,"DEVD",PSJPSYSE,CAB,DRG)) Q:'DRG D
..D DISPDOTS^PSJPDRUT(.PSJHTM,.PSJDOTS,1)
..Q:$D(PSJDRCAB(DRG))
..I '($G(PSJINP("PSJCSUB"))="ALL") Q:'$D(PSJINP("PSJCSUB",$$GETCLASS^PSJPDRIN(DRG)))
..S DRGDT=$O(^PS(58.6,"DEVD",PSJPSYSE,CAB,DRG,BDT))
..Q:'DRGDT!(DRGDT>EDT)
..S PSJDRCAB(DRG)=$P($G(^PSDRUG(+DRG,0)),"^")
S CAB="" F S CAB=$O(CAB(CAB)) Q:CAB="" D
.S DRG=0 F S DRG=$O(^PS(58.6,"MDRG",PSJPSYSE,CAB,DRG)) Q:DRG="" D
..Q:$D(PSJDRCAB("*"_+DRG))
..S DRGDT=$O(^PS(58.6,"MDRG",PSJPSYSE,CAB,DRG,BDT))
..Q:'DRGDT!(DRGDT>EDT)
..N PSTRANS,PSALTID
..S PSTRANS=+$O(^PS(58.6,"MDRG",PSJPSYSE,CAB,DRG,DRGDT,""))
..Q:'PSTRANS
..S PSDRGIEN=$P($G(^PS(58.6,+PSTRANS,0)),"^",3)
..Q:PSDRGIEN
..S PSALTID=$P($G(^PS(58.6,+PSTRANS,1)),"^",7)
..S PSJDRCAB("*"_DRG)=$G(PSALTID)
Q
;
DRUGSEL(PSJINP,INDRUG,OUTDRUG,DRWPCK,PSJSTOP) ; Select drug(s)
N COUNT,PSJCNT,DIR,X,Y,PSJDONE,DRGLIST,DRGNAME,PSJY,DRGN,PSJTMP,SELDRG,PSFOUND,PSALLPC
K DRWPCK
M DRGLIST=INDRUG
S COUNT=0,PSJDONE=0,OUTDRUG=""
D DRUGLIST^PSJPDRIN(.PSJINP,.DRGLIST)
I $D(DRGLIST)<10 D Q
.S PSJSTOP=1
.W !!,"Drug Item: "
.W !," No Drug Items available for selection..",!
.S DIR(0)="E" D ^DIR
I '$G(PSJINP("MANUNLOD")) W ! D EN^DDIOL(" Enter '^ALL' to select all available drug items") W !
F Q:$G(DUOUT)!$G(DTOUT)!$G(PSJDONE)!$G(PSJSTOP) D
.N PSJPART,II
.N DIR,X,Y,DUOUT
.S DIR(0)="FOA",DIR("A")="Select Drug Item: "_$S($D(OUTDRUG)>1:"",$G(PSJINP("MANUNLOD")):"",1:"^ALL// ")
.S DIR("?")="^D LIST^PSJPDRTR(.INDRUG,,15)"
.D ^DIR I X=""&($D(OUTDRUG)<10)&'$G(PSJINP("MANUNLOD")) S Y="ALL"
.I $E(X)="^" S Y=$$XALL^PSJPDRIP(X)
.I $G(DUOUT)!$G(DTOUT) S PSJSTOP=1 Q
.I Y="" D Q
..I $D(OUTDRUG)>1!$G(PSJINP("MANUNLOD")) S PSJDONE=1 Q
..W !!?2,"Select a single Item, several Items or enter ^ALL to select all Items."
.S PSJY=Y
.I PSJY="ALL" S OUTDRUG="ALL",PSJDONE=1 D Q
..I $G(PSJINP("MANUNLOD")) S DRWPCK="ALL" Q
..N DRGIEN S DRGIEN=0 F S DRGIEN=$O(INDRUG(DRGIEN)) Q:DRGIEN="" D
...S OUTDRUG(DRGIEN)=$S(DRGIEN["*":$P(DRGIEN,"*",2),1:$P($G(^PSDRUG(+DRGIEN,0)),"^"))
.I $D(DRGLIST("IEN",+PSJY)) D Q
..W " ",DRGLIST("IEN",+PSJY)
..S OUTDRUG(+PSJY)=$P($G(^PSDRUG(+PSJY,0)),"^")
..I $G(PSJINP("MANUNLOD")) D POCKET^PSJPDRIN(.PSJINP,+PSJY,.DRWPCK) S PSJDONE=1
.S PSALLPC=0 ; don't return all data pieces from partial lookup
.D PARTIAL^PSJPADPT(.PSJY,.DRGLIST,.SELDRG,1,,,.PSFOUND,,PSALLPC)
.M OUTDRUG=SELDRG
.I $G(PSJINP("MANUNLOD")) D Q
..S PSJY=$O(SELDRG(0))
..I $G(PSJY) D POCKET^PSJPDRIN(.PSJINP,+PSJY,.DRWPCK) S PSJDONE=1 Q
..W " ??"
.I '$G(PSFOUND) W " ?? (No match found)" S PSJDONE=0
Q
;
PATIENT(PSJINP,SELPAT) ; Get list of patients
D PATIENT^PSJPDRU1(.PSJINP)
Q
;
USER(PSJINP,PSJUSER) ; Get Vista Users (e.g., nurses) involved in PADE transactions
N PSJDONE,USER,USERX,SELUSER K PSJUSER
D USERLIST^PSJPDRUT(.PSJINP,.USER,.USERX)
;
F Q:$G(PSJDONE)!$G(PSJSTOP) D
.D SELUSER^PSJPDRUT(.PSJINP,.USER,.SELUSER,.USERX,.PSJSTOP)
S PSJUSER=$G(SELUSER)
S USER="" F S USER=$O(SELUSER(USER)) Q:USER="" D
.S PSJUSER(USER)=SELUSER(USER)
Q
;
TRANS(PSJINP,PSJTRANS,PSJOVR) ; Get Transaction Types of PADE transactions
N PSJDONE K PSJTRANS,PSJOVR,PSJTRX
F Q:$G(PSJSTOP)!$G(PSJDONE) D SELTRANS(.PSJTRANS,.PSJTRX)
Q:$G(PSJSTOP)
; Prompt for override only if a Vend (PSJTRANS(1)) or Return (PSJTRANS(7)) was selected
I $D(PSJTRX("Dispense"))!$D(PSJTRX("Return"))!$D(PSJTRX("Waste")) S PSJOVR=$$OVRTRAN()
Q
;
OVRTRAN() ; Prompt if only override transactions - only prompt if DISPENSE/VEND type was selected
N DIR
S DIR(0)="YA",DIR("B")="N"
S DIR("A")="Select Override Transaction only? "
S DIR("?",1)=" Select 'Y' to display transactions where the user"
S DIR("?",2)=" dispensed an item without an order. Otherwise ALL"
S DIR("?")=" entries will be displayed."
D ^DIR I $G(DUOUT)!$G(DTOUT) S PSJSTOP=1 Q ""
Q Y
;
SELTRANS(TRANS,TRANSX) ; Prompt for one transaction type (or ALL)
N DIR
W ! D EN^DDIOL(" Enter '^ALL' to select all Transaction Types.") W !
;
D TRANLIST(.PSJINP,.DIR)
D ^DIR I X="",$D(TRANS)<10 S Y="ALL"
I $E(X)["^" S Y=$$XALL^PSJPDRIP(X)
I $G(DTOUT)!$G(DUOUT) S PSJSTOP=1 Q
I Y="",$D(TRANS)>1 S PSJDONE=1 Q
I Y="ALL" S PSJDONE=1 D Q
.N PADLIST,CNT,TXPIECE
.S PADLIST=$P(DIR(0),"^",2)
.F CNT=1:1:$L(PADLIST,";") S TXPIECE=$P(PADLIST,";",CNT) S TRANS($P(TXPIECE,":"))=$P(TXPIECE,":",2),TRANSX($P(TXPIECE,":",2))=$P(TXPIECE,":")
.S TRANS="ALL"
I Y>0 D
.N PADLIST,CNT,TXPIECE
.S PADLIST=$P(DIR(0),"^",2)
.F CNT=1:1:$L(PADLIST,";") S TXPIECE=$P(PADLIST,";",CNT) I +TXPIECE=+Y S TRANS($P(TXPIECE,":"))=$P(TXPIECE,":",2),TRANSX($P(TXPIECE,":",2))=$P(TXPIECE,":")
Q
;
LIST(NLIST,MSG,MAX,AUDIT) ; Write list in LIST(ID1)=ID1
N II,NAME,NUMBER,TAB,NAME,ID1,ID2,PSCNT,DUOUT,DTOUT,DIR,X,Y,LIST,LISTX
K AUDIT S AUDIT=1 ; Return evidence this was called
S $P(TAB," ",80)=""
S PSCNT=0
Q:$D(NLIST)<10
I $L($G(MSG)) W !,MSG,!
I $D(MSG)>1 D W !
.S II=0 F S II=$O(MSG(II)) Q:'II W !,MSG(II)
S ID2="" F S ID2=$O(NLIST(ID2)) Q:ID2="" S NAME=$G(NLIST(ID2)) S:NAME="" NAME="UNKNOWN" D
.S LIST($P(NAME,"^")_"^"_ID2)=$P(NAME,"^",2),LISTX(ID2)=$P(NAME,"^")_"^"_ID2
S II="" F S II=$O(LISTX(II)) Q:II=""!$G(DTOUT)!$G(DUOUT) D
.S ID1=LISTX(II)
.N PSJMARG
.S PSJMARG=" "
.S PSJMARG=$S($E(ID1)="*":$E(TAB,1,17),$E(II)="*":$E(TAB,1,17),1:$E(TAB,1,12-$L($P(ID1,"^",2))))
.W !," "_$P(ID1,"^",2)_PSJMARG_$P(ID1,"^")_" "_$P(LIST(ID1),"^")
.S PSCNT=$G(PSCNT)+1
.I $G(MAX),(PSCNT>$G(MAX)) W !! S DIR(0)="E" D ^DIR S PSCNT=0 W !!
Q
;
PROCESS(PSJINP) ; Gather report data, store in ^TMP
N PSJBDT,PSJSCR,TSCREEN
S PSJBDT=$G(PSJINP("PSJBDT"))
S PSJSCR="I $$TSCREEN^PSJPDRTP(Y,.PSJINP)"
D LIST^DIC(58.6,,"@;2;1;23;10;.01I;4;15;12;3;16;14I;6.1;6.2;7.1;7.2;21;25;18;19;1.2;11;13","P",,PSJBDT,,"B",PSJSCR,,"^TMP($J,""TSCREEN"")")
D PROCSUM^PSJPDRTP(.PSJINP) Q
K ^TMP(PSJDLRJ,"TSCREEN")
Q
;
DIVSTR(PSJINP) ; Return Divisions in PSJINP("PSJDIV") in string
N DIVSTR,DIV,II,DIVNAM
S DIVSTR=""
I PSJINP("PSJDIV")="ALL" Q "ALL"
;
S DIV="" F II=0:1 S DIV=$O(PSJINP("PSJDIV",DIV)) Q:DIV="" D
.S DIVNAM=$P($G(^DG(40.8,+DIV,0)),"^")
.S DIVSTR=DIVSTR_$S(II:",",1:"")_DIVNAM
Q DIVSTR
;
TRANLIST(PSJINP,DIR) ; Set selectable transactions into DIR based on patient selection
N PATFLG,PADLIST,CNT,TXPIECE,LAST,PSJPSYS,PSJBDT,PSJEDT
S PATFLG=0
S PSJPSYS=+$G(PSJINP("PSJPSYS")),PSJBDT=+$G(PSJINP("PSJBDT")),PSJEDT=+$G(PSJINP("PSJEDT"))
; Filter to include ONLY transactions that have received from this vendor during this date range
S DIR(0)="SOA^"_$$TTYPDIR^PSJPDRUT(PSJPSYS,PSJBDT,PSJEDT)
I '$P(DIR(0),"^",2) D Q
.K DIR S DIR("A")="No recognized Transaction types have been received for this vendor system."
.S PSJSTOP=-1
S DIR("A")="Select Transaction Type: "_$S($D(TRANS)>1:"",1:"^ALL//")
S DIR("A",1)="Select one of the following transaction types:"
S PADLIST=$P(DIR(0),"^",2)
F CNT=1:1:$L(PADLIST,";") S TXPIECE=$P(PADLIST,";",CNT) D
.S DIR("A",CNT+1)=" "_$P(TXPIECE,":")_" "_$P(TXPIECE,":",2)
S LAST=$O(DIR("A",999999),-1)
S DIR("A",LAST+1)=" or ^ALL for all Transactions."
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSJPDRTR 16225 printed Apr 09, 2024@21:04:24 Page 2
PSJPDRTR ;BIR/JH-MAIN DRIVER PADE TRANSACTION REPORT ;18 JUN 96 / 2:58 PM
+1 ;;5.0;INPATIENT MEDICATIONS;**317**;16 DEC 97;Build 130
+2 ;
+3 ; Reference to ^%DT is supported by DBIA 10003.
+4 ; Reference to CLEAR^VALM1 is supported by DBIA 10116.
+5 ; Reference to ^XLFDT is supported by DBIA 10103.
+6 ; Reference to ^DPT supported by DBIA 10035
+7 ; Reference to ^PSDRUG supported by DBIA 2192
+8 QUIT
+9 ;
EN ; Main Entry point
+1 NEW PSJSTOP,PSDRG,PSJINP,DTOUT,DUOUT
+2 SET PSJSTOP=0
+3 FOR
if $GET(PSJSTOP)<0
QUIT
DO ENLOOP
+4 QUIT
+5 ;
ENLOOP ; Prompt loop
+1 NEW PSJINP,ZTSK,DIR,DIC,ZTSK,PSJTSK
+2 KILL ^TMP($JOB,"PSJPTLST"),^TMP($JOB,"PSJPAT")
+3 SET PSJSTOP=0
+4 DO ASK(.PSJINP)
if PSJSTOP
GOTO EXIT
+5 if $GET(PSJINP("PSJDEV"))="Q"
QUIT
START ; Queued entry
+1 NEW PSJSTOP,PSJDLRJ
SET PSJSTOP=0
+2 SET PSJDLRJ=$JOB
+3 IF $GET(ZTSK)
SET (PSJDLRJ,PSJINP("PSJTSK"))=ZTSK
+4 KILL ^TMP($JOB,"PSJPDRTR"),^TMP($JOB,"TSCREEN")
+5 DO PROCESS(.PSJINP)
if PSJSTOP
GOTO EXIT
+6 DO EN^PSJPDRTP(.PSJINP)
+7 IF $GET(PSJINP("PSJDELM"))="D"
Begin DoDot:1
+8 NEW DIR,X,Y
SET DIR(0)="EA"
+9 SET DIR("A",1)=""
+10 SET DIR("A",2)="The delimited report is complete."
+11 SET DIR("A")="Please turn logging off, then press return to continue."
+12 DO ^DIR
End DoDot:1
+13 QUIT
+14 ;
EXIT ; Clean up
+1 KILL ^TMP($JOB,"TSCREEN")
+2 KILL ^TMP($JOB,"PSJPDRTR")
+3 KILL ^TMP($JOB,"PSJPTLST")
+4 KILL ^TMP($JOB,"PSJPAT")
+5 QUIT
+6 ;
ASK(PSJINP) ;Prompt for selection criteria. Quit if PSJSTOP is true
+1 NEW PSJCSUB,PSJSYS,PSJDEV,PSJDIV,PADEV,PSJSUMM,PSJDELIM,PSJDRG,PSDRG,PSJUSER,PSJTRANS,PSJOVR,PSJDONE,PSJSYSE,PSJPAT,PSJPSYSE,PSJTRX
+2 DO CLEAR^VALM1
WRITE !!
+3 SET PSJSTOP=0
+4 WRITE ?20,"PADE Transaction Report",!
+5 SET PSJINP("PSJPSYS")=$$PSYS^PSJPDRIN()
if PSJSTOP
QUIT
+6 SET PSJINP("PSJPSYSE")=$PIECE($GET(^PS(58.601,+$GET(PSJINP("PSJPSYS")),0)),"^")
+7 DO DIV^PSJPDRIP(.PSJDIV,.PSJSTOP)
if PSJSTOP
QUIT
MERGE PSJINP("PSJDIV")=PSJDIV
+8 SET PSJINP("PSJBDT")=$$DATE^PSJPDRUT("B",.PSJSTOP)
if PSJSTOP
QUIT
+9 SET PSJINP("PSJEDT")=$$DATE^PSJPDRUT("E",.PSJSTOP,.PSJINP)
if PSJSTOP
QUIT
+10 DO PADEV(.PADEV,.PSJINP)
if PSJSTOP
QUIT
MERGE PSJINP("PADEV")=PADEV
+11 DO PSJCSUB^PSJPDRIN(.PSJINP,.PSJCSUB)
if PSJSTOP
QUIT
MERGE PSJINP("PSJCSUB")=PSJCSUB
+12 DO DRUG(.PSDRG,.PSJINP)
if PSJSTOP
QUIT
MERGE PSJINP("PSDRG")=PSDRG
+13 DO PATIENT(.PSJINP,.PSJPAT)
if PSJSTOP
QUIT
MERGE PSJINP("PSJPAT")=PSJPAT
MERGE ^TMP($JOB,"PSJPAT")=^TMP($JOB,"PSJPTLST","SELPAT")
KILL ^TMP($JOB,"PSJPTLST")
+14 DO TRANS(.PSJINP,.PSJTRANS,.PSJOVR)
if PSJSTOP
QUIT
MERGE PSJINP("PSJTRANS")=PSJTRANS
SET PSJINP("PSJOVR")=$GET(PSJOVR)
+15 DO USER(.PSJINP,.PSJUSER)
if PSJSTOP
QUIT
MERGE PSJINP("PSJUSER")=PSJUSER
+16 SET PSJINP("PSJDELM")=$$DELIM^PSJPDRIN
if PSJSTOP
QUIT
+17 SET PSJINP("PSJDEV")=$$SELDEV^PSJPDRIN("START^PSJPDRTR",.PSJINP,1,.PSJTSK)
Begin DoDot:1
+18 IF $GET(PSJTSK)
SET PSJINP("PSJTSK")=PSJTSK
MERGE ^TMP(PSJTSK,"PSJPAT")=^TMP($JOB,"PSJPAT")
+19 if $GET(DUOUT)!$GET(DTOUT)
SET PSJSTOP=1
End DoDot:1
if PSJSTOP
QUIT
+20 QUIT
+21 ;
PADEV(PADEV,PSJINP,PSJ58601) ; Get list of PADE device(s)
+1 NEW PADE,PSJI,PSJPSYS,BDT,EDT,PADEDT,PSJDONE,PADEX,PSJPSYSI,PADEVTMP
+2 SET BDT=$GET(PSJINP("PSJBDT"))
SET EDT=$GET(PSJINP("PSJEDT"))
+3 SET PSJPSYS=$PIECE($GET(^PS(58.601,+$GET(PSJINP("PSJPSYS")),0)),"^")
+4 SET PSJPSYSI=$GET(PSJINP("PSJPSYS"))
+5 DO PADELST(.PSJINP,.PADE,.PADEX,$GET(PSJ58601))
+6 ;
+7 IF $DATA(PADE)<10
Begin DoDot:1
+8 SET PSJSTOP=1
+9 WRITE !!,"PADE Dispensing Device: "
+10 WRITE !," No PADE dispensing device available for selection..",!
+11 SET DIR(0)="E"
DO ^DIR
End DoDot:1
QUIT
+12 WRITE !
DO EN^DDIOL(" Enter '^ALL' to select all PADE dispensing devices.")
WRITE !
+13 SET PSJPSYS=PSJPSYSI
+14 FOR
if $GET(PSJDONE)!$GET(PSJSTOP)
QUIT
DO SELPADE(.PADE,.PADEV,.PADEX,$GET(PSJ58601))
+15 if $GET(PSJSTOP)
QUIT
+16 SET PADE=""
FOR
SET PADE=$ORDER(PADEV(PADE))
if PADE=""
QUIT
Begin DoDot:1
+17 NEW PADVALS
SET PADVALS(1)=PADE
SET PADVALS(2)=PSJPSYS
+18 SET PADEV(PADE)=$$FIND1^DIC(58.63,,"X",PADE)
End DoDot:1
+19 QUIT
+20 ;
PADELST(PSJINP,PADE,PADEX,PSJ58601) ; Find selectable PADE devices for PADE Inbound System PSJPSYS
+1 ; and PADE transactions between PSJINP("PSJBDT") and PSJINP("EDT")
+2 ; INPUT: PSJINP("PSJPSYS")
+3 ; PSJINP("PSJBDT")
+4 ; PSJINP("PSJEDT")
+5 ; OUPUT: PADE(PADE NAME)=n
+6 ; PADE(n)=PADE NAME
+7 ;
+8 NEW PSJDIV,PSJHTM,PSJDOTS,PSPDIEN,PADETMP,PADETMPX,II
+9 SET PSJHTM=$PIECE($HOROLOG,",",2)
SET PSJDOTS=""
+10 SET BDT=$GET(PSJINP("PSJBDT"))
SET EDT=$GET(PSJINP("PSJEDT"))
+11 SET PSJPSYS=$PIECE($GET(^PS(58.601,+$GET(PSJINP("PSJPSYS")),0)),"^")
+12 SET PSJPSYSI=$GET(PSJINP("PSJPSYS"))
+13 SET PSJI=1
+14 IF '$GET(PSJ58601)
SET PADE=""
FOR
SET PADE=$ORDER(^PS(58.6,"DEV",PSJPSYS,PADE))
if PADE=""
QUIT
Begin DoDot:1
+15 if $DATA(PADE(PADE))
QUIT
+16 SET PADEDT=BDT
FOR
SET PADEDT=$ORDER(^PS(58.6,"DEV",PSJPSYS,PADE,PADEDT))
if 'PADEDT
QUIT
Begin DoDot:2
+17 DO DISPDOTS^PSJPDRUT(.PSJHTM,.PSJDOTS,1)
+18 if PADEDT>EDT
QUIT
+19 DO PADELST2(.PSJINP,.PADE,.PADEX)
End DoDot:2
End DoDot:1
+20 IF $GET(PSJ58601)
SET PSPDIEN=0
FOR
SET PSPDIEN=$ORDER(^PS(58.601,+PSJPSYSI,"DEVICE","B",PSPDIEN))
if 'PSPDIEN
QUIT
Begin DoDot:1
+21 SET PADE=$PIECE($GET(^PS(58.63,+PSPDIEN,0)),"^")
+22 if PADE=""!'$$DEVSCRN^PSJPDRUT(.PSJINP,PSPDIEN)
QUIT
+23 DO PADELST2(.PSJINP,.PADE,.PADEX)
End DoDot:1
+24 IF $DATA(PADEX)>1
NEW PADETMP,PADETMPX
MERGE PADETMP=PADE,PADETMPX=PADEX
KILL PADE,PADEX
Begin DoDot:1
+25 NEW PADNAME,PADIEN
+26 SET PADNAME=""
FOR II=1:1
SET PADNAME=$ORDER(PADETMP(PADNAME))
if PADNAME=""
QUIT
SET PADE(PADNAME)=II
SET PADEX(II)=PADNAME
End DoDot:1
+27 QUIT
+28 ;
PADELST2(PSJINP,PADE,PADEX) ; Continue building PADE device list
+1 if $DATA(PADE(PADE))
QUIT
+2 NEW PADIEN,PADESTAT,PSJPSYS
+3 SET PSJPSYS=PSJPSYSI
+4 SET PADIEN=$$FIND1^DIC(58.63,,"O",PADE)
IF PADIEN
SET PADESTAT=$PIECE($GET(^PS(58.63,+PADIEN,0)),"^",4)
SET PADESTAT=$SELECT(PADESTAT="I":" (INACTIVE)",1:"")
+5 KILL PSJDIV
DO GETS^DIQ(58.63,PADIEN,"2","I","PSJDIV")
+6 SET PSJDIV=+$GET(PSJDIV("58.63",PADIEN_",",2,"I"))
+7 if '$DATA(PSJINP("PSJDIV",PSJDIV))
QUIT
+8 SET PADE(PADE)=PSJI
+9 SET PADEX(PSJI)=PADE_"^"_$GET(PADESTAT)
SET PSJI=PSJI+1
+10 QUIT
+11 ;
SELPADE(PADE,PADEV,PADEX,PS58601) ; Prompt for one PADE device (or ALL)
+1 NEW DIR,X,Y,DEVNAME,PSJY,PSJLSTA,PSFOUND,PADEUP,NOXREF
+2 NEW PSJPART,II,PSELMSG,PLSTMSG,PADXDATA,PSALLPC
+3 SET PLSTMSG(1)="Transactions matching the entered Date Range and Division "
+4 SET PLSTMSG(2)="exist for the PADE Dispensing devices listed below."
+5 SET DIR(0)="FAO^1:30"
SET DIR("?")="^D LIST^PSJPDRTR(.PADEX,.PLSTMSG,15,.PSJLSTA)"
+6 SET DIR("A")="Select PADE Dispensing Device: "_$SELECT($DATA(PADEV)>1:"",1:" ^ALL// ")
+7 DO ^DIR
+8 IF X=""
IF ($DATA(PADEV)<10)
SET Y="ALL"
+9 IF $EXTRACT(X)="^"
SET Y=$$XALL^PSJPDRIP(X)
+10 IF $GET(DUOUT)!$GET(DTOUT)
SET PSJSTOP=1
QUIT
+11 IF Y="ALL"
MERGE PADEV=PADE
SET PADEV="ALL"
SET PSJDONE=1
QUIT
+12 IF Y=""
Begin DoDot:1
+13 IF $DATA(PADEV)>1
SET PSJDONE=1
QUIT
+14 WRITE !!?2,"Select a single Item, several Items or enter ^ALL to select all Items."
End DoDot:1
QUIT
+15 SET PSJY=Y
+16 DO PADEUP^PSJPDRUT(.PADE,.PADEUP)
+17 IF $DATA(PADE(PSJY))&$$UNIQUE^PSJPDRUT(PSJY,.PADE)
Begin DoDot:1
+18 WRITE " ",PSJY,$PIECE($GET(PADEX(PADE(PSJY))),"^",2)
SET PADEV(PSJY)=""
End DoDot:1
QUIT
+19 IF $DATA(PADEUP($$UPPER^HLFNC(PSJY)))&$$UNIQUE^PSJPDRUT($$UPPER^HLFNC(PSJY),.PADE)
Begin DoDot:1
+20 SET PADXDATA=$GET(PADEX(PADEUP($$UPPER^HLFNC(PSJY))))
+21 WRITE " ",$PIECE(PADXDATA,"^"),$PIECE(PADXDATA,"^",2)
IF $PIECE(PADXDATA,"^")]""
SET PADEV($PIECE(PADXDATA,"^"))=""
End DoDot:1
if ($PIECE($GET(PADXDATA),"^")]"")
QUIT
+22 ; If "?" list executed, check integers in PADEX list
+23 IF $GET(PSJLSTA)
IF $DATA(PADEX(PSJY))
Begin DoDot:1
+24 ; Null cabinet/device name? (impossible?!?!)
NEW PADENAME
SET PADENAME=$PIECE($GET(PADEX(PSJY)),"^")
IF PADENAME=""
WRITE " ???"
QUIT
+25 WRITE " ",$PIECE($GET(PADEX(PSJY)),"^")
SET PADEV(PADENAME)=""
End DoDot:1
QUIT
+26 SET PSELMSG="Select a PADE device"
+27 ; don't use cross refs, return all data from partial lookup
SET NOXREF=1
SET PSALLPC=1
+28 DO PARTIAL^PSJPADPT(PSJY,.PADE,.PADEV,,PSELMSG,.PADEX,.PSFOUND,NOXREF,PSALLPC)
+29 if $GET(PSFOUND)
QUIT
+30 WRITE " ?? (No match found)"
+31 QUIT
+32 ;
SELCSUB(PSJCSUB) ; Prompt for one controlled subs schedule or (ALL)
+1 NEW X,Y,SCHED,SCHLST,SCNT,I,PSJPAD,PSJTMP
+2 SET $PIECE(PSJPAD," ",80)=""
+3 WRITE !
DO EN^DDIOL(" Enter '^ALL' to select all Controlled substance schedules.")
WRITE !
+4 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;ALL:All CS Schedules"
+5 FOR I=1:1:$LENGTH(SCHLST,";")
SET PSJTMP=$LENGTH($PIECE($PIECE(SCHLST,";",I),":"))
Begin DoDot:1
+6 SET DIR("A",I)=$EXTRACT(PSJPAD,1,12-PSJTMP)_$PIECE($PIECE(SCHLST,";",I),":",1)_$EXTRACT(PSJPAD,1,6)_$PIECE($PIECE(SCHLST,";",I),":",2)
End DoDot:1
+7 SET DIR(0)="SAO^"_SCHLST
+8 SET DIR("A")="Select CS Schedule: "_$SELECT($DATA(PSJCSUB)<10:"^ALL//",1:"")
+9 DO ^DIR
IF X=""
IF $DATA(PSJCSUB)<10
SET Y="ALL"
+10 IF $EXTRACT(X)="^"
SET Y=$$XALL^PSJPDRIP(X)
+11 SET SCHED=Y
+12 IF $GET(DUOUT)!$GET(DTOUT)
SET PSJSTOP=1
QUIT
+13 IF SCHED="ALL"
DO ALLSCHED^PSJPDRIP(.PSJCSUB,SCHLST)
SET PSJCSUB="CS (ALL)"
SET PSJDONE=1
QUIT
+14 IF SCHED=""
Begin DoDot:1
+15 IF $DATA(PSJCSUB)>1
SET PSJDONE=1
QUIT
+16 WRITE " Select a CS Schedule"
End DoDot:1
QUIT
+17 SET PSJCSUB(SCHED)=""
+18 QUIT
+19 ;
DRUG(DRUG,PSJINP) ; Allow user to select appropriate subset of drug items
+1 NEW PSDONE,DIC,X,Y,GETDRG,LSTCNT,DRGARAY,PSJPSYS,PADEV,PSJDRC
+2 MERGE PADEV=PSJINP("PADEV")
+3 ; Get drugs linked to cabinet(s)
DO DRCAB(.PSJINP,.PSJDRC)
+4 ; Prompt fo drug item, allow drugs not on file
DO DRUGSEL^PSJPDRTR(.PSJINP,.PSJDRC,.DRUG,,.PSJSTOP)
+5 QUIT
+6 ;
DRCAB(PSJINP,PSJDRCAB) ; Return list of drugs in each cabinet in PSJINP("PADEV")
+1 ; Input = PSJINP("PADEV",CABINET NAME) - 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,DRGDT,BDT,EDT,PSJPSYSE,PSDRGIEN,PSJHTM,PSJDOTS
+5 SET PSJHTM=$PIECE($HOROLOG,",",2)
SET PSJDOTS=""
+6 SET PSJPSYS=$GET(PSJINP("PSJPSYS"))
+7 SET PSJPSYSE=$GET(PSJINP("PSJPSYSE"))
+8 IF PSJPSYSE=""
SET PSJPSYSE=$PIECE($GET(^PS(58.601,+PSJPSYS,0)),"^")
SET PSJINP("PSJPSYSE")=PSJPSYSE
+9 SET BDT=$GET(PSJINP("PSJBDT"))
SET EDT=$GET(PSJINP("PSJEDT"))
+10 MERGE CAB=PSJINP("PADEV")
+11 SET CAB=""
FOR
SET CAB=$ORDER(CAB(CAB))
if CAB=""
QUIT
Begin DoDot:1
+12 SET DRG=0
FOR
SET DRG=$ORDER(^PS(58.6,"DEVD",PSJPSYSE,CAB,DRG))
if 'DRG
QUIT
Begin DoDot:2
+13 DO DISPDOTS^PSJPDRUT(.PSJHTM,.PSJDOTS,1)
+14 if $DATA(PSJDRCAB(DRG))
QUIT
+15 IF '($GET(PSJINP("PSJCSUB"))="ALL")
if '$DATA(PSJINP("PSJCSUB",$$GETCLASS^PSJPDRIN(DRG)))
QUIT
+16 SET DRGDT=$ORDER(^PS(58.6,"DEVD",PSJPSYSE,CAB,DRG,BDT))
+17 if 'DRGDT!(DRGDT>EDT)
QUIT
+18 SET PSJDRCAB(DRG)=$PIECE($GET(^PSDRUG(+DRG,0)),"^")
End DoDot:2
End DoDot:1
+19 SET CAB=""
FOR
SET CAB=$ORDER(CAB(CAB))
if CAB=""
QUIT
Begin DoDot:1
+20 SET DRG=0
FOR
SET DRG=$ORDER(^PS(58.6,"MDRG",PSJPSYSE,CAB,DRG))
if DRG=""
QUIT
Begin DoDot:2
+21 if $DATA(PSJDRCAB("*"_+DRG))
QUIT
+22 SET DRGDT=$ORDER(^PS(58.6,"MDRG",PSJPSYSE,CAB,DRG,BDT))
+23 if 'DRGDT!(DRGDT>EDT)
QUIT
+24 NEW PSTRANS,PSALTID
+25 SET PSTRANS=+$ORDER(^PS(58.6,"MDRG",PSJPSYSE,CAB,DRG,DRGDT,""))
+26 if 'PSTRANS
QUIT
+27 SET PSDRGIEN=$PIECE($GET(^PS(58.6,+PSTRANS,0)),"^",3)
+28 if PSDRGIEN
QUIT
+29 SET PSALTID=$PIECE($GET(^PS(58.6,+PSTRANS,1)),"^",7)
+30 SET PSJDRCAB("*"_DRG)=$GET(PSALTID)
End DoDot:2
End DoDot:1
+31 QUIT
+32 ;
DRUGSEL(PSJINP,INDRUG,OUTDRUG,DRWPCK,PSJSTOP) ; Select drug(s)
+1 NEW COUNT,PSJCNT,DIR,X,Y,PSJDONE,DRGLIST,DRGNAME,PSJY,DRGN,PSJTMP,SELDRG,PSFOUND,PSALLPC
+2 KILL DRWPCK
+3 MERGE DRGLIST=INDRUG
+4 SET COUNT=0
SET PSJDONE=0
SET OUTDRUG=""
+5 DO DRUGLIST^PSJPDRIN(.PSJINP,.DRGLIST)
+6 IF $DATA(DRGLIST)<10
Begin DoDot:1
+7 SET PSJSTOP=1
+8 WRITE !!,"Drug Item: "
+9 WRITE !," No Drug Items available for selection..",!
+10 SET DIR(0)="E"
DO ^DIR
End DoDot:1
QUIT
+11 IF '$GET(PSJINP("MANUNLOD"))
WRITE !
DO EN^DDIOL(" Enter '^ALL' to select all available drug items")
WRITE !
+12 FOR
if $GET(DUOUT)!$GET(DTOUT)!$GET(PSJDONE)!$GET(PSJSTOP)
QUIT
Begin DoDot:1
+13 NEW PSJPART,II
+14 NEW DIR,X,Y,DUOUT
+15 SET DIR(0)="FOA"
SET DIR("A")="Select Drug Item: "_$SELECT($DATA(OUTDRUG)>1:"",$GET(PSJINP("MANUNLOD")):"",1:"^ALL// ")
+16 SET DIR("?")="^D LIST^PSJPDRTR(.INDRUG,,15)"
+17 DO ^DIR
IF X=""&($DATA(OUTDRUG)<10)&'$GET(PSJINP("MANUNLOD"))
SET Y="ALL"
+18 IF $EXTRACT(X)="^"
SET Y=$$XALL^PSJPDRIP(X)
+19 IF $GET(DUOUT)!$GET(DTOUT)
SET PSJSTOP=1
QUIT
+20 IF Y=""
Begin DoDot:2
+21 IF $DATA(OUTDRUG)>1!$GET(PSJINP("MANUNLOD"))
SET PSJDONE=1
QUIT
+22 WRITE !!?2,"Select a single Item, several Items or enter ^ALL to select all Items."
End DoDot:2
QUIT
+23 SET PSJY=Y
+24 IF PSJY="ALL"
SET OUTDRUG="ALL"
SET PSJDONE=1
Begin DoDot:2
+25 IF $GET(PSJINP("MANUNLOD"))
SET DRWPCK="ALL"
QUIT
+26 NEW DRGIEN
SET DRGIEN=0
FOR
SET DRGIEN=$ORDER(INDRUG(DRGIEN))
if DRGIEN=""
QUIT
Begin DoDot:3
+27 SET OUTDRUG(DRGIEN)=$SELECT(DRGIEN["*":$PIECE(DRGIEN,"*",2),1:$PIECE($GET(^PSDRUG(+DRGIEN,0)),"^"))
End DoDot:3
End DoDot:2
QUIT
+28 IF $DATA(DRGLIST("IEN",+PSJY))
Begin DoDot:2
+29 WRITE " ",DRGLIST("IEN",+PSJY)
+30 SET OUTDRUG(+PSJY)=$PIECE($GET(^PSDRUG(+PSJY,0)),"^")
+31 IF $GET(PSJINP("MANUNLOD"))
DO POCKET^PSJPDRIN(.PSJINP,+PSJY,.DRWPCK)
SET PSJDONE=1
End DoDot:2
QUIT
+32 ; don't return all data pieces from partial lookup
SET PSALLPC=0
+33 DO PARTIAL^PSJPADPT(.PSJY,.DRGLIST,.SELDRG,1,,,.PSFOUND,,PSALLPC)
+34 MERGE OUTDRUG=SELDRG
+35 IF $GET(PSJINP("MANUNLOD"))
Begin DoDot:2
+36 SET PSJY=$ORDER(SELDRG(0))
+37 IF $GET(PSJY)
DO POCKET^PSJPDRIN(.PSJINP,+PSJY,.DRWPCK)
SET PSJDONE=1
QUIT
+38 WRITE " ??"
End DoDot:2
QUIT
+39 IF '$GET(PSFOUND)
WRITE " ?? (No match found)"
SET PSJDONE=0
End DoDot:1
+40 QUIT
+41 ;
PATIENT(PSJINP,SELPAT) ; Get list of patients
+1 DO PATIENT^PSJPDRU1(.PSJINP)
+2 QUIT
+3 ;
USER(PSJINP,PSJUSER) ; Get Vista Users (e.g., nurses) involved in PADE transactions
+1 NEW PSJDONE,USER,USERX,SELUSER
KILL PSJUSER
+2 DO USERLIST^PSJPDRUT(.PSJINP,.USER,.USERX)
+3 ;
+4 FOR
if $GET(PSJDONE)!$GET(PSJSTOP)
QUIT
Begin DoDot:1
+5 DO SELUSER^PSJPDRUT(.PSJINP,.USER,.SELUSER,.USERX,.PSJSTOP)
End DoDot:1
+6 SET PSJUSER=$GET(SELUSER)
+7 SET USER=""
FOR
SET USER=$ORDER(SELUSER(USER))
if USER=""
QUIT
Begin DoDot:1
+8 SET PSJUSER(USER)=SELUSER(USER)
End DoDot:1
+9 QUIT
+10 ;
TRANS(PSJINP,PSJTRANS,PSJOVR) ; Get Transaction Types of PADE transactions
+1 NEW PSJDONE
KILL PSJTRANS,PSJOVR,PSJTRX
+2 FOR
if $GET(PSJSTOP)!$GET(PSJDONE)
QUIT
DO SELTRANS(.PSJTRANS,.PSJTRX)
+3 if $GET(PSJSTOP)
QUIT
+4 ; Prompt for override only if a Vend (PSJTRANS(1)) or Return (PSJTRANS(7)) was selected
+5 IF $DATA(PSJTRX("Dispense"))!$DATA(PSJTRX("Return"))!$DATA(PSJTRX("Waste"))
SET PSJOVR=$$OVRTRAN()
+6 QUIT
+7 ;
OVRTRAN() ; Prompt if only override transactions - only prompt if DISPENSE/VEND type was selected
+1 NEW DIR
+2 SET DIR(0)="YA"
SET DIR("B")="N"
+3 SET DIR("A")="Select Override Transaction only? "
+4 SET DIR("?",1)=" Select 'Y' to display transactions where the user"
+5 SET DIR("?",2)=" dispensed an item without an order. Otherwise ALL"
+6 SET DIR("?")=" entries will be displayed."
+7 DO ^DIR
IF $GET(DUOUT)!$GET(DTOUT)
SET PSJSTOP=1
QUIT ""
+8 QUIT Y
+9 ;
SELTRANS(TRANS,TRANSX) ; Prompt for one transaction type (or ALL)
+1 NEW DIR
+2 WRITE !
DO EN^DDIOL(" Enter '^ALL' to select all Transaction Types.")
WRITE !
+3 ;
+4 DO TRANLIST(.PSJINP,.DIR)
+5 DO ^DIR
IF X=""
IF $DATA(TRANS)<10
SET Y="ALL"
+6 IF $EXTRACT(X)["^"
SET Y=$$XALL^PSJPDRIP(X)
+7 IF $GET(DTOUT)!$GET(DUOUT)
SET PSJSTOP=1
QUIT
+8 IF Y=""
IF $DATA(TRANS)>1
SET PSJDONE=1
QUIT
+9 IF Y="ALL"
SET PSJDONE=1
Begin DoDot:1
+10 NEW PADLIST,CNT,TXPIECE
+11 SET PADLIST=$PIECE(DIR(0),"^",2)
+12 FOR CNT=1:1:$LENGTH(PADLIST,";")
SET TXPIECE=$PIECE(PADLIST,";",CNT)
SET TRANS($PIECE(TXPIECE,":"))=$PIECE(TXPIECE,":",2)
SET TRANSX($PIECE(TXPIECE,":",2))=$PIECE(TXPIECE,":")
+13 SET TRANS="ALL"
End DoDot:1
QUIT
+14 IF Y>0
Begin DoDot:1
+15 NEW PADLIST,CNT,TXPIECE
+16 SET PADLIST=$PIECE(DIR(0),"^",2)
+17 FOR CNT=1:1:$LENGTH(PADLIST,";")
SET TXPIECE=$PIECE(PADLIST,";",CNT)
IF +TXPIECE=+Y
SET TRANS($PIECE(TXPIECE,":"))=$PIECE(TXPIECE,":",2)
SET TRANSX($PIECE(TXPIECE,":",2))=$PIECE(TXPIECE,":")
End DoDot:1
+18 QUIT
+19 ;
LIST(NLIST,MSG,MAX,AUDIT) ; Write list in LIST(ID1)=ID1
+1 NEW II,NAME,NUMBER,TAB,NAME,ID1,ID2,PSCNT,DUOUT,DTOUT,DIR,X,Y,LIST,LISTX
+2 ; Return evidence this was called
KILL AUDIT
SET AUDIT=1
+3 SET $PIECE(TAB," ",80)=""
+4 SET PSCNT=0
+5 if $DATA(NLIST)<10
QUIT
+6 IF $LENGTH($GET(MSG))
WRITE !,MSG,!
+7 IF $DATA(MSG)>1
Begin DoDot:1
+8 SET II=0
FOR
SET II=$ORDER(MSG(II))
if 'II
QUIT
WRITE !,MSG(II)
End DoDot:1
WRITE !
+9 SET ID2=""
FOR
SET ID2=$ORDER(NLIST(ID2))
if ID2=""
QUIT
SET NAME=$GET(NLIST(ID2))
if NAME=""
SET NAME="UNKNOWN"
Begin DoDot:1
+10 SET LIST($PIECE(NAME,"^")_"^"_ID2)=$PIECE(NAME,"^",2)
SET LISTX(ID2)=$PIECE(NAME,"^")_"^"_ID2
End DoDot:1
+11 SET II=""
FOR
SET II=$ORDER(LISTX(II))
if II=""!$GET(DTOUT)!$GET(DUOUT)
QUIT
Begin DoDot:1
+12 SET ID1=LISTX(II)
+13 NEW PSJMARG
+14 SET PSJMARG=" "
+15 SET PSJMARG=$SELECT($EXTRACT(ID1)="*":$EXTRACT(TAB,1,17),$EXTRACT(II)="*":$EXTRACT(TAB,1,17),1:$EXTRACT(TAB,1,12-$LENGTH($PIECE(ID1,"^",2))))
+16 WRITE !," "_$PIECE(ID1,"^",2)_PSJMARG_$PIECE(ID1,"^")_" "_$PIECE(LIST(ID1),"^")
+17 SET PSCNT=$GET(PSCNT)+1
+18 IF $GET(MAX)
IF (PSCNT>$GET(MAX))
WRITE !!
SET DIR(0)="E"
DO ^DIR
SET PSCNT=0
WRITE !!
End DoDot:1
+19 QUIT
+20 ;
PROCESS(PSJINP) ; Gather report data, store in ^TMP
+1 NEW PSJBDT,PSJSCR,TSCREEN
+2 SET PSJBDT=$GET(PSJINP("PSJBDT"))
+3 SET PSJSCR="I $$TSCREEN^PSJPDRTP(Y,.PSJINP)"
+4 DO LIST^DIC(58.6,,"@;2;1;23;10;.01I;4;15;12;3;16;14I;6.1;6.2;7.1;7.2;21;25;18;19;1.2;11;13","P",,PSJBDT,,"B",PSJSCR,,"^TMP($J,""TSCREEN"")")
+5 DO PROCSUM^PSJPDRTP(.PSJINP)
QUIT
+6 KILL ^TMP(PSJDLRJ,"TSCREEN")
+7 QUIT
+8 ;
DIVSTR(PSJINP) ; Return Divisions in PSJINP("PSJDIV") in string
+1 NEW DIVSTR,DIV,II,DIVNAM
+2 SET DIVSTR=""
+3 IF PSJINP("PSJDIV")="ALL"
QUIT "ALL"
+4 ;
+5 SET DIV=""
FOR II=0:1
SET DIV=$ORDER(PSJINP("PSJDIV",DIV))
if DIV=""
QUIT
Begin DoDot:1
+6 SET DIVNAM=$PIECE($GET(^DG(40.8,+DIV,0)),"^")
+7 SET DIVSTR=DIVSTR_$SELECT(II:",",1:"")_DIVNAM
End DoDot:1
+8 QUIT DIVSTR
+9 ;
TRANLIST(PSJINP,DIR) ; Set selectable transactions into DIR based on patient selection
+1 NEW PATFLG,PADLIST,CNT,TXPIECE,LAST,PSJPSYS,PSJBDT,PSJEDT
+2 SET PATFLG=0
+3 SET PSJPSYS=+$GET(PSJINP("PSJPSYS"))
SET PSJBDT=+$GET(PSJINP("PSJBDT"))
SET PSJEDT=+$GET(PSJINP("PSJEDT"))
+4 ; Filter to include ONLY transactions that have received from this vendor during this date range
+5 SET DIR(0)="SOA^"_$$TTYPDIR^PSJPDRUT(PSJPSYS,PSJBDT,PSJEDT)
+6 IF '$PIECE(DIR(0),"^",2)
Begin DoDot:1
+7 KILL DIR
SET DIR("A")="No recognized Transaction types have been received for this vendor system."
+8 SET PSJSTOP=-1
End DoDot:1
QUIT
+9 SET DIR("A")="Select Transaction Type: "_$SELECT($DATA(TRANS)>1:"",1:"^ALL//")
+10 SET DIR("A",1)="Select one of the following transaction types:"
+11 SET PADLIST=$PIECE(DIR(0),"^",2)
+12 FOR CNT=1:1:$LENGTH(PADLIST,";")
SET TXPIECE=$PIECE(PADLIST,";",CNT)
Begin DoDot:1
+13 SET DIR("A",CNT+1)=" "_$PIECE(TXPIECE,":")_" "_$PIECE(TXPIECE,":",2)
End DoDot:1
+14 SET LAST=$ORDER(DIR("A",999999),-1)
+15 SET DIR("A",LAST+1)=" or ^ALL for all Transactions."
+16 QUIT
