PSJORUTL ;BIR/MLM-MISC. PROCEDURE CALLS FOR OE/RR 3.0 ;24 Feb 99 / 10:43 AM
;;5.0;INPATIENT MEDICATIONS ;**4,14,22,256,358**;16 DEC 97;Build 10
;
;Reference to ^PS(50.416 is supported by DBIA 2196
;Reference to ^PS(50.606 is supported by DBIA 2174
;Reference to ^PS(52.6 is supported by DBIA 1231
;Reference to ^PS(52.7 is supported by DBIA 2173
;Reference to ^PSDRUG is supported by DBIA 2192
;Reference to ^PSNDF( is supported by DBIA 2195
;Reference to ^YSCL(603.01 is supported by DBIA 2697
;
ENDD(PD,TYP,PSJ,DFN) ; Find all entries in DRUG file (50) for the passed primary/usage.
;Input: PD - NATIONAL DRUG FILE ENTRY (20).PSNDF VA PRODUCT NAME ENTRY
; ^NDF ptr.NDF form ptr^NDF Name^Primary IEN^Primary
; Name^"99PSP".
; TYP- String identifying type of drug (O:OP; U:UD; I:IV etc).
;Output:PSJ- Array containing all entries in the DRUG file (50) tied
; to the PD for the type(s) of drugs specified. Array is
; returned: ARRAY(PSJ)=IEN^GENERIC NAME (.01)^PRICE PER
; DISPENSE UNIT (16)^NON-FORMULARY (51)^DISPENSE UNIT (14.5)
; ^MAX NUMBER OF REFILLS ;5.27.97/SAB
; If no 50 entries found, PSJ=0; Else PSJ=# of entries.
;
N MAX,DEA,DEAI,DDRG,INACT,ND,X,Y S PSJ=0,PD=+$P(PD,U,4)
F DDRG=0:0 S DDRG=$O(^PSDRUG("ASP",PD,DDRG)) Q:'DDRG S INACT=$G(^PSDRUG(DDRG,"I")) I ('INACT)!(INACT'<DT) S Y=$P($G(^PSDRUG(DDRG,2)),U,3) D
.F X=1:1:$L(TYP) I Y[$E(TYP,X) S Y=1 Q
.D:Y
..S ND=$G(^PSDRUG(DDRG,0)),Y=$G(^(660)),PSJ=PSJ+1,PSJ(PSJ)=DDRG_U_$P(ND,U)_U_$P(Y,U,6)_U_$P(ND,U,9)_U_$P(Y,U,8) D MAX S PSJ(PSJ)=PSJ(PSJ)_U_MAX K MAX
Q
;
ENDDIV(PD,TYP,VOLUME,PSJ) ; Find all entries in DRUG file (50) for the passed Orderable item, IV additive/solution.
;Input: PD - Orderable item Pointer.
; TYP- String identifying type of drug (A:ADDITIVE, B:BASE).
; VOLUME- Volume used to uniquely identify a dispense drug.
;Output:PSJ- A string containing all entries in the DRUG file (50) tied
; to the PD for the type(s) of drugs specified. This string
; returned: PSJ=IEN^GENERIC NAME (.01)^PRICE PER DISPENSE
; UNIT (16)^NON-FORMULARY (51)^DISPENSE UNIT (14.5)
;
NEW PSJIENS,Y S PSJ=0
Q:$G(PD)=""
Q:$G(TYP)=""
S:TYP="A" PSJIENS=$$ADDD^PSJMISC(PD)
S:TYP="B" PSJIENS=$$SOLDD^PSJMISC(PD,$G(VOLUME))
I PSJIENS="" Q
S ND=$G(^PSDRUG(+PSJIENS,0)),Y=$G(^(660)),PSJ=+PSJIENS_U_$P(ND,U)_U_$P(Y,U,6)_U_$P(ND,U,9)_U_$P(Y,U,8)
Q
;
ENDCM(DDRG) ; Find Drug Cost, Message, and VA Product Name IEN
;Input: DDRG - IEN of entry in DRUG file (50).
;Output: PRICE PER DISPENSE UNIT(16)^MESSAGE (101)^NATIONAL DRUG FILE
; ENTRY(20).PSNDF VA PRODUCT NAME ENTRY (22)^QTY DISPENSE MESSAGE
; If either NDF ptr is not found 0 will be returned instead of 20.22.
;
N X S X=$G(^PSDRUG(+DDRG,"ND"))
Q $P($G(^PSDRUG(+DDRG,660)),U,3)_U_$P($G(^(0)),U,10)_U_$S('+X:0,'$P(X,U,3):0,1:+X_"."_$P(X,U,3))_U_$P($G(^PSDRUG(+DDRG,5)),"^")
;
ENRFA(DDRG,TYP,PSJ) ; Returns formulary alternatives for a dispense drug.
;Input: DDRG - IEN of entry in DRUG file (50).
; TYP - String identifying type of drug (O:OP; U:UD; I:IV etc).
;Output: ARRAY(INDEX#)=IEN of Formulary alternative^Formulary
; alternative name^Formulary alternative cost^Orderable Item
; IEN^Orderable Item name^MAX NUMBER REFILLS.
;If no alternatives are found PSJ=0; Else PSJ=# of entries.
;
K PSJ S PSJ=0 Q:'$O(^PSDRUG(+DDRG,65,0))
N MAX,DEA,DEAI,X,XX,Y,YY S YY=0
F X=0:0 S X=$O(^PSDRUG(+DDRG,65,X)) Q:'X S Y=$G(^PSDRUG(+DDRG,65,X,0)) I X D
.F XX=1:1:$L(TYP) I $P($G(^PSDRUG(+Y,2)),U,3)[$E(TYP,XX) S YY=1 Q
.D:YY
..S YY=+$G(^PSDRUG(+Y,2)),PSJ=PSJ+1,PSJ(+Y)=+Y_U_$$ENDDN^PSGMI(+Y)_U_$P($G(^PSDRUG(+Y,660)),U,6)_U_YY_U_$$OIDF^PSJLMUT1(YY) D MAX S PSJ(+Y)=PSJ(+Y)_U_MAX K MAX
Q
;
ENDF(PN) ; Returns dosage form for the specified VA Product Name.
;Input: PN - NATIONAL DRUG FILE ENTRY (20).PSNDF VA PRODUCT NAME ENTRY
;Output: NDF Dosage Form IEN^NDF Dosage From IEN
;
; NEW NDF CALL
N X S X="PSNAPIS" X ^%ZOSF("TEST") I N PSJDF,X1,X2 S X1=+$P(PN,"."),X2=+$P(PN,".",2),PSJDF=$$PSJDF^PSNAPIS(X1,X2) Q $S(PSJDF="":0,1:PSJDF)
;
N PSJNDF,X S X=$P($G(^PSNDF(+$P(PN,"."),5,+$P(PN,".",2),0)),U,2),X=+$G(^PSNDF(+$P(PN,"."),2,+X,0)),PSJDF=$P($G(^PS(50.606,+X,0)),U)
Q $S(PSJDF="":0,'X:0,1:+X_U_PSJDF)
;
ENNDFS(PN) ; Returns STRENGTH from ^PSNDF for the specified VA Product Name.
; NEW NDF CALL
N X S X="PSNAPIS" X ^%ZOSF("TEST") I N X1,X2,PNS S X1=+$P(PN,"."),X2=+$P(PN,".",2),PNS=$$PSJST^PSNAPIS(X1,X2) Q $S(PNS="":0,1:PNS)
;
N PNS,X,Y S X=$P($G(^PSNDF(+$P(PN,"."),5,+$P(PN,".",2),0)),U,3),Y=+$P($G(^PSNDF(+$P(PN,"."),5,+$P(PN,".",2),0)),"^",2),PNS=$P($G(^PSNDF(+$P(PN,"."),2,+Y,3,+X,0)),U)
Q $S(PNS="":0,'X:0,1:+X_U_PNS)
;
ENDI(PN,PSJ) ; Find all ingredients for the passed dispense drug.
;Input: PN - VA Product Name IEN
;Output: PSJ - Array listing ingredients for the specified PN in the
; form of PSJ(Ing. file ptr (50.416))=Ing IEN^Ing. name
; ^Ing. amt./Ing. units
;If no ing. found, PSJ=0. If ing. found, PSJ=1
; NEW NDF CALL
N X S X="PSNAPIS" X ^%ZOSF("TEST") I N X1,X2 S X1=+$P(PN,"."),X2=+$P(PN,".",2),PSJ=$$PSJING^PSNAPIS(X1,X2,.PSJ) Q
;
N GDP,ING,INGND,INGNME,INGPTR,PNP,X,Y
S PSJ=0,GDP=$P(PN,"."),PNP=$P(PN,".",2)
F X=1:1:3 S INGND=$G(^PSNDF(+GDP,5,+PNP,X)) F Y=1:1:$L(INGND,",") D
.S ING=$P(INGND,",",Y),INGNME=$P($G(^PSNDF(+GDP,1,+ING,0)),U),INGPTR=$S(INGNME="":"Not Found",1:$O(^PS(50.416,"B",INGNME,0)))
.S PSJ=1,PSJ(+INGPTR)=INGPTR_U_INGNME_U_$P(ING,"/",2,3)
Q
;
ENSDC(PSGP) ; Add IV and UD orders to ^TMP global used for order checking.
; Input: PSGP - Patient IEN
; Output: ^TMP($J("ORDERS",DRUG NAME)=DRUG CLASS CODE^NDF POINTER*
;
MAX ;returns max number of refills for outpatient orders ;5.27.97/SAB
K MAX S DEA=$P($G(^PSDRUG(DDRG,0)),"^",3)
I $P($G(^PSDRUG(DDRG,"CLOZ1")),"^")="PSOCLO1",$G(DFN) D Q
.S CLOZPAT=$O(^YSCL(603.01,"C",DFN,0)) S MAX=$S($P($G(^YSCL(603.01,+CLOZPAT,0)),"^",3)="B":1,1:0) K CLOZPAT
I DEA["A",DEA'["B" S MAX=0 K DEA Q
F DEAI=1:1:$L(DEA) I $E(+DEA,DEAI)>1,$E(+DEA,DEAI)<6 S MAX=5
K DEA,DEAI Q:$G(MAX)=5 S MAX=11
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSJORUTL 6284 printed Dec 13, 2024@02:08:29 Page 2
PSJORUTL ;BIR/MLM-MISC. PROCEDURE CALLS FOR OE/RR 3.0 ;24 Feb 99 / 10:43 AM
+1 ;;5.0;INPATIENT MEDICATIONS ;**4,14,22,256,358**;16 DEC 97;Build 10
+2 ;
+3 ;Reference to ^PS(50.416 is supported by DBIA 2196
+4 ;Reference to ^PS(50.606 is supported by DBIA 2174
+5 ;Reference to ^PS(52.6 is supported by DBIA 1231
+6 ;Reference to ^PS(52.7 is supported by DBIA 2173
+7 ;Reference to ^PSDRUG is supported by DBIA 2192
+8 ;Reference to ^PSNDF( is supported by DBIA 2195
+9 ;Reference to ^YSCL(603.01 is supported by DBIA 2697
+10 ;
ENDD(PD,TYP,PSJ,DFN) ; Find all entries in DRUG file (50) for the passed primary/usage.
+1 ;Input: PD - NATIONAL DRUG FILE ENTRY (20).PSNDF VA PRODUCT NAME ENTRY
+2 ; ^NDF ptr.NDF form ptr^NDF Name^Primary IEN^Primary
+3 ; Name^"99PSP".
+4 ; TYP- String identifying type of drug (O:OP; U:UD; I:IV etc).
+5 ;Output:PSJ- Array containing all entries in the DRUG file (50) tied
+6 ; to the PD for the type(s) of drugs specified. Array is
+7 ; returned: ARRAY(PSJ)=IEN^GENERIC NAME (.01)^PRICE PER
+8 ; DISPENSE UNIT (16)^NON-FORMULARY (51)^DISPENSE UNIT (14.5)
+9 ; ^MAX NUMBER OF REFILLS ;5.27.97/SAB
+10 ; If no 50 entries found, PSJ=0; Else PSJ=# of entries.
+11 ;
+12 NEW MAX,DEA,DEAI,DDRG,INACT,ND,X,Y
SET PSJ=0
SET PD=+$PIECE(PD,U,4)
+13 FOR DDRG=0:0
SET DDRG=$ORDER(^PSDRUG("ASP",PD,DDRG))
if 'DDRG
QUIT
SET INACT=$GET(^PSDRUG(DDRG,"I"))
IF ('INACT)!(INACT'<DT)
SET Y=$PIECE($GET(^PSDRUG(DDRG,2)),U,3)
Begin DoDot:1
+14 FOR X=1:1:$LENGTH(TYP)
IF Y[$EXTRACT(TYP,X)
SET Y=1
QUIT
+15 if Y
Begin DoDot:2
+16 SET ND=$GET(^PSDRUG(DDRG,0))
SET Y=$GET(^(660))
SET PSJ=PSJ+1
SET PSJ(PSJ)=DDRG_U_$PIECE(ND,U)_U_$PIECE(Y,U,6)_U_$PIECE(ND,U,9)_U_$PIECE(Y,U,8)
DO MAX
SET PSJ(PSJ)=PSJ(PSJ)_U_MAX
KILL MAX
End DoDot:2
End DoDot:1
+17 QUIT
+18 ;
ENDDIV(PD,TYP,VOLUME,PSJ) ; Find all entries in DRUG file (50) for the passed Orderable item, IV additive/solution.
+1 ;Input: PD - Orderable item Pointer.
+2 ; TYP- String identifying type of drug (A:ADDITIVE, B:BASE).
+3 ; VOLUME- Volume used to uniquely identify a dispense drug.
+4 ;Output:PSJ- A string containing all entries in the DRUG file (50) tied
+5 ; to the PD for the type(s) of drugs specified. This string
+6 ; returned: PSJ=IEN^GENERIC NAME (.01)^PRICE PER DISPENSE
+7 ; UNIT (16)^NON-FORMULARY (51)^DISPENSE UNIT (14.5)
+8 ;
+9 NEW PSJIENS,Y
SET PSJ=0
+10 if $GET(PD)=""
QUIT
+11 if $GET(TYP)=""
QUIT
+12 if TYP="A"
SET PSJIENS=$$ADDD^PSJMISC(PD)
+13 if TYP="B"
SET PSJIENS=$$SOLDD^PSJMISC(PD,$GET(VOLUME))
+14 IF PSJIENS=""
QUIT
+15 SET ND=$GET(^PSDRUG(+PSJIENS,0))
SET Y=$GET(^(660))
SET PSJ=+PSJIENS_U_$PIECE(ND,U)_U_$PIECE(Y,U,6)_U_$PIECE(ND,U,9)_U_$PIECE(Y,U,8)
+16 QUIT
+17 ;
ENDCM(DDRG) ; Find Drug Cost, Message, and VA Product Name IEN
+1 ;Input: DDRG - IEN of entry in DRUG file (50).
+2 ;Output: PRICE PER DISPENSE UNIT(16)^MESSAGE (101)^NATIONAL DRUG FILE
+3 ; ENTRY(20).PSNDF VA PRODUCT NAME ENTRY (22)^QTY DISPENSE MESSAGE
+4 ; If either NDF ptr is not found 0 will be returned instead of 20.22.
+5 ;
+6 NEW X
SET X=$GET(^PSDRUG(+DDRG,"ND"))
+7 QUIT $PIECE($GET(^PSDRUG(+DDRG,660)),U,3)_U_$PIECE($GET(^(0)),U,10)_U_$SELECT('+X:0,'$PIECE(X,U,3):0,1:+X_"."_$PIECE(X,U,3))_U_$PIECE($GET(^PSDRUG(+DDRG,5)),"^")
+8 ;
ENRFA(DDRG,TYP,PSJ) ; Returns formulary alternatives for a dispense drug.
+1 ;Input: DDRG - IEN of entry in DRUG file (50).
+2 ; TYP - String identifying type of drug (O:OP; U:UD; I:IV etc).
+3 ;Output: ARRAY(INDEX#)=IEN of Formulary alternative^Formulary
+4 ; alternative name^Formulary alternative cost^Orderable Item
+5 ; IEN^Orderable Item name^MAX NUMBER REFILLS.
+6 ;If no alternatives are found PSJ=0; Else PSJ=# of entries.
+7 ;
+8 KILL PSJ
SET PSJ=0
if '$ORDER(^PSDRUG(+DDRG,65,0))
QUIT
+9 NEW MAX,DEA,DEAI,X,XX,Y,YY
SET YY=0
+10 FOR X=0:0
SET X=$ORDER(^PSDRUG(+DDRG,65,X))
if 'X
QUIT
SET Y=$GET(^PSDRUG(+DDRG,65,X,0))
IF X
Begin DoDot:1
+11 FOR XX=1:1:$LENGTH(TYP)
IF $PIECE($GET(^PSDRUG(+Y,2)),U,3)[$EXTRACT(TYP,XX)
SET YY=1
QUIT
+12 if YY
Begin DoDot:2
+13 SET YY=+$GET(^PSDRUG(+Y,2))
SET PSJ=PSJ+1
SET PSJ(+Y)=+Y_U_$$ENDDN^PSGMI(+Y)_U_$PIECE($GET(^PSDRUG(+Y,660)),U,6)_U_YY_U_$$OIDF^PSJLMUT1(YY)
DO MAX
SET PSJ(+Y)=PSJ(+Y)_U_MAX
KILL MAX
End DoDot:2
End DoDot:1
+14 QUIT
+15 ;
ENDF(PN) ; Returns dosage form for the specified VA Product Name.
+1 ;Input: PN - NATIONAL DRUG FILE ENTRY (20).PSNDF VA PRODUCT NAME ENTRY
+2 ;Output: NDF Dosage Form IEN^NDF Dosage From IEN
+3 ;
+4 ; NEW NDF CALL
+5 NEW X
SET X="PSNAPIS"
XECUTE ^%ZOSF("TEST")
IF $TEST
NEW PSJDF,X1,X2
SET X1=+$PIECE(PN,".")
SET X2=+$PIECE(PN,".",2)
SET PSJDF=$$PSJDF^PSNAPIS(X1,X2)
QUIT $SELECT(PSJDF="":0,1:PSJDF)
+6 ;
+7 NEW PSJNDF,X
SET X=$PIECE($GET(^PSNDF(+$PIECE(PN,"."),5,+$PIECE(PN,".",2),0)),U,2)
SET X=+$GET(^PSNDF(+$PIECE(PN,"."),2,+X,0))
SET PSJDF=$PIECE($GET(^PS(50.606,+X,0)),U)
+8 QUIT $SELECT(PSJDF="":0,'X:0,1:+X_U_PSJDF)
+9 ;
ENNDFS(PN) ; Returns STRENGTH from ^PSNDF for the specified VA Product Name.
+1 ; NEW NDF CALL
+2 NEW X
SET X="PSNAPIS"
XECUTE ^%ZOSF("TEST")
IF $TEST
NEW X1,X2,PNS
SET X1=+$PIECE(PN,".")
SET X2=+$PIECE(PN,".",2)
SET PNS=$$PSJST^PSNAPIS(X1,X2)
QUIT $SELECT(PNS="":0,1:PNS)
+3 ;
+4 NEW PNS,X,Y
SET X=$PIECE($GET(^PSNDF(+$PIECE(PN,"."),5,+$PIECE(PN,".",2),0)),U,3)
SET Y=+$PIECE($GET(^PSNDF(+$PIECE(PN,"."),5,+$PIECE(PN,".",2),0)),"^",2)
SET PNS=$PIECE($GET(^PSNDF(+$PIECE(PN,"."),2,+Y,3,+X,0)),U)
+5 QUIT $SELECT(PNS="":0,'X:0,1:+X_U_PNS)
+6 ;
ENDI(PN,PSJ) ; Find all ingredients for the passed dispense drug.
+1 ;Input: PN - VA Product Name IEN
+2 ;Output: PSJ - Array listing ingredients for the specified PN in the
+3 ; form of PSJ(Ing. file ptr (50.416))=Ing IEN^Ing. name
+4 ; ^Ing. amt./Ing. units
+5 ;If no ing. found, PSJ=0. If ing. found, PSJ=1
+6 ; NEW NDF CALL
+7 NEW X
SET X="PSNAPIS"
XECUTE ^%ZOSF("TEST")
IF $TEST
NEW X1,X2
SET X1=+$PIECE(PN,".")
SET X2=+$PIECE(PN,".",2)
SET PSJ=$$PSJING^PSNAPIS(X1,X2,.PSJ)
QUIT
+8 ;
+9 NEW GDP,ING,INGND,INGNME,INGPTR,PNP,X,Y
+10 SET PSJ=0
SET GDP=$PIECE(PN,".")
SET PNP=$PIECE(PN,".",2)
+11 FOR X=1:1:3
SET INGND=$GET(^PSNDF(+GDP,5,+PNP,X))
FOR Y=1:1:$LENGTH(INGND,",")
Begin DoDot:1
+12 SET ING=$PIECE(INGND,",",Y)
SET INGNME=$PIECE($GET(^PSNDF(+GDP,1,+ING,0)),U)
SET INGPTR=$SELECT(INGNME="":"Not Found",1:$ORDER(^PS(50.416,"B",INGNME,0)))
+13 SET PSJ=1
SET PSJ(+INGPTR)=INGPTR_U_INGNME_U_$PIECE(ING,"/",2,3)
End DoDot:1
+14 QUIT
+15 ;
ENSDC(PSGP) ; Add IV and UD orders to ^TMP global used for order checking.
+1 ; Input: PSGP - Patient IEN
+2 ; Output: ^TMP($J("ORDERS",DRUG NAME)=DRUG CLASS CODE^NDF POINTER*
+3 ;
MAX ;returns max number of refills for outpatient orders ;5.27.97/SAB
+1 KILL MAX
SET DEA=$PIECE($GET(^PSDRUG(DDRG,0)),"^",3)
+2 IF $PIECE($GET(^PSDRUG(DDRG,"CLOZ1")),"^")="PSOCLO1"
IF $GET(DFN)
Begin DoDot:1
+3 SET CLOZPAT=$ORDER(^YSCL(603.01,"C",DFN,0))
SET MAX=$SELECT($PIECE($GET(^YSCL(603.01,+CLOZPAT,0)),"^",3)="B":1,1:0)
KILL CLOZPAT
End DoDot:1
QUIT
+4 IF DEA["A"
IF DEA'["B"
SET MAX=0
KILL DEA
QUIT
+5 FOR DEAI=1:1:$LENGTH(DEA)
IF $EXTRACT(+DEA,DEAI)>1
IF $EXTRACT(+DEA,DEAI)<6
SET MAX=5
+6 KILL DEA,DEAI
if $GET(MAX)=5
QUIT
SET MAX=11
+7 QUIT
