PSSUTLA1 ;BHAM ISC/RTR-PSS utility routine ;08/21/00
;;1.0;PHARMACY DATA MANAGEMENT;**38,49,53,54,66,69,238**;9/30/97;Build 3
;Reference to EN^DDIOL supported by DBIA 10142
;Reference to ^PS(53.1 supported by DBIA 2140
;Reference to ^PS(52.41 supported by DBIA 2844
;Reference to ^PSRX supported by DBIA 2845
;Reference to ^DG(40.8 supported by DBIA 728
;
EN3(PSSBINTR,PSSBLGTH) ;
;Pass in to EN3 the internal number from 50.7, and the length of the
;array you want. Returns expanded Instructions is PSSBSIG array
K PSSBSIG N X,BVAR,BVAR1,III,CNT,NNN,BLIM,Y,PISIG,Z0,Z1,CNTZ,FFF
Q:'$G(PSSBINTR)!('$G(PSSBLGTH))
S X=$P($G(^PS(50.7,PSSBINTR,"INS")),"^") Q:X=""
S PISIG(1)="",CNTZ=1 Q:$L(X)<1 F Z0=1:1:$L(X," ") G:Z0="" START S Z1=$P(X," ",Z0) D G:'$D(X) START
.D:$D(X)&($G(Z1)]"") D ADD
..S Y=$O(^PS(51,"B",Z1,0)) Q:'Y!($P($G(^PS(51,+Y,0)),"^",4)>1) S Z1=$P($G(^PS(51,Y,0)),"^",2) Q:'$D(^(9)) S Y=$P(X," ",Z0-1),Y=$E(Y,$L(Y)) S:Y>1 Z1=^(9)
START ;
S (BVAR,BVAR1)="",III=1
F FFF=0:0 S FFF=$O(PISIG(FFF)) Q:'FFF S CNT=0 F NNN=1:1:$L(PISIG(FFF)) I $E(PISIG(FFF),NNN)=" "!($L(PISIG(FFF))=NNN) S CNT=CNT+1 D I $L(BVAR)>PSSBLGTH S PSSBSIG(III)=BLIM_" ",III=III+1,BVAR=BVAR1
.S BVAR1=$P(PISIG(FFF)," ",(CNT))
.S BLIM=BVAR
.S BVAR=$S(BVAR="":BVAR1,1:BVAR_" "_BVAR1)
I $G(BVAR)'="" S PSSBSIG(III)=BVAR
I $G(PSSBSIG(1))=""!($G(PSSBSIG(1))=" ") S PSSBSIG(1)=$G(PSSBSIG(2)) K PSSBSIG(2)
F CNTZ=0:0 S CNTZ=$O(PSSBSIG(CNTZ)) Q:'CNTZ S PSSX("PI",CNTZ)=$G(PSSBSIG(CNTZ))
K PSSBSIG
Q
ADD ;
I $L(PISIG(CNTZ))+$L(Z1)+1<246 S PISIG(CNTZ)=PISIG(CNTZ)_" "_Z1 Q
S CNTZ=CNTZ+1 S PISIG(CNTZ)=Z1
Q
;
DEA(PSSDIENM) ;Return DEA Special Handling for CPRS Dose Call
;1 Requires wet sig, DEA contains 1, or a 2
;2 = Controlled Sub, no wet sig required, DEA contains 3, 4, or 5
;0 = others
Q:'$G(PSSDIENM)
N PSSDEAX,PSSDEAXV
S PSSDEAX=$P($G(^PSDRUG(PSSDIENM,0)),"^",3)
I PSSDEAX[1!(PSSDEAX[2) S PSSDEAXV=1 G DSET
I PSSDEAX[3!(PSSDEAX[4)!(PSSDEAX[5) S PSSDEAXV=2 G DSET
S PSSDEAXV=0
DSET ;
S PSSX("DD",PSSDIENM)=PSSX("DD",PSSDIENM)_"^"_PSSDEAXV_"^"_$S($D(PSSHLF(PSSDIENM)):1,1:0)
Q
HELP ;
Q:$G(X)=""
N PSSSIG,PSSYX,PSSZ0,PSSZ1,PSSCTX,PSSLPX,PSSBVAR,PSSBVAR1,PSSIII,PSSFFF,PCT,PNNN,PSSBLIM,PSSIG
S PSSIG(1)="",PSSCTX=1 Q:$L(X)<1 F PSSZ0=1:1:$L(X," ") G:PSSZ0="" HELP1 S PSSZ1=$P(X," ",PSSZ0) D G:'$D(X) HELP1
.D:$D(X)&($G(PSSZ1)]"") D HELPADD
..S PSSYX=$O(^PS(51,"B",PSSZ1,0)) Q:'PSSYX!($P($G(^PS(51,+PSSYX,0)),"^",4)>1) S PSSZ1=$P($G(^PS(51,PSSYX,0)),"^",2) Q:'$D(^(9)) S PSSYX=$P(X," ",PSSZ0-1),PSSYX=$E(PSSYX,$L(PSSYX)) S:PSSYX>1 PSSZ1=^(9)
HELP1 ;
S (PSSBVAR,PSSBVAR1)="",PSSIII=1
F PSSFFF=0:0 S PSSFFF=$O(PSSIG(PSSFFF)) Q:'PSSFFF S PCT=0 F PNNN=1:1:$L(PSSIG(PSSFFF)) I $E(PSSIG(PSSFFF),PNNN)=" "!($L(PSSIG(PSSFFF))=PNNN) S PCT=PCT+1 D I $L(PSSBVAR)>70 S PSSSIG(PSSIII)=PSSBLIM_" ",PSSIII=PSSIII+1,PSSBVAR=PSSBVAR1
.S PSSBVAR1=$P(PSSIG(PSSFFF)," ",(PCT))
.S PSSBLIM=PSSBVAR
.S PSSBVAR=$S(PSSBVAR="":PSSBVAR1,1:PSSBVAR_" "_PSSBVAR1)
I $G(PSSBVAR)'="" S PSSSIG(PSSIII)=PSSBVAR
I $G(PSSSIG(1))=""!($G(PSSSIG(1))=" ") S PSSSIG(1)=$G(PSSSIG(2)) K PSSSIG(2)
F PSSLPX=0:0 S PSSLPX=$O(PSSSIG(PSSLPX)) Q:'PSSLPX D:PSSLPX=1 EN^DDIOL(" ") D EN^DDIOL(" "_$G(PSSSIG(PSSLPX)))
Q
HELPADD ;
I $L(PSSIG(PSSCTX))+$L(PSSZ1)+1<246 S PSSIG(PSSCTX)=PSSIG(PSSCTX)_" "_PSSZ1 Q
S PSSCTX=PSSCTX+1 S PSSIG(PSSCTX)=PSSZ1
Q
PRICE() ;Return price per dose for CPRS Dose call
;DLOOP = Internal entry number from Drug file
;PSSUDOS = Dispense units per Dose
N PSSPRICE,PSSPRQ
I '$G(DLOOP) Q ""
S PSSPRICE=$P($G(^PSDRUG(DLOOP,660)),"^",6) I 'PSSPRICE Q ""
I $G(PSSUDOS) S PSSPRQ=PSSUDOS*PSSPRICE G PRICEQ
I $G(PSSBCM) S PSSPRQ=PSSBCM*PSSPRICE
PRICEQ ;
I $E($G(PSSPRQ))="." S PSSPRQ=0_$G(PSSPRQ)
Q $G(PSSPRQ)
;
Q
;
OIDEA(PSSXOI,PSSXOIP) ;
;DEA return based on Orderable Item, Item and Usage passed in
;1 means DEA contains a 1, or a 2
;2 means DEA contains a 3, or a 4, or a 5
;0 means all others
N PSSXOLP,PSSXOLPD,PSSXOLPX,PSSXNODD,PSSPKLX
S (PSSXOLPD,PSSXNODD)=0 I PSSXOIP="X" G OIDQ
I '$G(PSSXOI)!($G(PSSXOIP)="") G OIDQ
S PSSPKLX=$S(PSSXOIP="I":1,PSSXOIP="U":1,1:0)
F PSSXOLP=0:0 S PSSXOLP=$O(^PSDRUG("ASP",PSSXOI,PSSXOLP)) Q:'PSSXOLP!(PSSXOLPD=1) D
.I $P($G(^PSDRUG(PSSXOLP,"I")),"^"),$P($G(^("I")),"^")<DT Q
.I 'PSSPKLX,$P($G(^PSDRUG(PSSXOLP,2)),"^",3)'["O" Q
.I PSSPKLX I $P($G(^PSDRUG(PSSXOLP,2)),"^",3)'["U",$P($G(^(2)),"^",3)'["I" Q
.S PSSXNODD=1
.S PSSXOLPX=$P($G(^PSDRUG(PSSXOLP,0)),"^",3)
.I PSSXOLPX[1!(PSSXOLPX[2) S PSSXOLPD=1 Q
.I PSSXOLPX[3!(PSSXOLPX[4)!(PSSXOLPX[5) S PSSXOLPD=2
OIDQ ;
I PSSXOLPD=0,'PSSXNODD S PSSXOLPD=""
Q PSSXOLPD
;
Q
;
LEAD ;Leading zeros, CPRS Dosage call
N PSSBK,PSSBK1,PSSBKD
F PSSLD=0:0 S PSSLD=$O(PSSX(PSSLD)) Q:'PSSLD D
.I $E($P(PSSX(PSSLD),"^"),1)="." S $P(PSSX(PSSLD),"^")="0"_$P(PSSX(PSSLD),"^")
.I $E($P(PSSX(PSSLD),"^",2),1)="." S $P(PSSX(PSSLD),"^",2)="0"_$P(PSSX(PSSLD),"^",2)
.I $P(PSSX(PSSLD),"^",2)["/." S PSSBKD=$P(PSSX(PSSLD),"^",2) D
..S PSSBK=$P(PSSBKD,"/."),PSSBK1=$P(PSSBKD,"/.",2)
..S $P(PSSX(PSSLD),"^",2)=$G(PSSBK)_"/0."_$G(PSSBK1)
.I $E($P(PSSX(PSSLD),"^",5),1)="." S $P(PSSX(PSSLD),"^",5)="0"_$P(PSSX(PSSLD),"^",5)
.I $P(PSSX(PSSLD),"^",5)["/." S PSSBKD=$P(PSSX(PSSLD),"^",5) D
..S PSSBK=$P(PSSBKD,"/."),PSSBK1=$P(PSSBKD,"/.",2)
..S $P(PSSX(PSSLD),"^",5)=$G(PSSBK)_"/0."_$G(PSSBK1)
.I $O(PSSX(PSSLD,0)) D
..F PSSLD1=0:0 S PSSLD1=$O(PSSX(PSSLD,PSSLD1)) Q:'PSSLD1 D
...I $E($P(PSSX(PSSLD,PSSLD1),"^"),1)="." S $P(PSSX(PSSLD,PSSLD1),"^")="0"_$P(PSSX(PSSLD,PSSLD1),"^")
...I $E($P(PSSX(PSSLD,PSSLD1),"^",2),1)="." S $P(PSSX(PSSLD,PSSLD1),"^",2)="0"_$P(PSSX(PSSLD,PSSLD1),"^",2)
...I $P(PSSX(PSSLD,PSSLD1),"^",2)["/." S PSSBKD=$P(PSSX(PSSLD,PSSLD1),"^",2) D
....S PSSBK=$P(PSSBKD,"/."),PSSBK1=$P(PSSBKD,"/.",2)
....S $P(PSSX(PSSLD,PSSLD1),"^",2)=$G(PSSBK)_"/0."_$G(PSSBK1)
...I $E($P(PSSX(PSSLD,PSSLD1),"^",5),1)="." S $P(PSSX(PSSLD,PSSLD1),"^",5)="0"_$P(PSSX(PSSLD,PSSLD1),"^",5)
...I $P(PSSX(PSSLD,PSSLD1),"^",5)["/." S PSSBKD=$P(PSSX(PSSLD,PSSLD1),"^",5) D
....S PSSBK=$P(PSSBKD,"/."),PSSBK1=$P(PSSBKD,"/.",2)
....S $P(PSSX(PSSLD,PSSLD1),"^",5)=$G(PSSBK)_"/0."_$G(PSSBK1)
S PSSLD="" F S PSSLD=$O(PSSX("DD",PSSLD)) Q:PSSLD="" D
.I $E($P(PSSX("DD",PSSLD),"^",5),1)="." S $P(PSSX("DD",PSSLD),"^",5)="0"_$P(PSSX("DD",PSSLD),"^",5)
Q
LEADP ;Leading zeros pharmacy call
N PSSBB,PSSBB1,PSSBBD
F PSSMD=0:0 S PSSMD=$O(PSSX(PSSMD)) Q:'PSSMD D
.F PSSMDN=1,3,5,11 I $E($P(PSSX(PSSMD),"^",PSSMDN),1)="." S $P(PSSX(PSSMD),"^",PSSMDN)="0"_$P(PSSX(PSSMD),"^",PSSMDN)
.I $P(PSSX(PSSMD),"^",2)["/." S PSSBBD=$P(PSSX(PSSMD),"^",2) D
..S PSSBB=$P(PSSBBD,"/."),PSSBB1=$P(PSSBBD,"/.",2)
..S $P(PSSX(PSSMD),"^",2)=$G(PSSBB)_"/0."_$G(PSSBB1)
.I $P(PSSX(PSSMD),"^",11)["/." S PSSBBD=$P(PSSX(PSSMD),"^",11) D
..S PSSBB=$P(PSSBBD,"/."),PSSBB1=$P(PSSBBD,"/.",2)
..S $P(PSSX(PSSMD),"^",11)=$G(PSSBB)_"/0."_$G(PSSBB1)
.I $O(PSSX(PSSMD,0)) D
..F PSSMD1=0:0 S PSSMD1=$O(PSSX(PSSMD,PSSMD1)) Q:'PSSMD1 D
...F PSSMDN=1,3,5,11 I $E($P(PSSX(PSSMD,PSSMD1),"^",PSSMDN),1)="." S $P(PSSX(PSSMD,PSSMD1),"^",PSSMDN)="0"_$P(PSSX(PSSMD,PSSMD1),"^",PSSMDN)
...I $P(PSSX(PSSMD,PSSMD1),"^",2)["/." S PSSBBD=$P(PSSX(PSSMD,PSSMD1),"^",2) D
....S PSSBB=$P(PSSBBD,"/."),PSSBB1=$P(PSSBBD,"/.",2)
....S $P(PSSX(PSSMD,PSSMD1),"^",2)=$G(PSSBB)_"/0."_$G(PSSBB1)
...I $P(PSSX(PSSMD,PSSMD1),"^",11)["/." S PSSBBD=$P(PSSX(PSSMD,PSSMD1),"^",11) D
....S PSSBB=$P(PSSBBD,"/."),PSSBB1=$P(PSSBBD,"/.",2)
....S $P(PSSX(PSSMD,PSSMD1),"^",11)=$G(PSSBB)_"/0."_$G(PSSBB1)
S PSSMD="" F S PSSMD=$O(PSSX("DD",PSSMD)) Q:PSSMD="" D
.I $E($P(PSSX("DD",PSSMD),"^",5),1)="." S $P(PSSX("DD",PSSMD),"^",5)="0"_$P(PSSX("DD",PSSMD),"^",5)
Q
DUP ;delete str/unit if duplicate local doses with strength are found
N PSSLXA,PSSLXL,PSSLXFL,PSSLXQ,PSSLXLD,PSSLXMED,PSSLXSTR,PSSLXND,PSSLXX
S PSSLXFL=0
S PSSLXL="" F S PSSLXL=$O(PSSX(PSSLXL)) Q:PSSLXL=""!(PSSLXFL) D
.S PSSLXND=$G(PSSX(PSSLXL)),PSSLXSTR=""
.S PSSLXLD=$P(PSSLXND,"^",5),PSSLXMED=$P(PSSLXND,"^",6) I PSSLXMED S PSSLXSTR=$P($G(PSSX("DD",PSSLXMED)),"^",5)
.I PSSLXLD'="",PSSLXMED'="",PSSLXSTR'="" D
..S PSSLXA(PSSLXLD,PSSLXSTR,PSSLXMED)=""
..S PSSLXX="" F S PSSLXX=$O(PSSLXA(PSSLXLD,PSSLXSTR,PSSLXX)) Q:PSSLXX=""!(PSSLXFL) I PSSLXX'=PSSLXMED S PSSLXFL=1
I PSSLXFL S PSSLXQ="" F S PSSLXQ=$O(PSSX("DD",PSSLXQ)) Q:PSSLXQ="" S $P(PSSX("DD",PSSLXQ),"^",5)="",$P(PSSX("DD",PSSLXQ),"^",6)=""
Q
;
PLACER(PSSPDFN,PSSPIEN) ;Return CPRS order number from Pharmacy order
;PSSPDFN = Patient internal number
;PSSPIEN = Pharmacy number - U-Unit Dose, V-IV, P-Inpatient Pending, S-Outpatient Pending, R-Prescription, N-Non-VA
I '$G(PSSPDFN) Q ""
I PSSPIEN'?1.N1U Q ""
N PSSPAK,PSSLOC S PSSPAK=$E(PSSPIEN,$L(PSSPIEN))
S PSSLOC=$S(PSSPAK="U":5,PSSPAK="V":"IV","PSRN"[PSSPAK:1,1:"")
I PSSLOC="" Q ""
I "UV"[PSSPAK Q $P($G(^PS(55,PSSPDFN,PSSLOC,+PSSPIEN,0)),"^",21)
I PSSPAK="R" Q $P($G(^PSRX(+PSSPIEN,"OR1")),"^",2)
I PSSPAK="P" Q $P($G(^PS(53.1,+PSSPIEN,0)),"^",21)
I PSSPAK="S" Q $P($G(^PS(52.41,+PSSPIEN,0)),"^")
Q $P($G(^PS(55,PSSPDFN,"NVA",+PSSPIEN,0)),"^",8)
;
LOC(PSSPDFN,PSSPIEN) ;Return Location from Pharmacy order
;PSSPDFN = Patient internal number
;PSSPIEN = Pharmacy number - U-Unit Dose, V-IV, P-Inpatient Pending, S-Outpatient Pending, R-Prescription, N-Non-VA
I '$G(PSSPDFN)!($G(PSSPIEN)'?1.N1U) Q $$LOCIN
N PSSPAK,PSSHLOC,PSSWRD,PSSWRDN,PSSRSLT,PSSROOM,PSSRLIN,PSSRLINN,PSSERR
S PSSPAK=$E(PSSPIEN,$L(PSSPIEN)),PSSRSLT=""
I "UVP"[PSSPAK D Q PSSRSLT
.I PSSPAK="V" S PSSHLOC=$P($G(^PS(55,PSSPDFN,"IV",+PSSPIEN,"DSS")),"^")
.I PSSPAK="P" S PSSHLOC=$P($G(^PS(53.1,+PSSPIEN,"DSS")),"^")
.I PSSPAK="U" S PSSHLOC=$P($G(^PS(55,PSSPDFN,5,+PSSPIEN,8)),"^")
.I PSSHLOC S PSSRSLT=$$LOCHL(PSSHLOC) I PSSRSLT Q
.S PSSWRD=$$LOCWA
.I PSSWRD S PSSHLOC=$P($G(^DIC(42,+PSSPIEN,44)),"^") I PSSHLOC S PSSRSLT=$$LOCHL(PSSHLOC) I PSSRSLT Q
.I PSSWRD S PSSWRDN=$P($G(^DIC(42,PSSWRD,0)),"^") I PSSWRDN'="" S PSSRSLT=PSSWRD_"^"_PSSWRDN_"^"_42 Q
.S PSSROOM="" I PSSPAK="V" S PSSROOM=$P($G(^PS(55,PSSPDFN,"IV",+PSSPIEN,2)),"^",2)
.I PSSPAK="P" S PSSROOM=$P($G(^PS(53.1,+PSSPIEN,8)),"^",8)
.I PSSROOM S PSSRSLT=$$LOCDI(PSSROOM) I PSSRSLT Q
.S PSSRSLT=$$LOCIN
I "SRN"[PSSPAK D Q PSSRSLT
.I PSSPAK="N" S PSSHLOC=$P($G(^PS(55,PSSPDFN,"NVA",+PSSPIEN,0)),"^",12)
.I PSSPAK="R" S PSSHLOC=$P($G(^PSRX(+PSSPIEN,0)),"^",5)
.I PSSPAK="S" S PSSHLOC=$P($G(^PS(52.41,+PSSPIEN,0)),"^",13)
.I PSSHLOC S PSSRSLT=$$LOCHL(PSSHLOC) I PSSRSLT Q
.I PSSPAK="S" S PSSRLIN=$P($G(^PS(52.41,+PSSPIEN,"INI")),"^") I PSSRLIN S PSSRLINN=$$GET1^DIQ(52.41,+PSSPIEN_",",100,,,"PSSERR") I PSSRLINN'="" S PSSRSLT=PSSRLIN_"^"_PSSRLINN_"^"_4 Q
.S PSSRSLT=$$LOCIN
Q $$LOCIN
;
LOCWA() ;Return ward
N VAHOW,VAROOT,VAINDT,VAIN,VAERR
D INP^VADPT
Q +$G(VAIN(4))
;
LOCHL(PSSCLN) ;Return hospital location file #44
N PSSCLNN S PSSCLNN=$P($G(^SC(PSSCLN,0)),"^")
Q $S(PSSCLNN'="":PSSCLN_"^"_PSSCLNN_"^"_44,1:"")
;
LOCDI(PSSDIV) ;Return division file #40.8
N PSSDIVN S PSSDIVN=$P($G(^DG(40.8,PSSDIV,0)),"^")
Q $S(PSSDIVN'="":PSSDIV_"^"_PSSDIVN_"^"_40.8,1:"")
;
LOCIN() ;Return institution file #4
Q $P($$SITE^VASITE,"^",1,2)_"^"_4
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSSUTLA1 11273 printed Sep 23, 2025@20:10:23 Page 2
PSSUTLA1 ;BHAM ISC/RTR-PSS utility routine ;08/21/00
+1 ;;1.0;PHARMACY DATA MANAGEMENT;**38,49,53,54,66,69,238**;9/30/97;Build 3
+2 ;Reference to EN^DDIOL supported by DBIA 10142
+3 ;Reference to ^PS(53.1 supported by DBIA 2140
+4 ;Reference to ^PS(52.41 supported by DBIA 2844
+5 ;Reference to ^PSRX supported by DBIA 2845
+6 ;Reference to ^DG(40.8 supported by DBIA 728
+7 ;
EN3(PSSBINTR,PSSBLGTH) ;
+1 ;Pass in to EN3 the internal number from 50.7, and the length of the
+2 ;array you want. Returns expanded Instructions is PSSBSIG array
+3 KILL PSSBSIG
NEW X,BVAR,BVAR1,III,CNT,NNN,BLIM,Y,PISIG,Z0,Z1,CNTZ,FFF
+4 if '$GET(PSSBINTR)!('$GET(PSSBLGTH))
QUIT
+5 SET X=$PIECE($GET(^PS(50.7,PSSBINTR,"INS")),"^")
if X=""
QUIT
+6 SET PISIG(1)=""
SET CNTZ=1
if $LENGTH(X)<1
QUIT
FOR Z0=1:1:$LENGTH(X," ")
if Z0=""
GOTO START
SET Z1=$PIECE(X," ",Z0)
Begin DoDot:1
+7 if $DATA(X)&($GET(Z1)]"")
Begin DoDot:2
+8 SET Y=$ORDER(^PS(51,"B",Z1,0))
if 'Y!($PIECE($GET(^PS(51,+Y,0)),"^",4)>1)
QUIT
SET Z1=$PIECE($GET(^PS(51,Y,0)),"^",2)
if '$DATA(^(9))
QUIT
SET Y=$PIECE(X," ",Z0-1)
SET Y=$EXTRACT(Y,$LENGTH(Y))
if Y>1
SET Z1=^(9)
End DoDot:2
DO ADD
End DoDot:1
if '$DATA(X)
GOTO START
START ;
+1 SET (BVAR,BVAR1)=""
SET III=1
+2 FOR FFF=0:0
SET FFF=$ORDER(PISIG(FFF))
if 'FFF
QUIT
SET CNT=0
FOR NNN=1:1:$LENGTH(PISIG(FFF))
IF $EXTRACT(PISIG(FFF),NNN)=" "!($LENGTH(PISIG(FFF))=NNN)
SET CNT=CNT+1
Begin DoDot:1
+3 SET BVAR1=$PIECE(PISIG(FFF)," ",(CNT))
+4 SET BLIM=BVAR
+5 SET BVAR=$SELECT(BVAR="":BVAR1,1:BVAR_" "_BVAR1)
End DoDot:1
IF $LENGTH(BVAR)>PSSBLGTH
SET PSSBSIG(III)=BLIM_" "
SET III=III+1
SET BVAR=BVAR1
+6 IF $GET(BVAR)'=""
SET PSSBSIG(III)=BVAR
+7 IF $GET(PSSBSIG(1))=""!($GET(PSSBSIG(1))=" ")
SET PSSBSIG(1)=$GET(PSSBSIG(2))
KILL PSSBSIG(2)
+8 FOR CNTZ=0:0
SET CNTZ=$ORDER(PSSBSIG(CNTZ))
if 'CNTZ
QUIT
SET PSSX("PI",CNTZ)=$GET(PSSBSIG(CNTZ))
+9 KILL PSSBSIG
+10 QUIT
ADD ;
+1 IF $LENGTH(PISIG(CNTZ))+$LENGTH(Z1)+1<246
SET PISIG(CNTZ)=PISIG(CNTZ)_" "_Z1
QUIT
+2 SET CNTZ=CNTZ+1
SET PISIG(CNTZ)=Z1
+3 QUIT
+4 ;
DEA(PSSDIENM) ;Return DEA Special Handling for CPRS Dose Call
+1 ;1 Requires wet sig, DEA contains 1, or a 2
+2 ;2 = Controlled Sub, no wet sig required, DEA contains 3, 4, or 5
+3 ;0 = others
+4 if '$GET(PSSDIENM)
QUIT
+5 NEW PSSDEAX,PSSDEAXV
+6 SET PSSDEAX=$PIECE($GET(^PSDRUG(PSSDIENM,0)),"^",3)
+7 IF PSSDEAX[1!(PSSDEAX[2)
SET PSSDEAXV=1
GOTO DSET
+8 IF PSSDEAX[3!(PSSDEAX[4)!(PSSDEAX[5)
SET PSSDEAXV=2
GOTO DSET
+9 SET PSSDEAXV=0
DSET ;
+1 SET PSSX("DD",PSSDIENM)=PSSX("DD",PSSDIENM)_"^"_PSSDEAXV_"^"_$SELECT($DATA(PSSHLF(PSSDIENM)):1,1:0)
+2 QUIT
HELP ;
+1 if $GET(X)=""
QUIT
+2 NEW PSSSIG,PSSYX,PSSZ0,PSSZ1,PSSCTX,PSSLPX,PSSBVAR,PSSBVAR1,PSSIII,PSSFFF,PCT,PNNN,PSSBLIM,PSSIG
+3 SET PSSIG(1)=""
SET PSSCTX=1
if $LENGTH(X)<1
QUIT
FOR PSSZ0=1:1:$LENGTH(X," ")
if PSSZ0=""
GOTO HELP1
SET PSSZ1=$PIECE(X," ",PSSZ0)
Begin DoDot:1
+4 if $DATA(X)&($GET(PSSZ1)]"")
Begin DoDot:2
+5 SET PSSYX=$ORDER(^PS(51,"B",PSSZ1,0))
if 'PSSYX!($PIECE($GET(^PS(51,+PSSYX,0)),"^",4)>1)
QUIT
SET PSSZ1=$PIECE($GET(^PS(51,PSSYX,0)),"^",2)
if '$DATA(^(9))
QUIT
SET PSSYX=$PIECE(X," ",PSSZ0-1)
SET PSSYX=$EXTRACT(PSSYX,$LENGTH(PSSYX))
if PSSYX>1
SET PSSZ1=^(9)
End DoDot:2
DO HELPADD
End DoDot:1
if '$DATA(X)
GOTO HELP1
HELP1 ;
+1 SET (PSSBVAR,PSSBVAR1)=""
SET PSSIII=1
+2 FOR PSSFFF=0:0
SET PSSFFF=$ORDER(PSSIG(PSSFFF))
if 'PSSFFF
QUIT
SET PCT=0
FOR PNNN=1:1:$LENGTH(PSSIG(PSSFFF))
IF $EXTRACT(PSSIG(PSSFFF),PNNN)=" "!($LENGTH(PSSIG(PSSFFF))=PNNN)
SET PCT=PCT+1
Begin DoDot:1
+3 SET PSSBVAR1=$PIECE(PSSIG(PSSFFF)," ",(PCT))
+4 SET PSSBLIM=PSSBVAR
+5 SET PSSBVAR=$SELECT(PSSBVAR="":PSSBVAR1,1:PSSBVAR_" "_PSSBVAR1)
End DoDot:1
IF $LENGTH(PSSBVAR)>70
SET PSSSIG(PSSIII)=PSSBLIM_" "
SET PSSIII=PSSIII+1
SET PSSBVAR=PSSBVAR1
+6 IF $GET(PSSBVAR)'=""
SET PSSSIG(PSSIII)=PSSBVAR
+7 IF $GET(PSSSIG(1))=""!($GET(PSSSIG(1))=" ")
SET PSSSIG(1)=$GET(PSSSIG(2))
KILL PSSSIG(2)
+8 FOR PSSLPX=0:0
SET PSSLPX=$ORDER(PSSSIG(PSSLPX))
if 'PSSLPX
QUIT
if PSSLPX=1
DO EN^DDIOL(" ")
DO EN^DDIOL(" "_$GET(PSSSIG(PSSLPX)))
+9 QUIT
HELPADD ;
+1 IF $LENGTH(PSSIG(PSSCTX))+$LENGTH(PSSZ1)+1<246
SET PSSIG(PSSCTX)=PSSIG(PSSCTX)_" "_PSSZ1
QUIT
+2 SET PSSCTX=PSSCTX+1
SET PSSIG(PSSCTX)=PSSZ1
+3 QUIT
PRICE() ;Return price per dose for CPRS Dose call
+1 ;DLOOP = Internal entry number from Drug file
+2 ;PSSUDOS = Dispense units per Dose
+3 NEW PSSPRICE,PSSPRQ
+4 IF '$GET(DLOOP)
QUIT ""
+5 SET PSSPRICE=$PIECE($GET(^PSDRUG(DLOOP,660)),"^",6)
IF 'PSSPRICE
QUIT ""
+6 IF $GET(PSSUDOS)
SET PSSPRQ=PSSUDOS*PSSPRICE
GOTO PRICEQ
+7 IF $GET(PSSBCM)
SET PSSPRQ=PSSBCM*PSSPRICE
PRICEQ ;
+1 IF $EXTRACT($GET(PSSPRQ))="."
SET PSSPRQ=0_$GET(PSSPRQ)
+2 QUIT $GET(PSSPRQ)
+3 ;
+4 QUIT
+5 ;
OIDEA(PSSXOI,PSSXOIP) ;
+1 ;DEA return based on Orderable Item, Item and Usage passed in
+2 ;1 means DEA contains a 1, or a 2
+3 ;2 means DEA contains a 3, or a 4, or a 5
+4 ;0 means all others
+5 NEW PSSXOLP,PSSXOLPD,PSSXOLPX,PSSXNODD,PSSPKLX
+6 SET (PSSXOLPD,PSSXNODD)=0
IF PSSXOIP="X"
GOTO OIDQ
+7 IF '$GET(PSSXOI)!($GET(PSSXOIP)="")
GOTO OIDQ
+8 SET PSSPKLX=$SELECT(PSSXOIP="I":1,PSSXOIP="U":1,1:0)
+9 FOR PSSXOLP=0:0
SET PSSXOLP=$ORDER(^PSDRUG("ASP",PSSXOI,PSSXOLP))
if 'PSSXOLP!(PSSXOLPD=1)
QUIT
Begin DoDot:1
+10 IF $PIECE($GET(^PSDRUG(PSSXOLP,"I")),"^")
IF $PIECE($GET(^("I")),"^")<DT
QUIT
+11 IF 'PSSPKLX
IF $PIECE($GET(^PSDRUG(PSSXOLP,2)),"^",3)'["O"
QUIT
+12 IF PSSPKLX
IF $PIECE($GET(^PSDRUG(PSSXOLP,2)),"^",3)'["U"
IF $PIECE($GET(^(2)),"^",3)'["I"
QUIT
+13 SET PSSXNODD=1
+14 SET PSSXOLPX=$PIECE($GET(^PSDRUG(PSSXOLP,0)),"^",3)
+15 IF PSSXOLPX[1!(PSSXOLPX[2)
SET PSSXOLPD=1
QUIT
+16 IF PSSXOLPX[3!(PSSXOLPX[4)!(PSSXOLPX[5)
SET PSSXOLPD=2
End DoDot:1
OIDQ ;
+1 IF PSSXOLPD=0
IF 'PSSXNODD
SET PSSXOLPD=""
+2 QUIT PSSXOLPD
+3 ;
+4 QUIT
+5 ;
LEAD ;Leading zeros, CPRS Dosage call
+1 NEW PSSBK,PSSBK1,PSSBKD
+2 FOR PSSLD=0:0
SET PSSLD=$ORDER(PSSX(PSSLD))
if 'PSSLD
QUIT
Begin DoDot:1
+3 IF $EXTRACT($PIECE(PSSX(PSSLD),"^"),1)="."
SET $PIECE(PSSX(PSSLD),"^")="0"_$PIECE(PSSX(PSSLD),"^")
+4 IF $EXTRACT($PIECE(PSSX(PSSLD),"^",2),1)="."
SET $PIECE(PSSX(PSSLD),"^",2)="0"_$PIECE(PSSX(PSSLD),"^",2)
+5 IF $PIECE(PSSX(PSSLD),"^",2)["/."
SET PSSBKD=$PIECE(PSSX(PSSLD),"^",2)
Begin DoDot:2
+6 SET PSSBK=$PIECE(PSSBKD,"/.")
SET PSSBK1=$PIECE(PSSBKD,"/.",2)
+7 SET $PIECE(PSSX(PSSLD),"^",2)=$GET(PSSBK)_"/0."_$GET(PSSBK1)
End DoDot:2
+8 IF $EXTRACT($PIECE(PSSX(PSSLD),"^",5),1)="."
SET $PIECE(PSSX(PSSLD),"^",5)="0"_$PIECE(PSSX(PSSLD),"^",5)
+9 IF $PIECE(PSSX(PSSLD),"^",5)["/."
SET PSSBKD=$PIECE(PSSX(PSSLD),"^",5)
Begin DoDot:2
+10 SET PSSBK=$PIECE(PSSBKD,"/.")
SET PSSBK1=$PIECE(PSSBKD,"/.",2)
+11 SET $PIECE(PSSX(PSSLD),"^",5)=$GET(PSSBK)_"/0."_$GET(PSSBK1)
End DoDot:2
+12 IF $ORDER(PSSX(PSSLD,0))
Begin DoDot:2
+13 FOR PSSLD1=0:0
SET PSSLD1=$ORDER(PSSX(PSSLD,PSSLD1))
if 'PSSLD1
QUIT
Begin DoDot:3
+14 IF $EXTRACT($PIECE(PSSX(PSSLD,PSSLD1),"^"),1)="."
SET $PIECE(PSSX(PSSLD,PSSLD1),"^")="0"_$PIECE(PSSX(PSSLD,PSSLD1),"^")
+15 IF $EXTRACT($PIECE(PSSX(PSSLD,PSSLD1),"^",2),1)="."
SET $PIECE(PSSX(PSSLD,PSSLD1),"^",2)="0"_$PIECE(PSSX(PSSLD,PSSLD1),"^",2)
+16 IF $PIECE(PSSX(PSSLD,PSSLD1),"^",2)["/."
SET PSSBKD=$PIECE(PSSX(PSSLD,PSSLD1),"^",2)
Begin DoDot:4
+17 SET PSSBK=$PIECE(PSSBKD,"/.")
SET PSSBK1=$PIECE(PSSBKD,"/.",2)
+18 SET $PIECE(PSSX(PSSLD,PSSLD1),"^",2)=$GET(PSSBK)_"/0."_$GET(PSSBK1)
End DoDot:4
+19 IF $EXTRACT($PIECE(PSSX(PSSLD,PSSLD1),"^",5),1)="."
SET $PIECE(PSSX(PSSLD,PSSLD1),"^",5)="0"_$PIECE(PSSX(PSSLD,PSSLD1),"^",5)
+20 IF $PIECE(PSSX(PSSLD,PSSLD1),"^",5)["/."
SET PSSBKD=$PIECE(PSSX(PSSLD,PSSLD1),"^",5)
Begin DoDot:4
+21 SET PSSBK=$PIECE(PSSBKD,"/.")
SET PSSBK1=$PIECE(PSSBKD,"/.",2)
+22 SET $PIECE(PSSX(PSSLD,PSSLD1),"^",5)=$GET(PSSBK)_"/0."_$GET(PSSBK1)
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+23 SET PSSLD=""
FOR
SET PSSLD=$ORDER(PSSX("DD",PSSLD))
if PSSLD=""
QUIT
Begin DoDot:1
+24 IF $EXTRACT($PIECE(PSSX("DD",PSSLD),"^",5),1)="."
SET $PIECE(PSSX("DD",PSSLD),"^",5)="0"_$PIECE(PSSX("DD",PSSLD),"^",5)
End DoDot:1
+25 QUIT
LEADP ;Leading zeros pharmacy call
+1 NEW PSSBB,PSSBB1,PSSBBD
+2 FOR PSSMD=0:0
SET PSSMD=$ORDER(PSSX(PSSMD))
if 'PSSMD
QUIT
Begin DoDot:1
+3 FOR PSSMDN=1,3,5,11
IF $EXTRACT($PIECE(PSSX(PSSMD),"^",PSSMDN),1)="."
SET $PIECE(PSSX(PSSMD),"^",PSSMDN)="0"_$PIECE(PSSX(PSSMD),"^",PSSMDN)
+4 IF $PIECE(PSSX(PSSMD),"^",2)["/."
SET PSSBBD=$PIECE(PSSX(PSSMD),"^",2)
Begin DoDot:2
+5 SET PSSBB=$PIECE(PSSBBD,"/.")
SET PSSBB1=$PIECE(PSSBBD,"/.",2)
+6 SET $PIECE(PSSX(PSSMD),"^",2)=$GET(PSSBB)_"/0."_$GET(PSSBB1)
End DoDot:2
+7 IF $PIECE(PSSX(PSSMD),"^",11)["/."
SET PSSBBD=$PIECE(PSSX(PSSMD),"^",11)
Begin DoDot:2
+8 SET PSSBB=$PIECE(PSSBBD,"/.")
SET PSSBB1=$PIECE(PSSBBD,"/.",2)
+9 SET $PIECE(PSSX(PSSMD),"^",11)=$GET(PSSBB)_"/0."_$GET(PSSBB1)
End DoDot:2
+10 IF $ORDER(PSSX(PSSMD,0))
Begin DoDot:2
+11 FOR PSSMD1=0:0
SET PSSMD1=$ORDER(PSSX(PSSMD,PSSMD1))
if 'PSSMD1
QUIT
Begin DoDot:3
+12 FOR PSSMDN=1,3,5,11
IF $EXTRACT($PIECE(PSSX(PSSMD,PSSMD1),"^",PSSMDN),1)="."
SET $PIECE(PSSX(PSSMD,PSSMD1),"^",PSSMDN)="0"_$PIECE(PSSX(PSSMD,PSSMD1),"^",PSSMDN)
+13 IF $PIECE(PSSX(PSSMD,PSSMD1),"^",2)["/."
SET PSSBBD=$PIECE(PSSX(PSSMD,PSSMD1),"^",2)
Begin DoDot:4
+14 SET PSSBB=$PIECE(PSSBBD,"/.")
SET PSSBB1=$PIECE(PSSBBD,"/.",2)
+15 SET $PIECE(PSSX(PSSMD,PSSMD1),"^",2)=$GET(PSSBB)_"/0."_$GET(PSSBB1)
End DoDot:4
+16 IF $PIECE(PSSX(PSSMD,PSSMD1),"^",11)["/."
SET PSSBBD=$PIECE(PSSX(PSSMD,PSSMD1),"^",11)
Begin DoDot:4
+17 SET PSSBB=$PIECE(PSSBBD,"/.")
SET PSSBB1=$PIECE(PSSBBD,"/.",2)
+18 SET $PIECE(PSSX(PSSMD,PSSMD1),"^",11)=$GET(PSSBB)_"/0."_$GET(PSSBB1)
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+19 SET PSSMD=""
FOR
SET PSSMD=$ORDER(PSSX("DD",PSSMD))
if PSSMD=""
QUIT
Begin DoDot:1
+20 IF $EXTRACT($PIECE(PSSX("DD",PSSMD),"^",5),1)="."
SET $PIECE(PSSX("DD",PSSMD),"^",5)="0"_$PIECE(PSSX("DD",PSSMD),"^",5)
End DoDot:1
+21 QUIT
DUP ;delete str/unit if duplicate local doses with strength are found
+1 NEW PSSLXA,PSSLXL,PSSLXFL,PSSLXQ,PSSLXLD,PSSLXMED,PSSLXSTR,PSSLXND,PSSLXX
+2 SET PSSLXFL=0
+3 SET PSSLXL=""
FOR
SET PSSLXL=$ORDER(PSSX(PSSLXL))
if PSSLXL=""!(PSSLXFL)
QUIT
Begin DoDot:1
+4 SET PSSLXND=$GET(PSSX(PSSLXL))
SET PSSLXSTR=""
+5 SET PSSLXLD=$PIECE(PSSLXND,"^",5)
SET PSSLXMED=$PIECE(PSSLXND,"^",6)
IF PSSLXMED
SET PSSLXSTR=$PIECE($GET(PSSX("DD",PSSLXMED)),"^",5)
+6 IF PSSLXLD'=""
IF PSSLXMED'=""
IF PSSLXSTR'=""
Begin DoDot:2
+7 SET PSSLXA(PSSLXLD,PSSLXSTR,PSSLXMED)=""
+8 SET PSSLXX=""
FOR
SET PSSLXX=$ORDER(PSSLXA(PSSLXLD,PSSLXSTR,PSSLXX))
if PSSLXX=""!(PSSLXFL)
QUIT
IF PSSLXX'=PSSLXMED
SET PSSLXFL=1
End DoDot:2
End DoDot:1
+9 IF PSSLXFL
SET PSSLXQ=""
FOR
SET PSSLXQ=$ORDER(PSSX("DD",PSSLXQ))
if PSSLXQ=""
QUIT
SET $PIECE(PSSX("DD",PSSLXQ),"^",5)=""
SET $PIECE(PSSX("DD",PSSLXQ),"^",6)=""
+10 QUIT
+11 ;
PLACER(PSSPDFN,PSSPIEN) ;Return CPRS order number from Pharmacy order
+1 ;PSSPDFN = Patient internal number
+2 ;PSSPIEN = Pharmacy number - U-Unit Dose, V-IV, P-Inpatient Pending, S-Outpatient Pending, R-Prescription, N-Non-VA
+3 IF '$GET(PSSPDFN)
QUIT ""
+4 IF PSSPIEN'?1.N1U
QUIT ""
+5 NEW PSSPAK,PSSLOC
SET PSSPAK=$EXTRACT(PSSPIEN,$LENGTH(PSSPIEN))
+6 SET PSSLOC=$SELECT(PSSPAK="U":5,PSSPAK="V":"IV","PSRN"[PSSPAK:1,1:"")
+7 IF PSSLOC=""
QUIT ""
+8 IF "UV"[PSSPAK
QUIT $PIECE($GET(^PS(55,PSSPDFN,PSSLOC,+PSSPIEN,0)),"^",21)
+9 IF PSSPAK="R"
QUIT $PIECE($GET(^PSRX(+PSSPIEN,"OR1")),"^",2)
+10 IF PSSPAK="P"
QUIT $PIECE($GET(^PS(53.1,+PSSPIEN,0)),"^",21)
+11 IF PSSPAK="S"
QUIT $PIECE($GET(^PS(52.41,+PSSPIEN,0)),"^")
+12 QUIT $PIECE($GET(^PS(55,PSSPDFN,"NVA",+PSSPIEN,0)),"^",8)
+13 ;
LOC(PSSPDFN,PSSPIEN) ;Return Location from Pharmacy order
+1 ;PSSPDFN = Patient internal number
+2 ;PSSPIEN = Pharmacy number - U-Unit Dose, V-IV, P-Inpatient Pending, S-Outpatient Pending, R-Prescription, N-Non-VA
+3 IF '$GET(PSSPDFN)!($GET(PSSPIEN)'?1.N1U)
QUIT $$LOCIN
+4 NEW PSSPAK,PSSHLOC,PSSWRD,PSSWRDN,PSSRSLT,PSSROOM,PSSRLIN,PSSRLINN,PSSERR
+5 SET PSSPAK=$EXTRACT(PSSPIEN,$LENGTH(PSSPIEN))
SET PSSRSLT=""
+6 IF "UVP"[PSSPAK
Begin DoDot:1
+7 IF PSSPAK="V"
SET PSSHLOC=$PIECE($GET(^PS(55,PSSPDFN,"IV",+PSSPIEN,"DSS")),"^")
+8 IF PSSPAK="P"
SET PSSHLOC=$PIECE($GET(^PS(53.1,+PSSPIEN,"DSS")),"^")
+9 IF PSSPAK="U"
SET PSSHLOC=$PIECE($GET(^PS(55,PSSPDFN,5,+PSSPIEN,8)),"^")
+10 IF PSSHLOC
SET PSSRSLT=$$LOCHL(PSSHLOC)
IF PSSRSLT
QUIT
+11 SET PSSWRD=$$LOCWA
+12 IF PSSWRD
SET PSSHLOC=$PIECE($GET(^DIC(42,+PSSPIEN,44)),"^")
IF PSSHLOC
SET PSSRSLT=$$LOCHL(PSSHLOC)
IF PSSRSLT
QUIT
+13 IF PSSWRD
SET PSSWRDN=$PIECE($GET(^DIC(42,PSSWRD,0)),"^")
IF PSSWRDN'=""
SET PSSRSLT=PSSWRD_"^"_PSSWRDN_"^"_42
QUIT
+14 SET PSSROOM=""
IF PSSPAK="V"
SET PSSROOM=$PIECE($GET(^PS(55,PSSPDFN,"IV",+PSSPIEN,2)),"^",2)
+15 IF PSSPAK="P"
SET PSSROOM=$PIECE($GET(^PS(53.1,+PSSPIEN,8)),"^",8)
+16 IF PSSROOM
SET PSSRSLT=$$LOCDI(PSSROOM)
IF PSSRSLT
QUIT
+17 SET PSSRSLT=$$LOCIN
End DoDot:1
QUIT PSSRSLT
+18 IF "SRN"[PSSPAK
Begin DoDot:1
+19 IF PSSPAK="N"
SET PSSHLOC=$PIECE($GET(^PS(55,PSSPDFN,"NVA",+PSSPIEN,0)),"^",12)
+20 IF PSSPAK="R"
SET PSSHLOC=$PIECE($GET(^PSRX(+PSSPIEN,0)),"^",5)
+21 IF PSSPAK="S"
SET PSSHLOC=$PIECE($GET(^PS(52.41,+PSSPIEN,0)),"^",13)
+22 IF PSSHLOC
SET PSSRSLT=$$LOCHL(PSSHLOC)
IF PSSRSLT
QUIT
+23 IF PSSPAK="S"
SET PSSRLIN=$PIECE($GET(^PS(52.41,+PSSPIEN,"INI")),"^")
IF PSSRLIN
SET PSSRLINN=$$GET1^DIQ(52.41,+PSSPIEN_",",100,,,"PSSERR")
IF PSSRLINN'=""
SET PSSRSLT=PSSRLIN_"^"_PSSRLINN_"^"_4
QUIT
+24 SET PSSRSLT=$$LOCIN
End DoDot:1
QUIT PSSRSLT
+25 QUIT $$LOCIN
+26 ;
LOCWA() ;Return ward
+1 NEW VAHOW,VAROOT,VAINDT,VAIN,VAERR
+2 DO INP^VADPT
+3 QUIT +$GET(VAIN(4))
+4 ;
LOCHL(PSSCLN) ;Return hospital location file #44
+1 NEW PSSCLNN
SET PSSCLNN=$PIECE($GET(^SC(PSSCLN,0)),"^")
+2 QUIT $SELECT(PSSCLNN'="":PSSCLN_"^"_PSSCLNN_"^"_44,1:"")
+3 ;
LOCDI(PSSDIV) ;Return division file #40.8
+1 NEW PSSDIVN
SET PSSDIVN=$PIECE($GET(^DG(40.8,PSSDIV,0)),"^")
+2 QUIT $SELECT(PSSDIVN'="":PSSDIV_"^"_PSSDIVN_"^"_40.8,1:"")
+3 ;
LOCIN() ;Return institution file #4
+1 QUIT $PIECE($$SITE^VASITE,"^",1,2)_"^"_4
