PSJPDRU1 ;BIR/MV-PADE REPORT UTILITIES ;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
;
PATIENT(PSJINP) ; Get list of patients
N PSJDONE,PATX,PAT,PATXX,PATSSN K PSJPAT,PSJSTOP
S PSJSTOP=""
D PATLIST^PSJPDRU1(.PSJINP)
I $D(^TMP($J,"PSJPTLST","PAT"))<10 D Q
.W !!,"Patient: "
.W !," No patients available for selection..",!
F Q:$G(PSJDONE)!$G(PSJSTOP) D
.D SELPAT^PSJPDRU1(.PSJINP)
Q
;
PATLIST(PSJINP) ; Build list of patients that may be selected based on transaction date range and PADE Inbound System
N PSJDEV,PADEV,PSDRG,PSJBDT,PSJEDT,PSJTRDT,TRANS,PSJDONE,PSUNAME,PSJII,PSPTNAME,PSPTLN,PSPTFN,PSPTID,PSPTND3,PATRAWID,PSJHTM,PSJDOTS
S PSJHTM=$P($H,",",2),PSJDOTS="" ; If search takes too long, may have to print "Searching..", followed by dots every 2 seconds
K ^TMP($J,"PSJPTLST")
K PAT S PSJII=1
M PSJDEV=PSJINP("PADEV")
M PSDRG=PSJINP("PSDRG")
S PSJBDT=$G(PSJINP("PSJBDT"))
S PSJEDT=$G(PSJINP("PSJEDT"))
S PAT="" F S PAT=$O(^PS(58.6,"P",PAT)) Q:PAT="" D
.D DISPDOTS^PSJPDRUT(.PSJHTM,.PSJDOTS,1)
.S PSJTRDT=$$FMADD^XLFDT(PSJBDT,,,,-1),PSJDONE=0
.F S PSJTRDT=$O(^PS(58.6,"P",PAT,PSJTRDT)) Q:(PSJTRDT>PSJEDT)!$G(PSJDONE)!(PSJTRDT="") D
..N PSDRG S PSDRG="" F S PSDRG=$O(^PS(58.6,"P",PAT,PSJTRDT,PSDRG)) Q:PSDRG="" D
...D DISPDOTS^PSJPDRUT(.PSJHTM,.PSJDOTS,1)
...S TRANS=0 F S TRANS=$O(^PS(58.6,"P",PAT,PSJTRDT,PSDRG,TRANS)) Q:'TRANS D
....I $E(PSDRG,1,3)'="zz~" Q:'$D(PSJINP("PSDRG",PSDRG))
....I $E(PSDRG,1,3)="zz~" Q:'$D(PSJINP("PSDRG","*"_$E(PSDRG,4,99)))
....N CAB,SYS,PSPTID,PATND0,PATSSN
....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 PATND0=$G(^DPT(+PAT,0)) S PSPTNAME=$P(PATND0,"^"),PATSSN=$P(PATND0,"^",9) I PATSSN S PSPTNAME=PSPTNAME_" ("_$E(PATSSN,$L(PATSSN)-3,$L(PATSSN))_")"
....S PSPTND3=$G(^PS(58.6,+TRANS,3)) S PSPTLN=$P(PSPTND3,"^",5),PSPTFN=$P(PSPTND3,"^",6),PATRAWID=$P(PSPTND3,"^",7)
....S PSPTID=$S(($G(PAT)):PAT,$G(PATRAWID):PATRAWID,PAT="zz":"-",1:PAT)
....S PATSSN=$S($G(PATSSN):PATSSN,1:PSPTID)
....I PSPTNAME="" S PSPTNAME=$S((PSPTLN'="")&(PSPTFN'=""):PSPTLN_","_PSPTFN,PSPTLN'="":PSPTLN,PSPTFN'="":PSPTFN,1:"")
....I PSPTNAME="" S PSPTNAME=$P(PSPTND3,"^",4)
....I PSPTID="-",(PSPTNAME]"") S PSPTID="*",PSPTNAME="UNKNOWN PATIENT" S:'$G(PATSSN) PATSSN="*"
....I PSPTNAME="" S PSPTNAME="NO PATIENT"
....;
....S ^TMP($J,"PSJPTLST","PAT",PSPTID)=PSPTNAME,^TMP($J,"PSJPTLST","PATX",PSPTNAME)=PSPTID
....I PATSSN?9N S ^TMP($J,"PSJPTLST","PSPSSN",$E(PATSSN,6,9),PSPTID)=PSPTNAME
....I PATSSN'="" S ^TMP($J,"PSJPTLST","PATRAW",PATSSN)=PSPTNAME
....I PAT'="zz" S PSJDONE=1
....S PSJII=PSJII+1
Q
;
SELPAT(PSJINP) ; Prompt for one patient (or ALL)
N DIR,X,Y,PATNAME,DUOUT,DTOUT
N PSJPART,II,PSELMSG,PLSTMSG
K PSJSTOP S PSJSTOP=""
W ! D EN^DDIOL(" Enter '^ALL' to select all Patients associated with PADE transactions.") W !
S PLSTMSG(1)="Transactions matching the entered Date Range and Division "
S PLSTMSG(2)="exist for the Patients listed below."
S DIR(0)="FAO^1:30",DIR("?")="^D TMPLIST^PSJPDRU1(""PATRAW"",20)"
;
S DIR("A")="Select Patient: "_$S($D(^TMP($J,"PSJPTLST","SELPAT"))>1:"",1:"^ALL// ")
D ^DIR I X="" S Y=$S($D(^TMP($J,"PSJPTLST","SELPAT"))<10:"ALL",1:"")
I $E(X)="^" S Y=$$XALL^PSJPDRIP(X)
I $G(DUOUT)!$G(DTOUT) S PSJSTOP=1 Q
I Y="ALL" M ^TMP($J,"PSJPTLST","SELPAT")=^TMP($J,"PSJPTLST","PAT") S ^TMP($J,"PSJPTLST","SELPAT")="ALL",PSJDONE=1 Q
I Y="" D Q
.I $D(^TMP($J,"PSJPTLST","SELPAT"))>1 S PSJDONE=1 Q
.W !!?2,"Select a single Patient, several Patients or enter ^ALL to select all Patients."
S PSJY=Y
I $D(^TMP($J,"PSJPTLST","PSPSSN",PSJY)) D Q
.N I,SSN,ID,DIR,LISTDIR,LISTARR,NAME
.S SSN=PSJY S ID="" F I=1:1 S ID=$O(^TMP($J,"PSJPTLST","PSPSSN",SSN,ID)) Q:ID="" D
..I I=1 D Q
...S LISTDIR="1:"_^TMP($J,"PSJPTLST","PSPSSN",SSN,ID)_"("_SSN_")",LISTARR(1)=ID_"^"_^TMP($J,"PSJPTLST","PSPSSN",SSN,ID)
...S DIR("A",1)="1 "_^TMP($J,"PSJPTLST","PSPSSN",SSN,ID)
..S LISTDIR=$G(LISTDIR)_";"_I_":"_^TMP($J,"PSJPTLST","PSPSSN",SSN,ID)_"("_SSN_")",LISTARR(I)=ID_"^"_^TMP($J,"PSJPTLST","PSPSSN",SSN,ID)
..S DIR("A",I)=I_" "_^TMP($J,"PSJPTLST","PSPSSN",SSN,ID)
.I '$O(DIR("A",1)) S Y=1 W " "_$P(LISTARR(Y),"^",2)
.I $O(DIR("A",1)) S DIR(0)="SOA^"_LISTDIR,DIR("A")="Select Patient: " D ^DIR
.I Y S ID=$P(LISTARR(Y),"^"),NAME=$P(LISTARR(Y),"^",2),^TMP($J,"PSJPTLST","SELPAT",ID)=NAME
I $D(^TMP($J,"PSJPTLST","PAT",PSJY)) D Q
.W " ",^TMP($J,"PSJPTLST","PAT",PSJY) S ^TMP($J,"PSJPTLST","SELPAT",PSJY)=^TMP($J,"PSJPTLST","PAT",PSJY)
I $D(^TMP($J,"PSJPTLST","PATX",PSJY)) D Q
.W " ",^TMP($J,"PSJPTLST","PATX",PSJY) S ^TMP($J,"PSJPTLST","SELPAT",PSJY)=^TMP($J,"PSJPTLST","PATX",PSJY)
S PSELMSG="Select a Patient"
D PARTPT^PSJPDRU1(PSJY)
Q:$D(^TMP($J,"PSJPTLST","SELPAT"))>1
W " ?? (No match found)"
Q
;
TMPLIST(LIST,MAX) ; Write list in LIST(ID1)=ID1
N II,DRGNAME,NUMBER,TAB,NAME,ID1,ID2,PSCNT,DUOUT,DTOUT,DIR,X,Y
S $P(TAB," ",80)=""
S PSCNT=0
Q:$D(^TMP($J,"PSJPTLST",LIST))<10
S ID1="" F S ID1=$O(^TMP($J,"PSJPTLST",LIST,ID1)) Q:ID1=""!$G(DTOUT)!$G(DUOUT) D
.I ^TMP($J,"PSJPTLST",LIST,ID1)="" W !,$E(TAB,1,10)_ID1 Q
.N PSJMARG
.S PSJMARG=$S($E(ID1)="*":$E(TAB,1,17),1:$E(TAB,1,14-$L(ID1)))
.W !,PSJMARG_ID1_" "_$P(^TMP($J,"PSJPTLST",LIST,ID1),"^")_" "_$P(^TMP($J,"PSJPTLST",LIST,ID1),"^",2)
.S PSCNT=$G(PSCNT)+1
.I $G(MAX),(PSCNT>$G(MAX)) W !! S DIR(0)="E" D ^DIR S PSCNT=0 W !!
Q
;
PARTPT(PSJY) ; Lookup PSJY in INARRAY
; INPUT - PSJY=Lookup text
; - INARRAY(text)=number - Array of selectable data
; OUTPUT - OUTARRAY(text)=number - Entry selected from INARRAY
;
N PSJPART,ITMNAME,II,ITM,ITMX,Y,PSJTMP
;
; ^TMP($J,"PSJPTLST","PAT",PSPTID)=PSPTNAME
; ^TMP($J,"PSJPTLST","PATX",PSPTNAME)=PSPTID
; I PATSSN?9N S ^TMP($J,"PSJPTLST","PSPSSN",$E(PATSSN,6,9),PSPTID)=PSPTNAME
; I PATSSN'="" S ^TMP($J,"PSJPTLST","PATRAW",PATSSN)=PSPTNAME
;
K ^TMP($J,"PSJPTLST","ITM"),^TMP($J,"PSJPTLST","ITMX")
S II=1,ITMID="" F S ITMID=$O(^TMP($J,"PSJPTLST","PAT",ITMID)) Q:ITMID="" D
.Q:ITMID="IEN"!(ITMID="NAME")
.S ^TMP($J,"PSJPTLST","ITM",ITMID)=$P(^TMP($J,"PSJPTLST","PAT",ITMID),"^")
.S ^TMP($J,"PSJPTLST","ITMX",^TMP($J,"PSJPTLST","PAT",ITMID))=$P(^TMP($J,"PSJPTLST","PAT",ITMID),"^",2)
;
Q:$D(^TMP($J,"PSJPTLST","ITM"))<10
F ITM="" F S ITM=$O(^TMP($J,"PSJPTLST","ITM",ITM)) Q:ITM="" D
.I $E(ITM,1,$L(PSJY))=PSJY S PSJPART(II,ITM)=^TMP($J,"PSJPTLST","PAT",ITM) S II=II+1 Q
.I $E(^TMP($J,"PSJPTLST","ITM",ITM),1,$L(PSJY))=PSJY S PSJPART(II,ITM)=^TMP($J,"PSJPTLST","ITM",ITM) D Q
..S PSJPART(II,ITM)=PSJPART(II,ITM) S II=II+1
;
I $D(PSJPART(1)) D
.N DIR,STRING,CNT
.I '$O(PSJPART(1)) S PSJTMP=$O(PSJPART(1,"")) S ^TMP($J,"PSJPTLST","SELPAT",PSJTMP)=PSJPART(1,PSJTMP) D Q
..W !," "_$O(PSJPART(1,"")),?15,PSJPART(1,PSJTMP)
.S CNT=0 F S CNT=$O(PSJPART(CNT)) Q:'CNT D
..N ITMID S ITMID=$O(PSJPART(CNT,""))
..S STRING=$G(STRING)_CNT_":"_ITMID_";"
..S DIR("A",CNT)=" "_CNT_" "_ITMID_" "_$P($G(PSJPART(CNT,ITMID)),"^")
.S DIR("A")="Choose 1-"_+$O(PSJPART(9999999),-1)_": "
.S DIR(0)="SAO^"_STRING D ^DIR
.I Y>0 N PSPTSEL S PSPTSEL=$O(PSJPART(+Y,"")),^TMP($J,"PSJPTLST","SELPAT",PSPTSEL)=$G(PSJPART(+Y,PSPTSEL)) D Q
..N ID2 S ID2=$G(PSJPART(+Y,PSPTSEL)) I ID2]"" W " ",ID2
.S PSJY=""
Q
;
PTTRFLG(PSJINP) ; Return patient selection flag
; INPUT: PSJINP array of all responses to report prompts
; OUTPUT: FLAG indicating 1-All (Patients and Missing, or Blank, Patients),
; 2-Only Individual Patients (exclude missing pateints),
; 0-Only Missing or Blank patients
K PATFLG,PSJOB
S PATFLG=0
S PSJOB=$S($G(PSJINP("PSJTSK")):+$G(PSJINP("PSJTSK")),1:$J)
S PATFLG=($G(^TMP(PSJOB,"PSJPAT"))="ALL") ; All individual patients PLUS all non-patient transactions
I 'PATFLG S PATFLG=$O(^TMP(PSJOB,"PSJPAT",0)) D ; One or more individual patients
.I PATFLG!(PATFLG="*") S PATFLG=2
I PATFLG=2,$D(^TMP(PSJOB,"PSJPAT","-")) S PATFLG=1 ; One or more individual patients PLUS non-patient transactions
Q PATFLG
;
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
;
BLDSTR(PSJINP,PSLNOD,PSJCOMM) ; Build output data string
; INPUT: PSJINP() = array of user report input/selections
; PSLNOD = header node from PADE INBOUND TRANSACTION file (#58.6), by way of LIST^DIC call output in ^TMP($J,"TSCREEN"
; OUTPUT: PSLNDSTR = string of report output to be stored in ^TMP($J,"PSJPDRTR"
N PSJPSYS,PSJCAB,PSJDRG,II,PSJCOL,PSJOVR,PSJUID,PSJPAT,PSJQTY,PSJTTYP,PSJPUSR,PSJTYABB,PSAB,PSTMP,PSJTRDT,PSJTRDMO,PSJTYPNM,PSJTYPCD
N PSJUSRID,PSJWITID
S PSJPSYS=+PSJINP("PSJPSYS")
M PSJCAB=PSJINP("PADEV")
M PSJDRG=PSJINP("PSDRG")
; Format Date to external
K PSLNDSTR
S PSLNDSTR=$P(PSLNOD,"^",6,99)
S PSJTRDT=$TR($P($$FMTE^XLFDT($P(PSLNDSTR,"^"),2),":",1,2),"@"," ")
S $P(PSJTRDT,"/")=$TR($J($P(PSJTRDT,"/"),2)," ",0)
S $P(PSLNDSTR,"^")=PSJTRDT
; Format Override; depends on transaction type of the 58.6 entry (e.g., load/unload can't be an override, should be null)
S PSJTYPNM=$P(PSLNDSTR,"^",2)
S PSJTYPCD=$$EXTT^PSJPDRUT(PSJTYPNM)
;S PSJOVR=$S(PSJTYPCD="V":1,(PSJTYPCD="R"):1,1:"") I PSJOVR S PSJOVR=$S($P(PSLNDSTR,"^",3):"N",1:"Y")
S PSJOVR=$$PTRNSTYP^PSJPAD7I(PSJTYPCD) S:'PSJOVR PSJOVR=""
I PSJOVR S PSJOVR=$S($P(PSLNDSTR,"^",3):"N",1:"Y")
S $P(PSLNDSTR,"^",3)=$S($G(PSJINP("PSJDELM"))="R":" "_PSJOVR,1:PSJOVR)
; Format Patient (Add ID to name - last 4 of SSN)
S PSJPAT=$P(PSLNDSTR,"^",7) D
.N PATNAME,PATSSN
.S PATNAME=$P($G(^DPT(+PSJPAT,0)),"^")
.I PATNAME="" D Q
..N TRANS S TRANS=+$G(PSLNOD)
..S PSJPAT=$P($G(PSLNDSTR),"^",13)
..I TRANS S PATSSN=$P($G(^PS(58.6,+TRANS,3)),"^",7) I PATSSN S PSJPAT=PSJPAT_"("_PATSSN_")"
.S PATSSN=$P($G(^DPT(+PSJPAT,0)),"^",9) Q:$G(PATSSN)=""
.S PSJPAT=PATNAME_"("_$E(PATSSN,6,9)_")"
S $P(PSLNDSTR,"^",7)=PSJPAT
; Pull out Comment to PSJCOMM.
S PSJCOMM=$P(PSLNDSTR,"^",12)
; Add ID's to User and Witness
S PSJPUSR=""
S PSJUSRID=$P(PSLNDSTR,"^",8) D
.Q:PSJUSRID="" S PSJPUSR=$$PADEUSR^PSJPDRUT(+$G(PSJPSYS),PSJUSRID)
.I 'PSJPUSR S PSJPUSR=$P(PSJPUSR,"^",3)
.S PSJUSRID="("_PSJUSRID_")"
S PSJWITID=$P(PSLNDSTR,"^",10) S:PSJWITID'="" PSJWITID="("_PSJWITID_")"
F II=4:1:6 S PSTMP=$P(PSLNDSTR,"^",II) I PSTMP["." S PSTMP=$P(PSTMP,".")_"."_$E($P(PSTMP,".",2),1,2),$P(PSLNDSTR,"^",II)=PSTMP
; If Expected Balance is null, check for Actual Balance
N PSABC,PSEBC S PSABC=$P(PSLNOD,"^",23),PSEBC=$P(PSLNDSTR,"^",10)
S $P(PSLNDSTR,"^",10)=$S(((PSEBC="")&PSABC):PSABC,1:PSEBC)
S PSLNDSTR=$P(PSLNDSTR,"^",1,7)_"^"_$S($P(PSJPUSR,"^",2)]"":$P(PSJPUSR,"^",2),1:$P(PSLNDSTR,"^",9))_PSJUSRID_"^"_$P(PSLNDSTR,"^",11)_PSJWITID_"^^"
; Transaction Type conversion
S PSJTTYP=$$TTEX^PSJPDRUT(PSJTYPCD)
;
; Signed Quantity as interpreted by PADE inbound based on Transaction Type
S PSJQTY=+$P(PSLNDSTR,"^",5) D
.N TMPARRAY,TSIGN S TMPARRAY(6)=PSJQTY
.S TMPARRAY(5)=$$EXTT^PSJPDRUT(PSJTTYP)
.S TSIGN=$$TSIGN^PSJPADIT(.TMPARRAY) S TSIGN=$S(TSIGN="-":"-",1:"")
.S TMPARRAY(6)=$S(PSJQTY["-":PSJQTY/-1,1:PSJQTY)
.S PSJQTY=$S($G(TMPARRAY(5))="W":"NA",$G(TMPARRAY(6)):TSIGN_TMPARRAY(6),1:0)
;
I PSJQTY["." S PSJQTY=$P(PSJQTY,".")_"."_$E($P(PSJQTY,".",2),1,2)
S $P(PSLNDSTR,"^",5)=PSJQTY
;
I PSJTTYP="Count" D
.N PSENDBAL,PSBEGBAL S PSENDBAL=$P(PSLNDSTR,"^",6) I 'PSENDBAL,$G(PSJQTY) S PSENDBAL=PSJQTY S $P(PSLNDSTR,"^",6)=PSJQTY
.S PSBEGBAL=$P(PSLNDSTR,"^",4) I 'PSBEGBAL,$G(PSJQTY) S PSBEGBAL=PSJQTY S $P(PSLNDSTR,"^",4)=PSJQTY
; Right Justify Quantities if formatted output
I $G(PSJINP("PSJDELM"))'="D" F II=4:1:6 S $P(PSLNDSTR,"^",II)=$J($P(PSLNDSTR,"^",II),5)
S $P(PSLNDSTR,"^",2)=PSJTTYP
; If delimited output, make adjustments
I $G(PSJINP("PSJDELM"))="D" D
.; If delimited output, add comment to end of string
.I PSJCOMM'="" S PSLNDSTR=PSLNDSTR_"^"_PSJCOMM
.; Break out Patient,User, and Witness ID's into separate delimited pieces if delimited output
.N PIECE F PIECE=7,9,11 D
..N NAMID,NAM,ID S NAMID=$P(PSLNDSTR,"^",PIECE)
..S NAM=$P(NAMID,"("),ID=$P(NAMID,"(",2),ID=$TR(ID,")")
..S PSLNDSTR=$P(PSLNDSTR,"^",1,PIECE-1)_"^"_NAM_"^"_ID_"^"_$P(PSLNDSTR,"^",PIECE+1,99)
Q PSLNDSTR
;
INSYSPAR(PSPARACT) ; Allow edit of PSJ PADE OE BALANCES parameter.
; Input = PSPARACT - Default parameter setting - only prompt if 0(NO).
; - If 1(YES), set without prompting - if vendor is activated, system must also be activated
N DIR,X,Y,PSPARIEN,PSALLOFF,PSPARVAL,PSPARER
S PSPARIEN=$$FIND1^DIC(8989.51,,,"PSJ PADE OE BALANCES")
S PSALLOFF=0
I '$G(PSPARACT) D Q:'PSALLOFF
.S DIR(0)="YAO",DIR("B")="Y"
.S DIR("A")="Completely disable PADE IOE indicators (for ALL vendors)? "
.S DIR("?",1)=" This sets the ""PSJ PADE OE BALANCES"" system parameter that"
.S DIR("?",2)=" inactivates all PADE indicators in Inpatient Order Entry,"
.S DIR("?",3)=" (IOE) for all vendors. To inactivate one specific vendor only,"
.S DIR("?")=" use the ""DISPLAY PADE INDICATORS IN IOE?"" prompt."
.D ^DIR
.S PSALLOFF=$S($G(Y):1,1:0)
S PSPARVAL=$S($G(PSPARACT):1,1:0)
D EN^XPAR("SYS",PSPARIEN,,PSPARVAL,"PSPARER")
I $D(PSPARER)>1 W !,"ERROR - Parameter not set"
Q
;
DEVONOFF(PSJPSYS,OFFON) ; Set status of all dispensing devices (cabinet) to OFF or ON for system PSJPSYS
;
N DIE,DA,DR,X,Y,PSVAL
N FDA,PSERR
N PSICAB ; Pointer to cabinet in PADE INVENTORY SYSTEM "DEVICE" subfile (not to cabinet ien in DEVICE file #58.63)
N PSDCAB ; Pointer to cabinet in PADE DISPENSING DEVICE (#58.63) file
Q:'$G(PSJPSYS)
Q:'$D(^PS(58.601,+$G(PSJPSYS),"DEVICE"))
Q:($G(OFFON)'=1)&($G(OFFON)'=0) ; must be 1(yes=ACTIVE) or 0(no=INACTIVE)
S PSICAB=0 F S PSICAB=$O(^PS(58.601,+$G(PSJPSYS),"DEVICE",PSICAB)) Q:'PSICAB D
.S PSDCAB=+$G(^PS(58.601,PSJPSYS,"DEVICE",PSICAB,0))
.Q:'$G(PSDCAB) Q:'$D(^PS(58.63,+PSDCAB,0)) ; Device not in device file #58.63
.S PSVAL=$S(OFFON=1:"A",1:"I")
.S FDA(58.63,PSDCAB_",",4)=PSVAL
.D FILE^DIE("","FDA","PSERR")
Q
;
DEVSTCHK(PSJPSYS) ; Return status of all dispensing devices (cabinet) for system PSJPSYS
; If all devices have a status OFF, return 0; if ANY devices do NOT have a status of INACTIVE, return 1
N DIE,DA,DR,X,Y,PSTATUS
N PSICAB ; Pointer to cabinet in PADE INVENTORY SYSTEM "DEVICE" subfile (not to cabinet ien in DEVICE file #58.63)
N PSDCAB ; Pointer to cabinet in PADE DISPENSING DEVICE (#58.63) file
Q:'$G(PSJPSYS) 0
Q:'$D(^PS(58.601,+$G(PSJPSYS),"DEVICE")) 0
S PSTATUS=0
S PSICAB=0 F S PSICAB=$O(^PS(58.601,+$G(PSJPSYS),"DEVICE",PSICAB)) Q:'PSICAB!$G(PSTATUS) D
.S PSDCAB=+$G(^PS(58.601,PSJPSYS,"DEVICE",PSICAB,0))
.Q:'$G(PSDCAB) Q:'$D(^PS(58.63,+PSDCAB,0)) ; Device not in device file #58.63
.S PSTATUS=$P($G(^PS(58.63,+PSDCAB,0)),"^",4)
.S PSTATUS=$S(PSTATUS="I":0,1:1)
Q PSTATUS
;
DELBADSY ; Check for and delete "?BAD" entries in PADE INVENTORY SYSTEM file (#58.601)
; "?BAD" entry may result when user enters "" new DISPENSING DEVICE (#58.63) file entry, and FileMan creates the "?BAD" KEY index
N SYS,SYSNAM,BADSYS
S SYS=0 F S SYS=$O(^PS(58.601,SYS)) Q:'SYS D
.I $G(^PS(58.601,SYS,0))="?BAD",'$D(^PS(58.601,SYS,4)) S BADSYS(SYS)=$P($G(^PS(58.601,SYS,0)),"^")
Q:'$D(BADSYS)
S SYS=0 F S SYS=$O(BADSYS(SYS)) Q:'SYS D
.Q:$G(BADSYS(SYS))'="?BAD"
.N DIK,DA
.S DIK="^PS(58.601,",DA=+SYS D ^DIK
Q
;
TSIGN(PADATA) ; Determine if the transaction amount needs to be added or subtracted, depending on the transaction type
N TRNSIGN,II
S TRNSIGN="" F II="V","B","U","E","D" I PADATA(5)=II S TRNSIGN="-"
I PADATA(5)="A"&($E(PADATA(6))="-") S TRNSIGN="-" ; Discrepancies (type="A") may be either + or -
Q $S(TRNSIGN="-":"-",1:"")
;
DEVBAL(PADESYS,PADEDEV,DRUGIEN) ; Calculate Device BALANCE for PADE device=PADEDEV drug=DRUGIEN
K DEVBAL S DEVBAL="" ; Initialize returned balance
N DRAWER ; Pocket_subdrawer IEN
N DRWOUT,DEVOUT ; Return array from LIST^DIC
N DRWDRG
N PSERR
N DRWTOT
; We need system and device to find device balance
I '$G(PADESYS)!'$G(PADEDEV) Q ""
;
Q:'DRUGIEN ""
S DRAWER=0 F S DRAWER=$O(^PS(58.601,PADESYS,"DEVICE",PADEDEV,"DRAWER",DRAWER)) Q:'DRAWER D
.S DRWDRG=0 F S DRWDRG=$O(^PS(58.601,PADESYS,"DEVICE",PADEDEV,"DRAWER",DRAWER,"DRUG","B",DRWDRG)) Q:'DRWDRG D
..Q:DRWDRG'=DRUGIEN ; Is this the drug we're looking for?
..N DRWDRIEN ; The IEN of the drug's entry in the drawer
..S DRWDRIEN=$O(^PS(58.601,PADESYS,"DEVICE",PADEDEV,"DRAWER",DRAWER,"DRUG","B",DRWDRG,0))
..Q:'DRWDRIEN ; Bad index - this shouldn't happen
..S DRWTOT=$P($G(^PS(58.601,PADESYS,"DEVICE",PADEDEV,"DRAWER",DRAWER,"DRUG",DRWDRIEN,0)),"^",2)
..S DEVBAL=$G(DEVBAL)+DRWTOT
Q DEVBAL
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSJPDRU1 17692 printed Dec 13, 2024@02:08:50 Page 2
PSJPDRU1 ;BIR/MV-PADE REPORT UTILITIES ;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 ;
PATIENT(PSJINP) ; Get list of patients
+1 NEW PSJDONE,PATX,PAT,PATXX,PATSSN
KILL PSJPAT,PSJSTOP
+2 SET PSJSTOP=""
+3 DO PATLIST^PSJPDRU1(.PSJINP)
+4 IF $DATA(^TMP($JOB,"PSJPTLST","PAT"))<10
Begin DoDot:1
+5 WRITE !!,"Patient: "
+6 WRITE !," No patients available for selection..",!
End DoDot:1
QUIT
+7 FOR
if $GET(PSJDONE)!$GET(PSJSTOP)
QUIT
Begin DoDot:1
+8 DO SELPAT^PSJPDRU1(.PSJINP)
End DoDot:1
+9 QUIT
+10 ;
PATLIST(PSJINP) ; Build list of patients that may be selected based on transaction date range and PADE Inbound System
+1 NEW PSJDEV,PADEV,PSDRG,PSJBDT,PSJEDT,PSJTRDT,TRANS,PSJDONE,PSUNAME,PSJII,PSPTNAME,PSPTLN,PSPTFN,PSPTID,PSPTND3,PATRAWID,PSJHTM,PSJDOTS
+2 ; If search takes too long, may have to print "Searching..", followed by dots every 2 seconds
SET PSJHTM=$PIECE($HOROLOG,",",2)
SET PSJDOTS=""
+3 KILL ^TMP($JOB,"PSJPTLST")
+4 KILL PAT
SET PSJII=1
+5 MERGE PSJDEV=PSJINP("PADEV")
+6 MERGE PSDRG=PSJINP("PSDRG")
+7 SET PSJBDT=$GET(PSJINP("PSJBDT"))
+8 SET PSJEDT=$GET(PSJINP("PSJEDT"))
+9 SET PAT=""
FOR
SET PAT=$ORDER(^PS(58.6,"P",PAT))
if PAT=""
QUIT
Begin DoDot:1
+10 DO DISPDOTS^PSJPDRUT(.PSJHTM,.PSJDOTS,1)
+11 SET PSJTRDT=$$FMADD^XLFDT(PSJBDT,,,,-1)
SET PSJDONE=0
+12 FOR
SET PSJTRDT=$ORDER(^PS(58.6,"P",PAT,PSJTRDT))
if (PSJTRDT>PSJEDT)!$GET(PSJDONE)!(PSJTRDT="")
QUIT
Begin DoDot:2
+13 NEW PSDRG
SET PSDRG=""
FOR
SET PSDRG=$ORDER(^PS(58.6,"P",PAT,PSJTRDT,PSDRG))
if PSDRG=""
QUIT
Begin DoDot:3
+14 DO DISPDOTS^PSJPDRUT(.PSJHTM,.PSJDOTS,1)
+15 SET TRANS=0
FOR
SET TRANS=$ORDER(^PS(58.6,"P",PAT,PSJTRDT,PSDRG,TRANS))
if 'TRANS
QUIT
Begin DoDot:4
+16 IF $EXTRACT(PSDRG,1,3)'="zz~"
if '$DATA(PSJINP("PSDRG",PSDRG))
QUIT
+17 IF $EXTRACT(PSDRG,1,3)="zz~"
if '$DATA(PSJINP("PSDRG","*"_$EXTRACT(PSDRG,4,99)))
QUIT
+18 NEW CAB,SYS,PSPTID,PATND0,PATSSN
+19 SET CAB=$PIECE($GET(^PS(58.6,+TRANS,0)),"^",2)
IF CAB]""
if '$DATA(PSJINP("PADEV",CAB))
QUIT
+20 SET SYS=$PIECE($GET(^PS(58.6,+TRANS,1)),"^",3)
IF SYS]""
if SYS'=$GET(PSJINP("PSJPSYSE"))
QUIT
+21 SET PATND0=$GET(^DPT(+PAT,0))
SET PSPTNAME=$PIECE(PATND0,"^")
SET PATSSN=$PIECE(PATND0,"^",9)
IF PATSSN
SET PSPTNAME=PSPTNAME_" ("_$EXTRACT(PATSSN,$LENGTH(PATSSN)-3,$LENGTH(PATSSN))_")"
+22 SET PSPTND3=$GET(^PS(58.6,+TRANS,3))
SET PSPTLN=$PIECE(PSPTND3,"^",5)
SET PSPTFN=$PIECE(PSPTND3,"^",6)
SET PATRAWID=$PIECE(PSPTND3,"^",7)
+23 SET PSPTID=$SELECT(($GET(PAT)):PAT,$GET(PATRAWID):PATRAWID,PAT="zz":"-",1:PAT)
+24 SET PATSSN=$SELECT($GET(PATSSN):PATSSN,1:PSPTID)
+25 IF PSPTNAME=""
SET PSPTNAME=$SELECT((PSPTLN'="")&(PSPTFN'=""):PSPTLN_","_PSPTFN,PSPTLN'="":PSPTLN,PSPTFN'="":PSPTFN,1:"")
+26 IF PSPTNAME=""
SET PSPTNAME=$PIECE(PSPTND3,"^",4)
+27 IF PSPTID="-"
IF (PSPTNAME]"")
SET PSPTID="*"
SET PSPTNAME="UNKNOWN PATIENT"
if '$GET(PATSSN)
SET PATSSN="*"
+28 IF PSPTNAME=""
SET PSPTNAME="NO PATIENT"
+29 ;
+30 SET ^TMP($JOB,"PSJPTLST","PAT",PSPTID)=PSPTNAME
SET ^TMP($JOB,"PSJPTLST","PATX",PSPTNAME)=PSPTID
+31 IF PATSSN?9N
SET ^TMP($JOB,"PSJPTLST","PSPSSN",$EXTRACT(PATSSN,6,9),PSPTID)=PSPTNAME
+32 IF PATSSN'=""
SET ^TMP($JOB,"PSJPTLST","PATRAW",PATSSN)=PSPTNAME
+33 IF PAT'="zz"
SET PSJDONE=1
+34 SET PSJII=PSJII+1
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+35 QUIT
+36 ;
SELPAT(PSJINP) ; Prompt for one patient (or ALL)
+1 NEW DIR,X,Y,PATNAME,DUOUT,DTOUT
+2 NEW PSJPART,II,PSELMSG,PLSTMSG
+3 KILL PSJSTOP
SET PSJSTOP=""
+4 WRITE !
DO EN^DDIOL(" Enter '^ALL' to select all Patients associated with PADE transactions.")
WRITE !
+5 SET PLSTMSG(1)="Transactions matching the entered Date Range and Division "
+6 SET PLSTMSG(2)="exist for the Patients listed below."
+7 SET DIR(0)="FAO^1:30"
SET DIR("?")="^D TMPLIST^PSJPDRU1(""PATRAW"",20)"
+8 ;
+9 SET DIR("A")="Select Patient: "_$SELECT($DATA(^TMP($JOB,"PSJPTLST","SELPAT"))>1:"",1:"^ALL// ")
+10 DO ^DIR
IF X=""
SET Y=$SELECT($DATA(^TMP($JOB,"PSJPTLST","SELPAT"))<10:"ALL",1:"")
+11 IF $EXTRACT(X)="^"
SET Y=$$XALL^PSJPDRIP(X)
+12 IF $GET(DUOUT)!$GET(DTOUT)
SET PSJSTOP=1
QUIT
+13 IF Y="ALL"
MERGE ^TMP($JOB,"PSJPTLST","SELPAT")=^TMP($JOB,"PSJPTLST","PAT")
SET ^TMP($JOB,"PSJPTLST","SELPAT")="ALL"
SET PSJDONE=1
QUIT
+14 IF Y=""
Begin DoDot:1
+15 IF $DATA(^TMP($JOB,"PSJPTLST","SELPAT"))>1
SET PSJDONE=1
QUIT
+16 WRITE !!?2,"Select a single Patient, several Patients or enter ^ALL to select all Patients."
End DoDot:1
QUIT
+17 SET PSJY=Y
+18 IF $DATA(^TMP($JOB,"PSJPTLST","PSPSSN",PSJY))
Begin DoDot:1
+19 NEW I,SSN,ID,DIR,LISTDIR,LISTARR,NAME
+20 SET SSN=PSJY
SET ID=""
FOR I=1:1
SET ID=$ORDER(^TMP($JOB,"PSJPTLST","PSPSSN",SSN,ID))
if ID=""
QUIT
Begin DoDot:2
+21 IF I=1
Begin DoDot:3
+22 SET LISTDIR="1:"_^TMP($JOB,"PSJPTLST","PSPSSN",SSN,ID)_"("_SSN_")"
SET LISTARR(1)=ID_"^"_^TMP($JOB,"PSJPTLST","PSPSSN",SSN,ID)
+23 SET DIR("A",1)="1 "_^TMP($JOB,"PSJPTLST","PSPSSN",SSN,ID)
End DoDot:3
QUIT
+24 SET LISTDIR=$GET(LISTDIR)_";"_I_":"_^TMP($JOB,"PSJPTLST","PSPSSN",SSN,ID)_"("_SSN_")"
SET LISTARR(I)=ID_"^"_^TMP($JOB,"PSJPTLST","PSPSSN",SSN,ID)
+25 SET DIR("A",I)=I_" "_^TMP($JOB,"PSJPTLST","PSPSSN",SSN,ID)
End DoDot:2
+26 IF '$ORDER(DIR("A",1))
SET Y=1
WRITE " "_$PIECE(LISTARR(Y),"^",2)
+27 IF $ORDER(DIR("A",1))
SET DIR(0)="SOA^"_LISTDIR
SET DIR("A")="Select Patient: "
DO ^DIR
+28 IF Y
SET ID=$PIECE(LISTARR(Y),"^")
SET NAME=$PIECE(LISTARR(Y),"^",2)
SET ^TMP($JOB,"PSJPTLST","SELPAT",ID)=NAME
End DoDot:1
QUIT
+29 IF $DATA(^TMP($JOB,"PSJPTLST","PAT",PSJY))
Begin DoDot:1
+30 WRITE " ",^TMP($JOB,"PSJPTLST","PAT",PSJY)
SET ^TMP($JOB,"PSJPTLST","SELPAT",PSJY)=^TMP($JOB,"PSJPTLST","PAT",PSJY)
End DoDot:1
QUIT
+31 IF $DATA(^TMP($JOB,"PSJPTLST","PATX",PSJY))
Begin DoDot:1
+32 WRITE " ",^TMP($JOB,"PSJPTLST","PATX",PSJY)
SET ^TMP($JOB,"PSJPTLST","SELPAT",PSJY)=^TMP($JOB,"PSJPTLST","PATX",PSJY)
End DoDot:1
QUIT
+33 SET PSELMSG="Select a Patient"
+34 DO PARTPT^PSJPDRU1(PSJY)
+35 if $DATA(^TMP($JOB,"PSJPTLST","SELPAT"))>1
QUIT
+36 WRITE " ?? (No match found)"
+37 QUIT
+38 ;
TMPLIST(LIST,MAX) ; Write list in LIST(ID1)=ID1
+1 NEW II,DRGNAME,NUMBER,TAB,NAME,ID1,ID2,PSCNT,DUOUT,DTOUT,DIR,X,Y
+2 SET $PIECE(TAB," ",80)=""
+3 SET PSCNT=0
+4 if $DATA(^TMP($JOB,"PSJPTLST",LIST))<10
QUIT
+5 SET ID1=""
FOR
SET ID1=$ORDER(^TMP($JOB,"PSJPTLST",LIST,ID1))
if ID1=""!$GET(DTOUT)!$GET(DUOUT)
QUIT
Begin DoDot:1
+6 IF ^TMP($JOB,"PSJPTLST",LIST,ID1)=""
WRITE !,$EXTRACT(TAB,1,10)_ID1
QUIT
+7 NEW PSJMARG
+8 SET PSJMARG=$SELECT($EXTRACT(ID1)="*":$EXTRACT(TAB,1,17),1:$EXTRACT(TAB,1,14-$LENGTH(ID1)))
+9 WRITE !,PSJMARG_ID1_" "_$PIECE(^TMP($JOB,"PSJPTLST",LIST,ID1),"^")_" "_$PIECE(^TMP($JOB,"PSJPTLST",LIST,ID1),"^",2)
+10 SET PSCNT=$GET(PSCNT)+1
+11 IF $GET(MAX)
IF (PSCNT>$GET(MAX))
WRITE !!
SET DIR(0)="E"
DO ^DIR
SET PSCNT=0
WRITE !!
End DoDot:1
+12 QUIT
+13 ;
PARTPT(PSJY) ; Lookup PSJY in INARRAY
+1 ; INPUT - PSJY=Lookup text
+2 ; - INARRAY(text)=number - Array of selectable data
+3 ; OUTPUT - OUTARRAY(text)=number - Entry selected from INARRAY
+4 ;
+5 NEW PSJPART,ITMNAME,II,ITM,ITMX,Y,PSJTMP
+6 ;
+7 ; ^TMP($J,"PSJPTLST","PAT",PSPTID)=PSPTNAME
+8 ; ^TMP($J,"PSJPTLST","PATX",PSPTNAME)=PSPTID
+9 ; I PATSSN?9N S ^TMP($J,"PSJPTLST","PSPSSN",$E(PATSSN,6,9),PSPTID)=PSPTNAME
+10 ; I PATSSN'="" S ^TMP($J,"PSJPTLST","PATRAW",PATSSN)=PSPTNAME
+11 ;
+12 KILL ^TMP($JOB,"PSJPTLST","ITM"),^TMP($JOB,"PSJPTLST","ITMX")
+13 SET II=1
SET ITMID=""
FOR
SET ITMID=$ORDER(^TMP($JOB,"PSJPTLST","PAT",ITMID))
if ITMID=""
QUIT
Begin DoDot:1
+14 if ITMID="IEN"!(ITMID="NAME")
QUIT
+15 SET ^TMP($JOB,"PSJPTLST","ITM",ITMID)=$PIECE(^TMP($JOB,"PSJPTLST","PAT",ITMID),"^")
+16 SET ^TMP($JOB,"PSJPTLST","ITMX",^TMP($JOB,"PSJPTLST","PAT",ITMID))=$PIECE(^TMP($JOB,"PSJPTLST","PAT",ITMID),"^",2)
End DoDot:1
+17 ;
+18 if $DATA(^TMP($JOB,"PSJPTLST","ITM"))<10
QUIT
+19 FOR ITM=""
FOR
SET ITM=$ORDER(^TMP($JOB,"PSJPTLST","ITM",ITM))
if ITM=""
QUIT
Begin DoDot:1
+20 IF $EXTRACT(ITM,1,$LENGTH(PSJY))=PSJY
SET PSJPART(II,ITM)=^TMP($JOB,"PSJPTLST","PAT",ITM)
SET II=II+1
QUIT
+21 IF $EXTRACT(^TMP($JOB,"PSJPTLST","ITM",ITM),1,$LENGTH(PSJY))=PSJY
SET PSJPART(II,ITM)=^TMP($JOB,"PSJPTLST","ITM",ITM)
Begin DoDot:2
+22 SET PSJPART(II,ITM)=PSJPART(II,ITM)
SET II=II+1
End DoDot:2
QUIT
End DoDot:1
+23 ;
+24 IF $DATA(PSJPART(1))
Begin DoDot:1
+25 NEW DIR,STRING,CNT
+26 IF '$ORDER(PSJPART(1))
SET PSJTMP=$ORDER(PSJPART(1,""))
SET ^TMP($JOB,"PSJPTLST","SELPAT",PSJTMP)=PSJPART(1,PSJTMP)
Begin DoDot:2
+27 WRITE !," "_$ORDER(PSJPART(1,"")),?15,PSJPART(1,PSJTMP)
End DoDot:2
QUIT
+28 SET CNT=0
FOR
SET CNT=$ORDER(PSJPART(CNT))
if 'CNT
QUIT
Begin DoDot:2
+29 NEW ITMID
SET ITMID=$ORDER(PSJPART(CNT,""))
+30 SET STRING=$GET(STRING)_CNT_":"_ITMID_";"
+31 SET DIR("A",CNT)=" "_CNT_" "_ITMID_" "_$PIECE($GET(PSJPART(CNT,ITMID)),"^")
End DoDot:2
+32 SET DIR("A")="Choose 1-"_+$ORDER(PSJPART(9999999),-1)_": "
+33 SET DIR(0)="SAO^"_STRING
DO ^DIR
+34 IF Y>0
NEW PSPTSEL
SET PSPTSEL=$ORDER(PSJPART(+Y,""))
SET ^TMP($JOB,"PSJPTLST","SELPAT",PSPTSEL)=$GET(PSJPART(+Y,PSPTSEL))
Begin DoDot:2
+35 NEW ID2
SET ID2=$GET(PSJPART(+Y,PSPTSEL))
IF ID2]""
WRITE " ",ID2
End DoDot:2
QUIT
+36 SET PSJY=""
End DoDot:1
+37 QUIT
+38 ;
PTTRFLG(PSJINP) ; Return patient selection flag
+1 ; INPUT: PSJINP array of all responses to report prompts
+2 ; OUTPUT: FLAG indicating 1-All (Patients and Missing, or Blank, Patients),
+3 ; 2-Only Individual Patients (exclude missing pateints),
+4 ; 0-Only Missing or Blank patients
+5 KILL PATFLG,PSJOB
+6 SET PATFLG=0
+7 SET PSJOB=$SELECT($GET(PSJINP("PSJTSK")):+$GET(PSJINP("PSJTSK")),1:$JOB)
+8 ; All individual patients PLUS all non-patient transactions
SET PATFLG=($GET(^TMP(PSJOB,"PSJPAT"))="ALL")
+9 ; One or more individual patients
IF 'PATFLG
SET PATFLG=$ORDER(^TMP(PSJOB,"PSJPAT",0))
Begin DoDot:1
+10 IF PATFLG!(PATFLG="*")
SET PATFLG=2
End DoDot:1
+11 ; One or more individual patients PLUS non-patient transactions
IF PATFLG=2
IF $DATA(^TMP(PSJOB,"PSJPAT","-"))
SET PATFLG=1
+12 QUIT PATFLG
+13 ;
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 ;
BLDSTR(PSJINP,PSLNOD,PSJCOMM) ; Build output data string
+1 ; INPUT: PSJINP() = array of user report input/selections
+2 ; PSLNOD = header node from PADE INBOUND TRANSACTION file (#58.6), by way of LIST^DIC call output in ^TMP($J,"TSCREEN"
+3 ; OUTPUT: PSLNDSTR = string of report output to be stored in ^TMP($J,"PSJPDRTR"
+4 NEW PSJPSYS,PSJCAB,PSJDRG,II,PSJCOL,PSJOVR,PSJUID,PSJPAT,PSJQTY,PSJTTYP,PSJPUSR,PSJTYABB,PSAB,PSTMP,PSJTRDT,PSJTRDMO,PSJTYPNM,PSJTYPCD
+5 NEW PSJUSRID,PSJWITID
+6 SET PSJPSYS=+PSJINP("PSJPSYS")
+7 MERGE PSJCAB=PSJINP("PADEV")
+8 MERGE PSJDRG=PSJINP("PSDRG")
+9 ; Format Date to external
+10 KILL PSLNDSTR
+11 SET PSLNDSTR=$PIECE(PSLNOD,"^",6,99)
+12 SET PSJTRDT=$TRANSLATE($PIECE($$FMTE^XLFDT($PIECE(PSLNDSTR,"^"),2),":",1,2),"@"," ")
+13 SET $PIECE(PSJTRDT,"/")=$TRANSLATE($JUSTIFY($PIECE(PSJTRDT,"/"),2)," ",0)
+14 SET $PIECE(PSLNDSTR,"^")=PSJTRDT
+15 ; Format Override; depends on transaction type of the 58.6 entry (e.g., load/unload can't be an override, should be null)
+16 SET PSJTYPNM=$PIECE(PSLNDSTR,"^",2)
+17 SET PSJTYPCD=$$EXTT^PSJPDRUT(PSJTYPNM)
+18 ;S PSJOVR=$S(PSJTYPCD="V":1,(PSJTYPCD="R"):1,1:"") I PSJOVR S PSJOVR=$S($P(PSLNDSTR,"^",3):"N",1:"Y")
+19 SET PSJOVR=$$PTRNSTYP^PSJPAD7I(PSJTYPCD)
if 'PSJOVR
SET PSJOVR=""
+20 IF PSJOVR
SET PSJOVR=$SELECT($PIECE(PSLNDSTR,"^",3):"N",1:"Y")
+21 SET $PIECE(PSLNDSTR,"^",3)=$SELECT($GET(PSJINP("PSJDELM"))="R":" "_PSJOVR,1:PSJOVR)
+22 ; Format Patient (Add ID to name - last 4 of SSN)
+23 SET PSJPAT=$PIECE(PSLNDSTR,"^",7)
Begin DoDot:1
+24 NEW PATNAME,PATSSN
+25 SET PATNAME=$PIECE($GET(^DPT(+PSJPAT,0)),"^")
+26 IF PATNAME=""
Begin DoDot:2
+27 NEW TRANS
SET TRANS=+$GET(PSLNOD)
+28 SET PSJPAT=$PIECE($GET(PSLNDSTR),"^",13)
+29 IF TRANS
SET PATSSN=$PIECE($GET(^PS(58.6,+TRANS,3)),"^",7)
IF PATSSN
SET PSJPAT=PSJPAT_"("_PATSSN_")"
End DoDot:2
QUIT
+30 SET PATSSN=$PIECE($GET(^DPT(+PSJPAT,0)),"^",9)
if $GET(PATSSN)=""
QUIT
+31 SET PSJPAT=PATNAME_"("_$EXTRACT(PATSSN,6,9)_")"
End DoDot:1
+32 SET $PIECE(PSLNDSTR,"^",7)=PSJPAT
+33 ; Pull out Comment to PSJCOMM.
+34 SET PSJCOMM=$PIECE(PSLNDSTR,"^",12)
+35 ; Add ID's to User and Witness
+36 SET PSJPUSR=""
+37 SET PSJUSRID=$PIECE(PSLNDSTR,"^",8)
Begin DoDot:1
+38 if PSJUSRID=""
QUIT
SET PSJPUSR=$$PADEUSR^PSJPDRUT(+$GET(PSJPSYS),PSJUSRID)
+39 IF 'PSJPUSR
SET PSJPUSR=$PIECE(PSJPUSR,"^",3)
+40 SET PSJUSRID="("_PSJUSRID_")"
End DoDot:1
+41 SET PSJWITID=$PIECE(PSLNDSTR,"^",10)
if PSJWITID'=""
SET PSJWITID="("_PSJWITID_")"
+42 FOR II=4:1:6
SET PSTMP=$PIECE(PSLNDSTR,"^",II)
IF PSTMP["."
SET PSTMP=$PIECE(PSTMP,".")_"."_$EXTRACT($PIECE(PSTMP,".",2),1,2)
SET $PIECE(PSLNDSTR,"^",II)=PSTMP
+43 ; If Expected Balance is null, check for Actual Balance
+44 NEW PSABC,PSEBC
SET PSABC=$PIECE(PSLNOD,"^",23)
SET PSEBC=$PIECE(PSLNDSTR,"^",10)
+45 SET $PIECE(PSLNDSTR,"^",10)=$SELECT(((PSEBC="")&PSABC):PSABC,1:PSEBC)
+46 SET PSLNDSTR=$PIECE(PSLNDSTR,"^",1,7)_"^"_$SELECT($PIECE(PSJPUSR,"^",2)]"":$PIECE(PSJPUSR,"^",2),1:$PIECE(PSLNDSTR,"^",9))_PSJUSRID_"^"_$PIECE(PSLNDSTR,"^",11)_PSJWITID_"^^"
+47 ; Transaction Type conversion
+48 SET PSJTTYP=$$TTEX^PSJPDRUT(PSJTYPCD)
+49 ;
+50 ; Signed Quantity as interpreted by PADE inbound based on Transaction Type
+51 SET PSJQTY=+$PIECE(PSLNDSTR,"^",5)
Begin DoDot:1
+52 NEW TMPARRAY,TSIGN
SET TMPARRAY(6)=PSJQTY
+53 SET TMPARRAY(5)=$$EXTT^PSJPDRUT(PSJTTYP)
+54 SET TSIGN=$$TSIGN^PSJPADIT(.TMPARRAY)
SET TSIGN=$SELECT(TSIGN="-":"-",1:"")
+55 SET TMPARRAY(6)=$SELECT(PSJQTY["-":PSJQTY/-1,1:PSJQTY)
+56 SET PSJQTY=$SELECT($GET(TMPARRAY(5))="W":"NA",$GET(TMPARRAY(6)):TSIGN_TMPARRAY(6),1:0)
End DoDot:1
+57 ;
+58 IF PSJQTY["."
SET PSJQTY=$PIECE(PSJQTY,".")_"."_$EXTRACT($PIECE(PSJQTY,".",2),1,2)
+59 SET $PIECE(PSLNDSTR,"^",5)=PSJQTY
+60 ;
+61 IF PSJTTYP="Count"
Begin DoDot:1
+62 NEW PSENDBAL,PSBEGBAL
SET PSENDBAL=$PIECE(PSLNDSTR,"^",6)
IF 'PSENDBAL
IF $GET(PSJQTY)
SET PSENDBAL=PSJQTY
SET $PIECE(PSLNDSTR,"^",6)=PSJQTY
+63 SET PSBEGBAL=$PIECE(PSLNDSTR,"^",4)
IF 'PSBEGBAL
IF $GET(PSJQTY)
SET PSBEGBAL=PSJQTY
SET $PIECE(PSLNDSTR,"^",4)=PSJQTY
End DoDot:1
+64 ; Right Justify Quantities if formatted output
+65 IF $GET(PSJINP("PSJDELM"))'="D"
FOR II=4:1:6
SET $PIECE(PSLNDSTR,"^",II)=$JUSTIFY($PIECE(PSLNDSTR,"^",II),5)
+66 SET $PIECE(PSLNDSTR,"^",2)=PSJTTYP
+67 ; If delimited output, make adjustments
+68 IF $GET(PSJINP("PSJDELM"))="D"
Begin DoDot:1
+69 ; If delimited output, add comment to end of string
+70 IF PSJCOMM'=""
SET PSLNDSTR=PSLNDSTR_"^"_PSJCOMM
+71 ; Break out Patient,User, and Witness ID's into separate delimited pieces if delimited output
+72 NEW PIECE
FOR PIECE=7,9,11
Begin DoDot:2
+73 NEW NAMID,NAM,ID
SET NAMID=$PIECE(PSLNDSTR,"^",PIECE)
+74 SET NAM=$PIECE(NAMID,"(")
SET ID=$PIECE(NAMID,"(",2)
SET ID=$TRANSLATE(ID,")")
+75 SET PSLNDSTR=$PIECE(PSLNDSTR,"^",1,PIECE-1)_"^"_NAM_"^"_ID_"^"_$PIECE(PSLNDSTR,"^",PIECE+1,99)
End DoDot:2
End DoDot:1
+76 QUIT PSLNDSTR
+77 ;
INSYSPAR(PSPARACT) ; Allow edit of PSJ PADE OE BALANCES parameter.
+1 ; Input = PSPARACT - Default parameter setting - only prompt if 0(NO).
+2 ; - If 1(YES), set without prompting - if vendor is activated, system must also be activated
+3 NEW DIR,X,Y,PSPARIEN,PSALLOFF,PSPARVAL,PSPARER
+4 SET PSPARIEN=$$FIND1^DIC(8989.51,,,"PSJ PADE OE BALANCES")
+5 SET PSALLOFF=0
+6 IF '$GET(PSPARACT)
Begin DoDot:1
+7 SET DIR(0)="YAO"
SET DIR("B")="Y"
+8 SET DIR("A")="Completely disable PADE IOE indicators (for ALL vendors)? "
+9 SET DIR("?",1)=" This sets the ""PSJ PADE OE BALANCES"" system parameter that"
+10 SET DIR("?",2)=" inactivates all PADE indicators in Inpatient Order Entry,"
+11 SET DIR("?",3)=" (IOE) for all vendors. To inactivate one specific vendor only,"
+12 SET DIR("?")=" use the ""DISPLAY PADE INDICATORS IN IOE?"" prompt."
+13 DO ^DIR
+14 SET PSALLOFF=$SELECT($GET(Y):1,1:0)
End DoDot:1
if 'PSALLOFF
QUIT
+15 SET PSPARVAL=$SELECT($GET(PSPARACT):1,1:0)
+16 DO EN^XPAR("SYS",PSPARIEN,,PSPARVAL,"PSPARER")
+17 IF $DATA(PSPARER)>1
WRITE !,"ERROR - Parameter not set"
+18 QUIT
+19 ;
DEVONOFF(PSJPSYS,OFFON) ; Set status of all dispensing devices (cabinet) to OFF or ON for system PSJPSYS
+1 ;
+2 NEW DIE,DA,DR,X,Y,PSVAL
+3 NEW FDA,PSERR
+4 ; Pointer to cabinet in PADE INVENTORY SYSTEM "DEVICE" subfile (not to cabinet ien in DEVICE file #58.63)
NEW PSICAB
+5 ; Pointer to cabinet in PADE DISPENSING DEVICE (#58.63) file
NEW PSDCAB
+6 if '$GET(PSJPSYS)
QUIT
+7 if '$DATA(^PS(58.601,+$GET(PSJPSYS),"DEVICE"))
QUIT
+8 ; must be 1(yes=ACTIVE) or 0(no=INACTIVE)
if ($GET(OFFON)'=1)&($GET(OFFON)'=0)
QUIT
+9 SET PSICAB=0
FOR
SET PSICAB=$ORDER(^PS(58.601,+$GET(PSJPSYS),"DEVICE",PSICAB))
if 'PSICAB
QUIT
Begin DoDot:1
+10 SET PSDCAB=+$GET(^PS(58.601,PSJPSYS,"DEVICE",PSICAB,0))
+11 ; Device not in device file #58.63
if '$GET(PSDCAB)
QUIT
if '$DATA(^PS(58.63,+PSDCAB,0))
QUIT
+12 SET PSVAL=$SELECT(OFFON=1:"A",1:"I")
+13 SET FDA(58.63,PSDCAB_",",4)=PSVAL
+14 DO FILE^DIE("","FDA","PSERR")
End DoDot:1
+15 QUIT
+16 ;
DEVSTCHK(PSJPSYS) ; Return status of all dispensing devices (cabinet) for system PSJPSYS
+1 ; If all devices have a status OFF, return 0; if ANY devices do NOT have a status of INACTIVE, return 1
+2 NEW DIE,DA,DR,X,Y,PSTATUS
+3 ; Pointer to cabinet in PADE INVENTORY SYSTEM "DEVICE" subfile (not to cabinet ien in DEVICE file #58.63)
NEW PSICAB
+4 ; Pointer to cabinet in PADE DISPENSING DEVICE (#58.63) file
NEW PSDCAB
+5 if '$GET(PSJPSYS)
QUIT 0
+6 if '$DATA(^PS(58.601,+$GET(PSJPSYS),"DEVICE"))
QUIT 0
+7 SET PSTATUS=0
+8 SET PSICAB=0
FOR
SET PSICAB=$ORDER(^PS(58.601,+$GET(PSJPSYS),"DEVICE",PSICAB))
if 'PSICAB!$GET(PSTATUS)
QUIT
Begin DoDot:1
+9 SET PSDCAB=+$GET(^PS(58.601,PSJPSYS,"DEVICE",PSICAB,0))
+10 ; Device not in device file #58.63
if '$GET(PSDCAB)
QUIT
if '$DATA(^PS(58.63,+PSDCAB,0))
QUIT
+11 SET PSTATUS=$PIECE($GET(^PS(58.63,+PSDCAB,0)),"^",4)
+12 SET PSTATUS=$SELECT(PSTATUS="I":0,1:1)
End DoDot:1
+13 QUIT PSTATUS
+14 ;
DELBADSY ; Check for and delete "?BAD" entries in PADE INVENTORY SYSTEM file (#58.601)
+1 ; "?BAD" entry may result when user enters "" new DISPENSING DEVICE (#58.63) file entry, and FileMan creates the "?BAD" KEY index
+2 NEW SYS,SYSNAM,BADSYS
+3 SET SYS=0
FOR
SET SYS=$ORDER(^PS(58.601,SYS))
if 'SYS
QUIT
Begin DoDot:1
+4 IF $GET(^PS(58.601,SYS,0))="?BAD"
IF '$DATA(^PS(58.601,SYS,4))
SET BADSYS(SYS)=$PIECE($GET(^PS(58.601,SYS,0)),"^")
End DoDot:1
+5 if '$DATA(BADSYS)
QUIT
+6 SET SYS=0
FOR
SET SYS=$ORDER(BADSYS(SYS))
if 'SYS
QUIT
Begin DoDot:1
+7 if $GET(BADSYS(SYS))'="?BAD"
QUIT
+8 NEW DIK,DA
+9 SET DIK="^PS(58.601,"
SET DA=+SYS
DO ^DIK
End DoDot:1
+10 QUIT
+11 ;
TSIGN(PADATA) ; Determine if the transaction amount needs to be added or subtracted, depending on the transaction type
+1 NEW TRNSIGN,II
+2 SET TRNSIGN=""
FOR II="V","B","U","E","D"
IF PADATA(5)=II
SET TRNSIGN="-"
+3 ; Discrepancies (type="A") may be either + or -
IF PADATA(5)="A"&($EXTRACT(PADATA(6))="-")
SET TRNSIGN="-"
+4 QUIT $SELECT(TRNSIGN="-":"-",1:"")
+5 ;
DEVBAL(PADESYS,PADEDEV,DRUGIEN) ; Calculate Device BALANCE for PADE device=PADEDEV drug=DRUGIEN
+1 ; Initialize returned balance
KILL DEVBAL
SET DEVBAL=""
+2 ; Pocket_subdrawer IEN
NEW DRAWER
+3 ; Return array from LIST^DIC
NEW DRWOUT,DEVOUT
+4 NEW DRWDRG
+5 NEW PSERR
+6 NEW DRWTOT
+7 ; We need system and device to find device balance
+8 IF '$GET(PADESYS)!'$GET(PADEDEV)
QUIT ""
+9 ;
+10 if 'DRUGIEN
QUIT ""
+11 SET DRAWER=0
FOR
SET DRAWER=$ORDER(^PS(58.601,PADESYS,"DEVICE",PADEDEV,"DRAWER",DRAWER))
if 'DRAWER
QUIT
Begin DoDot:1
+12 SET DRWDRG=0
FOR
SET DRWDRG=$ORDER(^PS(58.601,PADESYS,"DEVICE",PADEDEV,"DRAWER",DRAWER,"DRUG","B",DRWDRG))
if 'DRWDRG
QUIT
Begin DoDot:2
+13 ; Is this the drug we're looking for?
if DRWDRG'=DRUGIEN
QUIT
+14 ; The IEN of the drug's entry in the drawer
NEW DRWDRIEN
+15 SET DRWDRIEN=$ORDER(^PS(58.601,PADESYS,"DEVICE",PADEDEV,"DRAWER",DRAWER,"DRUG","B",DRWDRG,0))
+16 ; Bad index - this shouldn't happen
if 'DRWDRIEN
QUIT
+17 SET DRWTOT=$PIECE($GET(^PS(58.601,PADESYS,"DEVICE",PADEDEV,"DRAWER",DRAWER,"DRUG",DRWDRIEN,0)),"^",2)
+18 SET DEVBAL=$GET(DEVBAL)+DRWTOT
End DoDot:2
End DoDot:1
+19 QUIT DEVBAL
