PSOBUILD ;IHS/DSD/JCM - BUILD ARRAY OF PATIENTS CURRENT MEDS [ 07/15/96 5:25 PM ] ;6/21/07 8:20am
;;7.0;OUTPATIENT PHARMACY;**23,82,119,132,235,206,251,441**;DEC 1997;Build 208
;External reference ^PS(50.606 supported by DBIA 2174
;External reference ^PS(50.7 supported by DBIA 2223
;External reference ^PS(55 supported by DBIA 2228
;External reference ^PSDRUG( supported by DBIA 221
; Input variables: PSODFN,DT,PSODTCUT
;
;Add Complex Orders to NVA Meds
;
START N ORD K PSOSD I '$D(PSODFN)!('$D(DT)) G END
D EOJ,INIT G:PSOQFLG END D BUILD
S STA="ACTIVE^NON-VERIFIED^REFILL^HOLD^NON-VERIFIED^ACTIVE^^^^^^ACTIVE^DISCONTINUED^^DISCONTINUED^DISCONTINUED^HOLD"
S DRG="" F I=0:0 S DRG=$O(PSOSD(DRG)) Q:DRG="" I $G(PSOSD(DRG))]"" S PSOSD($P(STA,"^",$P(PSOSD(DRG),"^",2)+1),DRG)=PSOSD(DRG) D K PSOSD(DRG)
.S $P(PSOSD($P(STA,"^",$P(PSOSD(DRG),"^",2)+1),DRG),"^",9)=$G(^TMP("PS",$J,$P(STA,"^",$P(PSOSD(DRG),"^",2)+1),DRG))
F PEN=0:0 S PEN=$O(^PS(52.41,"P",PSODFN,PEN)) Q:'PEN S ORD=^PS(52.41,PEN,0),PSOOI=$P(ORD,"^",8),PSODD=+$P(ORD,"^",9) D:$P(ORD,"^",3)'="DC"&($P(ORD,"^",3)'="DE")&($P(ORD,"^",3)'="HD")
.I 'PSODD N ZPSI,ZPSDC S (ZPSDC,ZPSI)=0 I $G(PSOOI) D
..F S ZPSI=$O(^PSDRUG("ASP",PSOOI,ZPSI)) Q:'ZPSI I $S('$D(^PSDRUG(ZPSI,"I")):1,'^("I"):1,DT'>^("I"):1,1:0),$S($P($G(^PSDRUG(ZPSI,2)),"^",3)'["O":0,1:1) S ZPSDC=ZPSDC+1,ZPSDC(ZPSDC)=ZPSI
..I ZPSDC=1 S PSODD=ZPSDC(1),$P(^PS(52.41,PEN,0),"^",9)=ZPSDC(1)
.K ZPSI,ZPSDC
.S DRG=$S(PSODD:$P($G(^PSDRUG(PSODD,0)),"^"),+PSOOI&('PSODD):$P(^PS(50.7,+PSOOI,0),"^")_" "_$P(^PS(50.606,$P(^PS(50.7,+PSOOI,0),"^",2),0),"^"),1:"") Q:DRG']""
.I $D(PSOSD("PENDING",DRG)) S DRG=DRG_"^"_PEN
.S PSOSD("PENDING",DRG)="*****^17^Z^Z^"_$S(PSODD:$P(^PSDRUG(PSODD,0),"^",2),1:"")_"^"_$P(^PS(52.41,PEN,0),"^",11)_"^"_$S($G(^PSDRUG(PSODD,"ND"))]"":+^("ND")_"A"_$P(^("ND"),"^",3),1:"")
.S PSOSD("PENDING",DRG)=PSOSD("PENDING",DRG)_"^"_$P(ORD,"^",10)_"^"_$P(ORD,"^",6)_"^"_PEN_"^"_$S($G(PSODD):$G(PSODD),1:""),PSOSD=+$G(PSOSD)+1 K PSOOI,PSODD
;*** Complex NVA Order Modifications ***
N DD,DDX,DOSE,SCHD,MEDR,DURA,CONJ,COMPLEX
F NVA=0:0 S NVA=$O(^PS(55,PSODFN,"NVA",NVA)) Q:'NVA S NON=^PS(55,PSODFN,"NVA",NVA,0) D:'$P(^PS(55,PSODFN,"NVA",NVA,0),"^",7) ;DO if not DC'd date
.I $O(^PS(55,PSODFN,"NVA",NVA,3,0)) D NVANEW Q
.D NVAOLD
END D EOJ
Q
;
NVANEW ;New Complex NVA order multiple file format logic
;loop thru DD multiple and create separate array entries for each item (in case contain a complex order)
F DD=0:0 S DD=$O(^PS(55,PSODFN,"NVA",NVA,3,DD)) Q:'DD D
.S DDX=DD_","_NVA_","_PSODFN
.S DOSE=$$GET1^DIQ(55.516,DDX,"DOSAGE","I")
.S SCHD=$$GET1^DIQ(55.516,DDX,"SCHEDULE","I")
.S MEDR=$$GET1^DIQ(55.516,DDX,"MEDICATION ROUTE","I")
.S DURA=$$GET1^DIQ(55.516,DDX,"DURATION","I")
.S CONJ=$$GET1^DIQ(55.516,DDX,"CONJUNCTION")
.S PSODD=$P(NON,"^",2),PSOOI=$P(NON,"^")
.S DRG=$S(PSODD:$P($G(^PSDRUG(PSODD,0)),"^"),+PSOOI&('PSODD):$P(^PS(50.7,+PSOOI,0),"^")_" "_$P(^PS(50.606,$P(^PS(50.7,+PSOOI,0),"^",2),0),"^"),1:"")
.I $D(PSOSD("ZNONVA",DRG)) S DRG=DRG_"^"_NVA_"^"_DD
.S PSOSD("ZNONVA",DRG)="****^9^Z^Z^"_$S(PSODD:$P(^PSDRUG(PSODD,0),"^",2),1:"")_"^"_DOSE_"^^"_SCHD_"^"_$P(NON,"^",10)_"^"_NVA_"^"_PSODD_"^"_DURA_"^"_CONJ ;append new pieces 12 & 13
.I PSODD S $P(PSOSD("ZNONVA",DRG),"^",7)=$S($G(^PSDRUG(PSODD,"ND"))]"":+^("ND")_"A"_$P(^("ND"),"^",3),1:"")
.S PSOSD=+$G(PSOSD)+1
Q
;
NVAOLD ;NVA Backwards compatible for old NON-VA file DD, pre-complex order SIG multiple file setup
; (after 441. By attrition, all records will eventually have the new complex order mult. file format)
S PSODD=$P(NON,"^",2),PSOOI=$P(NON,"^")
S DRG=$S(PSODD:$P($G(^PSDRUG(PSODD,0)),"^"),+PSOOI&('PSODD):$P(^PS(50.7,+PSOOI,0),"^")_" "_$P(^PS(50.606,$P(^PS(50.7,+PSOOI,0),"^",2),0),"^"),1:"")
I $D(PSOSD("ZNONVA",DRG)) S DRG=DRG_U_NVA ;build unique nva drug name subscript when same drug
S PSOSD("ZNONVA",DRG)="****^9^Z^Z^"_$S($P(NON,"^",2):$P(^PSDRUG($P(NON,"^",2),0),"^",2),1:"")_"^"_$P(NON,"^",3)_"^^"_$P(NON,"^",5)_"^"_$P(NON,"^",10)_"^"_NVA_"^"_$P(NON,"^",2)
I $P(NON,"^",2) S $P(PSOSD("ZNONVA",DRG),"^",7)=$S($G(^PSDRUG(PSODD,"ND"))]"":+^("ND")_"A"_$P(^("ND"),"^",3),1:"")
S PSOSD=+$G(PSOSD)+1
Q
;
INIT ;
K PSOSD,PSOMED S PSOQFLG=0,U="^",PSOBUILD("COUNT")=0 G:$D(PSODTCUT) INITX
I '$D(^PS(53,"B","OUTPATIENT")) S PSOQFLG=1 G INITX
S PSOX=$O(^PS(53,"B","OUTPATIENT","")) I 'PSOX S PSOQFLG=1 G INITX
;S DAYS=$S($D(DAYS360):360,1:45),X2=-$S($P($G(^PS(53,PSOX,0)),"^",3)+15>DAYS:$P($G(^(0)),"^",3)+15,1:DAYS),X1=DT D C^%DTC S PSODTCUT=X
S X2=-120,X1=DT D C^%DTC S PSODTCUT=X
INITX K X,X1,X2,PSOX
Q
;
BUILD ;build profiles
F PSOEXPDT=(PSODTCUT-1):0 S PSOEXPDT=$O(^PS(55,PSODFN,"P","A",PSOEXPDT)) Q:'PSOEXPDT F PSOBUILD("RX")=0:0 S PSOBUILD("RX")=$O(^PS(55,PSODFN,"P","A",PSOEXPDT,PSOBUILD("RX"))) Q:'PSOBUILD("RX") I $D(^PSRX(PSOBUILD("RX"),0)) D GET
BUILDX I PSOBUILD("COUNT")>0 S PSOSD=PSOBUILD("COUNT")
Q
GET ;data for profiles
Q:'$P(^PSRX(PSOBUILD("RX"),0),"^",2)
S (PSOSTF,PSOSTN)="",PSORX0=^PSRX(PSOBUILD("RX"),0),PSOST0=+^PSRX(PSOBUILD("RX"),"STA"),$P(PSORX0,"^",15)=PSOST0
G:PSOST0=13 GETX S PSORX2=$G(^PSRX(PSOBUILD("RX"),2))
S PSORX3=$G(^PSRX(PSOBUILD("RX"),3)) S:PSORX3="" PSORX3=$P(PSORX2,"^",2)
S PSODRG=+$P(PSORX0,"^",6) G:'$D(^PSDRUG(PSODRG,0)) GETX S PSODRUG0=^PSDRUG(PSODRG,0),PSOVACL=$P(PSODRUG0,"^",2),PSODYS=$P(PSORX0,"^",8)
;
I PSOST0<12!(PSOST0=16),PSOEXPDT<DT D:$P(PSORX0,"^",15)'=11
.S PSOST0=11,$P(PSORX0,"^",15)=11 N DIE,DIC,DR,DA,PSOBEXDA S DIE=52,(DA,PSOBEXDA)=PSOBUILD("RX"),DR="100////11" D ^DIE K DIE,DIC,DR
.D ECAN^PSOUTL(DA) K DA
.S STAT="SC",PHARMST="ZE",COMM="Medication Expired on "_$E(PSOEXPDT,4,5)_"/"_$E(PSOEXPDT,6,7)_"/"_$E(PSOEXPDT,2,3) D EN^PSOHLSN1(PSOBEXDA,STAT,PHARMST,COMM) K COMM,STAT,PHARMST,PSOBEXDA
I PSOST0=12,PSOEXPDT<DT S PSOST0=12
I PSOST0=5 D G GT1
.I $O(^PS(52.5,"B",PSOBUILD("RX"),0)),'$D(^PS(52.5,+$O(^(0)),0)) D Q
..S PSOST0=0 D FSTA
..K ^PS(52.5,"B",PSOBUILD("RX"),$O(^PS(52.5,"B",PSOBUILD("RX"),0)))
.I '$O(^PS(52.5,"B",PSOBUILD("RX"),0)) S PSOST0=0 D FSTA
I 'PSOST0 D STAT
GT1 G GETX:$D(NOEXP)&(PSOST0=11)
I $D(^PSDRUG(PSODRG,"I")),^("I")]"",DT>^("I") S PSOSTN=PSOSTN_"A" I $P($G(PSOPAR),"^",11)']"" S PSOSTF=PSOSTF_"A"
S PSONDF=$S($G(^PSDRUG(PSODRG,"ND"))]"":+^("ND")_"A"_$P(^("ND"),"^",3),1:0)
I $P($G(^PSDRUG(PSODRG,2)),"^",3)'["O" S PSOSTN=PSOSTN_"M"
S CLOZPT=$S($P($G(^PSDRUG(PSODRG,"CLOZ1")),"^")="PSOCLO1":1,1:0)
I 'CLOZPT,($P(PSODRUG0,"^",3)["A")&($P(PSODRUG0,"^",3)'["B") S PSOSTN=PSOSTN_"B",PSOSTF=PSOSTF_"B"
K CLOZPT I ($P(PSODRUG0,"^",3)["W")!($P(PSODRUG0,"^",3)[1)!($P(PSODRUG0,"^",3)[2) S PSOSTN=PSOSTN_"C"
I $D(^PS(53,+$P(PSORX0,"^",3),0)),'$P(^(0),"^",5) S PSOSTN=PSOSTN_"D"
I PSOST0=1 S PSOSTN=PSOSTN_"E"
S PSOLC=$P(PSORX0,"^"),PSOLC=$E(PSOLC,$L(PSOLC)) I $A(PSOLC)>90 S PSOSTN=PSOSTN_"F"
I PSOST0,PSOST0'=2,PSOST0'=6 S PSOSTF=PSOSTF_"Z"
I $G(PSORX("BAR CODE")),PSOST0,PSOST0'=2,PSOST0'=5,PSOST0'=6,PSOST0'=11,PSOST0'=12 S PSOSTN=PSOSTN_"Z" G BARC
I PSOST0,PSOST0'=2,PSOST0'=5,PSOST0'=6,PSOST0'=11,PSOST0'=12,PSOST0'=14 S PSOSTN=PSOSTN_"Z"
BARC S PSORFRM=$P(PSORX0,"^",9) F PSOJ=0:0 S PSOJ=$O(^PSRX(PSOBUILD("RX"),1,PSOJ)) Q:'PSOJ S PSORFRM=PSORFRM-1
S:PSORFRM<0 PSORFRM=0 S:PSORFRM=0 PSOSTF=PSOSTF_"G"
S PSODRUGN=$P(PSODRUG0,"^") I $D(PSOSD(PSODRUGN)),PSOST0>10 Q:$P(PSOSD(PSODRUGN),"^",2)<11 Q:$P(PSOSD(PSODRUGN),"^",2)>10&($P(PSORX0,"^",13)<$P(^PSRX(+$P(PSOSD(PSODRUGN),"^"),0),"^",13))
S:'$D(PSOSD(PSODRUGN)) PSOBUILD("COUNT")=PSOBUILD("COUNT")+1
I $D(PSOSD(PSODRUGN)),$P(PSOSD(PSODRUGN),"^",2)<10,PSOST0<10 S PSOSD(PSODRUGN_"^"_PSOBUILD("RX"))=PSOBUILD("RX")_"^"_PSOST0_"^"_PSOSTN_"^"_PSOSTF_"^"_PSOVACL_"^"_PSORFRM_"^"_PSONDF_"^"_PSODYS,PSOBUILD("COUNT")=PSOBUILD("COUNT")+1
E S PSOSD(PSODRUGN)=PSOBUILD("RX")_"^"_PSOST0_"^"_PSOSTN_"^"_PSOSTF_"^"_PSOVACL_"^"_PSORFRM_"^"_PSONDF_"^"_PSODYS
GETX Q
STAT N X S X=+$O(^PS(52.5,"B",PSOBUILD("RX"),0))
I X,$D(^PS(52.5,X,0)),$P($G(^PS(52.5,X,0)),"^",7)'="X",'$G(^PS(52.5,X,"P")) S PSOST0=5
I PSOST0 D FSTA
Q
FSTA S $P(PSORX0,"^",15)=PSOST0
N DIE,DR,DA S DIE=52,DA=PSOBUILD("RX"),DR="100////"_PSOST0 D ^DIE K DIE,DR,DA
Q
;
EOJ K ORD,PSOX,PSOEXPDT,PSODRG,PSODRUG0,PSOLC,PSONDF,PSOQFLG,PSORFRM,PSORX0,PSORX2,PSORX3,PSOST0,PSOSTF,PSOSTN,PSOJ,PSODRUGN,PSOVACL,PSOBUILD,PSODYS,PEN,DRG,NON,NVA
Q
INPAT(PSODFN) ;entry point for inpat meds to view patient's outpat. meds
D FULL^VALM1
S INPAT=1,X2=-120,X1=DT D C^%DTC S PSODTCUT=X D START,^PSODSPL
K PSOSD,DDH,PSCNT,PSOCT,PSODD,PSOOI,PSOPAR,PSOSTA,STP,STR,PSODTCUT,PSODFN,INPAT,DRG
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOBUILD 8614 printed Sep 23, 2025@20:01:25 Page 2
PSOBUILD ;IHS/DSD/JCM - BUILD ARRAY OF PATIENTS CURRENT MEDS [ 07/15/96 5:25 PM ] ;6/21/07 8:20am
+1 ;;7.0;OUTPATIENT PHARMACY;**23,82,119,132,235,206,251,441**;DEC 1997;Build 208
+2 ;External reference ^PS(50.606 supported by DBIA 2174
+3 ;External reference ^PS(50.7 supported by DBIA 2223
+4 ;External reference ^PS(55 supported by DBIA 2228
+5 ;External reference ^PSDRUG( supported by DBIA 221
+6 ; Input variables: PSODFN,DT,PSODTCUT
+7 ;
+8 ;Add Complex Orders to NVA Meds
+9 ;
START NEW ORD
KILL PSOSD
IF '$DATA(PSODFN)!('$DATA(DT))
GOTO END
+1 DO EOJ
DO INIT
if PSOQFLG
GOTO END
DO BUILD
+2 SET STA="ACTIVE^NON-VERIFIED^REFILL^HOLD^NON-VERIFIED^ACTIVE^^^^^^ACTIVE^DISCONTINUED^^DISCONTINUED^DISCONTINUED^HOLD"
+3 SET DRG=""
FOR I=0:0
SET DRG=$ORDER(PSOSD(DRG))
if DRG=""
QUIT
IF $GET(PSOSD(DRG))]""
SET PSOSD($PIECE(STA,"^",$PIECE(PSOSD(DRG),"^",2)+1),DRG)=PSOSD(DRG)
Begin DoDot:1
+4 SET $PIECE(PSOSD($PIECE(STA,"^",$PIECE(PSOSD(DRG),"^",2)+1),DRG),"^",9)=$GET(^TMP("PS",$JOB,$PIECE(STA,"^",$PIECE(PSOSD(DRG),"^",2)+1),DRG))
End DoDot:1
KILL PSOSD(DRG)
+5 FOR PEN=0:0
SET PEN=$ORDER(^PS(52.41,"P",PSODFN,PEN))
if 'PEN
QUIT
SET ORD=^PS(52.41,PEN,0)
SET PSOOI=$PIECE(ORD,"^",8)
SET PSODD=+$PIECE(ORD,"^",9)
if $PIECE(ORD,"^",3)'="DC"&($PIECE(ORD,"^",3)'="DE")&($PIECE(ORD,"^",3)'="HD")
Begin DoDot:1
+6 IF 'PSODD
NEW ZPSI,ZPSDC
SET (ZPSDC,ZPSI)=0
IF $GET(PSOOI)
Begin DoDot:2
+7 FOR
SET ZPSI=$ORDER(^PSDRUG("ASP",PSOOI,ZPSI))
if 'ZPSI
QUIT
IF $SELECT('$DATA(^PSDRUG(ZPSI,"I")):1,'^("I"):1,DT'>^("I"):1,1:0)
IF $SELECT($PIECE($GET(^PSDRUG(ZPSI,2)),"^",3)'["O":0,1:1)
SET ZPSDC=ZPSDC+1
SET ZPSDC(ZPSDC)=ZPSI
+8 IF ZPSDC=1
SET PSODD=ZPSDC(1)
SET $PIECE(^PS(52.41,PEN,0),"^",9)=ZPSDC(1)
End DoDot:2
+9 KILL ZPSI,ZPSDC
+10 SET DRG=$SELECT(PSODD:$PIECE($GET(^PSDRUG(PSODD,0)),"^"),+PSOOI&('PSODD):$PIECE(^PS(50.7,+PSOOI,0),"^")_" "_$PIECE(^PS(50.606,$PIECE(^PS(50.7,+PSOOI,0),"^",2),0),"^"),1:"")
if DRG']""
QUIT
+11 IF $DATA(PSOSD("PENDING",DRG))
SET DRG=DRG_"^"_PEN
+12 SET PSOSD("PENDING",DRG)="*****^17^Z^Z^"_$SELECT(PSODD:$PIECE(^PSDRUG(PSODD,0),"^",2),1:"")_"^"_$PIECE(^PS(52.41,PEN,0),"^",11)_"^"_$SELECT($GET(^PSDRUG(PSODD,"ND"))]"":+^("ND")_"A"_$PIECE(^("ND"),"^",3),1:"")
+13 SET PSOSD("PENDING",DRG)=PSOSD("PENDING",DRG)_"^"_$PIECE(ORD,"^",10)_"^"_$PIECE(ORD,"^",6)_"^"_PEN_"^"_$SELECT($GET(PSODD):$GET(PSODD),1:"")
SET PSOSD=+$GET(PSOSD)+1
KILL PSOOI,PSODD
End DoDot:1
+14 ;*** Complex NVA Order Modifications ***
+15 NEW DD,DDX,DOSE,SCHD,MEDR,DURA,CONJ,COMPLEX
+16 ;DO if not DC'd date
FOR NVA=0:0
SET NVA=$ORDER(^PS(55,PSODFN,"NVA",NVA))
if 'NVA
QUIT
SET NON=^PS(55,PSODFN,"NVA",NVA,0)
if '$PIECE(^PS(55,PSODFN,"NVA",NVA,0),"^",7)
Begin DoDot:1
+17 IF $ORDER(^PS(55,PSODFN,"NVA",NVA,3,0))
DO NVANEW
QUIT
+18 DO NVAOLD
End DoDot:1
END DO EOJ
+1 QUIT
+2 ;
NVANEW ;New Complex NVA order multiple file format logic
+1 ;loop thru DD multiple and create separate array entries for each item (in case contain a complex order)
+2 FOR DD=0:0
SET DD=$ORDER(^PS(55,PSODFN,"NVA",NVA,3,DD))
if 'DD
QUIT
Begin DoDot:1
+3 SET DDX=DD_","_NVA_","_PSODFN
+4 SET DOSE=$$GET1^DIQ(55.516,DDX,"DOSAGE","I")
+5 SET SCHD=$$GET1^DIQ(55.516,DDX,"SCHEDULE","I")
+6 SET MEDR=$$GET1^DIQ(55.516,DDX,"MEDICATION ROUTE","I")
+7 SET DURA=$$GET1^DIQ(55.516,DDX,"DURATION","I")
+8 SET CONJ=$$GET1^DIQ(55.516,DDX,"CONJUNCTION")
+9 SET PSODD=$PIECE(NON,"^",2)
SET PSOOI=$PIECE(NON,"^")
+10 SET DRG=$SELECT(PSODD:$PIECE($GET(^PSDRUG(PSODD,0)),"^"),+PSOOI&('PSODD):$PIECE(^PS(50.7,+PSOOI,0),"^")_" "_$PIECE(^PS(50.606,$PIECE(^PS(50.7,+PSOOI,0),"^",2),0),"^"),1:"")
+11 IF $DATA(PSOSD("ZNONVA",DRG))
SET DRG=DRG_"^"_NVA_"^"_DD
+12 ;append new pieces 12 & 13
SET PSOSD("ZNONVA",DRG)="****^9^Z^Z^"_$SELECT(PSODD:$PIECE(^PSDRUG(PSODD,0),"^",2),1:"")_"^"_DOSE_"^^"_SCHD_"^"_$PIECE(NON,"^",10)_"^"_NVA_"^"_PSODD_"^"_DURA_"^"_CONJ
+13 IF PSODD
SET $PIECE(PSOSD("ZNONVA",DRG),"^",7)=$SELECT($GET(^PSDRUG(PSODD,"ND"))]"":+^("ND")_"A"_$PIECE(^("ND"),"^",3),1:"")
+14 SET PSOSD=+$GET(PSOSD)+1
End DoDot:1
+15 QUIT
+16 ;
NVAOLD ;NVA Backwards compatible for old NON-VA file DD, pre-complex order SIG multiple file setup
+1 ; (after 441. By attrition, all records will eventually have the new complex order mult. file format)
+2 SET PSODD=$PIECE(NON,"^",2)
SET PSOOI=$PIECE(NON,"^")
+3 SET DRG=$SELECT(PSODD:$PIECE($GET(^PSDRUG(PSODD,0)),"^"),+PSOOI&('PSODD):$PIECE(^PS(50.7,+PSOOI,0),"^")_" "_$PIECE(^PS(50.606,$PIECE(^PS(50.7,+PSOOI,0),"^",2),0),"^"),1:"")
+4 ;build unique nva drug name subscript when same drug
IF $DATA(PSOSD("ZNONVA",DRG))
SET DRG=DRG_U_NVA
+5 SET PSOSD("ZNONVA",DRG)="****^9^Z^Z^"_$SELECT($PIECE(NON,"^",2):$PIECE(^PSDRUG($PIECE(NON,"^",2),0),"^",2),1:"")_"^"_$PIECE(NON,"^",3)_"^^"_$PIECE(NON,"^",5)_"^"_$PIECE(NON,"^",10)_"^"_NVA_"^"_$PIECE(NON,"^",2)
+6 IF $PIECE(NON,"^",2)
SET $PIECE(PSOSD("ZNONVA",DRG),"^",7)=$SELECT($GET(^PSDRUG(PSODD,"ND"))]"":+^("ND")_"A"_$PIECE(^("ND"),"^",3),1:"")
+7 SET PSOSD=+$GET(PSOSD)+1
+8 QUIT
+9 ;
INIT ;
+1 KILL PSOSD,PSOMED
SET PSOQFLG=0
SET U="^"
SET PSOBUILD("COUNT")=0
if $DATA(PSODTCUT)
GOTO INITX
+2 IF '$DATA(^PS(53,"B","OUTPATIENT"))
SET PSOQFLG=1
GOTO INITX
+3 SET PSOX=$ORDER(^PS(53,"B","OUTPATIENT",""))
IF 'PSOX
SET PSOQFLG=1
GOTO INITX
+4 ;S DAYS=$S($D(DAYS360):360,1:45),X2=-$S($P($G(^PS(53,PSOX,0)),"^",3)+15>DAYS:$P($G(^(0)),"^",3)+15,1:DAYS),X1=DT D C^%DTC S PSODTCUT=X
+5 SET X2=-120
SET X1=DT
DO C^%DTC
SET PSODTCUT=X
INITX KILL X,X1,X2,PSOX
+1 QUIT
+2 ;
BUILD ;build profiles
+1 FOR PSOEXPDT=(PSODTCUT-1):0
SET PSOEXPDT=$ORDER(^PS(55,PSODFN,"P","A",PSOEXPDT))
if 'PSOEXPDT
QUIT
FOR PSOBUILD("RX")=0:0
SET PSOBUILD("RX")=$ORDER(^PS(55,PSODFN,"P","A",PSOEXPDT,PSOBUILD("RX")))
if 'PSOBUILD("RX")
QUIT
IF $DATA(^PSRX(PSOBUILD("RX"),0))
DO GET
BUILDX IF PSOBUILD("COUNT")>0
SET PSOSD=PSOBUILD("COUNT")
+1 QUIT
GET ;data for profiles
+1 if '$PIECE(^PSRX(PSOBUILD("RX"),0),"^",2)
QUIT
+2 SET (PSOSTF,PSOSTN)=""
SET PSORX0=^PSRX(PSOBUILD("RX"),0)
SET PSOST0=+^PSRX(PSOBUILD("RX"),"STA")
SET $PIECE(PSORX0,"^",15)=PSOST0
+3 if PSOST0=13
GOTO GETX
SET PSORX2=$GET(^PSRX(PSOBUILD("RX"),2))
+4 SET PSORX3=$GET(^PSRX(PSOBUILD("RX"),3))
if PSORX3=""
SET PSORX3=$PIECE(PSORX2,"^",2)
+5 SET PSODRG=+$PIECE(PSORX0,"^",6)
if '$DATA(^PSDRUG(PSODRG,0))
GOTO GETX
SET PSODRUG0=^PSDRUG(PSODRG,0)
SET PSOVACL=$PIECE(PSODRUG0,"^",2)
SET PSODYS=$PIECE(PSORX0,"^",8)
+6 ;
+7 IF PSOST0<12!(PSOST0=16)
IF PSOEXPDT<DT
if $PIECE(PSORX0,"^",15)'=11
Begin DoDot:1
+8 SET PSOST0=11
SET $PIECE(PSORX0,"^",15)=11
NEW DIE,DIC,DR,DA,PSOBEXDA
SET DIE=52
SET (DA,PSOBEXDA)=PSOBUILD("RX")
SET DR="100////11"
DO ^DIE
KILL DIE,DIC,DR
+9 DO ECAN^PSOUTL(DA)
KILL DA
+10 SET STAT="SC"
SET PHARMST="ZE"
SET COMM="Medication Expired on "_$EXTRACT(PSOEXPDT,4,5)_"/"_$EXTRACT(PSOEXPDT,6,7)_"/"_$EXTRACT(PSOEXPDT,2,3)
DO EN^PSOHLSN1(PSOBEXDA,STAT,PHARMST,COMM)
KILL COMM,STAT,PHARMST,PSOBEXDA
End DoDot:1
+11 IF PSOST0=12
IF PSOEXPDT<DT
SET PSOST0=12
+12 IF PSOST0=5
Begin DoDot:1
+13 IF $ORDER(^PS(52.5,"B",PSOBUILD("RX"),0))
IF '$DATA(^PS(52.5,+$ORDER(^(0)),0))
Begin DoDot:2
+14 SET PSOST0=0
DO FSTA
+15 KILL ^PS(52.5,"B",PSOBUILD("RX"),$ORDER(^PS(52.5,"B",PSOBUILD("RX"),0)))
End DoDot:2
QUIT
+16 IF '$ORDER(^PS(52.5,"B",PSOBUILD("RX"),0))
SET PSOST0=0
DO FSTA
End DoDot:1
GOTO GT1
+17 IF 'PSOST0
DO STAT
GT1 if $DATA(NOEXP)&(PSOST0=11)
GOTO GETX
+1 IF $DATA(^PSDRUG(PSODRG,"I"))
IF ^("I")]""
IF DT>^("I")
SET PSOSTN=PSOSTN_"A"
IF $PIECE($GET(PSOPAR),"^",11)']""
SET PSOSTF=PSOSTF_"A"
+2 SET PSONDF=$SELECT($GET(^PSDRUG(PSODRG,"ND"))]"":+^("ND")_"A"_$PIECE(^("ND"),"^",3),1:0)
+3 IF $PIECE($GET(^PSDRUG(PSODRG,2)),"^",3)'["O"
SET PSOSTN=PSOSTN_"M"
+4 SET CLOZPT=$SELECT($PIECE($GET(^PSDRUG(PSODRG,"CLOZ1")),"^")="PSOCLO1":1,1:0)
+5 IF 'CLOZPT
IF ($PIECE(PSODRUG0,"^",3)["A")&($PIECE(PSODRUG0,"^",3)'["B")
SET PSOSTN=PSOSTN_"B"
SET PSOSTF=PSOSTF_"B"
+6 KILL CLOZPT
IF ($PIECE(PSODRUG0,"^",3)["W")!($PIECE(PSODRUG0,"^",3)[1)!($PIECE(PSODRUG0,"^",3)[2)
SET PSOSTN=PSOSTN_"C"
+7 IF $DATA(^PS(53,+$PIECE(PSORX0,"^",3),0))
IF '$PIECE(^(0),"^",5)
SET PSOSTN=PSOSTN_"D"
+8 IF PSOST0=1
SET PSOSTN=PSOSTN_"E"
+9 SET PSOLC=$PIECE(PSORX0,"^")
SET PSOLC=$EXTRACT(PSOLC,$LENGTH(PSOLC))
IF $ASCII(PSOLC)>90
SET PSOSTN=PSOSTN_"F"
+10 IF PSOST0
IF PSOST0'=2
IF PSOST0'=6
SET PSOSTF=PSOSTF_"Z"
+11 IF $GET(PSORX("BAR CODE"))
IF PSOST0
IF PSOST0'=2
IF PSOST0'=5
IF PSOST0'=6
IF PSOST0'=11
IF PSOST0'=12
SET PSOSTN=PSOSTN_"Z"
GOTO BARC
+12 IF PSOST0
IF PSOST0'=2
IF PSOST0'=5
IF PSOST0'=6
IF PSOST0'=11
IF PSOST0'=12
IF PSOST0'=14
SET PSOSTN=PSOSTN_"Z"
BARC SET PSORFRM=$PIECE(PSORX0,"^",9)
FOR PSOJ=0:0
SET PSOJ=$ORDER(^PSRX(PSOBUILD("RX"),1,PSOJ))
if 'PSOJ
QUIT
SET PSORFRM=PSORFRM-1
+1 if PSORFRM<0
SET PSORFRM=0
if PSORFRM=0
SET PSOSTF=PSOSTF_"G"
+2 SET PSODRUGN=$PIECE(PSODRUG0,"^")
IF $DATA(PSOSD(PSODRUGN))
IF PSOST0>10
if $PIECE(PSOSD(PSODRUGN),"^",2)<11
QUIT
if $PIECE(PSOSD(PSODRUGN),"^",2)>10&($PIECE(PSORX0,"^",13)<$PIECE(^PSRX(+$PIECE(PSOSD(PSODRUGN),"^"),0),"^",13))
QUIT
+3 if '$DATA(PSOSD(PSODRUGN))
SET PSOBUILD("COUNT")=PSOBUILD("COUNT")+1
+4 IF $DATA(PSOSD(PSODRUGN))
IF $PIECE(PSOSD(PSODRUGN),"^",2)<10
IF PSOST0<10
SET PSOSD(PSODRUGN_"^"_PSOBUILD("RX"))=PSOBUILD("RX")_"^"_PSOST0_"^"_PSOSTN_"^"_PSOSTF_"^"_PSOVACL_"^"_PSORFRM_"^"_PSONDF_"^"_PSODYS
SET PSOBUILD("COUNT")=PSOBUILD("COUNT")+1
+5 IF '$TEST
SET PSOSD(PSODRUGN)=PSOBUILD("RX")_"^"_PSOST0_"^"_PSOSTN_"^"_PSOSTF_"^"_PSOVACL_"^"_PSORFRM_"^"_PSONDF_"^"_PSODYS
GETX QUIT
STAT NEW X
SET X=+$ORDER(^PS(52.5,"B",PSOBUILD("RX"),0))
+1 IF X
IF $DATA(^PS(52.5,X,0))
IF $PIECE($GET(^PS(52.5,X,0)),"^",7)'="X"
IF '$GET(^PS(52.5,X,"P"))
SET PSOST0=5
+2 IF PSOST0
DO FSTA
+3 QUIT
FSTA SET $PIECE(PSORX0,"^",15)=PSOST0
+1 NEW DIE,DR,DA
SET DIE=52
SET DA=PSOBUILD("RX")
SET DR="100////"_PSOST0
DO ^DIE
KILL DIE,DR,DA
+2 QUIT
+3 ;
EOJ KILL ORD,PSOX,PSOEXPDT,PSODRG,PSODRUG0,PSOLC,PSONDF,PSOQFLG,PSORFRM,PSORX0,PSORX2,PSORX3,PSOST0,PSOSTF,PSOSTN,PSOJ,PSODRUGN,PSOVACL,PSOBUILD,PSODYS,PEN,DRG,NON,NVA
+1 QUIT
INPAT(PSODFN) ;entry point for inpat meds to view patient's outpat. meds
+1 DO FULL^VALM1
+2 SET INPAT=1
SET X2=-120
SET X1=DT
DO C^%DTC
SET PSODTCUT=X
DO START
DO ^PSODSPL
+3 KILL PSOSD,DDH,PSCNT,PSOCT,PSODD,PSOOI,PSOPAR,PSOSTA,STP,STR,PSODTCUT,PSODFN,INPAT,DRG
+4 QUIT
