VPRSDAP.m

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 ---VPRSDAP   10215     printed  Feb 19, 2025@00:12:24                                                                                                                                                                                                    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)