VPRSDAP ;SLC/MKB -- SDA Pharmacy utilities ;10/25/18 15:29
;;1.0;VIRTUAL PATIENT RECORD;**8,24,14,28,30**;Sep 01, 2011;Build 9
;;Per VHA Directive 6402, this routine should not be modified.
;
; External References DBIA#
; ------------------- -----
; ^%ZOSF 10096
; ^DIC(42 10039
; ^OR(100 5771
; ^ORD(100.98 6982
; ^ORD(101.43 2843
; ^PSB(53.79 5909
; ^SC 10040
; DILFD 2055
; DIQ 2056
; ORX8 2467
; PSN50P41 4531
; PSO52API 4820
; PSO5241 4821
; PSOORRL, ^TMP("PS",$J) 2400
; PSS50 4533
; PSS50P7 4662
; PSS51P1 4546
; PSS52P6 4549
; PSS52P7 4550
; PSSUTLA1 3373
; PSXOPUTL 2200
; XLFSTR 10104
;
PS1(IEN) ; -- set up single medication
; Returns ORIFN, ORPK, PSTYPE & VPRPS=^TMP
N X,CLS S ORIFN=+$G(IEN)
S ORPK=$G(^OR(100,ORIFN,4)) S:'DFN DFN=+$P($G(^(0)),U,2)
; last char = PS file
S X=$S(ORPK:$E(ORPK,$L(ORPK)),1:"Z") S:X=+X X="R",ORPK=ORPK_X
S CLS=$S("RSN"[X:"O",1:"I") ;"UV"[X:"I",1:$$GET1^DIQ(100,IEN_",",10,"I"))
S PSTYPE=$S(X="N":"N","RS"[X:"O",$$IV:"V",1:"I") K VPRATE
D:ORPK OEL^PSOORRL(DFN,ORPK_";"_CLS)
S VPRPS=$NA(^TMP("PS",$J))
; ck Status field
S X=$P($G(@VPRPS@(0)),U,6) D
. S:X="DISCONTINUE" X="DISCONTINUED"
. I X["/" S:X["/PARK" X=$P(X,"/") S:X["/SUSP" X="SUSPENDED"
S $P(@VPRPS@(0),U,6)=X
Q
;
OI(IEN) ; -- return orderable item for order IEN in the format
; ifn ^ [name] ^ pkg id
N Y S Y=""
I $P($G(^OR(100,IEN,.1,0)),U,4)>1 D ;use PSOI from api if multiple
. N X,I S X=$P($G(@VPRPS@(0)),U)
. S I=0 F S I=$O(^OR(100,IEN,.1,"B",I)) Q:I<1 Q:$P($G(^ORD(101.43,I,0)),U)[X
. S:I Y=I_U_X_U_$P($G(^ORD(101.43,I,0)),U,2)
I 'Y S Y=$$OI^ORX8(IEN) ;first/only
Q Y
;
SCHEDULE() ; -- return schedule name ^ type ^ admin times ^ #min
; Expects ORIFN, IEN from VPR DOSAGE STEP
N SCH,ADM,FREQ,I,Y S Y=""
; Outpt/NonVA only need Schedule
I "ON"[$G(PSTYPE) S Y=$$VALUE^ORX8(ORIFN,"SCHEDULE",IEN) Q Y
S I=+$O(@VPRPS@("SCH",0)),Y=$P($G(@VPRPS@("SCH",I,0)),U,1,2)
S I=+$O(@VPRPS@("ADM",0)),ADM=$G(@VPRPS@("ADM",I,0))
S SCH=$P(Y,U),$P(Y,U,3)=ADM I SCH="" Q ""
I '$D(^TMP("VPRX",$J,"SCH","B",SCH)) D
. D ZERO^PSS51P1(,SCH,"PSJ",,"SCH")
. M ^TMP("VPRX",$J,"SCH")=^TMP($J,"SCH")
. K ^TMP($J,"SCH")
S I=0 F S I=$O(^TMP("VPRX",$J,"SCH",I)) Q:I<1 I $L(ADM),$G(^(I,1))=ADM S $P(Y,U,4)=$G(^(2))
Q Y
;
LOC(DFN,ID) ; -- return Hosp Location for order
N X,Y,FN
S DFN=+$G(DFN),ID=$G(ID) I 'DFN!'ID Q ""
I '$L($T(LOC^PSSUTLA1)) Q ""
S X=$$LOC^PSSUTLA1(DFN,ID),FN=+$P(X,U,3)
I X,FN=44 Q +X
I X,FN=42 Q +$G(^DIC(42,+X,44))
Q ""
;
IMO(X,PS) ; -- return true, false, or null if IMO location X
N Y S Y=""
I $G(PS)'="I",$G(PS)'="V" Q ""
S Y=$S($P($G(^SC(+$G(X),0)),U,25):"true",1:"false")
Q Y
;
PSRX(RX) ; -- get RX info for extension properties
S RX=$G(RX),VPRX52=$NA(^TMP($J,"VPRX",DFN,+RX))
S VPRX52P=$NA(^TMP($J,"VPRXP",DFN,+RX))
Q:$G(PSTYPE)'="O"
I RX["S" D PEN^PSO5241(DFN,"VPRXP",+RX) Q
Q:RX'["R" ;Rx file
D RX^PSO52API(DFN,"VPRX",+RX,,3)
; get IB data too
D RX^PSO52API(DFN,"VPRXIB",+RX,,"I^O")
M @VPRX52=^TMP($J,"VPRXIB",DFN,+RX) K ^TMP($J,"VPRXIB",DFN,+RX)
Q
;
ROUTING(RX) ; -- get the Routing value [not in use]
N X,Y S (X,Y)="",RX=$G(RX)
I $G(ORPK)["R" S X=$P($G(@VPRPS@("RXN",0)),U,3)
I $G(ORPK)["S" S X=$P($G(@VPRX52P@(19)),U)
S:$L(X) Y=$S(X="M":"MAIL",X="W":"WINDOW",X="C":"ADMINISTERED IN CLINIC",X="P":"PARK",1:"")
Q Y
;
GETFILLS ; -- build DLIST(#)=#^data of fills, where data is
; date ^ daysSupply ^ qty ^ released ^ routing ^ remarks ^ returned
N I,N S N=0
N RX0,RXN S RX0=$G(@VPRPS@(0)),RXN=$G(@VPRPS@("RXN",0))
I $P(RXN,U,6) D ;original fill
. N X S X=$P(RXN,U,6)_U_$P(RX0,U,7,8)_U_$P(RXN,U,7)_U_$P(RXN,U,3)
. S:$G(@VPRX52@(32.1)) $P(X,U,7)=$P(@VPRX52@(32.1),U)
. S N=N+1,DLIST(N)="0^"_X
S I=0 F S I=$O(@VPRPS@("REF",I)) Q:I<1 S N=N+1,DLIST(N)=I_U_$G(@VPRPS@("REF",I,0))
S I=0 F S I=$O(@VPRPS@("PAR",I)) Q:I<1 S N=N+1,DLIST(N)="P"_I_U_$G(@VPRPS@("PAR",I,0))
Q
;
SUPPLY(IEN) ; -- return 1 or 0, if supply item
N Y S Y=$S($G(^TMP("VPRX",$J,"PSOI",+$G(PSOI),.09)):"true",1:"false")
Q Y
;
CMOP(RX) ; -- return CMOP indicator for RX
N Y S Y="",RX=+$G(RX)
I $$GET1^DIQ(52,RX,"6:213","I") S Y=">"
N X S X="PSXOPUTL" X ^%ZOSF("TEST") K X I $T D
. N DA,PSXZ S DA=RX D ^PSXOPUTL
. S X=$G(PSXZ(PSXZ("L"))) I X=0!(X=2) S Y="T"
Q Y
;
SIG(IEN) ; -- return Sig, append VPRPI if needed
N Y S Y=$$WP^VPRSDAOR(+$G(IEN),"SIG")
I $L(Y),$L($G(VPRPI)),Y'[VPRPI D ;append PI?
. N SIG,PI S SIG=$$UP^XLFSTR(Y)
. S PI=$$UP^XLFSTR(VPRPI),PI=$$TRIM^XLFSTR(PI) Q:SIG[PI
. S Y=SIG_$S($E(Y,$L(Y))=" ":"",1:" ")_PI
Q Y
;
DOSEFORM(IEN) ; -- return dose form
N Y S Y=""
I +$G(PSOI),'$D(^TMP("VPRX",$J,"PSOI",PSOI)) D
. D ZERO^PSS50P7(PSOI,,,"PSOI")
. M ^TMP("VPRX",$J,"PSOI",PSOI)=^TMP($J,"PSOI",PSOI)
. K ^TMP($J,"PSOI",PSOI)
S Y=$G(^TMP("VPRX",$J,"PSOI",+$G(PSOI),.02)) S:Y Y=Y_"^VA50.606"
Q Y
;
INGRD(NAME) ; -- reset NAME to ingredient IEN
; Also return VPRCODE=code^name^system
N IEN S IEN=""
S NAME=$G(NAME),VPRCODE=""
I $L(NAME) D
. D NAME^PSN50P41(NAME,"VPRDI") S IEN=+$O(^TMP($J,"VPRDI","P",NAME,0))
. K ^TMP($J,"VPRDI")
I IEN<1 S DDEOUT=1 Q
S VPRCODE=IEN_U_NAME,NAME=IEN ;reset, if passed by reference
D CODE(.VPRCODE,50.416)
Q
;
NDF(DRUG) ; -- return VA Drug Product info for DRUG (#50 ien)
; also returns DATA = code^name^system for RXN/VUID
I '$D(^TMP("VPRX",$J,"NDF",DRUG)) D
. D NDF^PSS50(DRUG,,,,,"NDF")
. M ^TMP("VPRX",$J,"NDF",DRUG)=^TMP($J,"NDF",DRUG)
. K ^TMP($J,"NDF",DRUG)
S VPRVAP=$NA(^TMP("VPRX",$J,"NDF",DRUG))
S DATA=$G(^TMP("VPRX",$J,"NDF",DRUG,22)) I DATA D ;#50.68
. D CODE(.DATA,50.68)
. S $P(DATA,U,2)=$P($G(@VPRVAP@(22)),U,2) ;RXN text unreliable
. S:'$L($P(DATA,U,3)) $P(DATA,U,3)="VA50.68"
I 'DATA S DATA=DRUG_U_$G(@VPRVAP@(.01))_"^VA50"
Q
;
CODE(MED,FILE) ; -- convert MED=ien^name to national code
; Reset MED = code^name^system for RxNorm or VUID
N Y S MED=$G(MED),FILE=+$G(FILE)
S Y=$$CODE^VPRSDA(+MED,FILE,"RXN")
I Y="" S Y=$$VUID^VPRD(+MED,FILE) S:$L(Y) Y=Y_U_$P(MED,U,2)_"^VHAT"
S:$L(Y) MED=Y ;reset to nat'l code string
Q
;
DOSES(IEN) ; -- build DLIST(n)=instance of Dose Instructions
N DA,I S IEN=+$G(IEN)
S DA=0 F S DA=$O(^OR(100,IEN,4.5,"ID","INSTR",DA)) Q:DA<1 D
. S I=+$P($G(^OR(100,IEN,4.5,DA,0)),U,3)
. S:I DLIST(I)=I
; look for NVA w/schedule (dose not required)
I '$O(DLIST(0)),$G(PSTYPE)="N",$O(^OR(100,IEN,4.5,"ID","SCHEDULE",0)) S DLIST(1)=1
Q
;
BCMA(IEN,MAX) ; -- get list of most recent administrations for order
N ORPK,ADT,DA,CNT,STS
S IEN=+$G(IEN),CNT=0,ADT=9999999,MAX=$G(MAX,10)
I $G(DFN)<1 S DFN=+$P($G(^OR(100,IEN,0)),U,2) Q:'DFN
S ORPK=$G(^OR(100,IEN,4)) Q:ORPK=""
F S ADT=$O(^PSB(53.79,"AORDX",DFN,ORPK,ADT),-1) Q:ADT<1 D Q:CNT'<MAX
. S DA=0 F S DA=+$O(^PSB(53.79,"AORDX",DFN,ORPK,ADT,DA)) Q:DA<1 D
.. ;I $P($G(^PSB(53.79,DA,0)),U,9)="RM" Q ;REMOVED
.. S CNT=CNT+1,DLIST(CNT)=DA
Q
;
PSB ; -- VPR PSB EVENTS protocol listener (BCMA)
N IEN,DFN,ORPK,ORIFN
S IEN=$S($P($G(PSBIEN),",",2)'="":+$P(PSBIEN,",",2),$G(PSBIEN)="+1":+$G(PSBIEN(1)),1:+$G(PSBIEN))
S DFN=+$G(^PSB(53.79,IEN,0)),ORPK=$P($G(^(.1)),U)
Q:DFN<1 Q:ORPK<1
S ORIFN=$$PLACER^PSSUTLA1(DFN,ORPK)
D:ORIFN POST^VPRHS(DFN,"Medication",+ORIFN_";100")
Q
;
ADMSTS(DA) ; -- return the code^name of administration status
N X,Y,Z,Z0 S DA=+$G(DA)
S Y=$P($G(PSB0),U,9),X="" I Y="N" D
. S Z="" F S Z=$O(^PSB(53.79,DA,.9,Z),-1) Q:'Z S Z0=$G(^(Z,0)) D Q:$L(X)
.. S X=$P(Z0,U,4) Q:X=""
.. S Y=$S(X="REMOVED":"RM",1:$E(X))
I X="" S X=$$EXTERNAL^DILFD(53.79,.09,,Y)
S:$L(X) Y=Y_U_X
Q Y
;
IV() ; -- Return 1 or 0, if order is for IV/infusion
I ORPK["V" Q 1
N X0,X S X0=$G(^OR(100,ORIFN,0))
I +$P(X0,U,5)=130 Q 1
S X=$P($G(^ORD(100.98,+$P(X0,U,11),0)),U,3)
I X?1"IV".E Q 1
I X="CI RX" Q 1
;I $G(^TMP("PS",$J,"A",0))!$G(^TMP("PS",$J,"B",0)) Q 1
Q 0
;
IVMEDS(IEN) ; -- build DLIST(#)=ien^amount^type[^bottle] for components
N CNT,GBL,I,Y,ND
S ORPK=$G(ORPK),CNT=0
S GBL=$S(ORPK["P":"^PS(53.1,",ORPK["U":"^PS(55,DFN,5,",1:"^PS(55,DFN,""IV"",")
F I=0:0 S I=$O(@(GBL_+ORPK_",""SOL"","_I_")")) Q:'I D
. S ND=$G(@(GBL_+ORPK_",""SOL"","_I_",0)"))
. S CNT=CNT+1,DLIST(CNT)=+ND_U_$P(ND,U,2)_"^B"
F I=0:0 S I=$O(@(GBL_+ORPK_",""AD"","_I_")")) Q:'I D
. S ND=$G(@(GBL_+ORPK_",""AD"","_I_",0)")),Y=+ND_U_$P(ND,U,2)_"^A"
. S:$L($P(ND,U,3)) Y=Y_U_$P(ND,U,3)
. S CNT=CNT+1,DLIST(CNT)=Y
Q
;
IV1(X) ; -- get VA Drug Product info for IV component X (from DLIST)
; Returns VPRPSIV = ien^name^amt^type^bottle#
N IEN,TYPE,NAME,DRUG
S VPRPSIV=$G(X) ;ien^amt^type[^bottle#] from IVMEDS
S IEN=+VPRPSIV,TYPE=$P(VPRPSIV,U,3)
D:TYPE="B" ZERO^PSS52P7(IEN,"","","VPRPSIV")
D:TYPE="A" ZERO^PSS52P6(IEN,"","","VPRPSIV")
S NAME=$G(^TMP($J,"VPRPSIV",IEN,.01)),DRUG=+$G(^(1))
S VPRPSIV=IEN_U_NAME_U_$P(VPRPSIV,U,2,99)
S X=+$G(DRUG) D:DRUG NDF^VPRSDAP(DRUG) ;#50 ien
I 'DRUG D ;return IV file instead
. S DATA=IEN_U_NAME_U_$S(TYPE="A":"VA52.6",TYPE="B":"VA52.7",1:"VA")
. S VPRVAP=$NA(^TMP("VPRX",$J,"NDF",0))
K ^TMP($J,"VPRPSIV")
Q
;
IVRATE(IEN) ; -- return IV Rate, or DDEOUT if invalid
; also VPRATE = numeric amount, if ## ml/hr
I $G(PSTYPE)'="V" S DDEOUT=1 Q ""
N X S IEN=+$G(IEN)
S X=$$VALUE^ORX8(IEN,"RATE")
I X?1.N1" ml/hr".E S VPRATE=+X Q +X
S DDEOUT=1
Q ""
;
IVTYPE(IEN) ; -- return IV Type, or DDEOUT if invalid
I $G(PSTYPE)'="V" S DDEOUT=1 Q ""
N X,Y,ORPK,FN,FLD,IENS
S IEN=+$G(IEN),Y="",ORPK=$G(^OR(100,IEN,4))
I ORPK["P" S FN=53.1,FLD=53,IENS=+ORPK
E S FN=55.01,FLD=.04,IENS=+ORPK_","_DFN
S Y=$$GET1^DIQ(FN,IENS_",",FLD)
Q Y
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVPRSDAP 10215 printed Apr 09, 2024@21:47:34 Page 2
VPRSDAP ;SLC/MKB -- SDA Pharmacy utilities ;10/25/18 15:29
+1 ;;1.0;VIRTUAL PATIENT RECORD;**8,24,14,28,30**;Sep 01, 2011;Build 9
+2 ;;Per VHA Directive 6402, this routine should not be modified.
+3 ;
+4 ; External References DBIA#
+5 ; ------------------- -----
+6 ; ^%ZOSF 10096
+7 ; ^DIC(42 10039
+8 ; ^OR(100 5771
+9 ; ^ORD(100.98 6982
+10 ; ^ORD(101.43 2843
+11 ; ^PSB(53.79 5909
+12 ; ^SC 10040
+13 ; DILFD 2055
+14 ; DIQ 2056
+15 ; ORX8 2467
+16 ; PSN50P41 4531
+17 ; PSO52API 4820
+18 ; PSO5241 4821
+19 ; PSOORRL, ^TMP("PS",$J) 2400
+20 ; PSS50 4533
+21 ; PSS50P7 4662
+22 ; PSS51P1 4546
+23 ; PSS52P6 4549
+24 ; PSS52P7 4550
+25 ; PSSUTLA1 3373
+26 ; PSXOPUTL 2200
+27 ; XLFSTR 10104
+28 ;
PS1(IEN) ; -- set up single medication
+1 ; Returns ORIFN, ORPK, PSTYPE & VPRPS=^TMP
+2 NEW X,CLS
SET ORIFN=+$GET(IEN)
+3 SET ORPK=$GET(^OR(100,ORIFN,4))
if 'DFN
SET DFN=+$PIECE($GET(^(0)),U,2)
+4 ; last char = PS file
+5 SET X=$SELECT(ORPK:$EXTRACT(ORPK,$LENGTH(ORPK)),1:"Z")
if X=+X
SET X="R"
SET ORPK=ORPK_X
+6 ;"UV"[X:"I",1:$$GET1^DIQ(100,IEN_",",10,"I"))
SET CLS=$SELECT("RSN"[X:"O",1:"I")
+7 SET PSTYPE=$SELECT(X="N":"N","RS"[X:"O",$$IV:"V",1:"I")
KILL VPRATE
+8 if ORPK
DO OEL^PSOORRL(DFN,ORPK_";"_CLS)
+9 SET VPRPS=$NAME(^TMP("PS",$JOB))
+10 ; ck Status field
+11 SET X=$PIECE($GET(@VPRPS@(0)),U,6)
Begin DoDot:1
+12 if X="DISCONTINUE"
SET X="DISCONTINUED"
+13 IF X["/"
if X["/PARK"
SET X=$PIECE(X,"/")
if X["/SUSP"
SET X="SUSPENDED"
End DoDot:1
+14 SET $PIECE(@VPRPS@(0),U,6)=X
+15 QUIT
+16 ;
OI(IEN) ; -- return orderable item for order IEN in the format
+1 ; ifn ^ [name] ^ pkg id
+2 NEW Y
SET Y=""
+3 ;use PSOI from api if multiple
IF $PIECE($GET(^OR(100,IEN,.1,0)),U,4)>1
Begin DoDot:1
+4 NEW X,I
SET X=$PIECE($GET(@VPRPS@(0)),U)
+5 SET I=0
FOR
SET I=$ORDER(^OR(100,IEN,.1,"B",I))
if I<1
QUIT
if $PIECE($GET(^ORD(101.43,I,0)),U)[X
QUIT
+6 if I
SET Y=I_U_X_U_$PIECE($GET(^ORD(101.43,I,0)),U,2)
End DoDot:1
+7 ;first/only
IF 'Y
SET Y=$$OI^ORX8(IEN)
+8 QUIT Y
+9 ;
SCHEDULE() ; -- return schedule name ^ type ^ admin times ^ #min
+1 ; Expects ORIFN, IEN from VPR DOSAGE STEP
+2 NEW SCH,ADM,FREQ,I,Y
SET Y=""
+3 ; Outpt/NonVA only need Schedule
+4 IF "ON"[$GET(PSTYPE)
SET Y=$$VALUE^ORX8(ORIFN,"SCHEDULE",IEN)
QUIT Y
+5 SET I=+$ORDER(@VPRPS@("SCH",0))
SET Y=$PIECE($GET(@VPRPS@("SCH",I,0)),U,1,2)
+6 SET I=+$ORDER(@VPRPS@("ADM",0))
SET ADM=$GET(@VPRPS@("ADM",I,0))
+7 SET SCH=$PIECE(Y,U)
SET $PIECE(Y,U,3)=ADM
IF SCH=""
QUIT ""
+8 IF '$DATA(^TMP("VPRX",$JOB,"SCH","B",SCH))
Begin DoDot:1
+9 DO ZERO^PSS51P1(,SCH,"PSJ",,"SCH")
+10 MERGE ^TMP("VPRX",$JOB,"SCH")=^TMP($JOB,"SCH")
+11 KILL ^TMP($JOB,"SCH")
End DoDot:1
+12 SET I=0
FOR
SET I=$ORDER(^TMP("VPRX",$JOB,"SCH",I))
if I<1
QUIT
IF $LENGTH(ADM)
IF $GET(^(I,1))=ADM
SET $PIECE(Y,U,4)=$GET(^(2))
+13 QUIT Y
+14 ;
LOC(DFN,ID) ; -- return Hosp Location for order
+1 NEW X,Y,FN
+2 SET DFN=+$GET(DFN)
SET ID=$GET(ID)
IF 'DFN!'ID
QUIT ""
+3 IF '$LENGTH($TEXT(LOC^PSSUTLA1))
QUIT ""
+4 SET X=$$LOC^PSSUTLA1(DFN,ID)
SET FN=+$PIECE(X,U,3)
+5 IF X
IF FN=44
QUIT +X
+6 IF X
IF FN=42
QUIT +$GET(^DIC(42,+X,44))
+7 QUIT ""
+8 ;
IMO(X,PS) ; -- return true, false, or null if IMO location X
+1 NEW Y
SET Y=""
+2 IF $GET(PS)'="I"
IF $GET(PS)'="V"
QUIT ""
+3 SET Y=$SELECT($PIECE($GET(^SC(+$GET(X),0)),U,25):"true",1:"false")
+4 QUIT Y
+5 ;
PSRX(RX) ; -- get RX info for extension properties
+1 SET RX=$GET(RX)
SET VPRX52=$NAME(^TMP($JOB,"VPRX",DFN,+RX))
+2 SET VPRX52P=$NAME(^TMP($JOB,"VPRXP",DFN,+RX))
+3 if $GET(PSTYPE)'="O"
QUIT
+4 IF RX["S"
DO PEN^PSO5241(DFN,"VPRXP",+RX)
QUIT
+5 ;Rx file
if RX'["R"
QUIT
+6 DO RX^PSO52API(DFN,"VPRX",+RX,,3)
+7 ; get IB data too
+8 DO RX^PSO52API(DFN,"VPRXIB",+RX,,"I^O")
+9 MERGE @VPRX52=^TMP($JOB,"VPRXIB",DFN,+RX)
KILL ^TMP($JOB,"VPRXIB",DFN,+RX)
+10 QUIT
+11 ;
ROUTING(RX) ; -- get the Routing value [not in use]
+1 NEW X,Y
SET (X,Y)=""
SET RX=$GET(RX)
+2 IF $GET(ORPK)["R"
SET X=$PIECE($GET(@VPRPS@("RXN",0)),U,3)
+3 IF $GET(ORPK)["S"
SET X=$PIECE($GET(@VPRX52P@(19)),U)
+4 if $LENGTH(X)
SET Y=$SELECT(X="M":"MAIL",X="W":"WINDOW",X="C":"ADMINISTERED IN CLINIC",X="P":"PARK",1:"")
+5 QUIT Y
+6 ;
GETFILLS ; -- build DLIST(#)=#^data of fills, where data is
+1 ; date ^ daysSupply ^ qty ^ released ^ routing ^ remarks ^ returned
+2 NEW I,N
SET N=0
+3 NEW RX0,RXN
SET RX0=$GET(@VPRPS@(0))
SET RXN=$GET(@VPRPS@("RXN",0))
+4 ;original fill
IF $PIECE(RXN,U,6)
Begin DoDot:1
+5 NEW X
SET X=$PIECE(RXN,U,6)_U_$PIECE(RX0,U,7,8)_U_$PIECE(RXN,U,7)_U_$PIECE(RXN,U,3)
+6 if $GET(@VPRX52@(32.1))
SET $PIECE(X,U,7)=$PIECE(@VPRX52@(32.1),U)
+7 SET N=N+1
SET DLIST(N)="0^"_X
End DoDot:1
+8 SET I=0
FOR
SET I=$ORDER(@VPRPS@("REF",I))
if I<1
QUIT
SET N=N+1
SET DLIST(N)=I_U_$GET(@VPRPS@("REF",I,0))
+9 SET I=0
FOR
SET I=$ORDER(@VPRPS@("PAR",I))
if I<1
QUIT
SET N=N+1
SET DLIST(N)="P"_I_U_$GET(@VPRPS@("PAR",I,0))
+10 QUIT
+11 ;
SUPPLY(IEN) ; -- return 1 or 0, if supply item
+1 NEW Y
SET Y=$SELECT($GET(^TMP("VPRX",$JOB,"PSOI",+$GET(PSOI),.09)):"true",1:"false")
+2 QUIT Y
+3 ;
CMOP(RX) ; -- return CMOP indicator for RX
+1 NEW Y
SET Y=""
SET RX=+$GET(RX)
+2 IF $$GET1^DIQ(52,RX,"6:213","I")
SET Y=">"
+3 NEW X
SET X="PSXOPUTL"
XECUTE ^%ZOSF("TEST")
KILL X
IF $TEST
Begin DoDot:1
+4 NEW DA,PSXZ
SET DA=RX
DO ^PSXOPUTL
+5 SET X=$GET(PSXZ(PSXZ("L")))
IF X=0!(X=2)
SET Y="T"
End DoDot:1
+6 QUIT Y
+7 ;
SIG(IEN) ; -- return Sig, append VPRPI if needed
+1 NEW Y
SET Y=$$WP^VPRSDAOR(+$GET(IEN),"SIG")
+2 ;append PI?
IF $LENGTH(Y)
IF $LENGTH($GET(VPRPI))
IF Y'[VPRPI
Begin DoDot:1
+3 NEW SIG,PI
SET SIG=$$UP^XLFSTR(Y)
+4 SET PI=$$UP^XLFSTR(VPRPI)
SET PI=$$TRIM^XLFSTR(PI)
if SIG[PI
QUIT
+5 SET Y=SIG_$SELECT($EXTRACT(Y,$LENGTH(Y))=" ":"",1:" ")_PI
End DoDot:1
+6 QUIT Y
+7 ;
DOSEFORM(IEN) ; -- return dose form
+1 NEW Y
SET Y=""
+2 IF +$GET(PSOI)
IF '$DATA(^TMP("VPRX",$JOB,"PSOI",PSOI))
Begin DoDot:1
+3 DO ZERO^PSS50P7(PSOI,,,"PSOI")
+4 MERGE ^TMP("VPRX",$JOB,"PSOI",PSOI)=^TMP($JOB,"PSOI",PSOI)
+5 KILL ^TMP($JOB,"PSOI",PSOI)
End DoDot:1
+6 SET Y=$GET(^TMP("VPRX",$JOB,"PSOI",+$GET(PSOI),.02))
if Y
SET Y=Y_"^VA50.606"
+7 QUIT Y
+8 ;
INGRD(NAME) ; -- reset NAME to ingredient IEN
+1 ; Also return VPRCODE=code^name^system
+2 NEW IEN
SET IEN=""
+3 SET NAME=$GET(NAME)
SET VPRCODE=""
+4 IF $LENGTH(NAME)
Begin DoDot:1
+5 DO NAME^PSN50P41(NAME,"VPRDI")
SET IEN=+$ORDER(^TMP($JOB,"VPRDI","P",NAME,0))
+6 KILL ^TMP($JOB,"VPRDI")
End DoDot:1
+7 IF IEN<1
SET DDEOUT=1
QUIT
+8 ;reset, if passed by reference
SET VPRCODE=IEN_U_NAME
SET NAME=IEN
+9 DO CODE(.VPRCODE,50.416)
+10 QUIT
+11 ;
NDF(DRUG) ; -- return VA Drug Product info for DRUG (#50 ien)
+1 ; also returns DATA = code^name^system for RXN/VUID
+2 IF '$DATA(^TMP("VPRX",$JOB,"NDF",DRUG))
Begin DoDot:1
+3 DO NDF^PSS50(DRUG,,,,,"NDF")
+4 MERGE ^TMP("VPRX",$JOB,"NDF",DRUG)=^TMP($JOB,"NDF",DRUG)
+5 KILL ^TMP($JOB,"NDF",DRUG)
End DoDot:1
+6 SET VPRVAP=$NAME(^TMP("VPRX",$JOB,"NDF",DRUG))
+7 ;#50.68
SET DATA=$GET(^TMP("VPRX",$JOB,"NDF",DRUG,22))
IF DATA
Begin DoDot:1
+8 DO CODE(.DATA,50.68)
+9 ;RXN text unreliable
SET $PIECE(DATA,U,2)=$PIECE($GET(@VPRVAP@(22)),U,2)
+10 if '$LENGTH($PIECE(DATA,U,3))
SET $PIECE(DATA,U,3)="VA50.68"
End DoDot:1
+11 IF 'DATA
SET DATA=DRUG_U_$GET(@VPRVAP@(.01))_"^VA50"
+12 QUIT
+13 ;
CODE(MED,FILE) ; -- convert MED=ien^name to national code
+1 ; Reset MED = code^name^system for RxNorm or VUID
+2 NEW Y
SET MED=$GET(MED)
SET FILE=+$GET(FILE)
+3 SET Y=$$CODE^VPRSDA(+MED,FILE,"RXN")
+4 IF Y=""
SET Y=$$VUID^VPRD(+MED,FILE)
if $LENGTH(Y)
SET Y=Y_U_$PIECE(MED,U,2)_"^VHAT"
+5 ;reset to nat'l code string
if $LENGTH(Y)
SET MED=Y
+6 QUIT
+7 ;
DOSES(IEN) ; -- build DLIST(n)=instance of Dose Instructions
+1 NEW DA,I
SET IEN=+$GET(IEN)
+2 SET DA=0
FOR
SET DA=$ORDER(^OR(100,IEN,4.5,"ID","INSTR",DA))
if DA<1
QUIT
Begin DoDot:1
+3 SET I=+$PIECE($GET(^OR(100,IEN,4.5,DA,0)),U,3)
+4 if I
SET DLIST(I)=I
End DoDot:1
+5 ; look for NVA w/schedule (dose not required)
+6 IF '$ORDER(DLIST(0))
IF $GET(PSTYPE)="N"
IF $ORDER(^OR(100,IEN,4.5,"ID","SCHEDULE",0))
SET DLIST(1)=1
+7 QUIT
+8 ;
BCMA(IEN,MAX) ; -- get list of most recent administrations for order
+1 NEW ORPK,ADT,DA,CNT,STS
+2 SET IEN=+$GET(IEN)
SET CNT=0
SET ADT=9999999
SET MAX=$GET(MAX,10)
+3 IF $GET(DFN)<1
SET DFN=+$PIECE($GET(^OR(100,IEN,0)),U,2)
if 'DFN
QUIT
+4 SET ORPK=$GET(^OR(100,IEN,4))
if ORPK=""
QUIT
+5 FOR
SET ADT=$ORDER(^PSB(53.79,"AORDX",DFN,ORPK,ADT),-1)
if ADT<1
QUIT
Begin DoDot:1
+6 SET DA=0
FOR
SET DA=+$ORDER(^PSB(53.79,"AORDX",DFN,ORPK,ADT,DA))
if DA<1
QUIT
Begin DoDot:2
+7 ;I $P($G(^PSB(53.79,DA,0)),U,9)="RM" Q ;REMOVED
+8 SET CNT=CNT+1
SET DLIST(CNT)=DA
End DoDot:2
End DoDot:1
if CNT'<MAX
QUIT
+9 QUIT
+10 ;
PSB ; -- VPR PSB EVENTS protocol listener (BCMA)
+1 NEW IEN,DFN,ORPK,ORIFN
+2 SET IEN=$SELECT($PIECE($GET(PSBIEN),",",2)'="":+$PIECE(PSBIEN,",",2),$GET(PSBIEN)="+1":+$GET(PSBIEN(1)),1:+$GET(PSBIEN))
+3 SET DFN=+$GET(^PSB(53.79,IEN,0))
SET ORPK=$PIECE($GET(^(.1)),U)
+4 if DFN<1
QUIT
if ORPK<1
QUIT
+5 SET ORIFN=$$PLACER^PSSUTLA1(DFN,ORPK)
+6 if ORIFN
DO POST^VPRHS(DFN,"Medication",+ORIFN_";100")
+7 QUIT
+8 ;
ADMSTS(DA) ; -- return the code^name of administration status
+1 NEW X,Y,Z,Z0
SET DA=+$GET(DA)
+2 SET Y=$PIECE($GET(PSB0),U,9)
SET X=""
IF Y="N"
Begin DoDot:1
+3 SET Z=""
FOR
SET Z=$ORDER(^PSB(53.79,DA,.9,Z),-1)
if 'Z
QUIT
SET Z0=$GET(^(Z,0))
Begin DoDot:2
+4 SET X=$PIECE(Z0,U,4)
if X=""
QUIT
+5 SET Y=$SELECT(X="REMOVED":"RM",1:$EXTRACT(X))
End DoDot:2
if $LENGTH(X)
QUIT
End DoDot:1
+6 IF X=""
SET X=$$EXTERNAL^DILFD(53.79,.09,,Y)
+7 if $LENGTH(X)
SET Y=Y_U_X
+8 QUIT Y
+9 ;
IV() ; -- Return 1 or 0, if order is for IV/infusion
+1 IF ORPK["V"
QUIT 1
+2 NEW X0,X
SET X0=$GET(^OR(100,ORIFN,0))
+3 IF +$PIECE(X0,U,5)=130
QUIT 1
+4 SET X=$PIECE($GET(^ORD(100.98,+$PIECE(X0,U,11),0)),U,3)
+5 IF X?1"IV".E
QUIT 1
+6 IF X="CI RX"
QUIT 1
+7 ;I $G(^TMP("PS",$J,"A",0))!$G(^TMP("PS",$J,"B",0)) Q 1
+8 QUIT 0
+9 ;
IVMEDS(IEN) ; -- build DLIST(#)=ien^amount^type[^bottle] for components
+1 NEW CNT,GBL,I,Y,ND
+2 SET ORPK=$GET(ORPK)
SET CNT=0
+3 SET GBL=$SELECT(ORPK["P":"^PS(53.1,",ORPK["U":"^PS(55,DFN,5,",1:"^PS(55,DFN,""IV"",")
+4 FOR I=0:0
SET I=$ORDER(@(GBL_+ORPK_",""SOL"","_I_")"))
if 'I
QUIT
Begin DoDot:1
+5 SET ND=$GET(@(GBL_+ORPK_",""SOL"","_I_",0)"))
+6 SET CNT=CNT+1
SET DLIST(CNT)=+ND_U_$PIECE(ND,U,2)_"^B"
End DoDot:1
+7 FOR I=0:0
SET I=$ORDER(@(GBL_+ORPK_",""AD"","_I_")"))
if 'I
QUIT
Begin DoDot:1
+8 SET ND=$GET(@(GBL_+ORPK_",""AD"","_I_",0)"))
SET Y=+ND_U_$PIECE(ND,U,2)_"^A"
+9 if $LENGTH($PIECE(ND,U,3))
SET Y=Y_U_$PIECE(ND,U,3)
+10 SET CNT=CNT+1
SET DLIST(CNT)=Y
End DoDot:1
+11 QUIT
+12 ;
IV1(X) ; -- get VA Drug Product info for IV component X (from DLIST)
+1 ; Returns VPRPSIV = ien^name^amt^type^bottle#
+2 NEW IEN,TYPE,NAME,DRUG
+3 ;ien^amt^type[^bottle#] from IVMEDS
SET VPRPSIV=$GET(X)
+4 SET IEN=+VPRPSIV
SET TYPE=$PIECE(VPRPSIV,U,3)
+5 if TYPE="B"
DO ZERO^PSS52P7(IEN,"","","VPRPSIV")
+6 if TYPE="A"
DO ZERO^PSS52P6(IEN,"","","VPRPSIV")
+7 SET NAME=$GET(^TMP($JOB,"VPRPSIV",IEN,.01))
SET DRUG=+$GET(^(1))
+8 SET VPRPSIV=IEN_U_NAME_U_$PIECE(VPRPSIV,U,2,99)
+9 ;#50 ien
SET X=+$GET(DRUG)
if DRUG
DO NDF^VPRSDAP(DRUG)
+10 ;return IV file instead
IF 'DRUG
Begin DoDot:1
+11 SET DATA=IEN_U_NAME_U_$SELECT(TYPE="A":"VA52.6",TYPE="B":"VA52.7",1:"VA")
+12 SET VPRVAP=$NAME(^TMP("VPRX",$JOB,"NDF",0))
End DoDot:1
+13 KILL ^TMP($JOB,"VPRPSIV")
+14 QUIT
+15 ;
IVRATE(IEN) ; -- return IV Rate, or DDEOUT if invalid
+1 ; also VPRATE = numeric amount, if ## ml/hr
+2 IF $GET(PSTYPE)'="V"
SET DDEOUT=1
QUIT ""
+3 NEW X
SET IEN=+$GET(IEN)
+4 SET X=$$VALUE^ORX8(IEN,"RATE")
+5 IF X?1.N1" ml/hr".E
SET VPRATE=+X
QUIT +X
+6 SET DDEOUT=1
+7 QUIT ""
+8 ;
IVTYPE(IEN) ; -- return IV Type, or DDEOUT if invalid
+1 IF $GET(PSTYPE)'="V"
SET DDEOUT=1
QUIT ""
+2 NEW X,Y,ORPK,FN,FLD,IENS
+3 SET IEN=+$GET(IEN)
SET Y=""
SET ORPK=$GET(^OR(100,IEN,4))
+4 IF ORPK["P"
SET FN=53.1
SET FLD=53
SET IENS=+ORPK
+5 IF '$TEST
SET FN=55.01
SET FLD=.04
SET IENS=+ORPK_","_DFN
+6 SET Y=$$GET1^DIQ(FN,IENS_",",FLD)
+7 QUIT Y
