- 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 Feb 18, 2025@23:34:54 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