PSJPDRUT ;BIR/MV-PADE REPORT UTILITIES ; 3/22/18 9:36am
;;5.0;INPATIENT MEDICATIONS;**317,365**;16 DEC 97;Build 2
;
; 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
;
DATE(BEGEND,PSJSTOP,PSJINP) ; Prompt for Start Date
N DIR,X,Y,DATE,PSJNOW,PSJDONE,TMPY,DUOUT,DTOUT
S PSJNOW=$$NOW^XLFDT
K %DT S %DT("A")="Enter"_$S($G(BEGEND)="B":" Start ",$G(BEGEND)="E":" End ",1:" ")_"Date: ",%DT="TAE"
F Q:$G(PSJSTOP)!$G(PSJDONE) D
.D ^%DT S TMPY=Y I ($D(DTOUT))!$G(DUOUT) S PSJSTOP=1 Q
.I ($G(BEGEND)="E"),($G(X)="T") S TMPY=$P(TMPY,".")_".24"
.I $G(TMPY)<1 D Q
..I $E(X)="^" S PSJSTOP=1 Q
..W !,?3,$S(BEGEND="B":"Start ",1:"End ")_"Date is required"
.I $G(BEGEND)="B" I TMPY>($$FMADD^XLFDT(PSJNOW)) D Q
..W $C(7),!?3,"Start Date cannot be in the future. Re-enter Start Date."
.I $G(BEGEND)="E",$G(PSJINP("PSJBDT")) I TMPY<PSJINP("PSJBDT") D Q
..W $C(7),!?3,"End Date cannot be before Start Date. Re-enter End Date."
.S PSJDONE=1
S:$G(PSJSTOP) TMPY=""
S DATE=TMPY
I $G(BEGEND)="E",($P(DATE,".",2)="") S DATE=$$FMADD^XLFDT($P(DATE,"."),1)
Q DATE
;
SELUSER(PSJINP,USER,SELUSER,USERX,PSJSTOP) ; Prompt for one user (or ALL)
N DIR,X,Y,USRNAME,DUOUT,DTOUT,PSFOUND,PSALLPC
N PSJPART,II,PSELMSG,PLSTMSG
W ! D EN^DDIOL(" Enter '^ALL' to select all Users associated with selected PADE transactions.") W !
S PLSTMSG(1)="Transactions matching the entered Date Range and Division "
S PLSTMSG(2)="exist for the Users listed below."
S DIR(0)="FAO^1:30",DIR("?")="^D LIST^PSJPDRTR(.USER,.PLSTMSG,15)"
S DIR("A")="Select User: "_$S($D(SELUSER)>1:"",1:"^ALL//")
D ^DIR I X="" S Y=$S($D(SELUSER)<10:"ALL",1:"")
I $E(X)="^" S Y=$$XALL^PSJPDRIP(X)
I $G(DUOUT)!$G(DTOUT) S PSJSTOP=1 Q
I Y="ALL" M SELUSER=USER S SELUSER="ALL",PSJDONE=1 Q
I Y="" D Q
.I $D(SELUSER)>1 S PSJDONE=1 Q
.W !!?2,"Select a single User, several Items or enter ^ALL to select all Items."
S PSJY=Y
I $D(USER(PSJY)) D Q
.W " ",USER(PSJY) S SELUSER(PSJY)=""
I $D(USERX(PSJY)) D Q
.W " ",USERX(PSJY) S SELUSER(USERX(PSJY))=""
S PSELMSG="Select a User"
S PSALLPC=1 ; return all data pieces from partial lookup
D PARTIAL^PSJPADPT(PSJY,.USER,.SELUSER,1,PSELMSG,,.PSFOUND,,PSALLPC)
Q:$G(PSFOUND)
W " ?? (No match found)"
;
Q
;
LIST(LIST,MSG) ; Write list in LIST(ID1)=ID1
N II,DRGNAME,NUMBER,TAB,NAME,ID1,ID2
S $P(TAB," ",80)=""
Q:$D(LIST)<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 ID1="" F S ID1=$O(LIST(ID1)) Q:ID1="" D
.I LIST(ID1)="" W !,$E(TAB,1,10)_ID1 Q
.W !,$E(TAB,1,14-$L(ID1))_ID1_" "_$P(LIST(ID1),"^")_" "_$P(LIST(ID1),"^",2)
Q
;
USERLIST(PSJINP,USER,USERX) ; Get list of selectable users in transactions matching date range, PADE device, and drug item criteria
; INPUT: PSJINP("
; OUTPUT: USER
;
N PSJDEV,PADEV,PSDRG,PSJBDT,PSJEDT,PSJTRDT,TRANS,PSJDONE,PSUNAME,PSJII,PSJHTM,PSJDOTS
S PSJHTM=$P($H,",",2),PSJDOTS=""
K USER S PSJII=1
M PSJDEV=PSJINP("PADEV")
M PSDRG=PSJINP("PSDRG")
S PSJBDT=$G(PSJINP("PSJBDT"))
S PSJEDT=$G(PSJINP("PSJEDT"))
S USER="" F S USER=$O(^PS(58.6,"USR",USER)) Q:USER="" D
.S PSJTRDT=$$FMADD^XLFDT(PSJEDT,,,,1),PSJDONE=0
.D DISPDOTS^PSJPDRUT(.PSJHTM,.PSJDOTS,1)
.F S PSJTRDT=$O(^PS(58.6,"USR",USER,PSJTRDT),-1) Q:(PSJTRDT<PSJBDT)!$G(PSJDONE)!(PSJTRDT="") D
..D DISPDOTS^PSJPDRUT(.PSJHTM,.PSJDOTS,1)
..S TRANS=0 F S TRANS=$O(^PS(58.6,"USR",USER,PSJTRDT,TRANS)) Q:'TRANS!$G(PSJDONE) D
...N CAB,SYS
...S CAB=$P($G(^PS(58.6,+TRANS,0)),"^",2) I CAB]"" Q:'$D(PSJINP("PADEV",CAB))
...S SYS=$P($G(^PS(58.6,+TRANS,1)),"^",3) I SYS]"" Q:SYS'=$G(PSJINP("PSJPSYSE"))
...S PSUNAME=$P($G(^PS(58.6,+TRANS,5)),"^",2)
...S:$TR(PSUNAME,",")="" PSUNAME="PADE,USER"
...S USER(USER)=PSUNAME,USERX(PSUNAME)=USER
...S PSJDONE=1,PSJII=PSJII+1
Q
;
DRUGSEL(PSJINP,INDRUG,OUTDRUG,DRWPCK,PSJSTOP) ; Select drug(s) via screened ^PSDRUG lookup
N COUNT,PSJCNT,DIR,X,Y,PSJDONE,DRGLIST,DRGNAME,PSJY,DRGN,PSJTMP,DUOUT,DTOUT
K DRWPCK
M DRGLIST=INDRUG
S COUNT=0,PSJDONE=0
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
W ! D EN^DDIOL(" Enter '^ALL' to select all available drug items ") W !
F Q:$G(DUOUT)!$G(DTOUT)!$G(PSJDONE) D
.N PSJPART,II
.N DIC,X,Y,PSJX
.S DIC="^PSDRUG(",DIC(0)="QEAZ",DIC("A")="Select Drug Item: "_$S($D(OUTDRUG)>1:"",1:"^ALL// ")
.S DIC("S")="I $D(DRGLIST(""IEN"",+Y))"
.D ^DIC S PSJX=X
.I $E(PSJX)="^" S Y=$$XALL^PSJPDRIP(PSJX)
.I $G(DUOUT)!$G(DTOUT) S PSJSTOP=1 Q
.I Y=-1 S Y=$S($D(OUTDRUG)>1:"",1:"ALL")
.I Y="" D Q
..I $D(OUTDRUG)>1 S PSJDONE=1 Q
..W !!?2,"Select a single Item, several Items or enter ^ALL to select all Items."
.S PSJY=Y
.I PSJY,$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
.I PSJX="",($D(OUTDRUG)<10) S Y="ALL"
.I PSJX="",($D(OUTDRUG)>1) S PSJDONE=1
.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 S OUTDRUG(DRGIEN)=$P($G(^PSDRUG(+DRGIEN,0)),"^")
Q
;
PSYS(PSLAYGO) ; Get PADE Inventory System
N PSYSIEN,PSYSCNT,PSYS,DIR,X,Y,PSYSLST,LISTDIR
S PSYSIEN=0 F PSYSCNT=0:1 S PSYSIEN=$O(^PS(58.601,PSYSIEN)) Q:'PSYSIEN D
.S PSYS=PSYSIEN
.S PSYSLST(PSYSIEN)=$$UPPER^HLFNC($P($G(^PS(58.601,PSYSIEN,0)),"^"))_" "_$P($G(^PS(58.601,+PSYS,4)),"^")
.S PSYSLSTX(PSYSCNT+1)=PSYSLST(PSYSIEN)_"^"_PSYSIEN
.S LISTDIR=$G(LISTDIR)_$S($G(PSYSCNT):";",1:"")_(PSYSCNT+1)_":"_PSYSLST(PSYSIEN)
I 'PSYSCNT D Q ""
.S PSJSTOP=-1
.D EN^DDIOL("No PADE Inventory data on file")
.N DIR S DIR(0)="EA",DIR("A")="Press Return to Continue... " D ^DIR
I PSYSCNT=1 S DIR("B")=$P($G(^PS(58.601,+PSYS,0)),"^")
S DIR(0)="SAO^"_LISTDIR
S DIR("A")="Select PADE Inventory System: "
D ^DIR
S PSYS=$S(Y>0:+Y,1:"") S:PSYS="" PSJSTOP=-1
I +$G(PSYS) S PSYS=$P(PSYSLSTX(PSYS),"^",2) S:PSYS="" PSJSTOP=-1
Q PSYS
;
ENSYS() ; Get PADE Inventory System
N PSYSIEN,PSYSCNT,PSYS,DIR,X,Y,PSYSLST,LISTDIR,PSYSNAM,PSYSALT
K PSJSTOP
F Q:$G(PSYS)!$G(PSJSTOP) D
.D GETSYS(.PSYSLST,.PSYSLSTX,.PSYSNAM,.PSYSALT)
.D SELSYS(.PSYSLST,.PSYSLSTX,.PSYSNAM,.PSYS)
Q PSYS
;
PTIX(PS586IEN,PSJOMS) ; Computed PATIENT to handle blank patients in "P" x-ref in Transaction file 586
N PATIENT
S PATIENT=$P($G(^PS(58.6,+$G(PS586IEN),0)),"^",15)
I '$G(PATIENT) S PATIENT=$G(FDA(58.6,"+1,",14))
I '$G(PATIENT) S PATIENT=$G(PSJOMS("DFN"))
Q:$G(PATIENT) PATIENT
Q "zz"
;
DRGIX(PS586IEN,PSJOMS) ; Computed DRUG ID to handle unknown drugs in "P" x-ref in Transaction file 58.6
I $P($G(^PS(58.6,+$G(PS586IEN),0)),"^",3) Q $P(^(0),"^",3)
I $P($G(^PS(58.6,+$G(PS586IEN),1)),"^",6)]"" Q "zz~"_$P(^(0),"^",6)
I $G(FDA(58.6,"+1,",2)) Q +$G(FDA(58.6,"+1,",2))
I $G(PSJOMS("DRGTXT"))]"" Q "zz~"_$G(PSJOMS("DRGTXT"))
Q "zz~UNKNOWN"
;
DISPDOTS(PSJHTM,PSJDOTS,SECONDS) ; Check to see if more than SECONDS seconds has elapsed in $H, since PSJHTM.
; INPUT - PSJHTM = the 2nd comma piece of $H (seconds)
; PSJDOTS = flag indicating whether initial message "Searching for matching transactions.." has (1) or has not 0 or "" already been displayed
I '$G(PSJHTM) S PSJHTM=$P($H,",",2)
I ($P($H,",",2)-PSJHTM)>1 D
.I '$G(PSJDOTS) W !?2,"Searching for matching transactions.." S PSJDOTS=1,PSJHTM=$P($H,",",2)
.W "." S PSJHTM=$P($H,",",2)
Q
;
PADEUP(PADEV,PADEVUP) ; Return PADEVUP array, containing subscripts converted to upper case from incoming PADEV array
N PADE
S PADE="" F S PADE=$O(PADEV(PADE)) Q:PADE="" S PADEVUP($$UPPER^HLFNC(PADE))=PADEV(PADE)
Q
;
DIV(PSJDIV,PSJSTOP) ; Perform manual entry and validation of DIVISION (40.8)
N PSJDONE,DIR,X,Y,DIVAR,DIVARX,PSJY,PSALLPC
K PSJDIV
D DIVLIST(.DIVAR,.DIVARX)
S PSJDIV=""
F Q:$G(PSJSTOP)!$G(PSJDONE) D
.N PSJTMP
.S DIR(0)="FAO^1:30",DIR("?")="^D DIVLKUP^PSJPDRUT(.DIVAR)"
.S DIR("A")="Select Division: "_$S($D(PSJDIV)>1:"",1:" ^ALL// ")
.D ^DIR I $E(X)="^" S Y=$$XALL^PSJPDRIP(X)
.I X="",($D(PSJDIV)<10) S Y="ALL"
.I Y="ALL" M PSJDIV=DIVAR S PSJDIV="ALL",PSJINP("PSJDIV")="ALL",PSJDONE=1 Q
.I $G(DUOUT)!$G(DTOUT) S PSJSTOP=1 Q
.I Y="" D Q
..I $D(PSJDIV)>1 S PSJDONE=1 Q
..W !!?2,"Select a single Division, several Divisions or enter ^ALL to select all Divisions."
.S PSJY=Y
.I $D(DIVAR(PSJY)) D Q
..N DIVIEN,PSALLPC
..S PSALLPC=1 ; return all data pieces from partial lookup
..S DIVIEN=$P(DIVAR(PSJY),"^",2)
..Q:'DIVIEN S PSJDIV(DIVIEN)=DIVAR(PSJY)
..W " ",PSJY," ",$P(DIVAR(PSJY),"^")
.I $D(DIVARX(PSJY)) D Q
..N DIVIEN S DIVIEN=$P(DIVAR(DIVARX(PSJY)),"^",2)
..Q:'DIVIEN S PSJDIV(DIVIEN)=PSJY
..W " ",PSJY," ",DIVARX(PSJY) ;p365
.S PSELMSG="Select a Division"
.S PSALLPC=1 ; Return all data pieces from partial lookup
.D PARTIAL^PSJPADPT(PSJY,.DIVARX,.PSJTMP,,PSELMSG,.DIVAR,.PSFOUND,,PSALLPC)
.I $G(PSFOUND) N PSDIV,DIVIEN S PSDIV=$O(PSJTMP("")) I PSDIV]"" S DIVIEN=$P($G(PSJTMP(PSDIV)),"^",2) I DIVIEN S PSJDIV(DIVIEN)=PSDIV_"^"_DIVIEN
.Q:$G(PSFOUND)
.W " ?? (No match found)"
Q
;
DIVLKUP(DIVAR) ; Lookup Division
D LIST^PSJPDRTR(.DIVAR,,15)
Q
;
DIVLIST(DIVAR,DIVARX) ; Get list of Divisions
N DIVNAM,DIVIEN,DIVCNT
S DIVNAM="" F DIVCNT=1:1 S DIVNAM=$O(^DG(40.8,"B",DIVNAM)) Q:DIVNAM="" D
.S DIVIEN=$O(^DG(40.8,"B",DIVNAM,0))
.S DIVAR(DIVIEN)=DIVNAM_"^"_DIVIEN,DIVARX(DIVNAM)=DIVIEN
Q
;
UPPER(PSTEXT) ; Convert X to upper case
N X,Y
S PSTEXT=$$UPPER^HLFNC(PSTEXT)
Q PSTEXT
;
GETSYS(PSYSLST,PSYSLSTX,PSYSNAM,PSYSALT) ; Get list of PADE Inventory Systems from file 58.601
;
N PSYSIEN,PSYSCNT
K PSYSLST,PSYSLSTX,PSYSNAM,PSYSALT,PSUPPER
S PSYSIEN=0 F PSYSCNT=0:1 S PSYSIEN=$O(^PS(58.601,PSYSIEN)) Q:'PSYSIEN D
.S PSYS=PSYSIEN
.S PSYSLST("IEN",PSYSIEN)=$P($G(^PS(58.601,PSYSIEN,0)),"^")
.S PSYSLST("NAME",PSYSLST("IEN",PSYSIEN))=PSYSIEN
.S PSYSLSTX(PSYSCNT+1)=PSYSLST("IEN",PSYSIEN)_" "_$P($G(^PS(58.601,+PSYSIEN,4)),"^")_"^"_PSYSIEN
.S PSYSNAM(PSYSLST("IEN",PSYSIEN))=PSYSIEN
.S PSYSALT=$P($G(^PS(58.601,+PSYSIEN,4)),"^") I PSYSALT]"" S PSYSNAM($$UPPER^PSJPDRUT(PSYSALT))=PSYSIEN
Q
;
SELSYS(PSYSLST,PSYSLTX,PSYSNAM,PSYS) ; Select dispensing system for editing
; Input: PSYSLST - list of dispensing systems, PSYSLST("IEN",IEN)=name, PSYSLST("NAME",name)=IEN
; PSYSLSTX - list of dispensing systems, PSYSLSTX(list#)=name
; PSYSNAM - list of dispensing systems, PSYSNAM(name)=list#
; Output: PSYS - IEN of dispensing system in file 58.601
N PSJY,PSFOUND,PSALLPC
K PSYS S PSYS=""
S DIR(0)="FAO",DIR("?")="^D LIST^PSJPDRTR(.PSYSLSTX,,15)"
S DIR("A")="Select PADE Inventory System: "
D ^DIR
;
I $G(DUOUT)!$G(DTOUT) S PSJSTOP=1 Q
I Y=""!($TR(Y," ")="")!(Y["^") D Q
.W !!?2,"Select a PADE Dispensing Inventory system or '^' to exit."
S PSJY=Y
I $D(PSYSLSTX(+PSJY)) D Q
.W " ",$P(PSYSLSTX(+PSJY),"^")
.S PSYS=$P(PSYSLSTX(+PSJY),"^",2)
I $D(PSYSNAM(PSJY)) D Q
.W " ",PSYSNAM(PSJY)
.S PSYS=PSYSNAM(PSJY)
I $D(PSYSALT(PSJY)) D Q
.W " ",PSYSLST(PSYSALT(PSJY))
.S PSYS=PSYSALT(PSJY)
S PSALLPC=1 ; return all data pieces from partial lookup
D PARTIAL^PSJPADPT(.PSJY,.PSYSNAM,.PSJY,1,,.PSYSLSTX,.PSFOUND,,PSALLPC)
I '$G(PSFOUND),($G(PSJY)]"") D Q
.N DIR,X,Y,FDA
.S DIR("A")=" Are you adding '"_PSJY_"' as a new PADE INVENTORY SYSTEM? "
.S DIR(0)="YAO",DIR("B")="N" D ^DIR Q:'Y
.S FDA(58.601,"?+1,",.01)=PSJY
.D UPDATE^DIE("E","FDA","PSYS","ERR")
.S PSYS=$S($G(PSYS(1)):+$G(PSYS(1)),1:"")
I $G(PSFOUND) S PSYS=$O(PSJY(0)),PSYS=+$G(PSYSNAM(PSYS)) I 'PSYS S PSYS=+$G(PSYSLST("NAME",PSYS))
Q
;
PADEUSR(PSJPSYS,PSJPDUSR) ; Return Vista user ID for PADE user PSJPDUSER, if it exists
N PSJSYSE,PSJVUSR,PSJVAL,PSJRSLT,PADUIEN
Q:$G(PSJPSYS)="" ""
Q:$G(PSJPDUSR)="" ""
S PSJSYSE=$P($G(^PS(58.601,+PSJPSYS,0)),"^")
Q:PSJSYSE="" ""
S PSJVAL(1)=PSJSYSE
S PSJVAL(2)=PSJPDUSR
S PSJVUSR=$$FIND1^DIC(58.64,,"K",.PSJVAL)
Q:'PSJVUSR ""
S PADUIEN=+$G(PSJVUSR)
D GETS^DIQ(58.64,+PSJVUSR,"2","IE","PSJRSLT")
S PSJVUSR=+$G(PSJRSLT(58.64,PSJVUSR_",",2,"I"))_"^"_$G(PSJRSLT(58.64,PSJVUSR_",",2,"E"))_"^"_PADUIEN
Q PSJVUSR
;
DEVSCRN(PSJINP,PSPDIEN) ; Screen PADE cabinet PSPDIEN (file 58.63)
; Compare PSJINP("PSJPSYS") to System Field (#1)(#58.63)
; and PSJINP("PSJDIV") to Division Field (#2) (58.63)
; Manually coded version of screen S PSJSCR="I $D(PSJINP(""PSJDIV"",+$G(^(2))))&($P($G(^(0)),""^"",2)=PSJPSYS)&'$$EMPTY^PSJPADPT(+Y)"
N PADEOK,DIVIEN,DIVNAME,SYSIEN,DIVTMP,DIVOK
S PADEOK=1
S DIVIEN=$P($G(^PS(58.63,+$G(PSPDIEN),2)),"^")
S DIVNAME=$P($G(^DG(40.8,+DIVIEN,0)),"^")
I DIVNAME="" Q 0 ; No division on file for cabinet, quit
; Division doesn't match any in PSJINP("PSJDIV"), quit
S DIVOK=0 S DIVTMP="" F S DIVTMP=$O(PSJINP("PSJDIV",DIVTMP)) Q:DIVTMP=""!$G(DIVOK) I $P($G(PSJINP("PSJDIV",DIVTMP)),"^",2)=DIVIEN S DIVOK=1
Q:'DIVOK 0
; System doesn't match PSJINP("PSJPSYS"), quit
S SYSIEN=$P($G(^PS(58.63,+$G(PSPDIEN),0)),"^",2)
I SYSIEN'=+$G(PSJINP("PSJPSYS")) Q 0
; Cabinet is empty, quit
Q:$$EMPTY^PSJPADPT(+PSPDIEN) 0
Q PADEOK
;
UNIQUE(PSJY,PADE) ; Is PSJY unique subscript in PADE(), or are there other partial matches (PADE(PSJY), PADE(PSJYnn), PADE(PSJYxx), etc)?
N NEXTSUB,PSJYLEN
I $G(PSJY)="" Q 1
I $D(PADE)<10 Q 1
S NEXTSUB=$O(PADE(PSJY))
S PSJYLEN=$L(PSJY)
I $E(NEXTSUB,1,PSJYLEN)=PSJY Q 0
Q 1
;
PSB(PSJOMS) ; Get Patient Specific Bin info
;
N PSPADFN,PSPADNM,PSPADPK
I (PSJOMS("COMMENT")'["PATIENT SPECIFIC BIN") Q
N PSSN S PSSN=$P(PSJOMS("COMMENT"),"-",2)
I $G(PSSN) S PSPADFN=$$PATSSN(PSSN) I $G(PSPADFN) S PSJOMS("SSN")=PSSN,PSJOMS("DFN")=PSPADFN
I $G(PSPADFN) S PSPADNM=$P($G(^DPT(+PSPADFN,0)),"^")
I ($G(PSPADNM)'="") S (PSJOMS("DFN"),PSJOMS("PTID"))=PSPADFN D
.S PSJOMS("PTNAMA")=$P(PSPADNM,",")
.S PSJOMS("PTNAMB")=$P(PSPADNM,",",2)
S PSPADPK=$G(PSJOMS("PKT"))
S PSJOMS("PKT")=PSJOMS("PKT")_"PSB"
Q
;
PATSSN(PSSN) ; If valid PSSN patient SSN, return patient PDFN pointer to ^DPT
N PSVAL,PSINDEX,PSJDFN
S PSJDFN=""
I $G(PSSN) S (X,PSVAL)=PSSN,PSINDEX="SSN" S PSJDFN=$$FIND1^DIC(2,,"X",PSVAL,PSINDEX,,"PSERR")
I '$G(PSJDFN),$G(PSSN) S PSJDFN=$O(^DPT("SSN",PSSN,""))
I '$G(PSJDFN),$G(PSSN) N TMPSSN S TMPSSN=$TR($J(+PSSN,9)," ",0) S PSJDFN=$O(^DPT("SSN",TMPSSN,""))
I 'PSJDFN S PSJDFN=""
I PSJDFN I '$D(^DPT(PSJDFN)) S PSJDFN=""
Q PSJDFN
;
TTYPDIR(PSJPSYS,BDT,EDT) ; build DIR(0) string of selectable transaction types
N TTYPDIR,TTARRAY,TT,II
Q:'$G(PSJPSYS) ""
Q:'$D(^PS(58.601,+PSJPSYS,0)) ""
D TTYPES(PSJPSYS,BDT,EDT,.TTARRAY)
S TTYPDIR=""
S TT="" F II=1:1 S TT=$O(TTARRAY(TT)) Q:TT="" D
.N TTYPNAM
.S TTYPNAM=TT
.I II=1 S TTYPDIR="1:"_TTYPNAM
.I II>1 S TTYPDIR=TTYPDIR_";"_II_":"_TTYPNAM
Q TTYPDIR
;
TTYPES(PSJPSYS,BDT,EDT,OUTTYP) ; Get list of all transaction Types for system PSJPSYS between begin date BDT and end date EDT
N TDT,SYSNAM,TDEV,TXIEN
K OUTTYP
S SYSNAM=$P($G(^PS(58.601,+$G(PSJPSYS),0)),"^")
S TDT=$$FMADD^XLFDT(BDT,,,-.1)
F S TDT=$O(^PS(58.6,"B",TDT)) Q:(TDT="")!(TDT>EDT) S TXIEN=0 F S TXIEN=$O(^PS(58.6,"B",TDT,TXIEN)) Q:'TXIEN D
.N TT
.Q:($P($G(^PS(58.6,TXIEN,1)),"^",3)'=SYSNAM)
.S TT=$P($G(^PS(58.6,TXIEN,0)),"^",5) Q:TT=""
.S TTYPNAM=$$TTEX(TT)
.Q:$D(OUTTYP(TTYPNAM))
.Q:'(",D,L,R,F,U,E,C,R,W,B,V,")[(","_TT_",")
.S OUTTYP(TTYPNAM)=""
Q
;
DEFTRAN(DEFTRAN) ; Get default list of ALL transaction types if none were found in transaction file
N II,TTYPNAM,TRANLIST,TTYPCOD
S TRANLIST="V:Dispense,L:Load,U:Unload,F:Fill/Refill,B:Empty Bin,C:Count,R:Return,W:Waste,E:Expired,A:Discrepancy"
N II F II=1:1:$L(TRANLIST,",") S II=$P(TRANLIST,",",II) Q:II="" D
.S TTYPCOD=$P(II,":"),TTYPNAM=$P(II,":",2)
.S DEFTRAN(TTYPNAM)=TTYPCOD
Q
;
TTEX(TTCODE) ; Convert Transaction Type code to Type Name
N TTNAME,TT
S TT=$$UPPER^PSJPDRUT($G(TTCODE))
S TTNAME=$S(TT="V":"Dispense",TT="L":"Load",TT="U":"Unload",TT="F":"Refill",TT="B":"Empty Bin",TT="C":"Count",TT="R":"Return",TT="W":"Waste",TT="E":"Expired",TT="D":"Destock",TT="A":"Discrepancy",TT="N":"Cancel",1:"Other")
Q TTNAME
;
EXTT(TTNAME) ; Convert Transaction Type Name to Type Code
N TTCODE,TT
S TT=$$UPPER^PSJPDRUT($G(TTNAME))
S:TT="" TT="OTHER"
S TTCODE=$P($T(@($E($P(TT," "),1,8)_"^PSJPDRUT")),";;",2)
S:TTCODE="" TTCODE="O"
Q TTCODE
;
DISPENSE ;;V
VEND ;;V
LOAD ;;L
UNLOAD ;;U
REFILL ;;F
EMPTY ;;B
COUNT ;;C
RETURN ;;R
WASTE ;;W
EXPIRED ;;E
DESTOCK ;;D
DISCREPA ;;A
CANCEL ;;N
UNKNOWN ;;O
OTHER ;;O
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSJPDRUT 17030 printed Sep 23, 2025@19:44:59 Page 2
PSJPDRUT ;BIR/MV-PADE REPORT UTILITIES ; 3/22/18 9:36am
+1 ;;5.0;INPATIENT MEDICATIONS;**317,365**;16 DEC 97;Build 2
+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 ;
DATE(BEGEND,PSJSTOP,PSJINP) ; Prompt for Start Date
+1 NEW DIR,X,Y,DATE,PSJNOW,PSJDONE,TMPY,DUOUT,DTOUT
+2 SET PSJNOW=$$NOW^XLFDT
+3 KILL %DT
SET %DT("A")="Enter"_$SELECT($GET(BEGEND)="B":" Start ",$GET(BEGEND)="E":" End ",1:" ")_"Date: "
SET %DT="TAE"
+4 FOR
if $GET(PSJSTOP)!$GET(PSJDONE)
QUIT
Begin DoDot:1
+5 DO ^%DT
SET TMPY=Y
IF ($DATA(DTOUT))!$GET(DUOUT)
SET PSJSTOP=1
QUIT
+6 IF ($GET(BEGEND)="E")
IF ($GET(X)="T")
SET TMPY=$PIECE(TMPY,".")_".24"
+7 IF $GET(TMPY)<1
Begin DoDot:2
+8 IF $EXTRACT(X)="^"
SET PSJSTOP=1
QUIT
+9 WRITE !,?3,$SELECT(BEGEND="B":"Start ",1:"End ")_"Date is required"
End DoDot:2
QUIT
+10 IF $GET(BEGEND)="B"
IF TMPY>($$FMADD^XLFDT(PSJNOW))
Begin DoDot:2
+11 WRITE $CHAR(7),!?3,"Start Date cannot be in the future. Re-enter Start Date."
End DoDot:2
QUIT
+12 IF $GET(BEGEND)="E"
IF $GET(PSJINP("PSJBDT"))
IF TMPY<PSJINP("PSJBDT")
Begin DoDot:2
+13 WRITE $CHAR(7),!?3,"End Date cannot be before Start Date. Re-enter End Date."
End DoDot:2
QUIT
+14 SET PSJDONE=1
End DoDot:1
+15 if $GET(PSJSTOP)
SET TMPY=""
+16 SET DATE=TMPY
+17 IF $GET(BEGEND)="E"
IF ($PIECE(DATE,".",2)="")
SET DATE=$$FMADD^XLFDT($PIECE(DATE,"."),1)
+18 QUIT DATE
+19 ;
SELUSER(PSJINP,USER,SELUSER,USERX,PSJSTOP) ; Prompt for one user (or ALL)
+1 NEW DIR,X,Y,USRNAME,DUOUT,DTOUT,PSFOUND,PSALLPC
+2 NEW PSJPART,II,PSELMSG,PLSTMSG
+3 WRITE !
DO EN^DDIOL(" Enter '^ALL' to select all Users associated with selected PADE transactions.")
WRITE !
+4 SET PLSTMSG(1)="Transactions matching the entered Date Range and Division "
+5 SET PLSTMSG(2)="exist for the Users listed below."
+6 SET DIR(0)="FAO^1:30"
SET DIR("?")="^D LIST^PSJPDRTR(.USER,.PLSTMSG,15)"
+7 SET DIR("A")="Select User: "_$SELECT($DATA(SELUSER)>1:"",1:"^ALL//")
+8 DO ^DIR
IF X=""
SET Y=$SELECT($DATA(SELUSER)<10:"ALL",1:"")
+9 IF $EXTRACT(X)="^"
SET Y=$$XALL^PSJPDRIP(X)
+10 IF $GET(DUOUT)!$GET(DTOUT)
SET PSJSTOP=1
QUIT
+11 IF Y="ALL"
MERGE SELUSER=USER
SET SELUSER="ALL"
SET PSJDONE=1
QUIT
+12 IF Y=""
Begin DoDot:1
+13 IF $DATA(SELUSER)>1
SET PSJDONE=1
QUIT
+14 WRITE !!?2,"Select a single User, several Items or enter ^ALL to select all Items."
End DoDot:1
QUIT
+15 SET PSJY=Y
+16 IF $DATA(USER(PSJY))
Begin DoDot:1
+17 WRITE " ",USER(PSJY)
SET SELUSER(PSJY)=""
End DoDot:1
QUIT
+18 IF $DATA(USERX(PSJY))
Begin DoDot:1
+19 WRITE " ",USERX(PSJY)
SET SELUSER(USERX(PSJY))=""
End DoDot:1
QUIT
+20 SET PSELMSG="Select a User"
+21 ; return all data pieces from partial lookup
SET PSALLPC=1
+22 DO PARTIAL^PSJPADPT(PSJY,.USER,.SELUSER,1,PSELMSG,,.PSFOUND,,PSALLPC)
+23 if $GET(PSFOUND)
QUIT
+24 WRITE " ?? (No match found)"
+25 ;
+26 QUIT
+27 ;
LIST(LIST,MSG) ; Write list in LIST(ID1)=ID1
+1 NEW II,DRGNAME,NUMBER,TAB,NAME,ID1,ID2
+2 SET $PIECE(TAB," ",80)=""
+3 if $DATA(LIST)<10
QUIT
+4 IF $LENGTH($GET(MSG))
WRITE !,MSG,!
+5 IF $DATA(MSG)>1
Begin DoDot:1
+6 SET II=0
FOR
SET II=$ORDER(MSG(II))
if 'II
QUIT
WRITE !,MSG(II)
End DoDot:1
WRITE !
+7 SET ID1=""
FOR
SET ID1=$ORDER(LIST(ID1))
if ID1=""
QUIT
Begin DoDot:1
+8 IF LIST(ID1)=""
WRITE !,$EXTRACT(TAB,1,10)_ID1
QUIT
+9 WRITE !,$EXTRACT(TAB,1,14-$LENGTH(ID1))_ID1_" "_$PIECE(LIST(ID1),"^")_" "_$PIECE(LIST(ID1),"^",2)
End DoDot:1
+10 QUIT
+11 ;
USERLIST(PSJINP,USER,USERX) ; Get list of selectable users in transactions matching date range, PADE device, and drug item criteria
+1 ; INPUT: PSJINP("
+2 ; OUTPUT: USER
+3 ;
+4 NEW PSJDEV,PADEV,PSDRG,PSJBDT,PSJEDT,PSJTRDT,TRANS,PSJDONE,PSUNAME,PSJII,PSJHTM,PSJDOTS
+5 SET PSJHTM=$PIECE($HOROLOG,",",2)
SET PSJDOTS=""
+6 KILL USER
SET PSJII=1
+7 MERGE PSJDEV=PSJINP("PADEV")
+8 MERGE PSDRG=PSJINP("PSDRG")
+9 SET PSJBDT=$GET(PSJINP("PSJBDT"))
+10 SET PSJEDT=$GET(PSJINP("PSJEDT"))
+11 SET USER=""
FOR
SET USER=$ORDER(^PS(58.6,"USR",USER))
if USER=""
QUIT
Begin DoDot:1
+12 SET PSJTRDT=$$FMADD^XLFDT(PSJEDT,,,,1)
SET PSJDONE=0
+13 DO DISPDOTS^PSJPDRUT(.PSJHTM,.PSJDOTS,1)
+14 FOR
SET PSJTRDT=$ORDER(^PS(58.6,"USR",USER,PSJTRDT),-1)
if (PSJTRDT<PSJBDT)!$GET(PSJDONE)!(PSJTRDT="")
QUIT
Begin DoDot:2
+15 DO DISPDOTS^PSJPDRUT(.PSJHTM,.PSJDOTS,1)
+16 SET TRANS=0
FOR
SET TRANS=$ORDER(^PS(58.6,"USR",USER,PSJTRDT,TRANS))
if 'TRANS!$GET(PSJDONE)
QUIT
Begin DoDot:3
+17 NEW CAB,SYS
+18 SET CAB=$PIECE($GET(^PS(58.6,+TRANS,0)),"^",2)
IF CAB]""
if '$DATA(PSJINP("PADEV",CAB))
QUIT
+19 SET SYS=$PIECE($GET(^PS(58.6,+TRANS,1)),"^",3)
IF SYS]""
if SYS'=$GET(PSJINP("PSJPSYSE"))
QUIT
+20 SET PSUNAME=$PIECE($GET(^PS(58.6,+TRANS,5)),"^",2)
+21 if $TRANSLATE(PSUNAME,",")=""
SET PSUNAME="PADE,USER"
+22 SET USER(USER)=PSUNAME
SET USERX(PSUNAME)=USER
+23 SET PSJDONE=1
SET PSJII=PSJII+1
End DoDot:3
End DoDot:2
End DoDot:1
+24 QUIT
+25 ;
DRUGSEL(PSJINP,INDRUG,OUTDRUG,DRWPCK,PSJSTOP) ; Select drug(s) via screened ^PSDRUG lookup
+1 NEW COUNT,PSJCNT,DIR,X,Y,PSJDONE,DRGLIST,DRGNAME,PSJY,DRGN,PSJTMP,DUOUT,DTOUT
+2 KILL DRWPCK
+3 MERGE DRGLIST=INDRUG
+4 SET COUNT=0
SET PSJDONE=0
+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 WRITE !
DO EN^DDIOL(" Enter '^ALL' to select all available drug items ")
WRITE !
+12 FOR
if $GET(DUOUT)!$GET(DTOUT)!$GET(PSJDONE)
QUIT
Begin DoDot:1
+13 NEW PSJPART,II
+14 NEW DIC,X,Y,PSJX
+15 SET DIC="^PSDRUG("
SET DIC(0)="QEAZ"
SET DIC("A")="Select Drug Item: "_$SELECT($DATA(OUTDRUG)>1:"",1:"^ALL// ")
+16 SET DIC("S")="I $D(DRGLIST(""IEN"",+Y))"
+17 DO ^DIC
SET PSJX=X
+18 IF $EXTRACT(PSJX)="^"
SET Y=$$XALL^PSJPDRIP(PSJX)
+19 IF $GET(DUOUT)!$GET(DTOUT)
SET PSJSTOP=1
QUIT
+20 IF Y=-1
SET Y=$SELECT($DATA(OUTDRUG)>1:"",1:"ALL")
+21 IF Y=""
Begin DoDot:2
+22 IF $DATA(OUTDRUG)>1
SET PSJDONE=1
QUIT
+23 WRITE !!?2,"Select a single Item, several Items or enter ^ALL to select all Items."
End DoDot:2
QUIT
+24 SET PSJY=Y
+25 IF PSJY
IF $DATA(DRGLIST("IEN",+PSJY))
Begin DoDot:2
+26 WRITE " ",DRGLIST("IEN",+PSJY)
+27 SET OUTDRUG(+PSJY)=$PIECE($GET(^PSDRUG(+PSJY,0)),"^")
+28 IF $GET(PSJINP("MANUNLOD"))
DO POCKET^PSJPDRIN(.PSJINP,+PSJY,.DRWPCK)
SET PSJDONE=1
End DoDot:2
QUIT
+29 IF PSJX=""
IF ($DATA(OUTDRUG)<10)
SET Y="ALL"
+30 IF PSJX=""
IF ($DATA(OUTDRUG)>1)
SET PSJDONE=1
+31 IF PSJY="ALL"
SET OUTDRUG="ALL"
SET PSJDONE=1
Begin DoDot:2
+32 IF $GET(PSJINP("MANUNLOD"))
SET DRWPCK="ALL"
QUIT
+33 NEW DRGIEN
SET DRGIEN=0
FOR
SET DRGIEN=$ORDER(INDRUG(DRGIEN))
if 'DRGIEN
QUIT
SET OUTDRUG(DRGIEN)=$PIECE($GET(^PSDRUG(+DRGIEN,0)),"^")
End DoDot:2
QUIT
End DoDot:1
+34 QUIT
+35 ;
PSYS(PSLAYGO) ; Get PADE Inventory System
+1 NEW PSYSIEN,PSYSCNT,PSYS,DIR,X,Y,PSYSLST,LISTDIR
+2 SET PSYSIEN=0
FOR PSYSCNT=0:1
SET PSYSIEN=$ORDER(^PS(58.601,PSYSIEN))
if 'PSYSIEN
QUIT
Begin DoDot:1
+3 SET PSYS=PSYSIEN
+4 SET PSYSLST(PSYSIEN)=$$UPPER^HLFNC($PIECE($GET(^PS(58.601,PSYSIEN,0)),"^"))_" "_$PIECE($GET(^PS(58.601,+PSYS,4)),"^")
+5 SET PSYSLSTX(PSYSCNT+1)=PSYSLST(PSYSIEN)_"^"_PSYSIEN
+6 SET LISTDIR=$GET(LISTDIR)_$SELECT($GET(PSYSCNT):";",1:"")_(PSYSCNT+1)_":"_PSYSLST(PSYSIEN)
End DoDot:1
+7 IF 'PSYSCNT
Begin DoDot:1
+8 SET PSJSTOP=-1
+9 DO EN^DDIOL("No PADE Inventory data on file")
+10 NEW DIR
SET DIR(0)="EA"
SET DIR("A")="Press Return to Continue... "
DO ^DIR
End DoDot:1
QUIT ""
+11 IF PSYSCNT=1
SET DIR("B")=$PIECE($GET(^PS(58.601,+PSYS,0)),"^")
+12 SET DIR(0)="SAO^"_LISTDIR
+13 SET DIR("A")="Select PADE Inventory System: "
+14 DO ^DIR
+15 SET PSYS=$SELECT(Y>0:+Y,1:"")
if PSYS=""
SET PSJSTOP=-1
+16 IF +$GET(PSYS)
SET PSYS=$PIECE(PSYSLSTX(PSYS),"^",2)
if PSYS=""
SET PSJSTOP=-1
+17 QUIT PSYS
+18 ;
ENSYS() ; Get PADE Inventory System
+1 NEW PSYSIEN,PSYSCNT,PSYS,DIR,X,Y,PSYSLST,LISTDIR,PSYSNAM,PSYSALT
+2 KILL PSJSTOP
+3 FOR
if $GET(PSYS)!$GET(PSJSTOP)
QUIT
Begin DoDot:1
+4 DO GETSYS(.PSYSLST,.PSYSLSTX,.PSYSNAM,.PSYSALT)
+5 DO SELSYS(.PSYSLST,.PSYSLSTX,.PSYSNAM,.PSYS)
End DoDot:1
+6 QUIT PSYS
+7 ;
PTIX(PS586IEN,PSJOMS) ; Computed PATIENT to handle blank patients in "P" x-ref in Transaction file 586
+1 NEW PATIENT
+2 SET PATIENT=$PIECE($GET(^PS(58.6,+$GET(PS586IEN),0)),"^",15)
+3 IF '$GET(PATIENT)
SET PATIENT=$GET(FDA(58.6,"+1,",14))
+4 IF '$GET(PATIENT)
SET PATIENT=$GET(PSJOMS("DFN"))
+5 if $GET(PATIENT)
QUIT PATIENT
+6 QUIT "zz"
+7 ;
DRGIX(PS586IEN,PSJOMS) ; Computed DRUG ID to handle unknown drugs in "P" x-ref in Transaction file 58.6
+1 IF $PIECE($GET(^PS(58.6,+$GET(PS586IEN),0)),"^",3)
QUIT $PIECE(^(0),"^",3)
+2 IF $PIECE($GET(^PS(58.6,+$GET(PS586IEN),1)),"^",6)]""
QUIT "zz~"_$PIECE(^(0),"^",6)
+3 IF $GET(FDA(58.6,"+1,",2))
QUIT +$GET(FDA(58.6,"+1,",2))
+4 IF $GET(PSJOMS("DRGTXT"))]""
QUIT "zz~"_$GET(PSJOMS("DRGTXT"))
+5 QUIT "zz~UNKNOWN"
+6 ;
DISPDOTS(PSJHTM,PSJDOTS,SECONDS) ; Check to see if more than SECONDS seconds has elapsed in $H, since PSJHTM.
+1 ; INPUT - PSJHTM = the 2nd comma piece of $H (seconds)
+2 ; PSJDOTS = flag indicating whether initial message "Searching for matching transactions.." has (1) or has not 0 or "" already been displayed
+3 IF '$GET(PSJHTM)
SET PSJHTM=$PIECE($HOROLOG,",",2)
+4 IF ($PIECE($HOROLOG,",",2)-PSJHTM)>1
Begin DoDot:1
+5 IF '$GET(PSJDOTS)
WRITE !?2,"Searching for matching transactions.."
SET PSJDOTS=1
SET PSJHTM=$PIECE($HOROLOG,",",2)
+6 WRITE "."
SET PSJHTM=$PIECE($HOROLOG,",",2)
End DoDot:1
+7 QUIT
+8 ;
PADEUP(PADEV,PADEVUP) ; Return PADEVUP array, containing subscripts converted to upper case from incoming PADEV array
+1 NEW PADE
+2 SET PADE=""
FOR
SET PADE=$ORDER(PADEV(PADE))
if PADE=""
QUIT
SET PADEVUP($$UPPER^HLFNC(PADE))=PADEV(PADE)
+3 QUIT
+4 ;
DIV(PSJDIV,PSJSTOP) ; Perform manual entry and validation of DIVISION (40.8)
+1 NEW PSJDONE,DIR,X,Y,DIVAR,DIVARX,PSJY,PSALLPC
+2 KILL PSJDIV
+3 DO DIVLIST(.DIVAR,.DIVARX)
+4 SET PSJDIV=""
+5 FOR
if $GET(PSJSTOP)!$GET(PSJDONE)
QUIT
Begin DoDot:1
+6 NEW PSJTMP
+7 SET DIR(0)="FAO^1:30"
SET DIR("?")="^D DIVLKUP^PSJPDRUT(.DIVAR)"
+8 SET DIR("A")="Select Division: "_$SELECT($DATA(PSJDIV)>1:"",1:" ^ALL// ")
+9 DO ^DIR
IF $EXTRACT(X)="^"
SET Y=$$XALL^PSJPDRIP(X)
+10 IF X=""
IF ($DATA(PSJDIV)<10)
SET Y="ALL"
+11 IF Y="ALL"
MERGE PSJDIV=DIVAR
SET PSJDIV="ALL"
SET PSJINP("PSJDIV")="ALL"
SET PSJDONE=1
QUIT
+12 IF $GET(DUOUT)!$GET(DTOUT)
SET PSJSTOP=1
QUIT
+13 IF Y=""
Begin DoDot:2
+14 IF $DATA(PSJDIV)>1
SET PSJDONE=1
QUIT
+15 WRITE !!?2,"Select a single Division, several Divisions or enter ^ALL to select all Divisions."
End DoDot:2
QUIT
+16 SET PSJY=Y
+17 IF $DATA(DIVAR(PSJY))
Begin DoDot:2
+18 NEW DIVIEN,PSALLPC
+19 ; return all data pieces from partial lookup
SET PSALLPC=1
+20 SET DIVIEN=$PIECE(DIVAR(PSJY),"^",2)
+21 if 'DIVIEN
QUIT
SET PSJDIV(DIVIEN)=DIVAR(PSJY)
+22 WRITE " ",PSJY," ",$PIECE(DIVAR(PSJY),"^")
End DoDot:2
QUIT
+23 IF $DATA(DIVARX(PSJY))
Begin DoDot:2
+24 NEW DIVIEN
SET DIVIEN=$PIECE(DIVAR(DIVARX(PSJY)),"^",2)
+25 if 'DIVIEN
QUIT
SET PSJDIV(DIVIEN)=PSJY
+26 ;p365
WRITE " ",PSJY," ",DIVARX(PSJY)
End DoDot:2
QUIT
+27 SET PSELMSG="Select a Division"
+28 ; Return all data pieces from partial lookup
SET PSALLPC=1
+29 DO PARTIAL^PSJPADPT(PSJY,.DIVARX,.PSJTMP,,PSELMSG,.DIVAR,.PSFOUND,,PSALLPC)
+30 IF $GET(PSFOUND)
NEW PSDIV,DIVIEN
SET PSDIV=$ORDER(PSJTMP(""))
IF PSDIV]""
SET DIVIEN=$PIECE($GET(PSJTMP(PSDIV)),"^",2)
IF DIVIEN
SET PSJDIV(DIVIEN)=PSDIV_"^"_DIVIEN
+31 if $GET(PSFOUND)
QUIT
+32 WRITE " ?? (No match found)"
End DoDot:1
+33 QUIT
+34 ;
DIVLKUP(DIVAR) ; Lookup Division
+1 DO LIST^PSJPDRTR(.DIVAR,,15)
+2 QUIT
+3 ;
DIVLIST(DIVAR,DIVARX) ; Get list of Divisions
+1 NEW DIVNAM,DIVIEN,DIVCNT
+2 SET DIVNAM=""
FOR DIVCNT=1:1
SET DIVNAM=$ORDER(^DG(40.8,"B",DIVNAM))
if DIVNAM=""
QUIT
Begin DoDot:1
+3 SET DIVIEN=$ORDER(^DG(40.8,"B",DIVNAM,0))
+4 SET DIVAR(DIVIEN)=DIVNAM_"^"_DIVIEN
SET DIVARX(DIVNAM)=DIVIEN
End DoDot:1
+5 QUIT
+6 ;
UPPER(PSTEXT) ; Convert X to upper case
+1 NEW X,Y
+2 SET PSTEXT=$$UPPER^HLFNC(PSTEXT)
+3 QUIT PSTEXT
+4 ;
GETSYS(PSYSLST,PSYSLSTX,PSYSNAM,PSYSALT) ; Get list of PADE Inventory Systems from file 58.601
+1 ;
+2 NEW PSYSIEN,PSYSCNT
+3 KILL PSYSLST,PSYSLSTX,PSYSNAM,PSYSALT,PSUPPER
+4 SET PSYSIEN=0
FOR PSYSCNT=0:1
SET PSYSIEN=$ORDER(^PS(58.601,PSYSIEN))
if 'PSYSIEN
QUIT
Begin DoDot:1
+5 SET PSYS=PSYSIEN
+6 SET PSYSLST("IEN",PSYSIEN)=$PIECE($GET(^PS(58.601,PSYSIEN,0)),"^")
+7 SET PSYSLST("NAME",PSYSLST("IEN",PSYSIEN))=PSYSIEN
+8 SET PSYSLSTX(PSYSCNT+1)=PSYSLST("IEN",PSYSIEN)_" "_$PIECE($GET(^PS(58.601,+PSYSIEN,4)),"^")_"^"_PSYSIEN
+9 SET PSYSNAM(PSYSLST("IEN",PSYSIEN))=PSYSIEN
+10 SET PSYSALT=$PIECE($GET(^PS(58.601,+PSYSIEN,4)),"^")
IF PSYSALT]""
SET PSYSNAM($$UPPER^PSJPDRUT(PSYSALT))=PSYSIEN
End DoDot:1
+11 QUIT
+12 ;
SELSYS(PSYSLST,PSYSLTX,PSYSNAM,PSYS) ; Select dispensing system for editing
+1 ; Input: PSYSLST - list of dispensing systems, PSYSLST("IEN",IEN)=name, PSYSLST("NAME",name)=IEN
+2 ; PSYSLSTX - list of dispensing systems, PSYSLSTX(list#)=name
+3 ; PSYSNAM - list of dispensing systems, PSYSNAM(name)=list#
+4 ; Output: PSYS - IEN of dispensing system in file 58.601
+5 NEW PSJY,PSFOUND,PSALLPC
+6 KILL PSYS
SET PSYS=""
+7 SET DIR(0)="FAO"
SET DIR("?")="^D LIST^PSJPDRTR(.PSYSLSTX,,15)"
+8 SET DIR("A")="Select PADE Inventory System: "
+9 DO ^DIR
+10 ;
+11 IF $GET(DUOUT)!$GET(DTOUT)
SET PSJSTOP=1
QUIT
+12 IF Y=""!($TRANSLATE(Y," ")="")!(Y["^")
Begin DoDot:1
+13 WRITE !!?2,"Select a PADE Dispensing Inventory system or '^' to exit."
End DoDot:1
QUIT
+14 SET PSJY=Y
+15 IF $DATA(PSYSLSTX(+PSJY))
Begin DoDot:1
+16 WRITE " ",$PIECE(PSYSLSTX(+PSJY),"^")
+17 SET PSYS=$PIECE(PSYSLSTX(+PSJY),"^",2)
End DoDot:1
QUIT
+18 IF $DATA(PSYSNAM(PSJY))
Begin DoDot:1
+19 WRITE " ",PSYSNAM(PSJY)
+20 SET PSYS=PSYSNAM(PSJY)
End DoDot:1
QUIT
+21 IF $DATA(PSYSALT(PSJY))
Begin DoDot:1
+22 WRITE " ",PSYSLST(PSYSALT(PSJY))
+23 SET PSYS=PSYSALT(PSJY)
End DoDot:1
QUIT
+24 ; return all data pieces from partial lookup
SET PSALLPC=1
+25 DO PARTIAL^PSJPADPT(.PSJY,.PSYSNAM,.PSJY,1,,.PSYSLSTX,.PSFOUND,,PSALLPC)
+26 IF '$GET(PSFOUND)
IF ($GET(PSJY)]"")
Begin DoDot:1
+27 NEW DIR,X,Y,FDA
+28 SET DIR("A")=" Are you adding '"_PSJY_"' as a new PADE INVENTORY SYSTEM? "
+29 SET DIR(0)="YAO"
SET DIR("B")="N"
DO ^DIR
if 'Y
QUIT
+30 SET FDA(58.601,"?+1,",.01)=PSJY
+31 DO UPDATE^DIE("E","FDA","PSYS","ERR")
+32 SET PSYS=$SELECT($GET(PSYS(1)):+$GET(PSYS(1)),1:"")
End DoDot:1
QUIT
+33 IF $GET(PSFOUND)
SET PSYS=$ORDER(PSJY(0))
SET PSYS=+$GET(PSYSNAM(PSYS))
IF 'PSYS
SET PSYS=+$GET(PSYSLST("NAME",PSYS))
+34 QUIT
+35 ;
PADEUSR(PSJPSYS,PSJPDUSR) ; Return Vista user ID for PADE user PSJPDUSER, if it exists
+1 NEW PSJSYSE,PSJVUSR,PSJVAL,PSJRSLT,PADUIEN
+2 if $GET(PSJPSYS)=""
QUIT ""
+3 if $GET(PSJPDUSR)=""
QUIT ""
+4 SET PSJSYSE=$PIECE($GET(^PS(58.601,+PSJPSYS,0)),"^")
+5 if PSJSYSE=""
QUIT ""
+6 SET PSJVAL(1)=PSJSYSE
+7 SET PSJVAL(2)=PSJPDUSR
+8 SET PSJVUSR=$$FIND1^DIC(58.64,,"K",.PSJVAL)
+9 if 'PSJVUSR
QUIT ""
+10 SET PADUIEN=+$GET(PSJVUSR)
+11 DO GETS^DIQ(58.64,+PSJVUSR,"2","IE","PSJRSLT")
+12 SET PSJVUSR=+$GET(PSJRSLT(58.64,PSJVUSR_",",2,"I"))_"^"_$GET(PSJRSLT(58.64,PSJVUSR_",",2,"E"))_"^"_PADUIEN
+13 QUIT PSJVUSR
+14 ;
DEVSCRN(PSJINP,PSPDIEN) ; Screen PADE cabinet PSPDIEN (file 58.63)
+1 ; Compare PSJINP("PSJPSYS") to System Field (#1)(#58.63)
+2 ; and PSJINP("PSJDIV") to Division Field (#2) (58.63)
+3 ; Manually coded version of screen S PSJSCR="I $D(PSJINP(""PSJDIV"",+$G(^(2))))&($P($G(^(0)),""^"",2)=PSJPSYS)&'$$EMPTY^PSJPADPT(+Y)"
+4 NEW PADEOK,DIVIEN,DIVNAME,SYSIEN,DIVTMP,DIVOK
+5 SET PADEOK=1
+6 SET DIVIEN=$PIECE($GET(^PS(58.63,+$GET(PSPDIEN),2)),"^")
+7 SET DIVNAME=$PIECE($GET(^DG(40.8,+DIVIEN,0)),"^")
+8 ; No division on file for cabinet, quit
IF DIVNAME=""
QUIT 0
+9 ; Division doesn't match any in PSJINP("PSJDIV"), quit
+10 SET DIVOK=0
SET DIVTMP=""
FOR
SET DIVTMP=$ORDER(PSJINP("PSJDIV",DIVTMP))
if DIVTMP=""!$GET(DIVOK)
QUIT
IF $PIECE($GET(PSJINP("PSJDIV",DIVTMP)),"^",2)=DIVIEN
SET DIVOK=1
+11 if 'DIVOK
QUIT 0
+12 ; System doesn't match PSJINP("PSJPSYS"), quit
+13 SET SYSIEN=$PIECE($GET(^PS(58.63,+$GET(PSPDIEN),0)),"^",2)
+14 IF SYSIEN'=+$GET(PSJINP("PSJPSYS"))
QUIT 0
+15 ; Cabinet is empty, quit
+16 if $$EMPTY^PSJPADPT(+PSPDIEN)
QUIT 0
+17 QUIT PADEOK
+18 ;
UNIQUE(PSJY,PADE) ; Is PSJY unique subscript in PADE(), or are there other partial matches (PADE(PSJY), PADE(PSJYnn), PADE(PSJYxx), etc)?
+1 NEW NEXTSUB,PSJYLEN
+2 IF $GET(PSJY)=""
QUIT 1
+3 IF $DATA(PADE)<10
QUIT 1
+4 SET NEXTSUB=$ORDER(PADE(PSJY))
+5 SET PSJYLEN=$LENGTH(PSJY)
+6 IF $EXTRACT(NEXTSUB,1,PSJYLEN)=PSJY
QUIT 0
+7 QUIT 1
+8 ;
PSB(PSJOMS) ; Get Patient Specific Bin info
+1 ;
+2 NEW PSPADFN,PSPADNM,PSPADPK
+3 IF (PSJOMS("COMMENT")'["PATIENT SPECIFIC BIN")
QUIT
+4 NEW PSSN
SET PSSN=$PIECE(PSJOMS("COMMENT"),"-",2)
+5 IF $GET(PSSN)
SET PSPADFN=$$PATSSN(PSSN)
IF $GET(PSPADFN)
SET PSJOMS("SSN")=PSSN
SET PSJOMS("DFN")=PSPADFN
+6 IF $GET(PSPADFN)
SET PSPADNM=$PIECE($GET(^DPT(+PSPADFN,0)),"^")
+7 IF ($GET(PSPADNM)'="")
SET (PSJOMS("DFN"),PSJOMS("PTID"))=PSPADFN
Begin DoDot:1
+8 SET PSJOMS("PTNAMA")=$PIECE(PSPADNM,",")
+9 SET PSJOMS("PTNAMB")=$PIECE(PSPADNM,",",2)
End DoDot:1
+10 SET PSPADPK=$GET(PSJOMS("PKT"))
+11 SET PSJOMS("PKT")=PSJOMS("PKT")_"PSB"
+12 QUIT
+13 ;
PATSSN(PSSN) ; If valid PSSN patient SSN, return patient PDFN pointer to ^DPT
+1 NEW PSVAL,PSINDEX,PSJDFN
+2 SET PSJDFN=""
+3 IF $GET(PSSN)
SET (X,PSVAL)=PSSN
SET PSINDEX="SSN"
SET PSJDFN=$$FIND1^DIC(2,,"X",PSVAL,PSINDEX,,"PSERR")
+4 IF '$GET(PSJDFN)
IF $GET(PSSN)
SET PSJDFN=$ORDER(^DPT("SSN",PSSN,""))
+5 IF '$GET(PSJDFN)
IF $GET(PSSN)
NEW TMPSSN
SET TMPSSN=$TRANSLATE($JUSTIFY(+PSSN,9)," ",0)
SET PSJDFN=$ORDER(^DPT("SSN",TMPSSN,""))
+6 IF 'PSJDFN
SET PSJDFN=""
+7 IF PSJDFN
IF '$DATA(^DPT(PSJDFN))
SET PSJDFN=""
+8 QUIT PSJDFN
+9 ;
TTYPDIR(PSJPSYS,BDT,EDT) ; build DIR(0) string of selectable transaction types
+1 NEW TTYPDIR,TTARRAY,TT,II
+2 if '$GET(PSJPSYS)
QUIT ""
+3 if '$DATA(^PS(58.601,+PSJPSYS,0))
QUIT ""
+4 DO TTYPES(PSJPSYS,BDT,EDT,.TTARRAY)
+5 SET TTYPDIR=""
+6 SET TT=""
FOR II=1:1
SET TT=$ORDER(TTARRAY(TT))
if TT=""
QUIT
Begin DoDot:1
+7 NEW TTYPNAM
+8 SET TTYPNAM=TT
+9 IF II=1
SET TTYPDIR="1:"_TTYPNAM
+10 IF II>1
SET TTYPDIR=TTYPDIR_";"_II_":"_TTYPNAM
End DoDot:1
+11 QUIT TTYPDIR
+12 ;
TTYPES(PSJPSYS,BDT,EDT,OUTTYP) ; Get list of all transaction Types for system PSJPSYS between begin date BDT and end date EDT
+1 NEW TDT,SYSNAM,TDEV,TXIEN
+2 KILL OUTTYP
+3 SET SYSNAM=$PIECE($GET(^PS(58.601,+$GET(PSJPSYS),0)),"^")
+4 SET TDT=$$FMADD^XLFDT(BDT,,,-.1)
+5 FOR
SET TDT=$ORDER(^PS(58.6,"B",TDT))
if (TDT="")!(TDT>EDT)
QUIT
SET TXIEN=0
FOR
SET TXIEN=$ORDER(^PS(58.6,"B",TDT,TXIEN))
if 'TXIEN
QUIT
Begin DoDot:1
+6 NEW TT
+7 if ($PIECE($GET(^PS(58.6,TXIEN,1)),"^",3)'=SYSNAM)
QUIT
+8 SET TT=$PIECE($GET(^PS(58.6,TXIEN,0)),"^",5)
if TT=""
QUIT
+9 SET TTYPNAM=$$TTEX(TT)
+10 if $DATA(OUTTYP(TTYPNAM))
QUIT
+11 if '(",D,L,R,F,U,E,C,R,W,B,V,")[(","_TT_",")
QUIT
+12 SET OUTTYP(TTYPNAM)=""
End DoDot:1
+13 QUIT
+14 ;
DEFTRAN(DEFTRAN) ; Get default list of ALL transaction types if none were found in transaction file
+1 NEW II,TTYPNAM,TRANLIST,TTYPCOD
+2 SET TRANLIST="V:Dispense,L:Load,U:Unload,F:Fill/Refill,B:Empty Bin,C:Count,R:Return,W:Waste,E:Expired,A:Discrepancy"
+3 NEW II
FOR II=1:1:$LENGTH(TRANLIST,",")
SET II=$PIECE(TRANLIST,",",II)
if II=""
QUIT
Begin DoDot:1
+4 SET TTYPCOD=$PIECE(II,":")
SET TTYPNAM=$PIECE(II,":",2)
+5 SET DEFTRAN(TTYPNAM)=TTYPCOD
End DoDot:1
+6 QUIT
+7 ;
TTEX(TTCODE) ; Convert Transaction Type code to Type Name
+1 NEW TTNAME,TT
+2 SET TT=$$UPPER^PSJPDRUT($GET(TTCODE))
+3 SET TTNAME=$SELECT(TT="V":"Dispense",TT="L":"Load",TT="U":"Unload",TT="F":"Refill",TT="B":"Empty Bin",TT="C":"Count",TT="R":"Return",TT="W":"Waste",TT="E":"Expired",TT="D":"Destock",TT="A":"Discrepancy",TT="N":"Cancel",1:"Other")
+4 QUIT TTNAME
+5 ;
EXTT(TTNAME) ; Convert Transaction Type Name to Type Code
+1 NEW TTCODE,TT
+2 SET TT=$$UPPER^PSJPDRUT($GET(TTNAME))
+3 if TT=""
SET TT="OTHER"
+4 SET TTCODE=$PIECE($TEXT(@($EXTRACT($PIECE(TT," "),1,8)_"^PSJPDRUT")),";;",2)
+5 if TTCODE=""
SET TTCODE="O"
+6 QUIT TTCODE
+7 ;
DISPENSE ;;V
VEND ;;V
LOAD ;;L
UNLOAD ;;U
REFILL ;;F
EMPTY ;;B
COUNT ;;C
RETURN ;;R
WASTE ;;W
EXPIRED ;;E
DESTOCK ;;D
DISCREPA ;;A
CANCEL ;;N
UNKNOWN ;;O
OTHER ;;O
+1 QUIT
