VPRDPSO ;SLC/MKB -- Outpatient Pharmacy extract ;8/2/11 15:29
;;1.0;VIRTUAL PATIENT RECORD;**1,4,12,13,28**;Sep 01, 2011;Build 6
;;Per VHA Directive 2004-038, this routine should not be modified.
;
; External References DBIA#
; ------------------- -----
; PSODI 4858
; PSOORDER,^TMP("PSOR",$J) 1878
; PSS50P7 4662
; PSS51P2 4548
; XLFDT 10103
; XLFSTR 10104
;
; ------------ Get prescription from VistA ------------
;
RX(ID,MED) ; -- return a prescription in MED("attribute")=value
N RX0,RX1,DRUG,PSOI,X,I,START,STOP,ORIFN,FILL,RFD,PRV K MED
N VPR ;PSOORDER kills VPR
K ^TMP("PSOR",$J) D EN^PSOORDER(DFN,+ID)
S RX0=$G(^TMP("PSOR",$J,+ID,0)),RX1=$G(^(1)),DRUG=$G(^("DRUG",0))
S MED("medID")=ID_";O",MED("vaType")="O",MED("type")="Prescription"
S ORIFN=+$P(RX1,U,8) S:ORIFN MED("orderID")=ORIFN
S PSOI=$G(^TMP("PSOR",$J,+ID,"DRUGOI",0)) I PSOI D
. S MED("name")=$P(PSOI,";",2)
. D ZERO^PSS50P7(+PSOI,,,"OI")
. S MED("form")=$P($G(^TMP($J,"OI",+PSOI,.02)),U,2)
. S:+$G(^TMP($J,"OI",+PSOI,.09)) MED("supply")=1
D:DRUG NDF^VPRDPS(+DRUG) ;add NDF data
S START=$P(RX0,U) S:START MED("start")=START
S STOP=$P(RX0,U,12) S:STOP MED("stop")=STOP ;_".2359"?
S X=$$GET1^PSODI(52,+ID_",",26,"I") S:X MED("expires")=$P(X,U,2) ;1^date
S X=$P(RX0,U,17) S:X MED("ordered")=X
S MED("vaStatus")=$$UP^XLFSTR($P($P(RX0,U,4),";",2)),X=$P($P(RX0,U,4),";")
S MED("status")=$S(X="H":"hold",X="DC":"not active",X="D"!(X="E"):"historical",1:"active")
S X=$$GET1^PSODI(52,+ID_",",521012,"I") S:X MED("parked")=$P(X,U,2) ;1^1/0
S X=$$GET1^PSODI(52,+ID_",",128,"I") S:X MED("indication")=$P(X,U,2) ;1^text
S MED("quantity")=$P(RX0,U,6),MED("daysSupply")=$P(RX0,U,7)
S MED("fillsAllowed")=$P(RX0,U,8),MED("fillsRemaining")=$P(RX0,U,9)
S MED("routing")=$P($P(RX1,U,6),";"),MED("prescription")=$P(RX0,U,5)
S MED("lastFilled")=$P(RX0,U,3) K FILL
N VPRI S VPRI=1 ; p13 add unique int to stop fills from overwriting each other
S X=$P(RX0,U,2) I X D ; p12 add initial fill
. S FILL(VPRI,X)=""
. S $P(FILL(VPRI,X),U,10)=$P(RX1,U,6)
. S $P(FILL(VPRI,X),U,8)=$P(RX0,U,13)
. S $P(FILL(VPRI,X),U,4)=$P(RX0,U,6)
. S $P(FILL(VPRI,X),U,5)=$P(RX0,U,7)
. S VPRI=2
S I=0 F S I=$O(^TMP("PSOR",$J,+ID,"REF",I)) Q:I<1 S X=$G(^(I,0)),FILL(VPRI,+X)=X,VPRI=VPRI+1
S I=0 F S I=$O(^TMP("PSOR",$J,+ID,"RPAR",I)) Q:I<1 S X=$G(^(I,0)),$P(X,U,14)=1,FILL(VPRI,+X)=X,VPRI=VPRI+1
S VPRI=0 F S VPRI=$O(FILL(VPRI)) Q:'VPRI D
.S (RFD,PRV)=0 F S RFD=$O(FILL(VPRI,RFD)) Q:RFD<1 S X=$G(FILL(VPRI,RFD)) D ;sort 1st
. . N MW,REL
. . S MW=$P($P(X,U,10),";"),REL=$P($P(X,U,8),".")
. . S MED("fill",VPRI)=$P(RFD,".")_U_MW_U_REL_U_$P(X,U,4,5)_$S($P(X,U,14):"^1",1:"")
. . S:$P(X,U,2) PRV=$P(X,U,2) ;save last provider
. . ; fill comments?
S X=$S($P(RX0,U,11):$P(RX0,U,11),$P(RX0,U,10):$P(RX0,U,10),1:0)
S:X MED("fillCost")=X
S X=$G(^TMP("PSOR",$J,+ID,"SIG",1,0)),I=1
F S I=$O(^TMP("PSOR",$J,+ID,"SIG",I)) Q:I<1 S X=X_$G(^(I,0))
S MED("sig")=X
S X=$G(^TMP("PSOR",$J,+ID,"PI",1,0)),I=1
F S I=$O(^TMP("PSOR",$J,+ID,"PI",I)) Q:I<1 S X=X_$G(^(I,0))
S:$L(X) MED("ptInstructions")=X
S I=0 F S I=$O(^TMP("PSOR",$J,+ID,"MI",I)) Q:I<1 S X=$G(^(I,0)) D
. N UD,NOUN,DOSE,UNIT,RTE,SCH,DUR,CONJ,END
. S UD=$P(X,U,2),NOUN=$P(X,U,4)
. S DOSE=$P(X,U),UNIT=$P($P(X,U,3),";",2)
. S RTE=+$P(X,U,7) D ALL^PSS51P2(RTE,,,,"MR")
. S RTE=$G(^TMP($J,"MR",RTE,1))
. S DUR=$P(X,U,5),CONJ=$P(X,U,6),SCH=$P(X,U,8)
. S END=$S(DUR:$$STOP(START,DUR),1:STOP)
. S MED("dose",I)=DOSE_U_UNIT_U_UD_U_NOUN_U_RTE_U_SCH_U_DUR_U_CONJ_U_START_U_END
. I $E(CONJ)="T",DUR S START=END
S:RX1 X=$TR($P(RX1,U),";","^")_U_$$PROVSPC^VPRD(+RX1),MED("orderingProvider")=X,MED("currentProvider")=X
S:$G(PRV) MED("currentProvider")=$TR(PRV,";","^")_U_$$PROVSPC^VPRD(+PRV)
S:$P(RX1,U,9) MED("pharmacist")=$TR($P(RX1,U,9),";","^")
S:$P(RX1,U,4) MED("location")=$TR($P(RX1,U,4),";","^")
S MED("facility")=$$FAC^VPRD(+$P(RX1,U,4))
K ^TMP("PSOR",$J),^TMP($J,"MR"),^TMP($J,"NDF"),^TMP($J,"OI")
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:$E(UNT)=" " UNT=$E(UNT,2,99) 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
;
ACTIVE(X) ; -- return 1 or 0, if X is an active status
N Y S Y=1
I X="PURGE" S Y=0
I X="DELETED" S Y=0
I X="EXPIRED" S Y=0 ;keep, to renew?
I $P(X," ")="DISCONTINUED" S Y=0
Q Y
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVPRDPSO 4655 printed Sep 23, 2025@20:21:17 Page 2
VPRDPSO ;SLC/MKB -- Outpatient Pharmacy extract ;8/2/11 15:29
+1 ;;1.0;VIRTUAL PATIENT RECORD;**1,4,12,13,28**;Sep 01, 2011;Build 6
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 ; External References DBIA#
+5 ; ------------------- -----
+6 ; PSODI 4858
+7 ; PSOORDER,^TMP("PSOR",$J) 1878
+8 ; PSS50P7 4662
+9 ; PSS51P2 4548
+10 ; XLFDT 10103
+11 ; XLFSTR 10104
+12 ;
+13 ; ------------ Get prescription from VistA ------------
+14 ;
RX(ID,MED) ; -- return a prescription in MED("attribute")=value
+1 NEW RX0,RX1,DRUG,PSOI,X,I,START,STOP,ORIFN,FILL,RFD,PRV
KILL MED
+2 ;PSOORDER kills VPR
NEW VPR
+3 KILL ^TMP("PSOR",$JOB)
DO EN^PSOORDER(DFN,+ID)
+4 SET RX0=$GET(^TMP("PSOR",$JOB,+ID,0))
SET RX1=$GET(^(1))
SET DRUG=$GET(^("DRUG",0))
+5 SET MED("medID")=ID_";O"
SET MED("vaType")="O"
SET MED("type")="Prescription"
+6 SET ORIFN=+$PIECE(RX1,U,8)
if ORIFN
SET MED("orderID")=ORIFN
+7 SET PSOI=$GET(^TMP("PSOR",$JOB,+ID,"DRUGOI",0))
IF PSOI
Begin DoDot:1
+8 SET MED("name")=$PIECE(PSOI,";",2)
+9 DO ZERO^PSS50P7(+PSOI,,,"OI")
+10 SET MED("form")=$PIECE($GET(^TMP($JOB,"OI",+PSOI,.02)),U,2)
+11 if +$GET(^TMP($JOB,"OI",+PSOI,.09))
SET MED("supply")=1
End DoDot:1
+12 ;add NDF data
if DRUG
DO NDF^VPRDPS(+DRUG)
+13 SET START=$PIECE(RX0,U)
if START
SET MED("start")=START
+14 ;_".2359"?
SET STOP=$PIECE(RX0,U,12)
if STOP
SET MED("stop")=STOP
+15 ;1^date
SET X=$$GET1^PSODI(52,+ID_",",26,"I")
if X
SET MED("expires")=$PIECE(X,U,2)
+16 SET X=$PIECE(RX0,U,17)
if X
SET MED("ordered")=X
+17 SET MED("vaStatus")=$$UP^XLFSTR($PIECE($PIECE(RX0,U,4),";",2))
SET X=$PIECE($PIECE(RX0,U,4),";")
+18 SET MED("status")=$SELECT(X="H":"hold",X="DC":"not active",X="D"!(X="E"):"historical",1:"active")
+19 ;1^1/0
SET X=$$GET1^PSODI(52,+ID_",",521012,"I")
if X
SET MED("parked")=$PIECE(X,U,2)
+20 ;1^text
SET X=$$GET1^PSODI(52,+ID_",",128,"I")
if X
SET MED("indication")=$PIECE(X,U,2)
+21 SET MED("quantity")=$PIECE(RX0,U,6)
SET MED("daysSupply")=$PIECE(RX0,U,7)
+22 SET MED("fillsAllowed")=$PIECE(RX0,U,8)
SET MED("fillsRemaining")=$PIECE(RX0,U,9)
+23 SET MED("routing")=$PIECE($PIECE(RX1,U,6),";")
SET MED("prescription")=$PIECE(RX0,U,5)
+24 SET MED("lastFilled")=$PIECE(RX0,U,3)
KILL FILL
+25 ; p13 add unique int to stop fills from overwriting each other
NEW VPRI
SET VPRI=1
+26 ; p12 add initial fill
SET X=$PIECE(RX0,U,2)
IF X
Begin DoDot:1
+27 SET FILL(VPRI,X)=""
+28 SET $PIECE(FILL(VPRI,X),U,10)=$PIECE(RX1,U,6)
+29 SET $PIECE(FILL(VPRI,X),U,8)=$PIECE(RX0,U,13)
+30 SET $PIECE(FILL(VPRI,X),U,4)=$PIECE(RX0,U,6)
+31 SET $PIECE(FILL(VPRI,X),U,5)=$PIECE(RX0,U,7)
+32 SET VPRI=2
End DoDot:1
+33 SET I=0
FOR
SET I=$ORDER(^TMP("PSOR",$JOB,+ID,"REF",I))
if I<1
QUIT
SET X=$GET(^(I,0))
SET FILL(VPRI,+X)=X
SET VPRI=VPRI+1
+34 SET I=0
FOR
SET I=$ORDER(^TMP("PSOR",$JOB,+ID,"RPAR",I))
if I<1
QUIT
SET X=$GET(^(I,0))
SET $PIECE(X,U,14)=1
SET FILL(VPRI,+X)=X
SET VPRI=VPRI+1
+35 SET VPRI=0
FOR
SET VPRI=$ORDER(FILL(VPRI))
if 'VPRI
QUIT
Begin DoDot:1
+36 ;sort 1st
SET (RFD,PRV)=0
FOR
SET RFD=$ORDER(FILL(VPRI,RFD))
if RFD<1
QUIT
SET X=$GET(FILL(VPRI,RFD))
Begin DoDot:2
+37 NEW MW,REL
+38 SET MW=$PIECE($PIECE(X,U,10),";")
SET REL=$PIECE($PIECE(X,U,8),".")
+39 SET MED("fill",VPRI)=$PIECE(RFD,".")_U_MW_U_REL_U_$PIECE(X,U,4,5)_$SELECT($PIECE(X,U,14):"^1",1:"")
+40 ;save last provider
if $PIECE(X,U,2)
SET PRV=$PIECE(X,U,2)
+41 ; fill comments?
End DoDot:2
End DoDot:1
+42 SET X=$SELECT($PIECE(RX0,U,11):$PIECE(RX0,U,11),$PIECE(RX0,U,10):$PIECE(RX0,U,10),1:0)
+43 if X
SET MED("fillCost")=X
+44 SET X=$GET(^TMP("PSOR",$JOB,+ID,"SIG",1,0))
SET I=1
+45 FOR
SET I=$ORDER(^TMP("PSOR",$JOB,+ID,"SIG",I))
if I<1
QUIT
SET X=X_$GET(^(I,0))
+46 SET MED("sig")=X
+47 SET X=$GET(^TMP("PSOR",$JOB,+ID,"PI",1,0))
SET I=1
+48 FOR
SET I=$ORDER(^TMP("PSOR",$JOB,+ID,"PI",I))
if I<1
QUIT
SET X=X_$GET(^(I,0))
+49 if $LENGTH(X)
SET MED("ptInstructions")=X
+50 SET I=0
FOR
SET I=$ORDER(^TMP("PSOR",$JOB,+ID,"MI",I))
if I<1
QUIT
SET X=$GET(^(I,0))
Begin DoDot:1
+51 NEW UD,NOUN,DOSE,UNIT,RTE,SCH,DUR,CONJ,END
+52 SET UD=$PIECE(X,U,2)
SET NOUN=$PIECE(X,U,4)
+53 SET DOSE=$PIECE(X,U)
SET UNIT=$PIECE($PIECE(X,U,3),";",2)
+54 SET RTE=+$PIECE(X,U,7)
DO ALL^PSS51P2(RTE,,,,"MR")
+55 SET RTE=$GET(^TMP($JOB,"MR",RTE,1))
+56 SET DUR=$PIECE(X,U,5)
SET CONJ=$PIECE(X,U,6)
SET SCH=$PIECE(X,U,8)
+57 SET END=$SELECT(DUR:$$STOP(START,DUR),1:STOP)
+58 SET MED("dose",I)=DOSE_U_UNIT_U_UD_U_NOUN_U_RTE_U_SCH_U_DUR_U_CONJ_U_START_U_END
+59 IF $EXTRACT(CONJ)="T"
IF DUR
SET START=END
End DoDot:1
+60 if RX1
SET X=$TRANSLATE($PIECE(RX1,U),";","^")_U_$$PROVSPC^VPRD(+RX1)
SET MED("orderingProvider")=X
SET MED("currentProvider")=X
+61 if $GET(PRV)
SET MED("currentProvider")=$TRANSLATE(PRV,";","^")_U_$$PROVSPC^VPRD(+PRV)
+62 if $PIECE(RX1,U,9)
SET MED("pharmacist")=$TRANSLATE($PIECE(RX1,U,9),";","^")
+63 if $PIECE(RX1,U,4)
SET MED("location")=$TRANSLATE($PIECE(RX1,U,4),";","^")
+64 SET MED("facility")=$$FAC^VPRD(+$PIECE(RX1,U,4))
+65 KILL ^TMP("PSOR",$JOB),^TMP($JOB,"MR"),^TMP($JOB,"NDF"),^TMP($JOB,"OI")
+66 QUIT
+67 ;
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 if $EXTRACT(UNT)=" "
SET UNT=$EXTRACT(UNT,2,99)
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 ;
ACTIVE(X) ; -- return 1 or 0, if X is an active status
+1 NEW Y
SET Y=1
+2 IF X="PURGE"
SET Y=0
+3 IF X="DELETED"
SET Y=0
+4 ;keep, to renew?
IF X="EXPIRED"
SET Y=0
+5 IF $PIECE(X," ")="DISCONTINUED"
SET Y=0
+6 QUIT Y
