Routine: VPRDPSO

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")

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  Feb 19, 2025@00:11:22                                                                                                                                                                                                     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

VPRDPSO.m