Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PSSUTLA1

PSSUTLA1.m

Go to the documentation of this file.
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