Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PSJPAD50

PSJPAD50.m

Go to the documentation of this file.
  1. PSJPAD50 ;BIR/JCH PADE DRUG LOOKUP ;8/25/15
  1. ;;5.0;INPATIENT MEDICATIONS;**317,392**;16 DEC 97;Build 2
  1. ;
  1. ; Reference to ^VADPT is supported by DBIA 10061.
  1. ; Reference to EN^DDIOL is supported by DBIA 10142.
  1. ; Reference to ^PSDRUG is supported by DBIA 2192.
  1. ; Reference to ^PS(55 is supported by DBIA 2191.
  1. ; Reference to ^SC( is supported by DBIA 10040.
  1. ;
  1. Q
  1. ;
  1. READDD(PSJDRG,PSJOI,PSJLOC,PSJORD,PSGORD) ; Get Dispense Drug
  1. ; Input : PSJDRG - (required) Pointer to DRUG file (#50)
  1. ; PSJOI - (optional) Pointer to PHARMACY ORDERABLE ITEM (#50.7) file
  1. ; PSJLOC - (required) Pointer to WARD (#42) file if input value is purely numeric
  1. ; Pointer to Hospital Location (#44) if last character of input value is "C"
  1. ; PSJORD - (optional) Inpatient Order number, pointer to NON-VERIFIED ORDERS (#53.1) file or PHARAMCY PATIENT (#55) file
  1. ; PSGORD - (optional) Inpatient Order number, pointer to NON-VERIFIED ORDERS (#53.1) file or PHARMACY PATIENT (#55) file
  1. ;
  1. N DTOUT,DUOUT,PSII,PSJDONE
  1. I '$G(PSJLOC)!(($E($G(PSJLOC),$L($G(PSJLOC)))'="W")&($E($G(PSJLOC),$L($G(PSJLOC)))'="C")) D
  1. .N LOCTYP,CLFLAG
  1. .S (LOCTYP,CLFLAG)=""
  1. .I '$G(DFN),$G(PSGP) N DFN S DFN=PSGP
  1. .I '$G(VAIN(4)),$G(DFN) N VAIN,VAINDT,VAROOT,VAHOW D INP^VADPT
  1. .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:"")
  1. .S LOCTYP=$S($D(^SC(+CLFLAG,0))&$P(CLFLAG,"^",2)?7N1.E:"CL",1:"WD")
  1. .S PSJLOC=$S((LOCTYP="CL")&CLFLAG:+CLFLAG_"CL",(LOCTYP="WD")&$G(VAIN(4)):+$G(VAIN(4))_"WD",1:"")
  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)
  1. Q
  1. ;
  1. 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
  1. N PSJDSRCH,NEWDRG,PSJSRCH,PSJDRG
  1. K PSJDONE
  1. ;
  1. S PSJSRCH=""
  1. S PSJLOC=$S($G(PSJLOC)["C":$G(PSJLOC),1:+$G(PSJLOC))
  1. F Q:$G(DTOUT)!$G(NEWDRG)!$G(DUOUT)!$G(PSJDONE) D
  1. .S PSJSRCH=""
  1. .S NEWDRG=$$PROMPT(.PSJDRG,.PSJDSRCH,PSJOI,PSJLOC,PSJORD,.PSJSRCH,PSII)
  1. ; If user quit, don't file anything into ^PS(53.4502
  1. Q:$G(DUOUT)!$G(DTOUT)
  1. ; If something was changed, file the change into ^PS(53.4502
  1. I $G(NEWDRG) D FILE(.NEWDRG,PSJSRCH)
  1. Q
  1. ;
  1. PROMPT(DRGIEN,DRGSRCH,PSJOI,PSJLOC,PSJORD,PSJSRCH,PSII) ; Prompt for Dispense Drug
  1. ; Input: DRGIEN = pointer to DRUG (#50)
  1. ; PSJOI = pointer to pharmacy orderable item (#50.7)
  1. ; PSJLOC = Patient ward location or order's clinic location
  1. ; PSJORD = Inpatient Order, pointer to file 55 or 53.1
  1. ; SELSRCH= Drug was selected from numbered list
  1. N DRGNAME,DIR,DA,X,Y,NEWDRIEN,DI,DCT,TMPSRCH
  1. K DRG
  1. S DIR(0)="FAO^1:30"
  1. S DRGNAME=""
  1. S DRGIEN=$G(DRGIEN)
  1. S DCT=0 F S DCT=$O(^PS(53.45,PSJSYSP,2,DCT)) Q:'DCT D
  1. .N DRGNAME
  1. .S DRGIEN=+$G(^PS(53.45,PSJSYSP,2,DCT,0))
  1. .Q:'$G(DRGIEN)
  1. .S DRGNAME=$P($G(^PSDRUG(+DRGIEN,0)),"^")
  1. .S DRGIEN(DCT)=DRGIEN_"^^"_DRGNAME,DRGIEN("NAM",DRGNAME,DCT)="",DRGIEN("NUM",+DRGIEN(DCT),DCT)=""
  1. I 'DRGIEN S DRGIEN=$O(DRGIEN("")),DRGIEN=+$G(DRGIEN(+DRGIEN))
  1. ;
  1. I $G(PSII)>1 S DRGIEN=""
  1. I $G(PSJORD) N PSJLOC S PSJLOC=$$ORDLOC($G(PSJORD),$G(PSGP))
  1. ;
  1. S NEWDRIEN=""
  1. K DRGSRCH
  1. S DRGNAME=$S($G(DRGIEN):$P($G(^PSDRUG(+DRGIEN,0)),"^"),1:"")
  1. S DIR("A")="Select DISPENSE DRUG: "_$S(DRGNAME]"":DRGNAME_"//",1:"")
  1. S DIR("?")="^D SEARCH^PSJPAD50(.DRGIEN,"""",PSJLOC,.NEWDRG,PSJOI,1)"
  1. ; Quit if default accepted, or user wants out
  1. D ^DIR I X=""!$G(DUOUT)!$G(DTOUT) D Q DRGIEN
  1. .I '$G(DRGIEN) S PSJDONE=1
  1. ;
  1. I X="@",$G(DRGIEN) D Q NEWDRIEN
  1. .I $G(PSJORD)["U" K X S NEWDRIEN="" D
  1. ..D EN^DDIOL("Drugs for active orders cannot be deleted, but can be given an INACTIVE DATE")
  1. .; If Pending renewal, set flag to prevent change to dispense drug, can only be inactivated.
  1. .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
  1. ..D EN^DDIOL("Dispense drugs for renewal orders cannot be deleted, but can be given an INACTIVE DATE.")
  1. .I $G(X)="" D EN^DDIOL("<NOTHING DELETED>") Q
  1. .N DIR S DIR(0)="Y",DIR("A")="SURE YOU WANT TO DELETE THE ENTIRE DISPENSE DRUG" D ^DIR
  1. .S NEWDRIEN=DRGIEN_"^@"
  1. ; Default not accepted
  1. S TMPSRCH=X,PSJSRCH=1
  1. I X]"" D SELSRCH(.DRGIEN,.NEWDRIEN,PSJOI,PSJLOC,TMPSRCH)
  1. ;
  1. S:NEWDRIEN<1 NEWDRIEN=""
  1. I 'NEWDRIEN K DRGSRCH
  1. Q NEWDRIEN
  1. ;
  1. ; Input: DRGIEN - Pointer to DRUG file (#50) passed in - default dispense drug
  1. ; DRGSRCH - Search value for DRUG file (user input)
  1. ; PSJLOC - Location of current order - Patient Ward (inpatient) or Clinic (clinic order)
  1. ; NEWDRG - Pointer to DRUG file (#50) selected by user
  1. ; PSJOI - Pointer to Pharmacy Orderable Item (#50.7), associated with order
  1. ; PSJHELP - Flag indicating search is for 1) display only: $G(PSJHELP)
  1. ; or 2) allows selection: '$G(PSJHELP)
  1. ;
  1. N PSJSEL,PSJLIST,PSJDCNT,PSJDIEN,PSJCONT
  1. S PSJCONT=1
  1. ;
  1. D DDLIST(.DRGIEN)
  1. ;
  1. S PSJLIST="",PSJOSCRN="",DRGSRCH="?"
  1. S PSJSEL=$$PSDRUG(DRGIEN,DRGSRCH,.PSJLIST,PSJLOC,PSJOI,PSJOSCRN)
  1. ; If a drug was selected, return in NEWDRG parameter by reference
  1. I PSJSEL S NEWDRG=PSJSEL
  1. Q
  1. ;
  1. SELECT(PSJLIST,PSJHELP) ; Select a drug from the list PSJLIST
  1. N CNT,LAST,PSJSEL,PSJOUT,DIR
  1. S PSJSEL=""
  1. S LAST=$O(PSJLIST(1,999999),-1) S:'LAST LAST=1
  1. S CNT=0 F S CNT=$O(PSJLIST(1,CNT)) Q:'CNT S PSJOUT(CNT)=" "_CNT_" "_PSJLIST(1,CNT)
  1. I '$D(PSJOUT) W:'$G(PSJHELP) " ??" Q ""
  1. D EN^DDIOL(" Choose from:")
  1. D EN^DDIOL(.PSJOUT)
  1. Q:$G(PSJHELP) ""
  1. S DIR(0)="NOA^1:"_LAST,DIR("A")="CHOOSE 1-"_$G(LAST)_": " D ^DIR
  1. S:$G(Y) PSJSEL=$G(PSJLIST(2,Y))
  1. Q PSJSEL
  1. ;
  1. SELSRCH(DRGIEN,NEWDRIEN,PSJOI,PSJLOC,TMPSRCH,PSJSCRN) ; Select drug
  1. ; OR, select drug from Orderable Item screened DRUG file (#50).
  1. ;
  1. N PARTNAM,FOUND,PSJLIST,DCT,PSJQSRCH,PSJLOC
  1. K DIR
  1. ;
  1. S PSJLOC=$$ORDLOC($G(PSJORD),$G(PSGP))
  1. I $L($G(TMPSRCH))>0,$D(DRGIEN)>1 D
  1. .N I,DRGNAME,PSJLAST,PSJDIR,DIR,Y
  1. .S DCT=0 F I=0:1 S DCT=$O(DRGIEN(DCT)) Q:'DCT
  1. .S DCT=$O(DRGIEN(0))
  1. .I I=1 S DRGNAME=$P($G(^PSDRUG(+DRGIEN(DCT),0)),"^") I $E(DRGNAME,1,$L(TMPSRCH))=TMPSRCH D Q
  1. ..S PARTNAM=$E(DRGNAME,$L(TMPSRCH)+1,$L(DRGNAME)) W PARTNAM
  1. ..S DIR(0)="Y",DIR("B")="Y",DIR("A")=" ...OK" D ^DIR
  1. ..I Y>0 S NEWDRIEN=+$G(DRGIEN(DCT))
  1. .N PSJDIR S DCT=0 F I=1:1 S DCT=$O(DRGIEN(DCT)) Q:'DCT D
  1. ..N PSJQTY,PSJMSG
  1. ..S PSJLOC=$$ORDLOC($G(PSJORD),$G(PSGP))
  1. ..S DRGNAME=$P($G(^PSDRUG(+DRGIEN(DCT),0)),"^")
  1. ..S PSJDIR=$G(PSJDIR)_I_":"_DRGNAME_";"
  1. ..S PSJQTY=$$DRGQTY^PSJPADSI(+$G(DRGIEN(DCT)),$S($E(PSJLOC,$L(PSJLOC))="C":"CL",1:"WD"),+PSJLOC)
  1. ..D GETS^DIQ(50,+$G(DRGIEN(DCT))_",",101,,"PSJMSG")
  1. ..S DIR("A",I)=" "_I_" "_DRGNAME_" PADE:"_PSJQTY_" "_$G(PSJMSG(50,DRGIEN_",",101))
  1. .Q:$L(PSJDIR)<4 S PSJLAST=+$O(DRGIEN(999),-1)
  1. .Q:'PSJLAST
  1. .S DIR(0)="SAO^"_PSJDIR,DIR("A")="CHOOSE 1-"_PSJLAST_": "
  1. .D ^DIR Q:Y<1
  1. .S:$G(DRGIEN(Y)) NEWDRIEN=+$G(DRGIEN(Y))
  1. ;
  1. Q:$G(NEWDRIEN)
  1. ;
  1. ; User input not matched to any dispense drugs already filed to order - try to find an exact match; if found, quit and return IEN
  1. S PSJQSRCH=0
  1. I '$G(FOUND) D S:$G(FOUND) NEWDRIEN=DRGIEN(FOUND) I $G(FOUND)!$G(PSJQSRCH) Q
  1. .N PSJSCR,PSJFIND
  1. .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""))"
  1. .S PSJFIND=$$FIND1^DIC(50,,"M",TMPSRCH,,PSJSCRN)
  1. .; 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
  1. .I PSJFIND,(+PSJFIND=+$G(DRGIEN)) S PSJQSRCH=1 Q
  1. .I $G(PSJFIND) D
  1. ..N DIR S DIR(0)="Y",DIR("B")="N",DIR("A")=" Are you adding '"_$P($G(^PSDRUG(+PSJFIND,0)),"^")_"' as a new DISPENSE DRUG? "
  1. ..D ^DIR Q:Y<1
  1. ..S FOUND=+$O(DRGIEN(999),-1)+1,DRGIEN(FOUND)=+PSJFIND_"^^"_$P($G(^PSDRUG(+PSJFIND,0)),"^")
  1. ; User selected a dispense drug that was already filed with the order - they must want to edit the Units per Dose
  1. I $G(FOUND) D
  1. .S PARTNAM=$S('TMPSRCH:$E($P(DRGIEN(FOUND),"^",3),$L(TMPSRCH)+1,99),1:" "_$P(DRGIEN(FOUND),"^",3)) W PARTNAM
  1. .N DIR,Y S DIR(0)="Y",DIR("B")="Y",DIR("A")=" ...OK" D ^DIR
  1. .I Y>0 S NEWDRIEN=+$G(DRGIEN(FOUND))
  1. Q:$G(NEWDRIEN) ; User accepted default
  1. ;
  1. S PSJLIST="",PSJOSCRN=""
  1. S FOUND=$$PSDRUG(DRGIEN,TMPSRCH,.PSJLIST,PSJLOC,PSJOI,PSJOSCRN)
  1. ; If a drug was selected, return in NEWDRIEN parameter by reference
  1. I FOUND S NEWDRIEN=FOUND
  1. Q
  1. ;
  1. FILE(DRGIEN,PSJSRCH) ; File drug into ^PS(53.45
  1. ;
  1. N DA,DIC,DIE,DR,DIR,PSDD
  1. ;
  1. ; If an existing dispense drug was selected, allow the user to interactively edit the entry and quit
  1. ;I $D(^PS(53.45,PSJSYSP,2,"B",+$G(DRGIEN))) S PSDD=$O(^PS(53.45,PSJSYSP,2,"B",+DRGIEN,0)) D Q
  1. S PSDD=$$CHK5345(+$G(PSJSYSP),+$G(DRGIEN)) I PSDD D Q
  1. .; If Pending renewal, set flag to prevent change to dispense drug, can only be inactivated.
  1. .N PSJPNDRN I $G(PSGORD) I $E(PSGORD,$L(PSGORD))="P",$P($G(^PS(53.1,+PSGORD,0)),"^",24)="R" S PSJPNDRN=1
  1. .; User wants to delete the dispense drug - delete and quit
  1. .I $P(DRGIEN,"^",2)="@" D Q
  1. ..N DIK,DA S DIK="^PS(53.45,"_+$G(PSJSYSP)_",2,",DA=PSDD,DA(1)=+$G(PSJSYSP)
  1. ..D ^DIK
  1. .;
  1. .; User wants to edit existing dispense drug
  1. .S DIE="^PS(53.45,"_PSJSYSP_",2,",DA=PSDD,DA(1)=PSJSYSP
  1. .S DR=$S($G(PSJSRCH):".01;",1:"")
  1. .S DR=DR_".02"_$S($G(PSJPNDRN):";.03",$E($G(PSJORD),$L(PSJORD))["U":";.03",1:"") D ^DIE
  1. ;
  1. ; If a new entry is being added, find the next available node
  1. I '$G(PSDD) S PSDD=$O(^PS(53.45,PSJSYSP,2,999),-1)+1
  1. ;
  1. S DIE="^PS(53.45,"_PSJSYSP_",2,",DA=PSDD,DA(1)=PSJSYSP,DR=".01////"_+$G(DRGIEN) D ^DIE
  1. ;
  1. ; If adding a new entry, allow the user to interactively add the entry
  1. S DIE="^PS(53.45,"_PSJSYSP_",2,",DA=PSDD,DA(1)=PSJSYSP
  1. S DR=".01;.02"_$S($G(PSJPNDRN):";.03",$E($L($G(PSJORD)))["U":";.03",1:"") D ^DIE
  1. Q
  1. ;
  1. PSDRUG(DRGIEN,DRGSRCH,PSJLIST,PSJLOC,PSJOI,PSJOSCRN) ; Look for drug in file 50
  1. ;
  1. N DIC,D,PSJTABLN,PSJLT
  1. ; If PSJLOC is appended with "C", flag it as clinic, otherwise, flag as ward
  1. S PSJLT=$S(PSJLOC["C":"CL",1:"WD")
  1. ; If not a clinic, and we don't know the ward, try to find from DFN via call to INP^VADPT
  1. I PSJLT="WD",'$G(PSJLOC) N VAIN,VAINDT,VAROOT,VAHOW D INP^VADPT S PSJLOC=+$G(VAIN(4))
  1. S PSJLOC=$S(+$G(PSJLOC):PSJLOC,1:+$G(VAIN(4)))
  1. S DIC="^PSDRUG(",D="B^C^VAPN^VAC^NDC^XATC^ASP"
  1. 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 !
  1. 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""))"
  1. S DIC(0)="QMEZ",X=DRGSRCH
  1. 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)"
  1. D MIX^DIC1
  1. Q Y
  1. ;
  1. ORDLOC(PSJORD,PSGP) ; Get clinic location from PSJORD order, if it exists
  1. N PSJLOC
  1. Q:'$G(PSJORD) ""
  1. Q:",U,P,"'[(","_$E(PSJORD,$L(PSJORD))_",") ""
  1. I PSJORD["U" S PSJLOC=$G(^PS(55,+$G(PSGP),5,+$G(PSJORD),8)) D Q PSJLOC
  1. .I PSJLOC,$P(PSJLOC,"^",2) S PSJLOC=+PSJLOC_"C"
  1. .I '$G(PSJLOC) S PSJLOC=+$G(VAIN(4))
  1. I PSJORD["P" S PSJLOC=$G(^PS(53.1,+$G(PSJORD),"DSS")) D Q PSJLOC
  1. .I PSJLOC,$P(PSJLOC,"^",2) S PSJLOC=+PSJLOC_"C"
  1. .I '$G(PSJLOC) S PSJLOC=+$G(VAIN(4))
  1. Q ""
  1. ;
  1. CHKWG(CAB,WARD) ; Return flag indicating WARD is linked to cabinet's WARD GROUPS
  1. N WG,WD
  1. S WG=0 F S WG=$O(^PS(58.63,CAB,3,"B",WG)) Q:'WG D
  1. .S WD=0 F S WD=$O(^PS(57.5,WG,1,"B",WD)) Q:'WD S WG(WD)=""
  1. Q $D(WG(+$G(WARD)))
  1. ;
  1. CHKCG(CAB,CLINIC) ; Return flag indicating CLINIC is linked to cabinet's CLINIC GROUPS
  1. N CG,CL,CLIEN
  1. S CG=0 F S CG=$O(^PS(58.63,CAB,5,"B",CG)) Q:'CG D
  1. .S CL=0 F S CL=$O(^PS(57.8,CG,1,CL)) Q:'CL D
  1. ..S CLIEN=$G(^PS(57.8,CG,1,CL,0)) Q:'CLIEN
  1. ..S CG(CLIEN)=""
  1. Q $D(CG(+$G(CLINIC)))
  1. ;
  1. PADEWD(WARD) ; Return flag indicating if WARD is linked to any active PADE ward groups
  1. Q:'$G(WARD) ""
  1. N PDWARDS,PWD,WG,PDLINK,PADE
  1. S PDLINK=0
  1. S WG=0 F S WG=$O(^PS(58.63,"WG",WG)) Q:'WG D
  1. .S PADE=0 F S PADE=$O(^PS(58.63,"WG",WG,PADE)) Q:'PADE D
  1. ..Q:$P($G(^PS(58.63,PADE,0)),"^",4)="I"
  1. ..S PWD=0 F S PWD=$O(^PS(57.5,WG,1,"B",PWD)) Q:'PWD S PWD(PWD)=""
  1. I $D(PWD(+WARD)) S PDLINK=1
  1. I '$G(PDLINK) I $D(^PS(58.63,"WD",+WARD)) D
  1. .S PADE=0 F S PADE=$O(^PS(58.63,"WD",+WARD,PADE)) Q:'PADE D
  1. ..Q:$P($G(^PS(58.63,PADE,0)),"^",4)="I"
  1. ..S PDLINK=1
  1. Q PDLINK
  1. ;
  1. PADECL(CLINIC) ; Return flag indicating if CLINIC is linked to any PADE devices
  1. Q:'$G(CLINIC) ""
  1. N PDCLINS,PCL,CG,PDLINK,PADE,CLINAM,PARTIAL
  1. S PDLINK=0
  1. S CG=0 F S CG=$O(^PS(58.63,"CG",CG)) Q:'CG D
  1. .S PADE=0 F S PADE=$O(^PS(58.63,"CG",CG,PADE)) Q:'PADE D
  1. ..Q:$P($G(^PS(58.63,PADE,0)),"^",4)="I"
  1. ..S PCL=0 F S PCL=$O(^PS(57.8,"AD",CG,PCL)) Q:'PCL S PCL(PCL)=""
  1. I $D(PCL(+CLINIC)) S PDLINK=1
  1. I '$G(PDLINK) I $D(^PS(58.63,"CL",+CLINIC)) D
  1. .S PADE=0 F S PADE=$O(^PS(58.63,"CL",+CLINIC,PADE)) Q:'PADE D
  1. ..Q:$P($G(^PS(58.63,PADE,0)),"^",4)="I"
  1. ..S PDLINK=1
  1. ; If no match, check PADEs associated with clinic wildcards
  1. I '$G(PDLINK) D GETS^DIQ(44,+CLINIC,".01",,"CLINAM") D
  1. .S CLINAM=$G(CLINAM(44,+CLINIC_",",".01")),PARTIAL=$E(CLINAM,1,2)
  1. .F S PARTIAL=$O(^PS(58.63,"WC",PARTIAL)) Q:PARTIAL=""!$G(PDLINK) D
  1. ..Q:$E(PARTIAL,1,3)'=$E(CLINAM,1,3)
  1. ..N PADE,STATUS S STATUS=""
  1. ..S PADE="" F S PADE=$O(^PS(58.63,"WC",PARTIAL,PADE)) Q:'PADE!$G(PDLINK) D
  1. ...S STATUS=$P($G(^PS(58.63,PADE,0)),"^",4)
  1. ...Q:(STATUS="I")
  1. ...I $E(CLINAM,1,$L(PARTIAL))=PARTIAL S PDLINK=1
  1. Q PDLINK
  1. ;
  1. DDLIST(DRGARRAY) ; List Drug Array when "?" entered at Dispense Drug prompt
  1. ;
  1. ;Select DISPENSE DRUG: ?
  1. N PSJDDAR,NXTDRG,LNCOUNT
  1. S LNCOUNT=1
  1. S PSJDDAR(LNCOUNT)=" Answer with DISPENSE DRUG",LNCOUNT=LNCOUNT+1
  1. S PSJDDAR(LNCOUNT)=" Choose from:",LNCOUNT=LNCOUNT+1
  1. S NXTDRG=0 F S NXTDRG=$O(DRGARRAY(NXTDRG)) Q:'NXTDRG D
  1. .N DRGIEN,DRGNAME
  1. .S DRGIEN=+$G(DRGARRAY(NXTDRG))
  1. .S DRGNAME=$P($G(^PSDRUG(+DRGIEN,0)),"^")
  1. .Q:DRGIEN="" S PSJDDAR(LNCOUNT)=" "_DRGNAME,LNCOUNT=LNCOUNT+1
  1. S PSJDDAR(LNCOUNT)="",LNCOUNT=LNCOUNT+1
  1. S PSJDDAR(LNCOUNT)=" You may enter a new DISPENSE DRUG, if you wish",LNCOUNT=LNCOUNT+1
  1. S PSJDDAR(LNCOUNT)=" Only dispense drugs marked for Unit Dose use.",LNCOUNT=LNCOUNT+1
  1. S PSJDDR(LNCOUNT)="",LNCOUNT=LNCOUNT+1
  1. S PSJDDAR(LNCOUNT)="",LNCOUNT=LNCOUNT+1
  1. D EN^DDIOL(.PSJDDAR)
  1. Q
  1. ;
  1. 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
  1. ; DRGIEN=pointer to drug IEN in file 50
  1. N DDCOUNT,FOUND
  1. Q:'$G(DRGIEN) 0
  1. S FOUND=0
  1. 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
  1. Q FOUND