VPRDJ05 ;SLC/MKB -- Medications by order ;8/2/11 15:29
;;1.0;VIRTUAL PATIENT RECORD;**2,18,33**;Sep 01, 2011;Build 8
;;Per VHA Directive 2004-038, this routine should not be modified.
;
; External References: see VPRDJ05V for DBIA list
;
; All tags expect DFN, ID, [VPRSTART, VPRSTOP, VPRMAX, VPRTEXT]
;
PS1(ID) ; -- med order
N ORPK,TYPE S ID=+$G(ID)
I '$$RX^VPRDPSOR(ID) Q ; p33 make sure this is really a med order
S ORPK=$$PKGID^ORX8(ID),TYPE=$E(ORPK,$L(ORPK)) S:TYPE=+TYPE TYPE="R"
;
N ORUPCHUK,ORVP,ORPCL,ORDUZ,ORODT,ORSTRT,ORSTOP,ORL,ORTO,ORSTS,ORNP,ORPV,ORTX
N MED,CLS,OI,X,LOC,FAC,DRUG,DA,CNT,VPRESP
S X=$S(ORPK:$E(ORPK,$L(ORPK)),1:"Z") S:X=+X X="R" ;last char = PS file
S CLS=$S("RSN"[X:"O","UV"[X:"I",1:$$GETCLS) ; p18 added package check in new function
S MED("uid")=$$SETUID^VPRUTILS("med",DFN,ID)
S MED("orders",1,"orderUid")=$$SETUID^VPRUTILS("order",DFN,ID)
S X=$$GET1^DIQ(100,ID_",",9,"I") S:X MED("orders",1,"predecessor")=$$SETUID^VPRUTILS("med",DFN,+X)
S X=$$GET1^DIQ(100,ID_",",9.1,"I") S:X MED("orders",1,"successor")=$$SETUID^VPRUTILS("med",DFN,+X)
S:ORPK MED("localId")=ORPK_";"_CLS
D EN^ORX8(ID) S X="" F S X=$O(ORUPCHUK(X)) Q:X="" S:$D(ORUPCHUK(X))#2 @X=ORUPCHUK(X)
S:$G(ORODT) MED("orders",1,"ordered")=$$JSONDT^VPRUTILS(ORODT)
S:$G(ORNP) MED("orders",1,"providerUid")=$$SETUID^VPRUTILS("user",,+ORNP),MED("orders",1,"providerName")=$P(ORNP,U,2)
S LOC=+$G(ORL),FAC=$$FAC^VPRD(LOC) I LOC D
. S MED("orders",1,"locationUid")=$$SETUID^VPRUTILS("location",,LOC)
. S MED("orders",1,"locationName")=$P(^SC(LOC,0),U)
D FACILITY^VPRUTILS(FAC,"MED")
S:$G(ORSTRT) MED("overallStart")=$$JSONDT^VPRUTILS(ORSTRT)
S:$G(ORSTOP) (MED("stopped"),MED("overallStop"))=$$JSONDT^VPRUTILS(ORSTOP)
S MED("vaStatus")=$P($G(ORSTS),U,2)
S MED("medStatusName")=$$STATUS^VPRDPSOR(+$G(ORSTS))
S MED("medStatus")=$$MEDSTAT^VPRDJ05V(MED("medStatusName"))
I CLS="I" D
. S:$P($G(^SC(+$G(LOC),0)),U,25) MED("IMO")="true"
. S X=$P($G(^OR(100,ID,3)),U,9) S:X MED("parent")=X
I ORPK D OEL^PSOORRL(DFN,ORPK_";"_CLS)
S X=$S(ORPK["N":"N",1:CLS),MED("vaType")=X,MED("medType")=$$TYPE^VPRDJ05V(X)
I CLS="O" S MED("type")=$S(ORPK["N":"OTC",1:"Prescription")
S X=$G(VPRESP("COMMENT",1)) S:$L(X) MED("comment")=X
I $$ISIV^VPRDJ05V G IV1^VPRDJ05V
;
A ; - Get order responses
S OI=$$OI^ORX8(ID) I OI D
. S X=$P(OI,U,2) S:$E(X,$L(X))=" " X=$E(X,1,$L(X)-1)
. S MED("name")=X
. D ZERO^PSS50P7(+$P(OI,U,3),,,"PSOI")
. S MED("productFormName")=$P($G(^TMP($J,"PSOI",+$P(OI,U,3),.02)),U,2)
. S:+$G(^TMP($J,"PSOI",+$P(OI,U,3),.09)) MED("supply")="true"
D RESP^VPRDPSOR(ID,.VPRESP) ;order responses
S DRUG=+$G(^TMP("PS",$J,"DD",1,0)) S:'DRUG DRUG=+$G(VPRESP("DRUG",1))
S MED("sig")=$S(CLS="I":"Give: ",1:"")_$G(VPRESP("SIG",1)) ;ORTX(2)
I CLS="O",'$L($G(VPRESP("SIG",1))),'$D(VPRESP("INSTR")) S MED("sig")=$G(VPRESP("COMMENT",1)) ;old Rx
;
B ; - Get dosages
I '$O(^OR(100,ID,2,0)) D ;single dose or OP
. N VPRY,START,STOP,DUR,CONJ,MIN
. S START=$G(ORSTRT),STOP=$G(ORSTOP),MIN=0
. S CNT=0 F S CNT=$O(VPRESP("INSTR",CNT)) Q:CNT<1 D
.. K VPRY D DOSE(.VPRY,CNT) M MED("dosages",CNT)=VPRY
.. ;determine start & stop per dose
.. S MED("dosages",CNT,"relativeStart")=MIN
.. S DUR=$G(VPRY("complexDuration")),CONJ=$G(VPRY("complexConjunction"))
.. S STOP=$S(DUR:$$STOP(START,DUR),1:STOP)
.. S:START MED("dosages",CNT,"start")=$$JSONDT^VPRUTILS(START)
.. S:STOP MED("dosages",CNT,"stop")=$$JSONDT^VPRUTILS(STOP)
.. S X=$$RELTIME(START,STOP,DUR,MIN),MED("dosages",CNT,"relativeStop")=$S($E(X)=".":0_X,1:X)
.. I $E(CONJ)="T",DUR S START=STOP,MIN=X
I $O(^OR(100,ID,2,0)) D
. N DD,CONJ,VPRY,MIN
. M CONJ=VPRESP("CONJ"),DUR=VPRESP("DAYS") S MIN=0
. S (DA,CNT)=0 F S DA=$O(^OR(100,ID,2,DA)) Q:DA<1 D ;child orders
.. K VPRESP,VPRY D RESP^VPRDPSOR(DA,.VPRESP),DOSE(.VPRY,1)
.. S CNT=CNT+1 M MED("dosages",CNT)=VPRY
.. S MED("dosages",CNT,"relativeStart")=MIN
.. S MED("dosages",CNT,"complexConjunction")=$G(CONJ(CNT))
.. S MED("dosages",CNT,"complexDuration")=$G(DUR(CNT))
.. S MED("dosages",CNT,"relatedOrder")=DA
.. S X=$P($G(^OR(100,DA,0)),U,8,9)
.. S:$P(X,U) MED("dosages",CNT,"start")=$$JSONDT^VPRUTILS($P(X,U))
.. S:$P(X,U,2) MED("dosages",CNT,"stop")=$$JSONDT^VPRUTILS($P(X,U,2))
.. I $P(X,U,2)>$G(ORSTOP) S ORSTOP=$P(X,U,2) ;get last stop time
.. S X=$$RELTIME($P(X,U),$P(X,U,2),$G(DUR(CNT)),MIN)
.. S MED("dosages",CNT,"relativeStop")=$S($E(X)=".":0_X,1:X) S:$G(CONJ(CNT))="T" MIN=X
.. S:'DRUG DD=+$G(VPRESP("DRUG",1)),DD(DD,DA)="" ;dispense drug(s)
.. ; get ^TMP("PS",$J) from 1st child, if Inpt parent:
.. I '$D(^TMP("PS",$J)) S ORPK=$$PKGID^ORX8(DA) D OEL^PSOORRL(DFN,ORPK_";"_CLS)
. S MED("stopped")=$$JSONDT^VPRUTILS($G(ORSTOP)) ;reset from last child order
. S DD=$O(DD(0)) I DD,'$O(DD(DD)) S DRUG=DD Q ;1 drug for order
. S (DD,CNT)=0 F S DD=$O(DD(DD)) Q:DD<1 S DA=0 F S DA=$O(DD(DD,DA)) Q:DA<1 S CNT=CNT+1 D NDF(DD,CNT,DA)
;
C ; - Get OP data
I CLS="O",ORPK'["N" D
. S MED("orders",1,"quantityOrdered")=$G(VPRESP("QTY",1))
. S MED("orders",1,"daysSupply")=$G(VPRESP("SUPPLY",1))
. S MED("orders",1,"vaRouting")=$G(VPRESP("PICKUP",1))
. S MED("orders",1,"fillsAllowed")=$G(VPRESP("REFILLS",1))
. S MED("patientInstruction")=$G(VPRESP("PI",1))
. Q:ORPK["P"!(ORPK["S") ;pending
. N VPR,RX0,RX1,FILL,RFD,MW,REL
. K ^TMP("PSOR",$J) D EN^PSOORDER(DFN,+ORPK)
. S RX0=$G(^TMP("PSOR",$J,+ORPK,0)),RX1=$G(^(1)),MED("orders",1,"prescriptionId")=$P(RX0,U,5)
. I '$G(VPRESP("QTY",1)) S MED("orders",1,"quantityOrdered")=$P(RX0,U,6)
. I '$G(VPRESP("SUPPLY",1)) S MED("orders",1,"daysSupply")=$P(RX0,U,7)
. S MED("orders",1,"fillsRemaining")=$P(RX0,U,9),MED("lastFilled")=$$JSONDT^VPRUTILS($P(RX0,U,3))
. S I=$P(RX0,U,2) I I S FILL(I)=I_"^^^"_$P(RX0,U,6,7)_"^^^"_$P(RX0,U,13)_"^^"_$P(RX1,U,6) ;original fill
. S I=0 F S I=$O(^TMP("PSOR",$J,+ORPK,"REF",I)) Q:I<1 S X=$G(^(I,0)),FILL(+X)=X
. S I=0 F S I=$O(^TMP("PSOR",$J,+ORPK,"RPAR",I)) Q:I<1 S X=$G(^(I,0)),$P(X,U,14)=1,FILL(+X)=X
. S (I,RFD)=0 F S RFD=$O(FILL(RFD)) Q:RFD<1 S X=$G(FILL(RFD)) D ;sort 1st
.. S I=I+1,MW=$P($P(X,U,10),";"),REL=$P($P(X,U,8),".")
.. S MED("fills",I,"dispenseDate")=$$JSONDT^VPRUTILS($P(RFD,"."))
.. S MED("fills",I,"releaseDate")=$$JSONDT^VPRUTILS(REL)
.. S MED("fills",I,"routing")=MW
.. S MED("fills",I,"quantityDispensed")=$P(X,U,4)
.. S MED("fills",I,"daysSupplyDispensed")=$P(X,U,5)
.. S:$P(X,U,14) MED("fills",I,"partial")=1 ;"true"
. S X=$S($P(RX0,U,11):$P(RX0,U,11),$P(RX0,U,10):$P(RX0,U,10),1:0)
. S:X MED("orders",1,"fillCost")=X
. S X=$$GET1^PSODI(52,+ORPK_",",26,"I") S:X MED("overallStop")=$$JSONDT^VPRUTILS($P(X,U,2)) ;1^expirationDate
I CLS="I" D
. S X=$$GET1^DIQ(55.06,+ORPK_","_DFN_",",25,"I")
. S:X MED("overallStop")=$$JSONDT^VPRUTILS(X)
. D BCMA^VPRDJ05V(.MED,DFN,ORPK)
;
PSQ ; finish
D:DRUG NDF(+DRUG)
S MED("qualifiedName")=$G(MED("name"))
S X=+$P($G(^TMP("PS",$J,"RXN",0)),U,5)
S:X MED("orders",1,"pharmacistUid")=$$SETUID^VPRUTILS("user",,X),MED("orders",1,"pharmacistName")=$P($G(^VA(200,X,0)),U)
K ^TMP("PS",$J),^TMP($J,"PSOI"),^TMP("PSOR",$J)
D ADD^VPRDJ("MED","med")
Q
;
DOSE(Y,N) ; -- return dosage data from VPRESP(ID,N) to Y("name")
N X,DUR,CONJ S N=+$G(N,1) K Y
S X=$P($G(VPRESP("DOSE",N)),"&",1,2) ; units per dose + noun
S Y("dose")=$S($L(X)>2:$TR(X,"&"," "),1:$P(X,"&"))
S Y("units")=$P(X,"&",2)
S X=+$G(VPRESP("ROUTE",N)) D ALL^PSS51P2(X,,,,"VPRTE")
S Y("routeName")=$G(^TMP($J,"VPRTE",X,1))
S X=$G(VPRESP("SCHEDULE",N)) I $L(X) S Y("scheduleName")=X D SCH^VPRDJ05V(X)
S X=$G(VPRESP("ADMIN",N)) S:$L(X) Y("adminTimes")=X
S X=$G(VPRESP("DAYS",N)) S:$L(X) Y("complexDuration")=X,DUR=X
S X=$G(VPRESP("CONJ",N)) S:$L(X) Y("complexConjunction")=X,CONJ=X
I $L($G(CONJ)),'$L($G(DUR)) D ;look ahead to find duration
. N I,D S I=$O(VPRESP("DAYS",N)),D=$S(I:$G(VPRESP("DAYS",I)),1:"")
. S:$L(D) Y("complexDuration")=D
K ^TMP($J,"VPRTE")
Q
;
STOP(BEG,X) ; -- Return date after adding X to BEG
N D,H,M,UNT,Y
S Y=BEG,(D,H,M)=0,UNT=$P(X,+X,2),X=+X
S UNT=$S($E(UNT)=" ":$E(UNT,2),1:$E(UNT)) I UNT="" S UNT="D"
S:UNT="L" D=30*X
S:UNT="W" D=7*X
S:UNT="D" D=X
S:UNT="H" H=X
S:UNT="M" M=X
S Y=$$FMADD^XLFDT(BEG,D,H,M)
Q Y
;
NDF(DRUG,VPI,ORD) ; -- Set NDF data for dispense DRUG ien
; code ^ name ^ vuid [^ role ^ concentration ^ order]
N LEN,VPRX,STR,VUID,X,I
S DRUG=+$G(DRUG) Q:'DRUG
D EN^PSSDI(50,,50,"901;902",DRUG,"VPRX")
S STR=$S($G(VPRX(50,DRUG,901)):$G(VPRX(50,DRUG,901))_" "_$G(VPRX(50,DRUG,902)),1:"")
D NDF^PSS50(DRUG,,,,,"NDF") S VPI=+$G(VPI,1)
;
S MED("products",VPI,"ingredientRole")="urn:sct:410942007" ;Drug
S:$G(ORD) MED("products",VPI,"relatedOrder")=ORD
S:$G(STR) MED("products",VPI,"strength")=STR
S X=$G(MED("name")) S:$L(X) MED("products",VPI,"ingredientName")=X
;
S X=$G(^TMP($J,"NDF",DRUG,20)) ;VA Generic
S MED("products",VPI,"ingredientCode")="urn:va:vuid:"_$$VUID^VPRD(+X,50.6)
S MED("products",VPI,"ingredientCodeName")=$P(X,U,2)
;
S X=$G(^TMP($J,"NDF",DRUG,22)) ;VA Product
S MED("products",VPI,"suppliedCode")="urn:va:vuid:"_$$VUID^VPRD(+X,50.68)
S MED("products",VPI,"suppliedName")=$P(X,U,2)
;
S X=$G(^TMP($J,"NDF",DRUG,25)) ;VA Drug Class
S MED("products",VPI,"drugClassCode")="urn:vadc:"_$P(X,U,2)
S MED("products",VPI,"drugClassName")=$P(X,U,3)
;
K ^TMP($J,"NDF")
Q
;
RELTIME(START,STOP,DUR,MIN) ; -- Return #min for dose
N Y S Y=0
I START>0,STOP>0 S Y=$$FMDIFF^XLFDT(STOP,START,2)\60 I 1
E I DUR S Y=$$TOMIN(DUR) I 1
E S Y=$G(VPRESP("SUPPLY",1))*1440
S Y=$S(Y:Y+MIN,1:MIN)
Q Y
;
TOMIN(DUR) ;
N RESULT,TIME,UNIT
S UNIT=$$UP^XLFSTR($E($P(DUR," ",2)))
I UNIT="" Q 0
S TIME=$P(DUR," ")
S RESULT=$S(UNIT="M":TIME,UNIT="H":TIME*60,UNIT="D":TIME*1440,UNIT="W":TIME*10080,UNIT="L":TIME*43200,1:0)
Q RESULT
GETCLS() ; p18 added package check
N PKGIEN S PKGIEN=$$GET1^DIQ(100,ID_",",12,"I")
I $P($G(^DIC(9.4,PKGIEN,0)),U)="INPATIENT MEDICATIONS" Q "I"
I $P($G(^DIC(9.4,PKGIEN,0)),U)="OUTPATIENT PHARMACY" Q "O"
Q $$GET1^DIQ(100,ID_",",10,"I")
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVPRDJ05 10161 printed Sep 23, 2025@20:21:01 Page 2
VPRDJ05 ;SLC/MKB -- Medications by order ;8/2/11 15:29
+1 ;;1.0;VIRTUAL PATIENT RECORD;**2,18,33**;Sep 01, 2011;Build 8
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 ; External References: see VPRDJ05V for DBIA list
+5 ;
+6 ; All tags expect DFN, ID, [VPRSTART, VPRSTOP, VPRMAX, VPRTEXT]
+7 ;
PS1(ID) ; -- med order
+1 NEW ORPK,TYPE
SET ID=+$GET(ID)
+2 ; p33 make sure this is really a med order
IF '$$RX^VPRDPSOR(ID)
QUIT
+3 SET ORPK=$$PKGID^ORX8(ID)
SET TYPE=$EXTRACT(ORPK,$LENGTH(ORPK))
if TYPE=+TYPE
SET TYPE="R"
+4 ;
+5 NEW ORUPCHUK,ORVP,ORPCL,ORDUZ,ORODT,ORSTRT,ORSTOP,ORL,ORTO,ORSTS,ORNP,ORPV,ORTX
+6 NEW MED,CLS,OI,X,LOC,FAC,DRUG,DA,CNT,VPRESP
+7 ;last char = PS file
SET X=$SELECT(ORPK:$EXTRACT(ORPK,$LENGTH(ORPK)),1:"Z")
if X=+X
SET X="R"
+8 ; p18 added package check in new function
SET CLS=$SELECT("RSN"[X:"O","UV"[X:"I",1:$$GETCLS)
+9 SET MED("uid")=$$SETUID^VPRUTILS("med",DFN,ID)
+10 SET MED("orders",1,"orderUid")=$$SETUID^VPRUTILS("order",DFN,ID)
+11 SET X=$$GET1^DIQ(100,ID_",",9,"I")
if X
SET MED("orders",1,"predecessor")=$$SETUID^VPRUTILS("med",DFN,+X)
+12 SET X=$$GET1^DIQ(100,ID_",",9.1,"I")
if X
SET MED("orders",1,"successor")=$$SETUID^VPRUTILS("med",DFN,+X)
+13 if ORPK
SET MED("localId")=ORPK_";"_CLS
+14 DO EN^ORX8(ID)
SET X=""
FOR
SET X=$ORDER(ORUPCHUK(X))
if X=""
QUIT
if $DATA(ORUPCHUK(X))#2
SET @X=ORUPCHUK(X)
+15 if $GET(ORODT)
SET MED("orders",1,"ordered")=$$JSONDT^VPRUTILS(ORODT)
+16 if $GET(ORNP)
SET MED("orders",1,"providerUid")=$$SETUID^VPRUTILS("user",,+ORNP)
SET MED("orders",1,"providerName")=$PIECE(ORNP,U,2)
+17 SET LOC=+$GET(ORL)
SET FAC=$$FAC^VPRD(LOC)
IF LOC
Begin DoDot:1
+18 SET MED("orders",1,"locationUid")=$$SETUID^VPRUTILS("location",,LOC)
+19 SET MED("orders",1,"locationName")=$PIECE(^SC(LOC,0),U)
End DoDot:1
+20 DO FACILITY^VPRUTILS(FAC,"MED")
+21 if $GET(ORSTRT)
SET MED("overallStart")=$$JSONDT^VPRUTILS(ORSTRT)
+22 if $GET(ORSTOP)
SET (MED("stopped"),MED("overallStop"))=$$JSONDT^VPRUTILS(ORSTOP)
+23 SET MED("vaStatus")=$PIECE($GET(ORSTS),U,2)
+24 SET MED("medStatusName")=$$STATUS^VPRDPSOR(+$GET(ORSTS))
+25 SET MED("medStatus")=$$MEDSTAT^VPRDJ05V(MED("medStatusName"))
+26 IF CLS="I"
Begin DoDot:1
+27 if $PIECE($GET(^SC(+$GET(LOC),0)),U,25)
SET MED("IMO")="true"
+28 SET X=$PIECE($GET(^OR(100,ID,3)),U,9)
if X
SET MED("parent")=X
End DoDot:1
+29 IF ORPK
DO OEL^PSOORRL(DFN,ORPK_";"_CLS)
+30 SET X=$SELECT(ORPK["N":"N",1:CLS)
SET MED("vaType")=X
SET MED("medType")=$$TYPE^VPRDJ05V(X)
+31 IF CLS="O"
SET MED("type")=$SELECT(ORPK["N":"OTC",1:"Prescription")
+32 SET X=$GET(VPRESP("COMMENT",1))
if $LENGTH(X)
SET MED("comment")=X
+33 IF $$ISIV^VPRDJ05V
GOTO IV1^VPRDJ05V
+34 ;
A ; - Get order responses
+1 SET OI=$$OI^ORX8(ID)
IF OI
Begin DoDot:1
+2 SET X=$PIECE(OI,U,2)
if $EXTRACT(X,$LENGTH(X))=" "
SET X=$EXTRACT(X,1,$LENGTH(X)-1)
+3 SET MED("name")=X
+4 DO ZERO^PSS50P7(+$PIECE(OI,U,3),,,"PSOI")
+5 SET MED("productFormName")=$PIECE($GET(^TMP($JOB,"PSOI",+$PIECE(OI,U,3),.02)),U,2)
+6 if +$GET(^TMP($JOB,"PSOI",+$PIECE(OI,U,3),.09))
SET MED("supply")="true"
End DoDot:1
+7 ;order responses
DO RESP^VPRDPSOR(ID,.VPRESP)
+8 SET DRUG=+$GET(^TMP("PS",$JOB,"DD",1,0))
if 'DRUG
SET DRUG=+$GET(VPRESP("DRUG",1))
+9 ;ORTX(2)
SET MED("sig")=$SELECT(CLS="I":"Give: ",1:"")_$GET(VPRESP("SIG",1))
+10 ;old Rx
IF CLS="O"
IF '$LENGTH($GET(VPRESP("SIG",1)))
IF '$DATA(VPRESP("INSTR"))
SET MED("sig")=$GET(VPRESP("COMMENT",1))
+11 ;
B ; - Get dosages
+1 ;single dose or OP
IF '$ORDER(^OR(100,ID,2,0))
Begin DoDot:1
+2 NEW VPRY,START,STOP,DUR,CONJ,MIN
+3 SET START=$GET(ORSTRT)
SET STOP=$GET(ORSTOP)
SET MIN=0
+4 SET CNT=0
FOR
SET CNT=$ORDER(VPRESP("INSTR",CNT))
if CNT<1
QUIT
Begin DoDot:2
+5 KILL VPRY
DO DOSE(.VPRY,CNT)
MERGE MED("dosages",CNT)=VPRY
+6 ;determine start & stop per dose
+7 SET MED("dosages",CNT,"relativeStart")=MIN
+8 SET DUR=$GET(VPRY("complexDuration"))
SET CONJ=$GET(VPRY("complexConjunction"))
+9 SET STOP=$SELECT(DUR:$$STOP(START,DUR),1:STOP)
+10 if START
SET MED("dosages",CNT,"start")=$$JSONDT^VPRUTILS(START)
+11 if STOP
SET MED("dosages",CNT,"stop")=$$JSONDT^VPRUTILS(STOP)
+12 SET X=$$RELTIME(START,STOP,DUR,MIN)
SET MED("dosages",CNT,"relativeStop")=$SELECT($EXTRACT(X)=".":0_X,1:X)
+13 IF $EXTRACT(CONJ)="T"
IF DUR
SET START=STOP
SET MIN=X
End DoDot:2
End DoDot:1
+14 IF $ORDER(^OR(100,ID,2,0))
Begin DoDot:1
+15 NEW DD,CONJ,VPRY,MIN
+16 MERGE CONJ=VPRESP("CONJ"),DUR=VPRESP("DAYS")
SET MIN=0
+17 ;child orders
SET (DA,CNT)=0
FOR
SET DA=$ORDER(^OR(100,ID,2,DA))
if DA<1
QUIT
Begin DoDot:2
+18 KILL VPRESP,VPRY
DO RESP^VPRDPSOR(DA,.VPRESP)
DO DOSE(.VPRY,1)
+19 SET CNT=CNT+1
MERGE MED("dosages",CNT)=VPRY
+20 SET MED("dosages",CNT,"relativeStart")=MIN
+21 SET MED("dosages",CNT,"complexConjunction")=$GET(CONJ(CNT))
+22 SET MED("dosages",CNT,"complexDuration")=$GET(DUR(CNT))
+23 SET MED("dosages",CNT,"relatedOrder")=DA
+24 SET X=$PIECE($GET(^OR(100,DA,0)),U,8,9)
+25 if $PIECE(X,U)
SET MED("dosages",CNT,"start")=$$JSONDT^VPRUTILS($PIECE(X,U))
+26 if $PIECE(X,U,2)
SET MED("dosages",CNT,"stop")=$$JSONDT^VPRUTILS($PIECE(X,U,2))
+27 ;get last stop time
IF $PIECE(X,U,2)>$GET(ORSTOP)
SET ORSTOP=$PIECE(X,U,2)
+28 SET X=$$RELTIME($PIECE(X,U),$PIECE(X,U,2),$GET(DUR(CNT)),MIN)
+29 SET MED("dosages",CNT,"relativeStop")=$SELECT($EXTRACT(X)=".":0_X,1:X)
if $GET(CONJ(CNT))="T"
SET MIN=X
+30 ;dispense drug(s)
if 'DRUG
SET DD=+$GET(VPRESP("DRUG",1))
SET DD(DD,DA)=""
+31 ; get ^TMP("PS",$J) from 1st child, if Inpt parent:
+32 IF '$DATA(^TMP("PS",$JOB))
SET ORPK=$$PKGID^ORX8(DA)
DO OEL^PSOORRL(DFN,ORPK_";"_CLS)
End DoDot:2
+33 ;reset from last child order
SET MED("stopped")=$$JSONDT^VPRUTILS($GET(ORSTOP))
+34 ;1 drug for order
SET DD=$ORDER(DD(0))
IF DD
IF '$ORDER(DD(DD))
SET DRUG=DD
QUIT
+35 SET (DD,CNT)=0
FOR
SET DD=$ORDER(DD(DD))
if DD<1
QUIT
SET DA=0
FOR
SET DA=$ORDER(DD(DD,DA))
if DA<1
QUIT
SET CNT=CNT+1
DO NDF(DD,CNT,DA)
End DoDot:1
+36 ;
C ; - Get OP data
+1 IF CLS="O"
IF ORPK'["N"
Begin DoDot:1
+2 SET MED("orders",1,"quantityOrdered")=$GET(VPRESP("QTY",1))
+3 SET MED("orders",1,"daysSupply")=$GET(VPRESP("SUPPLY",1))
+4 SET MED("orders",1,"vaRouting")=$GET(VPRESP("PICKUP",1))
+5 SET MED("orders",1,"fillsAllowed")=$GET(VPRESP("REFILLS",1))
+6 SET MED("patientInstruction")=$GET(VPRESP("PI",1))
+7 ;pending
if ORPK["P"!(ORPK["S")
QUIT
+8 NEW VPR,RX0,RX1,FILL,RFD,MW,REL
+9 KILL ^TMP("PSOR",$JOB)
DO EN^PSOORDER(DFN,+ORPK)
+10 SET RX0=$GET(^TMP("PSOR",$JOB,+ORPK,0))
SET RX1=$GET(^(1))
SET MED("orders",1,"prescriptionId")=$PIECE(RX0,U,5)
+11 IF '$GET(VPRESP("QTY",1))
SET MED("orders",1,"quantityOrdered")=$PIECE(RX0,U,6)
+12 IF '$GET(VPRESP("SUPPLY",1))
SET MED("orders",1,"daysSupply")=$PIECE(RX0,U,7)
+13 SET MED("orders",1,"fillsRemaining")=$PIECE(RX0,U,9)
SET MED("lastFilled")=$$JSONDT^VPRUTILS($PIECE(RX0,U,3))
+14 ;original fill
SET I=$PIECE(RX0,U,2)
IF I
SET FILL(I)=I_"^^^"_$PIECE(RX0,U,6,7)_"^^^"_$PIECE(RX0,U,13)_"^^"_$PIECE(RX1,U,6)
+15 SET I=0
FOR
SET I=$ORDER(^TMP("PSOR",$JOB,+ORPK,"REF",I))
if I<1
QUIT
SET X=$GET(^(I,0))
SET FILL(+X)=X
+16 SET I=0
FOR
SET I=$ORDER(^TMP("PSOR",$JOB,+ORPK,"RPAR",I))
if I<1
QUIT
SET X=$GET(^(I,0))
SET $PIECE(X,U,14)=1
SET FILL(+X)=X
+17 ;sort 1st
SET (I,RFD)=0
FOR
SET RFD=$ORDER(FILL(RFD))
if RFD<1
QUIT
SET X=$GET(FILL(RFD))
Begin DoDot:2
+18 SET I=I+1
SET MW=$PIECE($PIECE(X,U,10),";")
SET REL=$PIECE($PIECE(X,U,8),".")
+19 SET MED("fills",I,"dispenseDate")=$$JSONDT^VPRUTILS($PIECE(RFD,"."))
+20 SET MED("fills",I,"releaseDate")=$$JSONDT^VPRUTILS(REL)
+21 SET MED("fills",I,"routing")=MW
+22 SET MED("fills",I,"quantityDispensed")=$PIECE(X,U,4)
+23 SET MED("fills",I,"daysSupplyDispensed")=$PIECE(X,U,5)
+24 ;"true"
if $PIECE(X,U,14)
SET MED("fills",I,"partial")=1
End DoDot:2
+25 SET X=$SELECT($PIECE(RX0,U,11):$PIECE(RX0,U,11),$PIECE(RX0,U,10):$PIECE(RX0,U,10),1:0)
+26 if X
SET MED("orders",1,"fillCost")=X
+27 ;1^expirationDate
SET X=$$GET1^PSODI(52,+ORPK_",",26,"I")
if X
SET MED("overallStop")=$$JSONDT^VPRUTILS($PIECE(X,U,2))
End DoDot:1
+28 IF CLS="I"
Begin DoDot:1
+29 SET X=$$GET1^DIQ(55.06,+ORPK_","_DFN_",",25,"I")
+30 if X
SET MED("overallStop")=$$JSONDT^VPRUTILS(X)
+31 DO BCMA^VPRDJ05V(.MED,DFN,ORPK)
End DoDot:1
+32 ;
PSQ ; finish
+1 if DRUG
DO NDF(+DRUG)
+2 SET MED("qualifiedName")=$GET(MED("name"))
+3 SET X=+$PIECE($GET(^TMP("PS",$JOB,"RXN",0)),U,5)
+4 if X
SET MED("orders",1,"pharmacistUid")=$$SETUID^VPRUTILS("user",,X)
SET MED("orders",1,"pharmacistName")=$PIECE($GET(^VA(200,X,0)),U)
+5 KILL ^TMP("PS",$JOB),^TMP($JOB,"PSOI"),^TMP("PSOR",$JOB)
+6 DO ADD^VPRDJ("MED","med")
+7 QUIT
+8 ;
DOSE(Y,N) ; -- return dosage data from VPRESP(ID,N) to Y("name")
+1 NEW X,DUR,CONJ
SET N=+$GET(N,1)
KILL Y
+2 ; units per dose + noun
SET X=$PIECE($GET(VPRESP("DOSE",N)),"&",1,2)
+3 SET Y("dose")=$SELECT($LENGTH(X)>2:$TRANSLATE(X,"&"," "),1:$PIECE(X,"&"))
+4 SET Y("units")=$PIECE(X,"&",2)
+5 SET X=+$GET(VPRESP("ROUTE",N))
DO ALL^PSS51P2(X,,,,"VPRTE")
+6 SET Y("routeName")=$GET(^TMP($JOB,"VPRTE",X,1))
+7 SET X=$GET(VPRESP("SCHEDULE",N))
IF $LENGTH(X)
SET Y("scheduleName")=X
DO SCH^VPRDJ05V(X)
+8 SET X=$GET(VPRESP("ADMIN",N))
if $LENGTH(X)
SET Y("adminTimes")=X
+9 SET X=$GET(VPRESP("DAYS",N))
if $LENGTH(X)
SET Y("complexDuration")=X
SET DUR=X
+10 SET X=$GET(VPRESP("CONJ",N))
if $LENGTH(X)
SET Y("complexConjunction")=X
SET CONJ=X
+11 ;look ahead to find duration
IF $LENGTH($GET(CONJ))
IF '$LENGTH($GET(DUR))
Begin DoDot:1
+12 NEW I,D
SET I=$ORDER(VPRESP("DAYS",N))
SET D=$SELECT(I:$GET(VPRESP("DAYS",I)),1:"")
+13 if $LENGTH(D)
SET Y("complexDuration")=D
End DoDot:1
+14 KILL ^TMP($JOB,"VPRTE")
+15 QUIT
+16 ;
STOP(BEG,X) ; -- Return date after adding X to BEG
+1 NEW D,H,M,UNT,Y
+2 SET Y=BEG
SET (D,H,M)=0
SET UNT=$PIECE(X,+X,2)
SET X=+X
+3 SET UNT=$SELECT($EXTRACT(UNT)=" ":$EXTRACT(UNT,2),1:$EXTRACT(UNT))
IF UNT=""
SET UNT="D"
+4 if UNT="L"
SET D=30*X
+5 if UNT="W"
SET D=7*X
+6 if UNT="D"
SET D=X
+7 if UNT="H"
SET H=X
+8 if UNT="M"
SET M=X
+9 SET Y=$$FMADD^XLFDT(BEG,D,H,M)
+10 QUIT Y
+11 ;
NDF(DRUG,VPI,ORD) ; -- Set NDF data for dispense DRUG ien
+1 ; code ^ name ^ vuid [^ role ^ concentration ^ order]
+2 NEW LEN,VPRX,STR,VUID,X,I
+3 SET DRUG=+$GET(DRUG)
if 'DRUG
QUIT
+4 DO EN^PSSDI(50,,50,"901;902",DRUG,"VPRX")
+5 SET STR=$SELECT($GET(VPRX(50,DRUG,901)):$GET(VPRX(50,DRUG,901))_" "_$GET(VPRX(50,DRUG,902)),1:"")
+6 DO NDF^PSS50(DRUG,,,,,"NDF")
SET VPI=+$GET(VPI,1)
+7 ;
+8 ;Drug
SET MED("products",VPI,"ingredientRole")="urn:sct:410942007"
+9 if $GET(ORD)
SET MED("products",VPI,"relatedOrder")=ORD
+10 if $GET(STR)
SET MED("products",VPI,"strength")=STR
+11 SET X=$GET(MED("name"))
if $LENGTH(X)
SET MED("products",VPI,"ingredientName")=X
+12 ;
+13 ;VA Generic
SET X=$GET(^TMP($JOB,"NDF",DRUG,20))
+14 SET MED("products",VPI,"ingredientCode")="urn:va:vuid:"_$$VUID^VPRD(+X,50.6)
+15 SET MED("products",VPI,"ingredientCodeName")=$PIECE(X,U,2)
+16 ;
+17 ;VA Product
SET X=$GET(^TMP($JOB,"NDF",DRUG,22))
+18 SET MED("products",VPI,"suppliedCode")="urn:va:vuid:"_$$VUID^VPRD(+X,50.68)
+19 SET MED("products",VPI,"suppliedName")=$PIECE(X,U,2)
+20 ;
+21 ;VA Drug Class
SET X=$GET(^TMP($JOB,"NDF",DRUG,25))
+22 SET MED("products",VPI,"drugClassCode")="urn:vadc:"_$PIECE(X,U,2)
+23 SET MED("products",VPI,"drugClassName")=$PIECE(X,U,3)
+24 ;
+25 KILL ^TMP($JOB,"NDF")
+26 QUIT
+27 ;
RELTIME(START,STOP,DUR,MIN) ; -- Return #min for dose
+1 NEW Y
SET Y=0
+2 IF START>0
IF STOP>0
SET Y=$$FMDIFF^XLFDT(STOP,START,2)\60
IF 1
+3 IF '$TEST
IF DUR
SET Y=$$TOMIN(DUR)
IF 1
+4 IF '$TEST
SET Y=$GET(VPRESP("SUPPLY",1))*1440
+5 SET Y=$SELECT(Y:Y+MIN,1:MIN)
+6 QUIT Y
+7 ;
TOMIN(DUR) ;
+1 NEW RESULT,TIME,UNIT
+2 SET UNIT=$$UP^XLFSTR($EXTRACT($PIECE(DUR," ",2)))
+3 IF UNIT=""
QUIT 0
+4 SET TIME=$PIECE(DUR," ")
+5 SET RESULT=$SELECT(UNIT="M":TIME,UNIT="H":TIME*60,UNIT="D":TIME*1440,UNIT="W":TIME*10080,UNIT="L":TIME*43200,1:0)
+6 QUIT RESULT
GETCLS() ; p18 added package check
+1 NEW PKGIEN
SET PKGIEN=$$GET1^DIQ(100,ID_",",12,"I")
+2 IF $PIECE($GET(^DIC(9.4,PKGIEN,0)),U)="INPATIENT MEDICATIONS"
QUIT "I"
+3 IF $PIECE($GET(^DIC(9.4,PKGIEN,0)),U)="OUTPATIENT PHARMACY"
QUIT "O"
+4 QUIT $$GET1^DIQ(100,ID_",",10,"I")
