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