PSJPAD50 ;BIR/JCH PADE DRUG LOOKUP ;8/25/15
;;5.0;INPATIENT MEDICATIONS;**317,392**;16 DEC 97;Build 2
;
; Reference to ^VADPT is supported by DBIA 10061.
; Reference to EN^DDIOL is supported by DBIA 10142.
; Reference to ^PSDRUG is supported by DBIA 2192.
; Reference to ^PS(55 is supported by DBIA 2191.
; Reference to ^SC( is supported by DBIA 10040.
;
Q
;
READDD(PSJDRG,PSJOI,PSJLOC,PSJORD,PSGORD) ; Get Dispense Drug
; Input : PSJDRG - (required) Pointer to DRUG file (#50)
; PSJOI - (optional) Pointer to PHARMACY ORDERABLE ITEM (#50.7) file
; PSJLOC - (required) Pointer to WARD (#42) file if input value is purely numeric
; Pointer to Hospital Location (#44) if last character of input value is "C"
; PSJORD - (optional) Inpatient Order number, pointer to NON-VERIFIED ORDERS (#53.1) file or PHARAMCY PATIENT (#55) file
; PSGORD - (optional) Inpatient Order number, pointer to NON-VERIFIED ORDERS (#53.1) file or PHARMACY PATIENT (#55) file
;
N DTOUT,DUOUT,PSII,PSJDONE
I '$G(PSJLOC)!(($E($G(PSJLOC),$L($G(PSJLOC)))'="W")&($E($G(PSJLOC),$L($G(PSJLOC)))'="C")) D
.N LOCTYP,CLFLAG
.S (LOCTYP,CLFLAG)=""
.I '$G(DFN),$G(PSGP) N DFN S DFN=PSGP
.I '$G(VAIN(4)),$G(DFN) N VAIN,VAINDT,VAROOT,VAHOW D INP^VADPT
.I $G(PSJORD) S CLFLAG=$S($E(PSJORD,$L(PSJORD))="U":$G(^PS(55,+$G(DFN),5,+PSJORD,8)),$E(PSJORD,$L(PSJORD))="P":$G(^PS(53.1,+PSJORD,"DSS")),1:"")
.S LOCTYP=$S($D(^SC(+CLFLAG,0))&$P(CLFLAG,"^",2)?7N1.E:"CL",1:"WD")
.S PSJLOC=$S((LOCTYP="CL")&CLFLAG:+CLFLAG_"CL",(LOCTYP="WD")&$G(VAIN(4)):+$G(VAIN(4))_"WD",1:"")
F PSII=1:1:2 Q:$G(DTOUT)!$G(DUOUT)!$G(PSJDONE) D READLOOP($G(PSJDRG),$G(PSJOI),$G(PSJLOC),$G(PSJORD),$G(PSGORD),PSII,.PSJDONE)
Q
;
READLOOP(PSJDRG,PSJOI,PSJLOC,PSJORD,PSGORD,PSII,PSJDONE) ; Prompt for dispense drug until intentionally exits
; PSJSRCH - (optional)Partial name search done, drug selected from list, present Drug .01 field for edit
N PSJDSRCH,NEWDRG,PSJSRCH,PSJDRG
K PSJDONE
;
S PSJSRCH=""
S PSJLOC=$S($G(PSJLOC)["C":$G(PSJLOC),1:+$G(PSJLOC))
F Q:$G(DTOUT)!$G(NEWDRG)!$G(DUOUT)!$G(PSJDONE) D
.S PSJSRCH=""
.S NEWDRG=$$PROMPT(.PSJDRG,.PSJDSRCH,PSJOI,PSJLOC,PSJORD,.PSJSRCH,PSII)
; If user quit, don't file anything into ^PS(53.4502
Q:$G(DUOUT)!$G(DTOUT)
; If something was changed, file the change into ^PS(53.4502
I $G(NEWDRG) D FILE(.NEWDRG,PSJSRCH)
Q
;
PROMPT(DRGIEN,DRGSRCH,PSJOI,PSJLOC,PSJORD,PSJSRCH,PSII) ; Prompt for Dispense Drug
; Input: DRGIEN = pointer to DRUG (#50)
; PSJOI = pointer to pharmacy orderable item (#50.7)
; PSJLOC = Patient ward location or order's clinic location
; PSJORD = Inpatient Order, pointer to file 55 or 53.1
; SELSRCH= Drug was selected from numbered list
N DRGNAME,DIR,DA,X,Y,NEWDRIEN,DI,DCT,TMPSRCH
K DRG
S DIR(0)="FAO^1:30"
S DRGNAME=""
S DRGIEN=$G(DRGIEN)
S DCT=0 F S DCT=$O(^PS(53.45,PSJSYSP,2,DCT)) Q:'DCT D
.N DRGNAME
.S DRGIEN=+$G(^PS(53.45,PSJSYSP,2,DCT,0))
.Q:'$G(DRGIEN)
.S DRGNAME=$P($G(^PSDRUG(+DRGIEN,0)),"^")
.S DRGIEN(DCT)=DRGIEN_"^^"_DRGNAME,DRGIEN("NAM",DRGNAME,DCT)="",DRGIEN("NUM",+DRGIEN(DCT),DCT)=""
I 'DRGIEN S DRGIEN=$O(DRGIEN("")),DRGIEN=+$G(DRGIEN(+DRGIEN))
;
I $G(PSII)>1 S DRGIEN=""
I $G(PSJORD) N PSJLOC S PSJLOC=$$ORDLOC($G(PSJORD),$G(PSGP))
;
S NEWDRIEN=""
K DRGSRCH
S DRGNAME=$S($G(DRGIEN):$P($G(^PSDRUG(+DRGIEN,0)),"^"),1:"")
S DIR("A")="Select DISPENSE DRUG: "_$S(DRGNAME]"":DRGNAME_"//",1:"")
S DIR("?")="^D SEARCH^PSJPAD50(.DRGIEN,"""",PSJLOC,.NEWDRG,PSJOI,1)"
; Quit if default accepted, or user wants out
D ^DIR I X=""!$G(DUOUT)!$G(DTOUT) D Q DRGIEN
.I '$G(DRGIEN) S PSJDONE=1
;
I X="@",$G(DRGIEN) D Q NEWDRIEN
.I $G(PSJORD)["U" K X S NEWDRIEN="" D
..D EN^DDIOL("Drugs for active orders cannot be deleted, but can be given an INACTIVE DATE")
.; If Pending renewal, set flag to prevent change to dispense drug, can only be inactivated.
.N PSJPNDRN I $G(PSGORD) I $E(PSGORD,$L(PSGORD))="P",$P($G(^PS(53.1,+PSGORD,0)),"^",24)="R" K X S NEWDRIEN="" D
..D EN^DDIOL("Dispense drugs for renewal orders cannot be deleted, but can be given an INACTIVE DATE.")
.I $G(X)="" D EN^DDIOL("<NOTHING DELETED>") Q
.N DIR S DIR(0)="Y",DIR("A")="SURE YOU WANT TO DELETE THE ENTIRE DISPENSE DRUG" D ^DIR
.S NEWDRIEN=DRGIEN_"^@"
; Default not accepted
S TMPSRCH=X,PSJSRCH=1
I X]"" D SELSRCH(.DRGIEN,.NEWDRIEN,PSJOI,PSJLOC,TMPSRCH)
;
S:NEWDRIEN<1 NEWDRIEN=""
I 'NEWDRIEN K DRGSRCH
Q NEWDRIEN
;
SEARCH(DRGIEN,DRGSRCH,PSJLOC,NEWDRG,PSJOI,PSJHELP) ; Search Drug (#50) file using user input
; Input: DRGIEN - Pointer to DRUG file (#50) passed in - default dispense drug
; DRGSRCH - Search value for DRUG file (user input)
; PSJLOC - Location of current order - Patient Ward (inpatient) or Clinic (clinic order)
; NEWDRG - Pointer to DRUG file (#50) selected by user
; PSJOI - Pointer to Pharmacy Orderable Item (#50.7), associated with order
; PSJHELP - Flag indicating search is for 1) display only: $G(PSJHELP)
; or 2) allows selection: '$G(PSJHELP)
;
N PSJSEL,PSJLIST,PSJDCNT,PSJDIEN,PSJCONT
S PSJCONT=1
;
D DDLIST(.DRGIEN)
;
S PSJLIST="",PSJOSCRN="",DRGSRCH="?"
S PSJSEL=$$PSDRUG(DRGIEN,DRGSRCH,.PSJLIST,PSJLOC,PSJOI,PSJOSCRN)
; If a drug was selected, return in NEWDRG parameter by reference
I PSJSEL S NEWDRG=PSJSEL
Q
;
SELECT(PSJLIST,PSJHELP) ; Select a drug from the list PSJLIST
N CNT,LAST,PSJSEL,PSJOUT,DIR
S PSJSEL=""
S LAST=$O(PSJLIST(1,999999),-1) S:'LAST LAST=1
S CNT=0 F S CNT=$O(PSJLIST(1,CNT)) Q:'CNT S PSJOUT(CNT)=" "_CNT_" "_PSJLIST(1,CNT)
I '$D(PSJOUT) W:'$G(PSJHELP) " ??" Q ""
D EN^DDIOL(" Choose from:")
D EN^DDIOL(.PSJOUT)
Q:$G(PSJHELP) ""
S DIR(0)="NOA^1:"_LAST,DIR("A")="CHOOSE 1-"_$G(LAST)_": " D ^DIR
S:$G(Y) PSJSEL=$G(PSJLIST(2,Y))
Q PSJSEL
;
SELSRCH(DRGIEN,NEWDRIEN,PSJOI,PSJLOC,TMPSRCH,PSJSCRN) ; Select drug
; OR, select drug from Orderable Item screened DRUG file (#50).
;
N PARTNAM,FOUND,PSJLIST,DCT,PSJQSRCH,PSJLOC
K DIR
;
S PSJLOC=$$ORDLOC($G(PSJORD),$G(PSGP))
I $L($G(TMPSRCH))>0,$D(DRGIEN)>1 D
.N I,DRGNAME,PSJLAST,PSJDIR,DIR,Y
.S DCT=0 F I=0:1 S DCT=$O(DRGIEN(DCT)) Q:'DCT
.S DCT=$O(DRGIEN(0))
.I I=1 S DRGNAME=$P($G(^PSDRUG(+DRGIEN(DCT),0)),"^") I $E(DRGNAME,1,$L(TMPSRCH))=TMPSRCH D Q
..S PARTNAM=$E(DRGNAME,$L(TMPSRCH)+1,$L(DRGNAME)) W PARTNAM
..S DIR(0)="Y",DIR("B")="Y",DIR("A")=" ...OK" D ^DIR
..I Y>0 S NEWDRIEN=+$G(DRGIEN(DCT))
.N PSJDIR S DCT=0 F I=1:1 S DCT=$O(DRGIEN(DCT)) Q:'DCT D
..N PSJQTY,PSJMSG
..S PSJLOC=$$ORDLOC($G(PSJORD),$G(PSGP))
..S DRGNAME=$P($G(^PSDRUG(+DRGIEN(DCT),0)),"^")
..S PSJDIR=$G(PSJDIR)_I_":"_DRGNAME_";"
..S PSJQTY=$$DRGQTY^PSJPADSI(+$G(DRGIEN(DCT)),$S($E(PSJLOC,$L(PSJLOC))="C":"CL",1:"WD"),+PSJLOC)
..D GETS^DIQ(50,+$G(DRGIEN(DCT))_",",101,,"PSJMSG")
..S DIR("A",I)=" "_I_" "_DRGNAME_" PADE:"_PSJQTY_" "_$G(PSJMSG(50,DRGIEN_",",101))
.Q:$L(PSJDIR)<4 S PSJLAST=+$O(DRGIEN(999),-1)
.Q:'PSJLAST
.S DIR(0)="SAO^"_PSJDIR,DIR("A")="CHOOSE 1-"_PSJLAST_": "
.D ^DIR Q:Y<1
.S:$G(DRGIEN(Y)) NEWDRIEN=+$G(DRGIEN(Y))
;
Q:$G(NEWDRIEN)
;
; User input not matched to any dispense drugs already filed to order - try to find an exact match; if found, quit and return IEN
S PSJQSRCH=0
I '$G(FOUND) D S:$G(FOUND) NEWDRIEN=DRGIEN(FOUND) I $G(FOUND)!$G(PSJQSRCH) Q
.N PSJSCR,PSJFIND
.S PSJSCRN="I $P($G(^(2)),U,3)[""U"",$S('$G(PSJOI):1,1:PSJOI=+$G(^(2))) I ($G(^PSDRUG(+$G(Y)))>($$NOW^XLFDT-1))!'$G(^PSDRUG(+$G(Y),""I""))"
.S PSJFIND=$$FIND1^DIC(50,,"M",TMPSRCH,,PSJSCRN)
.; If there's only one exact match, but it's aleady in the order, and user didn't select it, quit, there's nothing else to do
.I PSJFIND,(+PSJFIND=+$G(DRGIEN)) S PSJQSRCH=1 Q
.I $G(PSJFIND) D
..N DIR S DIR(0)="Y",DIR("B")="N",DIR("A")=" Are you adding '"_$P($G(^PSDRUG(+PSJFIND,0)),"^")_"' as a new DISPENSE DRUG? "
..D ^DIR Q:Y<1
..S FOUND=+$O(DRGIEN(999),-1)+1,DRGIEN(FOUND)=+PSJFIND_"^^"_$P($G(^PSDRUG(+PSJFIND,0)),"^")
; User selected a dispense drug that was already filed with the order - they must want to edit the Units per Dose
I $G(FOUND) D
.S PARTNAM=$S('TMPSRCH:$E($P(DRGIEN(FOUND),"^",3),$L(TMPSRCH)+1,99),1:" "_$P(DRGIEN(FOUND),"^",3)) W PARTNAM
.N DIR,Y S DIR(0)="Y",DIR("B")="Y",DIR("A")=" ...OK" D ^DIR
.I Y>0 S NEWDRIEN=+$G(DRGIEN(FOUND))
Q:$G(NEWDRIEN) ; User accepted default
;
S PSJLIST="",PSJOSCRN=""
S FOUND=$$PSDRUG(DRGIEN,TMPSRCH,.PSJLIST,PSJLOC,PSJOI,PSJOSCRN)
; If a drug was selected, return in NEWDRIEN parameter by reference
I FOUND S NEWDRIEN=FOUND
Q
;
FILE(DRGIEN,PSJSRCH) ; File drug into ^PS(53.45
;
N DA,DIC,DIE,DR,DIR,PSDD
;
; If an existing dispense drug was selected, allow the user to interactively edit the entry and quit
;I $D(^PS(53.45,PSJSYSP,2,"B",+$G(DRGIEN))) S PSDD=$O(^PS(53.45,PSJSYSP,2,"B",+DRGIEN,0)) D Q
S PSDD=$$CHK5345(+$G(PSJSYSP),+$G(DRGIEN)) I PSDD D Q
.; If Pending renewal, set flag to prevent change to dispense drug, can only be inactivated.
.N PSJPNDRN I $G(PSGORD) I $E(PSGORD,$L(PSGORD))="P",$P($G(^PS(53.1,+PSGORD,0)),"^",24)="R" S PSJPNDRN=1
.; User wants to delete the dispense drug - delete and quit
.I $P(DRGIEN,"^",2)="@" D Q
..N DIK,DA S DIK="^PS(53.45,"_+$G(PSJSYSP)_",2,",DA=PSDD,DA(1)=+$G(PSJSYSP)
..D ^DIK
.;
.; User wants to edit existing dispense drug
.S DIE="^PS(53.45,"_PSJSYSP_",2,",DA=PSDD,DA(1)=PSJSYSP
.S DR=$S($G(PSJSRCH):".01;",1:"")
.S DR=DR_".02"_$S($G(PSJPNDRN):";.03",$E($G(PSJORD),$L(PSJORD))["U":";.03",1:"") D ^DIE
;
; If a new entry is being added, find the next available node
I '$G(PSDD) S PSDD=$O(^PS(53.45,PSJSYSP,2,999),-1)+1
;
S DIE="^PS(53.45,"_PSJSYSP_",2,",DA=PSDD,DA(1)=PSJSYSP,DR=".01////"_+$G(DRGIEN) D ^DIE
;
; If adding a new entry, allow the user to interactively add the entry
S DIE="^PS(53.45,"_PSJSYSP_",2,",DA=PSDD,DA(1)=PSJSYSP
S DR=".01;.02"_$S($G(PSJPNDRN):";.03",$E($L($G(PSJORD)))["U":";.03",1:"") D ^DIE
Q
;
PSDRUG(DRGIEN,DRGSRCH,PSJLIST,PSJLOC,PSJOI,PSJOSCRN) ; Look for drug in file 50
;
N DIC,D,PSJTABLN,PSJLT
; If PSJLOC is appended with "C", flag it as clinic, otherwise, flag as ward
S PSJLT=$S(PSJLOC["C":"CL",1:"WD")
; If not a clinic, and we don't know the ward, try to find from DFN via call to INP^VADPT
I PSJLT="WD",'$G(PSJLOC) N VAIN,VAINDT,VAROOT,VAHOW D INP^VADPT S PSJLOC=+$G(VAIN(4))
S PSJLOC=$S(+$G(PSJLOC):PSJLOC,1:+$G(VAIN(4)))
S DIC="^PSDRUG(",D="B^C^VAPN^VAC^NDC^XATC^ASP"
S DIC("?")="Select the medication you wish the patient to receive." W:PSJSYSU<3 " You should consult",!,"with your pharmacy before ordering any non-formulary medication." W !
S DIC("S")="I $P($G(^(2)),U,3)[""U"",$S('$G(PSJOI):1,1:PSJOI=+$G(^(2))) I ($G(^PSDRUG(+$G(Y),""I""))>($G(PSGDT)))!'$G(^PSDRUG(+$G(Y),""I""))"
S DIC(0)="QMEZ",X=DRGSRCH
S $P(PSJTABLN," ",30)=" " S DIC("W")="W $E(PSJTABLN,1,(40-$L($P($G(^PSDRUG(+$G(Y),0)),""^""))))_"" PADE:""_$$DRGQTY^PSJPADSI(+Y,PSJLT,+$G(PSJLOC))_"" ""_$P($G(^PSDRUG(+Y,0)),""^"",10)"
D MIX^DIC1
Q Y
;
ORDLOC(PSJORD,PSGP) ; Get clinic location from PSJORD order, if it exists
N PSJLOC
Q:'$G(PSJORD) ""
Q:",U,P,"'[(","_$E(PSJORD,$L(PSJORD))_",") ""
I PSJORD["U" S PSJLOC=$G(^PS(55,+$G(PSGP),5,+$G(PSJORD),8)) D Q PSJLOC
.I PSJLOC,$P(PSJLOC,"^",2) S PSJLOC=+PSJLOC_"C"
.I '$G(PSJLOC) S PSJLOC=+$G(VAIN(4))
I PSJORD["P" S PSJLOC=$G(^PS(53.1,+$G(PSJORD),"DSS")) D Q PSJLOC
.I PSJLOC,$P(PSJLOC,"^",2) S PSJLOC=+PSJLOC_"C"
.I '$G(PSJLOC) S PSJLOC=+$G(VAIN(4))
Q ""
;
CHKWG(CAB,WARD) ; Return flag indicating WARD is linked to cabinet's WARD GROUPS
N WG,WD
S WG=0 F S WG=$O(^PS(58.63,CAB,3,"B",WG)) Q:'WG D
.S WD=0 F S WD=$O(^PS(57.5,WG,1,"B",WD)) Q:'WD S WG(WD)=""
Q $D(WG(+$G(WARD)))
;
CHKCG(CAB,CLINIC) ; Return flag indicating CLINIC is linked to cabinet's CLINIC GROUPS
N CG,CL,CLIEN
S CG=0 F S CG=$O(^PS(58.63,CAB,5,"B",CG)) Q:'CG D
.S CL=0 F S CL=$O(^PS(57.8,CG,1,CL)) Q:'CL D
..S CLIEN=$G(^PS(57.8,CG,1,CL,0)) Q:'CLIEN
..S CG(CLIEN)=""
Q $D(CG(+$G(CLINIC)))
;
PADEWD(WARD) ; Return flag indicating if WARD is linked to any active PADE ward groups
Q:'$G(WARD) ""
N PDWARDS,PWD,WG,PDLINK,PADE
S PDLINK=0
S WG=0 F S WG=$O(^PS(58.63,"WG",WG)) Q:'WG D
.S PADE=0 F S PADE=$O(^PS(58.63,"WG",WG,PADE)) Q:'PADE D
..Q:$P($G(^PS(58.63,PADE,0)),"^",4)="I"
..S PWD=0 F S PWD=$O(^PS(57.5,WG,1,"B",PWD)) Q:'PWD S PWD(PWD)=""
I $D(PWD(+WARD)) S PDLINK=1
I '$G(PDLINK) I $D(^PS(58.63,"WD",+WARD)) D
.S PADE=0 F S PADE=$O(^PS(58.63,"WD",+WARD,PADE)) Q:'PADE D
..Q:$P($G(^PS(58.63,PADE,0)),"^",4)="I"
..S PDLINK=1
Q PDLINK
;
PADECL(CLINIC) ; Return flag indicating if CLINIC is linked to any PADE devices
Q:'$G(CLINIC) ""
N PDCLINS,PCL,CG,PDLINK,PADE,CLINAM,PARTIAL
S PDLINK=0
S CG=0 F S CG=$O(^PS(58.63,"CG",CG)) Q:'CG D
.S PADE=0 F S PADE=$O(^PS(58.63,"CG",CG,PADE)) Q:'PADE D
..Q:$P($G(^PS(58.63,PADE,0)),"^",4)="I"
..S PCL=0 F S PCL=$O(^PS(57.8,"AD",CG,PCL)) Q:'PCL S PCL(PCL)=""
I $D(PCL(+CLINIC)) S PDLINK=1
I '$G(PDLINK) I $D(^PS(58.63,"CL",+CLINIC)) D
.S PADE=0 F S PADE=$O(^PS(58.63,"CL",+CLINIC,PADE)) Q:'PADE D
..Q:$P($G(^PS(58.63,PADE,0)),"^",4)="I"
..S PDLINK=1
; If no match, check PADEs associated with clinic wildcards
I '$G(PDLINK) D GETS^DIQ(44,+CLINIC,".01",,"CLINAM") D
.S CLINAM=$G(CLINAM(44,+CLINIC_",",".01")),PARTIAL=$E(CLINAM,1,2)
.F S PARTIAL=$O(^PS(58.63,"WC",PARTIAL)) Q:PARTIAL=""!$G(PDLINK) D
..Q:$E(PARTIAL,1,3)'=$E(CLINAM,1,3)
..N PADE,STATUS S STATUS=""
..S PADE="" F S PADE=$O(^PS(58.63,"WC",PARTIAL,PADE)) Q:'PADE!$G(PDLINK) D
...S STATUS=$P($G(^PS(58.63,PADE,0)),"^",4)
...Q:(STATUS="I")
...I $E(CLINAM,1,$L(PARTIAL))=PARTIAL S PDLINK=1
Q PDLINK
;
DDLIST(DRGARRAY) ; List Drug Array when "?" entered at Dispense Drug prompt
;
;Select DISPENSE DRUG: ?
N PSJDDAR,NXTDRG,LNCOUNT
S LNCOUNT=1
S PSJDDAR(LNCOUNT)=" Answer with DISPENSE DRUG",LNCOUNT=LNCOUNT+1
S PSJDDAR(LNCOUNT)=" Choose from:",LNCOUNT=LNCOUNT+1
S NXTDRG=0 F S NXTDRG=$O(DRGARRAY(NXTDRG)) Q:'NXTDRG D
.N DRGIEN,DRGNAME
.S DRGIEN=+$G(DRGARRAY(NXTDRG))
.S DRGNAME=$P($G(^PSDRUG(+DRGIEN,0)),"^")
.Q:DRGIEN="" S PSJDDAR(LNCOUNT)=" "_DRGNAME,LNCOUNT=LNCOUNT+1
S PSJDDAR(LNCOUNT)="",LNCOUNT=LNCOUNT+1
S PSJDDAR(LNCOUNT)=" You may enter a new DISPENSE DRUG, if you wish",LNCOUNT=LNCOUNT+1
S PSJDDAR(LNCOUNT)=" Only dispense drugs marked for Unit Dose use.",LNCOUNT=LNCOUNT+1
S PSJDDR(LNCOUNT)="",LNCOUNT=LNCOUNT+1
S PSJDDAR(LNCOUNT)="",LNCOUNT=LNCOUNT+1
D EN^DDIOL(.PSJDDAR)
Q
;
CHK5345(PSJSYSP,DRGIEN) ; Check if file 50 pointer DRGIEN exists in Dispense Drug temp global ^PS(53.45,PSJSYSP,2,n
; PSJSYSP=User DUZ
; DRGIEN=pointer to drug IEN in file 50
N DDCOUNT,FOUND
Q:'$G(DRGIEN) 0
S FOUND=0
S DDCOUNT=0 F S DDCOUNT=$O(^PS(53.45,PSJSYSP,2,DDCOUNT)) Q:'DDCOUNT I $P($G(^PS(53.45,PSJSYSP,2,DDCOUNT,0)),"^")=+$G(DRGIEN) S FOUND=DDCOUNT
Q FOUND
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSJPAD50 15227 printed Dec 13, 2024@02:08:31 Page 2
PSJPAD50 ;BIR/JCH PADE DRUG LOOKUP ;8/25/15
+1 ;;5.0;INPATIENT MEDICATIONS;**317,392**;16 DEC 97;Build 2
+2 ;
+3 ; Reference to ^VADPT is supported by DBIA 10061.
+4 ; Reference to EN^DDIOL is supported by DBIA 10142.
+5 ; Reference to ^PSDRUG is supported by DBIA 2192.
+6 ; Reference to ^PS(55 is supported by DBIA 2191.
+7 ; Reference to ^SC( is supported by DBIA 10040.
+8 ;
+9 QUIT
+10 ;
READDD(PSJDRG,PSJOI,PSJLOC,PSJORD,PSGORD) ; Get Dispense Drug
+1 ; Input : PSJDRG - (required) Pointer to DRUG file (#50)
+2 ; PSJOI - (optional) Pointer to PHARMACY ORDERABLE ITEM (#50.7) file
+3 ; PSJLOC - (required) Pointer to WARD (#42) file if input value is purely numeric
+4 ; Pointer to Hospital Location (#44) if last character of input value is "C"
+5 ; PSJORD - (optional) Inpatient Order number, pointer to NON-VERIFIED ORDERS (#53.1) file or PHARAMCY PATIENT (#55) file
+6 ; PSGORD - (optional) Inpatient Order number, pointer to NON-VERIFIED ORDERS (#53.1) file or PHARMACY PATIENT (#55) file
+7 ;
+8 NEW DTOUT,DUOUT,PSII,PSJDONE
+9 IF '$GET(PSJLOC)!(($EXTRACT($GET(PSJLOC),$LENGTH($GET(PSJLOC)))'="W")&($EXTRACT($GET(PSJLOC),$LENGTH($GET(PSJLOC)))'="C"))
Begin DoDot:1
+10 NEW LOCTYP,CLFLAG
+11 SET (LOCTYP,CLFLAG)=""
+12 IF '$GET(DFN)
IF $GET(PSGP)
NEW DFN
SET DFN=PSGP
+13 IF '$GET(VAIN(4))
IF $GET(DFN)
NEW VAIN,VAINDT,VAROOT,VAHOW
DO INP^VADPT
+14 IF $GET(PSJORD)
SET CLFLAG=$SELECT($EXTRACT(PSJORD,$LENGTH(PSJORD))="U":$GET(^PS(55,+$GET(DFN),5,+PSJORD,8)),$EXTRACT(PSJORD,$LENGTH(PSJORD))="P":$GET(^PS(53.1,+PSJORD,"DSS")),1:"")
+15 SET LOCTYP=$SELECT($DATA(^SC(+CLFLAG,0))&$PIECE(CLFLAG,"^",2)?7N1.E:"CL",1:"WD")
+16 SET PSJLOC=$SELECT((LOCTYP="CL")&CLFLAG:+CLFLAG_"CL",(LOCTYP="WD")&$GET(VAIN(4)):+$GET(VAIN(4))_"WD",1:"")
End DoDot:1
+17 FOR PSII=1:1:2
if $GET(DTOUT)!$GET(DUOUT)!$GET(PSJDONE)
QUIT
DO READLOOP($GET(PSJDRG),$GET(PSJOI),$GET(PSJLOC),$GET(PSJORD),$GET(PSGORD),PSII,.PSJDONE)
+18 QUIT
+19 ;
READLOOP(PSJDRG,PSJOI,PSJLOC,PSJORD,PSGORD,PSII,PSJDONE) ; Prompt for dispense drug until intentionally exits
+1 ; PSJSRCH - (optional)Partial name search done, drug selected from list, present Drug .01 field for edit
+2 NEW PSJDSRCH,NEWDRG,PSJSRCH,PSJDRG
+3 KILL PSJDONE
+4 ;
+5 SET PSJSRCH=""
+6 SET PSJLOC=$SELECT($GET(PSJLOC)["C":$GET(PSJLOC),1:+$GET(PSJLOC))
+7 FOR
if $GET(DTOUT)!$GET(NEWDRG)!$GET(DUOUT)!$GET(PSJDONE)
QUIT
Begin DoDot:1
+8 SET PSJSRCH=""
+9 SET NEWDRG=$$PROMPT(.PSJDRG,.PSJDSRCH,PSJOI,PSJLOC,PSJORD,.PSJSRCH,PSII)
End DoDot:1
+10 ; If user quit, don't file anything into ^PS(53.4502
+11 if $GET(DUOUT)!$GET(DTOUT)
QUIT
+12 ; If something was changed, file the change into ^PS(53.4502
+13 IF $GET(NEWDRG)
DO FILE(.NEWDRG,PSJSRCH)
+14 QUIT
+15 ;
PROMPT(DRGIEN,DRGSRCH,PSJOI,PSJLOC,PSJORD,PSJSRCH,PSII) ; Prompt for Dispense Drug
+1 ; Input: DRGIEN = pointer to DRUG (#50)
+2 ; PSJOI = pointer to pharmacy orderable item (#50.7)
+3 ; PSJLOC = Patient ward location or order's clinic location
+4 ; PSJORD = Inpatient Order, pointer to file 55 or 53.1
+5 ; SELSRCH= Drug was selected from numbered list
+6 NEW DRGNAME,DIR,DA,X,Y,NEWDRIEN,DI,DCT,TMPSRCH
+7 KILL DRG
+8 SET DIR(0)="FAO^1:30"
+9 SET DRGNAME=""
+10 SET DRGIEN=$GET(DRGIEN)
+11 SET DCT=0
FOR
SET DCT=$ORDER(^PS(53.45,PSJSYSP,2,DCT))
if 'DCT
QUIT
Begin DoDot:1
+12 NEW DRGNAME
+13 SET DRGIEN=+$GET(^PS(53.45,PSJSYSP,2,DCT,0))
+14 if '$GET(DRGIEN)
QUIT
+15 SET DRGNAME=$PIECE($GET(^PSDRUG(+DRGIEN,0)),"^")
+16 SET DRGIEN(DCT)=DRGIEN_"^^"_DRGNAME
SET DRGIEN("NAM",DRGNAME,DCT)=""
SET DRGIEN("NUM",+DRGIEN(DCT),DCT)=""
End DoDot:1
+17 IF 'DRGIEN
SET DRGIEN=$ORDER(DRGIEN(""))
SET DRGIEN=+$GET(DRGIEN(+DRGIEN))
+18 ;
+19 IF $GET(PSII)>1
SET DRGIEN=""
+20 IF $GET(PSJORD)
NEW PSJLOC
SET PSJLOC=$$ORDLOC($GET(PSJORD),$GET(PSGP))
+21 ;
+22 SET NEWDRIEN=""
+23 KILL DRGSRCH
+24 SET DRGNAME=$SELECT($GET(DRGIEN):$PIECE($GET(^PSDRUG(+DRGIEN,0)),"^"),1:"")
+25 SET DIR("A")="Select DISPENSE DRUG: "_$SELECT(DRGNAME]"":DRGNAME_"//",1:"")
+26 SET DIR("?")="^D SEARCH^PSJPAD50(.DRGIEN,"""",PSJLOC,.NEWDRG,PSJOI,1)"
+27 ; Quit if default accepted, or user wants out
+28 DO ^DIR
IF X=""!$GET(DUOUT)!$GET(DTOUT)
Begin DoDot:1
+29 IF '$GET(DRGIEN)
SET PSJDONE=1
End DoDot:1
QUIT DRGIEN
+30 ;
+31 IF X="@"
IF $GET(DRGIEN)
Begin DoDot:1
+32 IF $GET(PSJORD)["U"
KILL X
SET NEWDRIEN=""
Begin DoDot:2
+33 DO EN^DDIOL("Drugs for active orders cannot be deleted, but can be given an INACTIVE DATE")
End DoDot:2
+34 ; If Pending renewal, set flag to prevent change to dispense drug, can only be inactivated.
+35 NEW PSJPNDRN
IF $GET(PSGORD)
IF $EXTRACT(PSGORD,$LENGTH(PSGORD))="P"
IF $PIECE($GET(^PS(53.1,+PSGORD,0)),"^",24)="R"
KILL X
SET NEWDRIEN=""
Begin DoDot:2
+36 DO EN^DDIOL("Dispense drugs for renewal orders cannot be deleted, but can be given an INACTIVE DATE.")
End DoDot:2
+37 IF $GET(X)=""
DO EN^DDIOL("<NOTHING DELETED>")
QUIT
+38 NEW DIR
SET DIR(0)="Y"
SET DIR("A")="SURE YOU WANT TO DELETE THE ENTIRE DISPENSE DRUG"
DO ^DIR
+39 SET NEWDRIEN=DRGIEN_"^@"
End DoDot:1
QUIT NEWDRIEN
+40 ; Default not accepted
+41 SET TMPSRCH=X
SET PSJSRCH=1
+42 IF X]""
DO SELSRCH(.DRGIEN,.NEWDRIEN,PSJOI,PSJLOC,TMPSRCH)
+43 ;
+44 if NEWDRIEN<1
SET NEWDRIEN=""
+45 IF 'NEWDRIEN
KILL DRGSRCH
+46 QUIT NEWDRIEN
+47 ;
SEARCH(DRGIEN,DRGSRCH,PSJLOC,NEWDRG,PSJOI,PSJHELP) ; Search Drug (#50) file using user input
+1 ; Input: DRGIEN - Pointer to DRUG file (#50) passed in - default dispense drug
+2 ; DRGSRCH - Search value for DRUG file (user input)
+3 ; PSJLOC - Location of current order - Patient Ward (inpatient) or Clinic (clinic order)
+4 ; NEWDRG - Pointer to DRUG file (#50) selected by user
+5 ; PSJOI - Pointer to Pharmacy Orderable Item (#50.7), associated with order
+6 ; PSJHELP - Flag indicating search is for 1) display only: $G(PSJHELP)
+7 ; or 2) allows selection: '$G(PSJHELP)
+8 ;
+9 NEW PSJSEL,PSJLIST,PSJDCNT,PSJDIEN,PSJCONT
+10 SET PSJCONT=1
+11 ;
+12 DO DDLIST(.DRGIEN)
+13 ;
+14 SET PSJLIST=""
SET PSJOSCRN=""
SET DRGSRCH="?"
+15 SET PSJSEL=$$PSDRUG(DRGIEN,DRGSRCH,.PSJLIST,PSJLOC,PSJOI,PSJOSCRN)
+16 ; If a drug was selected, return in NEWDRG parameter by reference
+17 IF PSJSEL
SET NEWDRG=PSJSEL
+18 QUIT
+19 ;
SELECT(PSJLIST,PSJHELP) ; Select a drug from the list PSJLIST
+1 NEW CNT,LAST,PSJSEL,PSJOUT,DIR
+2 SET PSJSEL=""
+3 SET LAST=$ORDER(PSJLIST(1,999999),-1)
if 'LAST
SET LAST=1
+4 SET CNT=0
FOR
SET CNT=$ORDER(PSJLIST(1,CNT))
if 'CNT
QUIT
SET PSJOUT(CNT)=" "_CNT_" "_PSJLIST(1,CNT)
+5 IF '$DATA(PSJOUT)
if '$GET(PSJHELP)
WRITE " ??"
QUIT ""
+6 DO EN^DDIOL(" Choose from:")
+7 DO EN^DDIOL(.PSJOUT)
+8 if $GET(PSJHELP)
QUIT ""
+9 SET DIR(0)="NOA^1:"_LAST
SET DIR("A")="CHOOSE 1-"_$GET(LAST)_": "
DO ^DIR
+10 if $GET(Y)
SET PSJSEL=$GET(PSJLIST(2,Y))
+11 QUIT PSJSEL
+12 ;
SELSRCH(DRGIEN,NEWDRIEN,PSJOI,PSJLOC,TMPSRCH,PSJSCRN) ; Select drug
+1 ; OR, select drug from Orderable Item screened DRUG file (#50).
+2 ;
+3 NEW PARTNAM,FOUND,PSJLIST,DCT,PSJQSRCH,PSJLOC
+4 KILL DIR
+5 ;
+6 SET PSJLOC=$$ORDLOC($GET(PSJORD),$GET(PSGP))
+7 IF $LENGTH($GET(TMPSRCH))>0
IF $DATA(DRGIEN)>1
Begin DoDot:1
+8 NEW I,DRGNAME,PSJLAST,PSJDIR,DIR,Y
+9 SET DCT=0
FOR I=0:1
SET DCT=$ORDER(DRGIEN(DCT))
if 'DCT
QUIT
+10 SET DCT=$ORDER(DRGIEN(0))
+11 IF I=1
SET DRGNAME=$PIECE($GET(^PSDRUG(+DRGIEN(DCT),0)),"^")
IF $EXTRACT(DRGNAME,1,$LENGTH(TMPSRCH))=TMPSRCH
Begin DoDot:2
+12 SET PARTNAM=$EXTRACT(DRGNAME,$LENGTH(TMPSRCH)+1,$LENGTH(DRGNAME))
WRITE PARTNAM
+13 SET DIR(0)="Y"
SET DIR("B")="Y"
SET DIR("A")=" ...OK"
DO ^DIR
+14 IF Y>0
SET NEWDRIEN=+$GET(DRGIEN(DCT))
End DoDot:2
QUIT
+15 NEW PSJDIR
SET DCT=0
FOR I=1:1
SET DCT=$ORDER(DRGIEN(DCT))
if 'DCT
QUIT
Begin DoDot:2
+16 NEW PSJQTY,PSJMSG
+17 SET PSJLOC=$$ORDLOC($GET(PSJORD),$GET(PSGP))
+18 SET DRGNAME=$PIECE($GET(^PSDRUG(+DRGIEN(DCT),0)),"^")
+19 SET PSJDIR=$GET(PSJDIR)_I_":"_DRGNAME_";"
+20 SET PSJQTY=$$DRGQTY^PSJPADSI(+$GET(DRGIEN(DCT)),$SELECT($EXTRACT(PSJLOC,$LENGTH(PSJLOC))="C":"CL",1:"WD"),+PSJLOC)
+21 DO GETS^DIQ(50,+$GET(DRGIEN(DCT))_",",101,,"PSJMSG")
+22 SET DIR("A",I)=" "_I_" "_DRGNAME_" PADE:"_PSJQTY_" "_$GET(PSJMSG(50,DRGIEN_",",101))
End DoDot:2
+23 if $LENGTH(PSJDIR)<4
QUIT
SET PSJLAST=+$ORDER(DRGIEN(999),-1)
+24 if 'PSJLAST
QUIT
+25 SET DIR(0)="SAO^"_PSJDIR
SET DIR("A")="CHOOSE 1-"_PSJLAST_": "
+26 DO ^DIR
if Y<1
QUIT
+27 if $GET(DRGIEN(Y))
SET NEWDRIEN=+$GET(DRGIEN(Y))
End DoDot:1
+28 ;
+29 if $GET(NEWDRIEN)
QUIT
+30 ;
+31 ; User input not matched to any dispense drugs already filed to order - try to find an exact match; if found, quit and return IEN
+32 SET PSJQSRCH=0
+33 IF '$GET(FOUND)
Begin DoDot:1
+34 NEW PSJSCR,PSJFIND
+35 SET PSJSCRN="I $P($G(^(2)),U,3)[""U"",$S('$G(PSJOI):1,1:PSJOI=+$G(^(2))) I ($G(^PSDRUG(+$G(Y)))>($$NOW^XLFDT-1))!'$G(^PSDRUG(+$G(Y),""I""))"
+36 SET PSJFIND=$$FIND1^DIC(50,,"M",TMPSRCH,,PSJSCRN)
+37 ; If there's only one exact match, but it's aleady in the order, and user didn't select it, quit, there's nothing else to do
+38 IF PSJFIND
IF (+PSJFIND=+$GET(DRGIEN))
SET PSJQSRCH=1
QUIT
+39 IF $GET(PSJFIND)
Begin DoDot:2
+40 NEW DIR
SET DIR(0)="Y"
SET DIR("B")="N"
SET DIR("A")=" Are you adding '"_$PIECE($GET(^PSDRUG(+PSJFIND,0)),"^")_"' as a new DISPENSE DRUG? "
+41 DO ^DIR
if Y<1
QUIT
+42 SET FOUND=+$ORDER(DRGIEN(999),-1)+1
SET DRGIEN(FOUND)=+PSJFIND_"^^"_$PIECE($GET(^PSDRUG(+PSJFIND,0)),"^")
End DoDot:2
End DoDot:1
if $GET(FOUND)
SET NEWDRIEN=DRGIEN(FOUND)
IF $GET(FOUND)!$GET(PSJQSRCH)
QUIT
+43 ; User selected a dispense drug that was already filed with the order - they must want to edit the Units per Dose
+44 IF $GET(FOUND)
Begin DoDot:1
+45 SET PARTNAM=$SELECT('TMPSRCH:$EXTRACT($PIECE(DRGIEN(FOUND),"^",3),$LENGTH(TMPSRCH)+1,99),1:" "_$PIECE(DRGIEN(FOUND),"^",3))
WRITE PARTNAM
+46 NEW DIR,Y
SET DIR(0)="Y"
SET DIR("B")="Y"
SET DIR("A")=" ...OK"
DO ^DIR
+47 IF Y>0
SET NEWDRIEN=+$GET(DRGIEN(FOUND))
End DoDot:1
+48 ; User accepted default
if $GET(NEWDRIEN)
QUIT
+49 ;
+50 SET PSJLIST=""
SET PSJOSCRN=""
+51 SET FOUND=$$PSDRUG(DRGIEN,TMPSRCH,.PSJLIST,PSJLOC,PSJOI,PSJOSCRN)
+52 ; If a drug was selected, return in NEWDRIEN parameter by reference
+53 IF FOUND
SET NEWDRIEN=FOUND
+54 QUIT
+55 ;
FILE(DRGIEN,PSJSRCH) ; File drug into ^PS(53.45
+1 ;
+2 NEW DA,DIC,DIE,DR,DIR,PSDD
+3 ;
+4 ; If an existing dispense drug was selected, allow the user to interactively edit the entry and quit
+5 ;I $D(^PS(53.45,PSJSYSP,2,"B",+$G(DRGIEN))) S PSDD=$O(^PS(53.45,PSJSYSP,2,"B",+DRGIEN,0)) D Q
+6 SET PSDD=$$CHK5345(+$GET(PSJSYSP),+$GET(DRGIEN))
IF PSDD
Begin DoDot:1
+7 ; If Pending renewal, set flag to prevent change to dispense drug, can only be inactivated.
+8 NEW PSJPNDRN
IF $GET(PSGORD)
IF $EXTRACT(PSGORD,$LENGTH(PSGORD))="P"
IF $PIECE($GET(^PS(53.1,+PSGORD,0)),"^",24)="R"
SET PSJPNDRN=1
+9 ; User wants to delete the dispense drug - delete and quit
+10 IF $PIECE(DRGIEN,"^",2)="@"
Begin DoDot:2
+11 NEW DIK,DA
SET DIK="^PS(53.45,"_+$GET(PSJSYSP)_",2,"
SET DA=PSDD
SET DA(1)=+$GET(PSJSYSP)
+12 DO ^DIK
End DoDot:2
QUIT
+13 ;
+14 ; User wants to edit existing dispense drug
+15 SET DIE="^PS(53.45,"_PSJSYSP_",2,"
SET DA=PSDD
SET DA(1)=PSJSYSP
+16 SET DR=$SELECT($GET(PSJSRCH):".01;",1:"")
+17 SET DR=DR_".02"_$SELECT($GET(PSJPNDRN):";.03",$EXTRACT($GET(PSJORD),$LENGTH(PSJORD))["U":";.03",1:"")
DO ^DIE
End DoDot:1
QUIT
+18 ;
+19 ; If a new entry is being added, find the next available node
+20 IF '$GET(PSDD)
SET PSDD=$ORDER(^PS(53.45,PSJSYSP,2,999),-1)+1
+21 ;
+22 SET DIE="^PS(53.45,"_PSJSYSP_",2,"
SET DA=PSDD
SET DA(1)=PSJSYSP
SET DR=".01////"_+$GET(DRGIEN)
DO ^DIE
+23 ;
+24 ; If adding a new entry, allow the user to interactively add the entry
+25 SET DIE="^PS(53.45,"_PSJSYSP_",2,"
SET DA=PSDD
SET DA(1)=PSJSYSP
+26 SET DR=".01;.02"_$SELECT($GET(PSJPNDRN):";.03",$EXTRACT($LENGTH($GET(PSJORD)))["U":";.03",1:"")
DO ^DIE
+27 QUIT
+28 ;
PSDRUG(DRGIEN,DRGSRCH,PSJLIST,PSJLOC,PSJOI,PSJOSCRN) ; Look for drug in file 50
+1 ;
+2 NEW DIC,D,PSJTABLN,PSJLT
+3 ; If PSJLOC is appended with "C", flag it as clinic, otherwise, flag as ward
+4 SET PSJLT=$SELECT(PSJLOC["C":"CL",1:"WD")
+5 ; If not a clinic, and we don't know the ward, try to find from DFN via call to INP^VADPT
+6 IF PSJLT="WD"
IF '$GET(PSJLOC)
NEW VAIN,VAINDT,VAROOT,VAHOW
DO INP^VADPT
SET PSJLOC=+$GET(VAIN(4))
+7 SET PSJLOC=$SELECT(+$GET(PSJLOC):PSJLOC,1:+$GET(VAIN(4)))
+8 SET DIC="^PSDRUG("
SET D="B^C^VAPN^VAC^NDC^XATC^ASP"
+9 SET DIC("?")="Select the medication you wish the patient to receive."
if PSJSYSU<3
WRITE " You should consult",!,"with your pharmacy before ordering any non-formulary medication."
WRITE !
+10 SET DIC("S")="I $P($G(^(2)),U,3)[""U"",$S('$G(PSJOI):1,1:PSJOI=+$G(^(2))) I ($G(^PSDRUG(+$G(Y),""I""))>($G(PSGDT)))!'$G(^PSDRUG(+$G(Y),""I""))"
+11 SET DIC(0)="QMEZ"
SET X=DRGSRCH
+12 SET $PIECE(PSJTABLN," ",30)=" "
SET DIC("W")="W $E(PSJTABLN,1,(40-$L($P($G(^PSDRUG(+$G(Y),0)),""^""))))_"" PADE:""_$$DRGQTY^PSJPADSI(+Y,PSJLT,+$G(PSJLOC))_"" ""_$P($G(^PSDRUG(+Y,0)),""^"",10)"
+13 DO MIX^DIC1
+14 QUIT Y
+15 ;
ORDLOC(PSJORD,PSGP) ; Get clinic location from PSJORD order, if it exists
+1 NEW PSJLOC
+2 if '$GET(PSJORD)
QUIT ""
+3 if ",U,P,"'[(","_$EXTRACT(PSJORD,$LENGTH(PSJORD))_",")
QUIT ""
+4 IF PSJORD["U"
SET PSJLOC=$GET(^PS(55,+$GET(PSGP),5,+$GET(PSJORD),8))
Begin DoDot:1
+5 IF PSJLOC
IF $PIECE(PSJLOC,"^",2)
SET PSJLOC=+PSJLOC_"C"
+6 IF '$GET(PSJLOC)
SET PSJLOC=+$GET(VAIN(4))
End DoDot:1
QUIT PSJLOC
+7 IF PSJORD["P"
SET PSJLOC=$GET(^PS(53.1,+$GET(PSJORD),"DSS"))
Begin DoDot:1
+8 IF PSJLOC
IF $PIECE(PSJLOC,"^",2)
SET PSJLOC=+PSJLOC_"C"
+9 IF '$GET(PSJLOC)
SET PSJLOC=+$GET(VAIN(4))
End DoDot:1
QUIT PSJLOC
+10 QUIT ""
+11 ;
CHKWG(CAB,WARD) ; Return flag indicating WARD is linked to cabinet's WARD GROUPS
+1 NEW WG,WD
+2 SET WG=0
FOR
SET WG=$ORDER(^PS(58.63,CAB,3,"B",WG))
if 'WG
QUIT
Begin DoDot:1
+3 SET WD=0
FOR
SET WD=$ORDER(^PS(57.5,WG,1,"B",WD))
if 'WD
QUIT
SET WG(WD)=""
End DoDot:1
+4 QUIT $DATA(WG(+$GET(WARD)))
+5 ;
CHKCG(CAB,CLINIC) ; Return flag indicating CLINIC is linked to cabinet's CLINIC GROUPS
+1 NEW CG,CL,CLIEN
+2 SET CG=0
FOR
SET CG=$ORDER(^PS(58.63,CAB,5,"B",CG))
if 'CG
QUIT
Begin DoDot:1
+3 SET CL=0
FOR
SET CL=$ORDER(^PS(57.8,CG,1,CL))
if 'CL
QUIT
Begin DoDot:2
+4 SET CLIEN=$GET(^PS(57.8,CG,1,CL,0))
if 'CLIEN
QUIT
+5 SET CG(CLIEN)=""
End DoDot:2
End DoDot:1
+6 QUIT $DATA(CG(+$GET(CLINIC)))
+7 ;
PADEWD(WARD) ; Return flag indicating if WARD is linked to any active PADE ward groups
+1 if '$GET(WARD)
QUIT ""
+2 NEW PDWARDS,PWD,WG,PDLINK,PADE
+3 SET PDLINK=0
+4 SET WG=0
FOR
SET WG=$ORDER(^PS(58.63,"WG",WG))
if 'WG
QUIT
Begin DoDot:1
+5 SET PADE=0
FOR
SET PADE=$ORDER(^PS(58.63,"WG",WG,PADE))
if 'PADE
QUIT
Begin DoDot:2
+6 if $PIECE($GET(^PS(58.63,PADE,0)),"^",4)="I"
QUIT
+7 SET PWD=0
FOR
SET PWD=$ORDER(^PS(57.5,WG,1,"B",PWD))
if 'PWD
QUIT
SET PWD(PWD)=""
End DoDot:2
End DoDot:1
+8 IF $DATA(PWD(+WARD))
SET PDLINK=1
+9 IF '$GET(PDLINK)
IF $DATA(^PS(58.63,"WD",+WARD))
Begin DoDot:1
+10 SET PADE=0
FOR
SET PADE=$ORDER(^PS(58.63,"WD",+WARD,PADE))
if 'PADE
QUIT
Begin DoDot:2
+11 if $PIECE($GET(^PS(58.63,PADE,0)),"^",4)="I"
QUIT
+12 SET PDLINK=1
End DoDot:2
End DoDot:1
+13 QUIT PDLINK
+14 ;
PADECL(CLINIC) ; Return flag indicating if CLINIC is linked to any PADE devices
+1 if '$GET(CLINIC)
QUIT ""
+2 NEW PDCLINS,PCL,CG,PDLINK,PADE,CLINAM,PARTIAL
+3 SET PDLINK=0
+4 SET CG=0
FOR
SET CG=$ORDER(^PS(58.63,"CG",CG))
if 'CG
QUIT
Begin DoDot:1
+5 SET PADE=0
FOR
SET PADE=$ORDER(^PS(58.63,"CG",CG,PADE))
if 'PADE
QUIT
Begin DoDot:2
+6 if $PIECE($GET(^PS(58.63,PADE,0)),"^",4)="I"
QUIT
+7 SET PCL=0
FOR
SET PCL=$ORDER(^PS(57.8,"AD",CG,PCL))
if 'PCL
QUIT
SET PCL(PCL)=""
End DoDot:2
End DoDot:1
+8 IF $DATA(PCL(+CLINIC))
SET PDLINK=1
+9 IF '$GET(PDLINK)
IF $DATA(^PS(58.63,"CL",+CLINIC))
Begin DoDot:1
+10 SET PADE=0
FOR
SET PADE=$ORDER(^PS(58.63,"CL",+CLINIC,PADE))
if 'PADE
QUIT
Begin DoDot:2
+11 if $PIECE($GET(^PS(58.63,PADE,0)),"^",4)="I"
QUIT
+12 SET PDLINK=1
End DoDot:2
End DoDot:1
+13 ; If no match, check PADEs associated with clinic wildcards
+14 IF '$GET(PDLINK)
DO GETS^DIQ(44,+CLINIC,".01",,"CLINAM")
Begin DoDot:1
+15 SET CLINAM=$GET(CLINAM(44,+CLINIC_",",".01"))
SET PARTIAL=$EXTRACT(CLINAM,1,2)
+16 FOR
SET PARTIAL=$ORDER(^PS(58.63,"WC",PARTIAL))
if PARTIAL=""!$GET(PDLINK)
QUIT
Begin DoDot:2
+17 if $EXTRACT(PARTIAL,1,3)'=$EXTRACT(CLINAM,1,3)
QUIT
+18 NEW PADE,STATUS
SET STATUS=""
+19 SET PADE=""
FOR
SET PADE=$ORDER(^PS(58.63,"WC",PARTIAL,PADE))
if 'PADE!$GET(PDLINK)
QUIT
Begin DoDot:3
+20 SET STATUS=$PIECE($GET(^PS(58.63,PADE,0)),"^",4)
+21 if (STATUS="I")
QUIT
+22 IF $EXTRACT(CLINAM,1,$LENGTH(PARTIAL))=PARTIAL
SET PDLINK=1
End DoDot:3
End DoDot:2
End DoDot:1
+23 QUIT PDLINK
+24 ;
DDLIST(DRGARRAY) ; List Drug Array when "?" entered at Dispense Drug prompt
+1 ;
+2 ;Select DISPENSE DRUG: ?
+3 NEW PSJDDAR,NXTDRG,LNCOUNT
+4 SET LNCOUNT=1
+5 SET PSJDDAR(LNCOUNT)=" Answer with DISPENSE DRUG"
SET LNCOUNT=LNCOUNT+1
+6 SET PSJDDAR(LNCOUNT)=" Choose from:"
SET LNCOUNT=LNCOUNT+1
+7 SET NXTDRG=0
FOR
SET NXTDRG=$ORDER(DRGARRAY(NXTDRG))
if 'NXTDRG
QUIT
Begin DoDot:1
+8 NEW DRGIEN,DRGNAME
+9 SET DRGIEN=+$GET(DRGARRAY(NXTDRG))
+10 SET DRGNAME=$PIECE($GET(^PSDRUG(+DRGIEN,0)),"^")
+11 if DRGIEN=""
QUIT
SET PSJDDAR(LNCOUNT)=" "_DRGNAME
SET LNCOUNT=LNCOUNT+1
End DoDot:1
+12 SET PSJDDAR(LNCOUNT)=""
SET LNCOUNT=LNCOUNT+1
+13 SET PSJDDAR(LNCOUNT)=" You may enter a new DISPENSE DRUG, if you wish"
SET LNCOUNT=LNCOUNT+1
+14 SET PSJDDAR(LNCOUNT)=" Only dispense drugs marked for Unit Dose use."
SET LNCOUNT=LNCOUNT+1
+15 SET PSJDDR(LNCOUNT)=""
SET LNCOUNT=LNCOUNT+1
+16 SET PSJDDAR(LNCOUNT)=""
SET LNCOUNT=LNCOUNT+1
+17 DO EN^DDIOL(.PSJDDAR)
+18 QUIT
+19 ;
CHK5345(PSJSYSP,DRGIEN) ; Check if file 50 pointer DRGIEN exists in Dispense Drug temp global ^PS(53.45,PSJSYSP,2,n
+1 ; PSJSYSP=User DUZ
+2 ; DRGIEN=pointer to drug IEN in file 50
+3 NEW DDCOUNT,FOUND
+4 if '$GET(DRGIEN)
QUIT 0
+5 SET FOUND=0
+6 SET DDCOUNT=0
FOR
SET DDCOUNT=$ORDER(^PS(53.45,PSJSYSP,2,DDCOUNT))
if 'DDCOUNT
QUIT
IF $PIECE($GET(^PS(53.45,PSJSYSP,2,DDCOUNT,0)),"^")=+$GET(DRGIEN)
SET FOUND=DDCOUNT
+7 QUIT FOUND
