- 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 Feb 18, 2025@23:34:52 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