PSODDPR4 ;BHAM - ISC/EJW,SAB - build local OP & RDI profiles ;07/19/07
;;7.0;OUTPATIENT PHARMACY;**251,375,387,379,390,372,416,484,500,518,785**;DEC 1997;Build 1
;External references to ^ORRDI1 supported by DBIA 4659
;External references to ^XTMP("ORRDI" supported by DBIA 4660
;External reference to ^PSDRUG( supported by DBIA 221
;External reference to IN^PSJBLDOC supported by DBIA 5306
;External references to ^PSSDSAPM supported by DBIA 5570
;External reference to ^PS(55 supported by DBIA 2228
;External reference to ENCHK^PSJORUT2 supported by DBIA 2376
;External reference to IN^PSSHRQ2 supported by DBIA 5369
;External reference to ^PS(50.606 supported by DBIA 2174
;External reference to ^PS(50.7 supported by DBIA 2223
;External reference to SUP^PSSDSAPI supported by DBIA 5425
;
BLD(PSODFN,LIST,PDRG,PTY) ;
;build OP, RDI, INP MEDS profiles
;PTY - P1;P2 where P1="I" for IP & "O" for OP (required), P2=Pharm order# (optional)
I '$D(PSODFN) W !,"Patient UNDEFINED!",! Q
I '$D(LIST) W !,"Input Base UNDEFINED!",! Q
K ^TMP($J,LIST)
ORD N PSODTCUT,X1,X2,ODRG,ORTYP,ORN,DO,IEN,NAME,PROF,PSOON,PSOFRMNM S (PROF,CNT)=0
F ZI=0:0 S ZI=$O(PDRG(ZI)) Q:'ZI S IEN=$P(PDRG(ZI),"^"),NAME=$P(PDRG(ZI),"^",2) K PSOFRMNM S:$G(PSOFRMOR) PSOFRMNM=$P(PDRG(ZI),"^",4) D DRG
I $D(PSJDGCK),'$D(PSGDGCKF) Q:$O(^TMP($J,LIST,"IN","PROSPECTIVE",""))="" ;no prospective drugs to pass in
I '$D(PSJDGCK),$O(^TMP($J,LIST,"IN","PROSPECTIVE",""))="" D:$O(PSODUPSP(0)) DRGSUP Q ;no prospective drugs to pass in and drug is supply, create supply nodes
S X1=DT,X2=-120 D C^%DTC S PSODTCUT=X D ^PSOBUILD,PROFILE
K PSOSD D REMOTE D:$P($G(PTY),";")="I" IN^PSJBLDOC(PSODFN,LIST,.PDRG,$G(PTY))
S ^TMP($J,LIST,"IN","IEN")=PSODFN,^TMP($J,LIST,"IN","DRUGDRUG")="",^TMP($J,LIST,"IN","THERAPY")=""
S ^TMP($J,LIST,"IN","SOURCE")=$P($G(PTY),";")
I $P($G(PTY),";")="O" D IMO^PSODDPR7(PSODFN)
N PSOICT,PSODRUG,PSOY,CNT,ZI
D IN^PSSHRQ2(LIST) D:$O(PSODUPSP(0)) DRGSUP
Q
PROFILE ;build profile drug input
N ID,ORTYP,DD,PSOI,ORN,RECTYP S (STA,DNM)="",DO=0
F S STA=$O(PSOSD(STA)) Q:STA="" F S DNM=$O(PSOSD(STA,DNM)) Q:DNM="" D
.I STA="PENDING" D Q
..Q:$P(^PS(52.41,$P(PSOSD(STA,DNM),"^",10),0),"^",3)="RF"
..S RXREC=$P(PSOSD(STA,DNM),"^",10),ORN=$P(^PS(52.41,RXREC,0),"^"),ODRG=$P(^(0),"^",9),ORTYP="P"
..I ODRG D K ODRG Q
...I $P($G(^PSDRUG(ODRG,0)),"^",3)["S"!($E($P($G(^PSDRUG(ODRG,0)),"^",2),1,2)="XA") Q
...S DRNM=$P(^PSDRUG(ODRG,0),"^"),DO=DO+1 D ID
..E N PSOI,DDRG,ODRG,SEQN,DDRG S PSOI=$P(^PS(52.41,RXREC,0),"^",8) D
...S DRNM=$P(^PS(50.7,PSOI,0),"^")_" "_$P(^PS(50.606,$P(^(0),"^",2),0),"^")
...S DDRG=$$DRG^PSSDSAPM(PSOI,"O") I '$P(DDRG,";") D:'$$NVATST^PSODDPRE(PSOI,"O") OIX Q
...I $P($G(^PSDRUG($P(DDRG,";"),0)),"^",3)["S"!($E($P($G(^PSDRUG($P(DDRG,";"),0)),"^",2),1,2)="XA") Q
...S ODRG=$P(DDRG,";"),SEQN=+$P(DDRG,";",3) K PSOI
...N ID S ID=+$$GETVUID^XTID(50.68,,+$P($G(^PSDRUG(ODRG,"ND")),"^",3)_",")
...D ID1
.I STA="ZNONVA" D Q
..S RXREC=$P(PSOSD(STA,DNM),"^",10),ODRG=$P(^PS(55,PSODFN,"NVA",RXREC,0),"^",2),ORN=$P($G(^(0)),"^",8),ORTYP="N"
..I ODRG D K ODRG Q
...I $P($G(^PSDRUG(ODRG,0)),"^",3)["S"!($E($P($G(^PSDRUG(ODRG,0)),"^",2),1,2)="XA") Q
...S DRNM=$P(^PSDRUG(ODRG,0),"^"),DO=DO+1 D ID
..E N PSOI,DDRG,ODRG,SEQN,DDRG,DRNM S PSOI=$P(^PS(55,PSODFN,"NVA",RXREC,0),"^") D
...S DRNM=$P(^PS(50.7,PSOI,0),"^")_" "_$P(^PS(50.606,$P(^(0),"^",2),0),"^")
...S DDRG=$$DRG^PSSDSAPM(PSOI,"X") I '$P(DDRG,";") D:'$$NVATST^PSODDPRE(PSOI,"X") OIX Q
...I $P($G(^PSDRUG($P(DDRG,";"),0)),"^",3)["S"!($E($P($G(^PSDRUG($P(DDRG,";"),0)),"^",2),1,2)="XA") Q
...S ODRG=$P(DDRG,";"),SEQN=+$P(DDRG,";",3),DO=DO+1 K PSOI
...N ID S ID=+$$GETVUID^XTID(50.68,,+$P($G(^PSDRUG(ODRG,"ND")),"^",3)_",")
...D ID1
.S RXREC=+PSOSD(STA,DNM)
.I $P($G(PTY),";")="O",$P($G(PTY),";",2)=RXREC Q
.I $P($G(^PSRX(RXREC,0)),"^",6) S ODRG=$P(^PSRX(RXREC,0),"^",6) D
..I $P($G(^PSDRUG(ODRG,0)),"^",3)["S"!($E($P($G(^PSDRUG(ODRG,0)),"^",2),1,2)="XA") Q
..I STA="DISCONTINUED" Q:$$DUPTHER^PSODDPRE(RXREC) ;screen out duplicate therapy for local orders
..S ORN=$P($G(^PSRX(RXREC,"OR1")),"^",2),ORTYP="O",DRNM=$P(^PSDRUG(ODRG,0),"^"),DO=DO+1 D ID
K RXREC,ID,STA,DNM,SEQN,PSOI,PSODD,P1,P3,OR1,P2,PSODRUG,DD,DRNM,DDRG
Q
ID N ID S ID=+$$GETVUID^XTID(50.68,,+$P($G(^PSDRUG(ODRG,"ND")),"^",3)_",")
S P1=$P($G(^PSDRUG(ODRG,"ND")),"^"),P2=$P($G(^("ND")),"^",3),X=$$PROD0^PSNAPIS(P1,P2),SEQN=+$P(X,"^",7)
ID1 I '$D(PSJDGCK) S ^TMP($J,LIST,"IN","PROFILE",ORTYP_";"_RXREC_";PROFILE;"_DO)=SEQN_"^"_ID_"^"_ODRG_"^"_DRNM_"^"_ORN_"^O" K ID
I $D(PSJDGCK) S ^TMP($J,LIST,"IN","PROSPECTIVE",ORTYP_";"_RXREC_";PROSPECTIVE;"_DO)=SEQN_"^"_ID_"^"_ODRG_"^"_DRNM_"^"_ORN_"^O" K ID
Q
OIX S ^TMP($J,LIST,"IN","EXCEPTIONS","OI",DRNM)=1_"^"_ORTYP_";"_RXREC_";PROFILE;"_DO
K TU
Q
REMOTE ;
I $T(HAVEHDR^ORRDI1)']"" Q
I '$$HAVEHDR^ORRDI1 Q
I $D(^XTMP("ORRDI","OUTAGE INFO","DOWN")) D Q
.I $T(REMOTE^PSORX1)]"" Q
.D HD^PSODDPR2():(($Y+5)'>IOSL)
.W !!,"Remote data not available - Only local order checks processed.",! D HD^PSODDPR2():(($Y+5)'>IOSL)
I $P($G(^XTMP("ORRDI","PSOO",PSODFN,0)),"^",3)<0 W !!,"Remote data not available - Only local order checks processed." D HD^PSODDPR2():(($Y+5)'>IOSL) Q
N PSORDI,RDIINST,RDIVUID,RDIRX,RDIDNAM,RDISTA,RDISIG,RDIDAYS,RDIQTY,RDIFILL,RDIEXP,RDIISS,RDIFILL,ZI
N RDIREF,RDIPHYS,PSOPROD,PSOCLASS,DRNM,RDITMP,PSODC,IT,PSOICT,NDF,RDIDI,PSOPRODA,PSOFILE,PSOSIG,PSOSEQN,X
I '$G(DT) S DT=$$DT^XLFDT
S PSORDI=0
I $T(GET^ORRDI1)]"" S PSORDI=$$GET^ORRDI1(PSODFN,"PSOO")
I PSORDI<1 Q
I '$D(^XTMP("ORRDI","PSOO",PSODFN)) Q
K ^TMP($J,LIST,"OUT","REMOTE")
D PARSE,FILTER
I '$D(^TMP($J,LIST,"OUT","REMOTE")) Q
N DIC D REMO
Q
REMO ;
S (PSOON,PSORDI)=0 F S PSORDI=$O(^TMP($J,LIST,"OUT","REMOTE",PSORDI)) Q:'PSORDI S RDITMP=^(PSORDI) D K PSOSEQN
.Q:$P(RDITMP,"^",2)=""
.;screen out dc'd remotes
.I $P($G(^TMP($J,LIST,"OUT","REMOTE",PSORDI)),"^",4)["DISC" D I $G(PSOON) K PSOON Q
..K X,Y,X1,X2
..S X=$P(^TMP($J,LIST,"OUT","REMOTE",PSORDI),"^",6) D ^%DT S X1=Y,X2=(+$P(^TMP($J,LIST,"OUT","REMOTE",PSORDI),"^",7)+7)
..D C^%DTC I X<DT S PSOON=1 K X,Y,X1,X2
.;
.S RDIVUID=$P(RDITMP,"^",2),RDIDNAM=$P(RDITMP,"^",3)
.I $O(PDRG(0)) F ZI=0:0 S ZI=$O(PDRG(ZI)) Q:'ZI I $P(^PSDRUG($P(PDRG(ZI),"^"),0),"^")=RDIDNAM S INDD=+$G(INDD)+1,^TMP($J,"DD",INDD,0)=$P(PDRG(ZI),"^")_"^"_RDIDNAM_"^^"_PSORDI_"Z;O"
.S DO=$G(DO)+1 D GETIREF^XTID(50.68,.01,RDIVUID,"PSOSEQN",1) I 'PSOSEQN S ^TMP($J,LIST,"IN","PROFILE","R;"_PSORDI_";PROFILE;"_DO)=0_"^"_RDIVUID_"^0^"_RDIDNAM_"^^" Q
.S SEQN="" S SEQN=$O(PSOSEQN(50.68,.01,SEQN)) Q:SEQN=""
.S P3=+SEQN,SEQN=$P($$PROD0^PSNAPIS(,P3),"^",7)
.;S ^TMP($J,LIST,"IN","PROFILE","R;"_PSORDI_";PROFILE;"_DO)=SEQN_"^"_RDIVUID_"^0^"_RDIDNAM_"^^"
.S ^TMP($J,LIST,"IN","PROFILE","R;"_PSORDI_";PROFILE;"_DO)=SEQN_"^"_RDIVUID_"^0^"_RDIDNAM_"^^O" ;P785
Q
;
PARSE ; PULL INFORMATION FROM ^XTMP
N PSORDI,LOCAL,NEWISS,BADEXP,PSOPRE,PSO30,NEWDC,NEWEXP
S PSORDI=0 F S PSORDI=$O(^XTMP("ORRDI","PSOO",PSODFN,PSORDI)) Q:'PSORDI D
.S RDISTA=$G(^XTMP("ORRDI","PSOO",PSODFN,PSORDI,5,0))
.I RDISTA="DELETED" Q
.S RDIINST=$G(^XTMP("ORRDI","PSOO",PSODFN,PSORDI,1,0))
.S RDIDNAM=$G(^XTMP("ORRDI","PSOO",PSODFN,PSORDI,2,0))
.S RDIVUID=$G(^XTMP("ORRDI","PSOO",PSODFN,PSORDI,3,0))
.I RDIVUID="" Q
.D GETPROD^PSOORRDI
.Q:$E($G(PSOCLASS),1,2)="XA"
.S RDIRX=$G(^XTMP("ORRDI","PSOO",PSODFN,PSORDI,4,0))
.S RDIQTY=$G(^XTMP("ORRDI","PSOO",PSODFN,PSORDI,6,0))
.S RDIDAYS=$P(RDIQTY,";",2),RDIQTY=$P(RDIQTY,";")
.I $E(RDIDAYS)="D" S RDIDAYS=$P(RDIDAYS,"D",2)
.S RDIEXP=$G(^XTMP("ORRDI","PSOO",PSODFN,PSORDI,7,0))
.S RDIISS=$G(^XTMP("ORRDI","PSOO",PSODFN,PSORDI,8,0))
.I RDIEXP?."/" S BADEXP=1 D I BADEXP Q
..I RDIISS?."/" Q
..S PSOPRE=$E(DT) I $P(RDIISS,"/",3)>($E(DT,2,3)+1) S PSOPRE=PSOPRE-1
..S NEWISS=PSOPRE_$P(RDIISS,"/",3)_$P(RDIISS,"/")_$P(RDIISS,"/",2) I NEWISS>(DT-10000) S RDIEXP=RDIISS,BADEXP=0
.I RDISTA["EXPIRE" S PSO30=0 D I PSO30 Q
..S PSOPRE=$E(DT) I $P(RDIEXP,"/",3)>($E(DT,2,3)+1) S PSO30=1 Q
..S NEWEXP=PSOPRE_$P(RDIEXP,"/",3)_$P(RDIEXP,"/")_$P(RDIEXP,"/",2)
..S X1=NEWEXP,X2=30 D C^%DTC I X<DT S PSO30=1
.I RDIRX'="" S LOCAL=0 D CHKLOCAL I LOCAL Q
.S RDIFILL=$G(^XTMP("ORRDI","PSOO",PSODFN,PSORDI,9,0))
.I RDISTA["DISCONT" S PSO30=0 D I PSO30 Q
..S PSOPRE=$E(DT) I $P(RDIFILL,"/",3)>($E(DT,2,3)+1) S PSO30=1 Q
..S NEWDC=PSOPRE_$P(RDIFILL,"/",3)_$P(RDIFILL,"/")_$P(RDIFILL,"/",2)
..S X1=NEWDC,X2=30+RDIDAYS D C^%DTC I X<DT S PSO30=1
.I RDISTA["DRUG INTERACTION" S RDISTA="NON-VERIFIED"
.S RDIREF=$G(^XTMP("ORRDI","PSOO",PSODFN,PSORDI,10,0))
.S RDIPHYS=$G(^XTMP("ORRDI","PSOO",PSODFN,PSORDI,11,0))
.S PSOSIG="" F S PSOSIG=$O(^XTMP("ORRDI","PSOO",PSODFN,PSORDI,14,PSOSIG)) Q:PSOSIG="" S PSOSIG(PSOSIG)=^(PSOSIG)
.S ^TMP($J,LIST,"OUT","REMOTE",PSORDI)=RDIINST_"^"_RDIVUID_"^"_RDIDNAM_"^"_RDISTA_"^"_RDIRX_"^"_RDIFILL_"^"_RDIDAYS_"^"_RDIQTY_"^"_RDIREF_"^"_RDIEXP_"^"_RDIPHYS_"^"_RDIISS
.S PSOSIG="" F S PSOSIG=$O(PSOSIG(PSOSIG)) Q:PSOSIG="" S ^TMP($J,LIST,"OUT","REMOTE",PSORDI,"SIG",PSOSIG)=PSOSIG(PSOSIG)
Q
;
CHKLOCAL ; IF SAME RX NUMBER AND ISSUE DATE - LOCAL RX
N PSOISS
I $D(^PSRX("B",RDIRX)) D
.N PSORX
.S PSORX=$O(^PSRX("B",RDIRX,"")) I 'PSORX Q
.S PSOISS=$P($G(^PSRX(PSORX,0)),"^",13)
.S PSOISS=$E(PSOISS,4,5)_"/"_$E(PSOISS,6,7)_"/"_$E(PSOISS,2,3)
.I PSOISS=RDIISS S LOCAL=1 Q
Q
;
FILTER ; FOR SAME DRUG VUID FOR SAME SITE, KEEP 1 ENTRY - CHECK BY ACTIVE STATUS FIRST THEN BY GREATEST EXPIRATION DATE
N XX,RDI,OLDEXP,RDIEXP,RDIEXP2,OLDEXP2,PSORDI,RDISTA,OLDSTA,OLDRDI,ZZ
S PSORDI=0
F S PSORDI=$O(^TMP($J,LIST,"OUT","REMOTE",PSORDI)) Q:'PSORDI D
.S XX=$G(^TMP($J,LIST,"OUT","REMOTE",PSORDI)),RDIINST=$P(XX,"^"),RDIVUID=$P(XX,"^",2),RDISTA=$P(XX,"^",4),RDIEXP=$P(XX,"^",10) Q:RDIINST="" Q:RDIVUID="" I RDIEXP="" Q
.I $D(RDI(RDIINST,RDIVUID)) S ZZ=RDI(RDIINST,RDIVUID) D Q
..I RDISTA="ACTIVE"!(RDISTA["SUSPEN") D Q
...S OLDSTA=$P(ZZ,"^",2) I OLDSTA["ACTIVE"!(OLDSTA["SUSPEN") D CHKEXP Q
...S OLDRDI=$P(ZZ,"^") K ^TMP($J,LIST,"OUT","REMOTE",OLDRDI) D SETRDI
..S OLDSTA=$P(ZZ,"^",2) I OLDSTA["ACTIVE"!(OLDSTA["SUSPEN") K ^TMP($J,LIST,"OUT","REMOTE",PSORDI) Q
..D CHKEXP ; ALL OTHER STATUSES - KEEP BY GREATER EXPIRATION DATE
.D SETRDI
Q
;
CHKEXP ;
N PSOPRE
S OLDEXP=$P(ZZ,"^",3) D I OLDEXP2>RDIEXP2 K ^TMP($J,"OUT","REMOTE",PSORDI) Q
.S PSOPRE=$E(DT) I $P(RDIEXP,"/",3)>($E(DT,2,3)+1) S PSOPRE=PSOPRE-1
.S RDIEXP2=PSOPRE_$P(RDIEXP,"/",3)_$P(RDIEXP,"/")_$P(RDIEXP,"/",2)
.S PSOPRE=$E(DT) I $P(OLDEXP,"/",3)>($E(DT,2,3)+1) S PSOPRE=PSOPRE-1
.S OLDEXP2=PSOPRE_$P(OLDEXP,"/",3)_$P(OLDEXP,"/")_$P(OLDEXP,"/",2)
S OLDRDI=$P(ZZ,"^") K ^TMP($J,LIST,"OUT","REMOTE",OLDRDI) D SETRDI
Q
;
SETRDI ;
S RDI(RDIINST,RDIVUID)=PSORDI_"^"_RDISTA_"^"_RDIEXP
Q
CPRS(PSODFN,LIST,PDRG,PTY) ;
;PDRG - Drug array in format of PDRG(n)=IEN (#50) ^ Drug name
;PTY - P1;P2 where P1="I" for IP & "O" for OP (required), P2=Pharm order# (optional)
I '$G(PSODFN) W !,"Patient UNDEFINED!",! Q
I '$O(PDRG(0)) W !,"Dispense Drug(s) UNDEFINED!",! Q
I '$D(LIST) W !,"Input Base UNDEFINED!",! Q
S ^TMP($J,LIST,"IN","PING")="" D IN^PSSHRQ2(LIST) I $P(^TMP($J,LIST,"OUT",0),"^")=-1 Q
K ^TMP($J,"ORDERS"),^TMP($J,"DD"),^TMP($J,LIST) N ZII,INDX,INDD,PSODUPSP,PSODUPSY,PSODUPLS,PSOFRMOR,PSOSUPNN S (INDX,INDD)=0,PSODUPSY=$G(PTY),PSODUPLS=LIST,PSOFRMOR=1
;build patient's drug profile outpat/inpat/non-va
D BLD^PSOORDRG,ENCHK^PSJORUT2(PSODFN,.INDX),NVA^PSOORDRG
;dup drug check CPRS ONLY
S PSOICT="",CNT=0 F ZII=0:0 S ZII=$O(PDRG(ZII)) Q:'ZII D:$$SUP^PSSDSAPI(+$P(PDRG(ZII),"^"))
.S PSOY=$P(PDRG(ZII),"^")_"^"_$P($G(^PSDRUG($P(PDRG(ZII),"^"),0)),"^"),PSOY(0)=$G(^PSDRUG(PDRG(ZII),0)),PSOSUPNN=$P(PDRG(ZII),"^",4)
.S IEN=+PSOY,NAME=$P(PSOY,"^",2),DNM=0 K PSOX1,PSOY
.F S DNM=$O(^TMP($J,"ORDERS",DNM)) Q:'DNM I NAME=$P(^TMP($J,"ORDERS",DNM),"^",3) D
..S INDD=$G(INDD)+1,^TMP($J,"DD",INDD,0)=IEN_"^"_NAME_"^"_$P(^TMP($J,"ORDERS",DNM),"^",4)_"^"_$P(^(DNM),"^",5),PSODUPSP(IEN,$S(PSOSUPNN:PSOSUPNN,1:"ACCEPT"))=PSODUPSY,PSODUPSP(IEN,"NAME")=NAME
K ^TMP($J,"ORDERS")
D ORD
Q
DRG ;
I $$SUP^PSSDSAPI(IEN) Q
N ID,SEQN S PSODRUG("NDF")=$S($G(^PSDRUG(IEN,"ND"))]"":+^("ND")_"A"_$P(^("ND"),"^",3),1:0)
S ID=$$GETVUID^XTID(50.68,,+$P($G(PSODRUG("NDF")),"A",2)_",")
S P1=$P($G(^PSDRUG(IEN,"ND")),"^"),P2=$P($G(^("ND")),"^",3),X=$$PROD0^PSNAPIS(P1,P2),SEQN=$P(X,"^",7)
I '$D(PSJDGCK) S CNT=$G(CNT)+1,^TMP($J,LIST,"IN","PROSPECTIVE",$P(PTY,";")_";"_$P(PTY,";",2)_";PROSPECTIVE;"_CNT)=SEQN_"^"_+ID_"^"_IEN_"^"_NAME_$S($G(PSOFRMOR):"^"_PSOFRMNM,1:"")
I $D(PSJDGCK),'$D(PSGDGCKF) S CNT=$G(CNT)+1,^TMP($J,LIST,"IN","PROSPECTIVE",$P(PTY,";")_";"_$P(PTY,";",2)_";PROSPECTIVE;"_CNT)=SEQN_"^"_+ID_"^"_IEN_"^"_NAME
K ID,SEQN,P1,P2,X,DNM
Q
;
DRGSUP ;Create "prospective" nodes for duplicate supply entries
N PSODPSID,PSODPSQN,PSODPSP1,PSODPSP2,PSODPSP3,PSODPSXX,PSODPSLP,PSODPSNF,PSODPSCT,PSODPSC1,PSODPSNM,PSODPSOR
S PSODPSCT=0
S PSODPSC1="" F S PSODPSC1=$O(^TMP($J,PSODUPLS,"IN","PROSPECTIVE",PSODPSC1)) Q:PSODPSC1="" S PSODPSP3=$P(PSODPSC1,";",4) I PSODPSP3>PSODPSCT S PSODPSCT=PSODPSP3
S PSODPSLP="" F S PSODPSLP=$O(PSODUPSP(PSODPSLP)) Q:PSODPSLP="" D
.S PSODPSOR="" F S PSODPSOR=$O(PSODUPSP(PSODPSLP,PSODPSOR)) Q:PSODPSOR="" D:PSODPSOR'="NAME"
..S PSODPSNM=$G(PSODUPSP(PSODPSLP,"NAME"))
..S PSODPSNF=$S($G(^PSDRUG(PSODPSLP,"ND"))]"":+^PSDRUG(PSODPSLP,"ND")_"A"_$P(^PSDRUG(PSODPSLP,"ND"),"^",3),1:0)
..S PSODPSID=$$GETVUID^XTID(50.68,,+$P($G(PSODPSNF),"A",2)_",")
..S PSODPSP1=$P($G(^PSDRUG(PSODPSLP,"ND")),"^"),PSODPSP2=$P($G(^PSDRUG(PSODPSLP,"ND")),"^",3),PSODPSXX=$$PROD0^PSNAPIS(PSODPSP1,PSODPSP2),PSODPSQN=$P(PSODPSXX,"^",7)
..S PSODPSCT=$G(PSODPSCT)+1,^TMP($J,PSODUPLS,"IN","PROSPECTIVE",$P(PSODUPSY,";")_";"_$P(PSODUPSY,";",2)_";PROSPECTIVE;"_PSODPSCT)=PSODPSQN_"^"_+PSODPSID_"^"_PSODPSLP_"^"_$G(PSODPSNM)_$S(PSODPSOR="ACCEPT":"",1:"^"_PSODPSOR)
Q
;
RVAGEN ;va generic for remote drugs
N PSOVUID,PSONDF,PSOVAG,DIC
S PSOVUID=$P(^TMP($J,"PSOPEPS","OUT","REMOTE",$P(ON,";",2)),"^",2) Q:'$G(PSOVUID)
K PSORDIID S PSOVAGEN="" D GETIREF^XTID("50.68",".01",PSOVUID,"PSORDIID")
S PSONDF=$O(PSORDIID(50.68,.01,"")) K PSORDIID
I +PSONDF D DATA^PSN50P68(+PSONDF,,"PSONDF") D
.S PSOVAG=$P($G(^TMP($J,"PSONDF",+PSONDF,.05)),U,2) ;*484
.N ZOT ;*484
.S ZOT=$S($P(ON,";")["C":1,$P(ON,";")="O":2,$P(ON,";")="R":3,$P(ON,";")="P":4,1:5) ;*484
.S ZDGDG(SV,ZOT,PSOVAG,DRG)=ON_"^"_CT,ZZDGDG3(SV,PSOVAG,DRG)="" ;*484
.I '$D(NSRT(SV,PSOVAG)) S NSRT(SV,PSOVAG)=3
.E S $P(NSRT(SV,PSOVAG),"^",1)=$P(NSRT(SV,PSOVAG),"^",1)_",3"
K ^TMP($J,"PSONDF")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSODDPR4 14708 printed Sep 23, 2025@20:02:42 Page 2
PSODDPR4 ;BHAM - ISC/EJW,SAB - build local OP & RDI profiles ;07/19/07
+1 ;;7.0;OUTPATIENT PHARMACY;**251,375,387,379,390,372,416,484,500,518,785**;DEC 1997;Build 1
+2 ;External references to ^ORRDI1 supported by DBIA 4659
+3 ;External references to ^XTMP("ORRDI" supported by DBIA 4660
+4 ;External reference to ^PSDRUG( supported by DBIA 221
+5 ;External reference to IN^PSJBLDOC supported by DBIA 5306
+6 ;External references to ^PSSDSAPM supported by DBIA 5570
+7 ;External reference to ^PS(55 supported by DBIA 2228
+8 ;External reference to ENCHK^PSJORUT2 supported by DBIA 2376
+9 ;External reference to IN^PSSHRQ2 supported by DBIA 5369
+10 ;External reference to ^PS(50.606 supported by DBIA 2174
+11 ;External reference to ^PS(50.7 supported by DBIA 2223
+12 ;External reference to SUP^PSSDSAPI supported by DBIA 5425
+13 ;
BLD(PSODFN,LIST,PDRG,PTY) ;
+1 ;build OP, RDI, INP MEDS profiles
+2 ;PTY - P1;P2 where P1="I" for IP & "O" for OP (required), P2=Pharm order# (optional)
+3 IF '$DATA(PSODFN)
WRITE !,"Patient UNDEFINED!",!
QUIT
+4 IF '$DATA(LIST)
WRITE !,"Input Base UNDEFINED!",!
QUIT
+5 KILL ^TMP($JOB,LIST)
ORD NEW PSODTCUT,X1,X2,ODRG,ORTYP,ORN,DO,IEN,NAME,PROF,PSOON,PSOFRMNM
SET (PROF,CNT)=0
+1 FOR ZI=0:0
SET ZI=$ORDER(PDRG(ZI))
if 'ZI
QUIT
SET IEN=$PIECE(PDRG(ZI),"^")
SET NAME=$PIECE(PDRG(ZI),"^",2)
KILL PSOFRMNM
if $GET(PSOFRMOR)
SET PSOFRMNM=$PIECE(PDRG(ZI),"^",4)
DO DRG
+2 ;no prospective drugs to pass in
IF $DATA(PSJDGCK)
IF '$DATA(PSGDGCKF)
if $ORDER(^TMP($JOB,LIST,"IN","PROSPECTIVE",""))=""
QUIT
+3 ;no prospective drugs to pass in and drug is supply, create supply nodes
IF '$DATA(PSJDGCK)
IF $ORDER(^TMP($JOB,LIST,"IN","PROSPECTIVE",""))=""
if $ORDER(PSODUPSP(0))
DO DRGSUP
QUIT
+4 SET X1=DT
SET X2=-120
DO C^%DTC
SET PSODTCUT=X
DO ^PSOBUILD
DO PROFILE
+5 KILL PSOSD
DO REMOTE
if $PIECE($GET(PTY),";")="I"
DO IN^PSJBLDOC(PSODFN,LIST,.PDRG,$GET(PTY))
+6 SET ^TMP($JOB,LIST,"IN","IEN")=PSODFN
SET ^TMP($JOB,LIST,"IN","DRUGDRUG")=""
SET ^TMP($JOB,LIST,"IN","THERAPY")=""
+7 SET ^TMP($JOB,LIST,"IN","SOURCE")=$PIECE($GET(PTY),";")
+8 IF $PIECE($GET(PTY),";")="O"
DO IMO^PSODDPR7(PSODFN)
+9 NEW PSOICT,PSODRUG,PSOY,CNT,ZI
+10 DO IN^PSSHRQ2(LIST)
if $ORDER(PSODUPSP(0))
DO DRGSUP
+11 QUIT
PROFILE ;build profile drug input
+1 NEW ID,ORTYP,DD,PSOI,ORN,RECTYP
SET (STA,DNM)=""
SET DO=0
+2 FOR
SET STA=$ORDER(PSOSD(STA))
if STA=""
QUIT
FOR
SET DNM=$ORDER(PSOSD(STA,DNM))
if DNM=""
QUIT
Begin DoDot:1
+3 IF STA="PENDING"
Begin DoDot:2
+4 if $PIECE(^PS(52.41,$PIECE(PSOSD(STA,DNM),"^",10),0),"^",3)="RF"
QUIT
+5 SET RXREC=$PIECE(PSOSD(STA,DNM),"^",10)
SET ORN=$PIECE(^PS(52.41,RXREC,0),"^")
SET ODRG=$PIECE(^(0),"^",9)
SET ORTYP="P"
+6 IF ODRG
Begin DoDot:3
+7 IF $PIECE($GET(^PSDRUG(ODRG,0)),"^",3)["S"!($EXTRACT($PIECE($GET(^PSDRUG(ODRG,0)),"^",2),1,2)="XA")
QUIT
+8 SET DRNM=$PIECE(^PSDRUG(ODRG,0),"^")
SET DO=DO+1
DO ID
End DoDot:3
KILL ODRG
QUIT
+9 IF '$TEST
NEW PSOI,DDRG,ODRG,SEQN,DDRG
SET PSOI=$PIECE(^PS(52.41,RXREC,0),"^",8)
Begin DoDot:3
+10 SET DRNM=$PIECE(^PS(50.7,PSOI,0),"^")_" "_$PIECE(^PS(50.606,$PIECE(^(0),"^",2),0),"^")
+11 SET DDRG=$$DRG^PSSDSAPM(PSOI,"O")
IF '$PIECE(DDRG,";")
if '$$NVATST^PSODDPRE(PSOI,"O")
DO OIX
QUIT
+12 IF $PIECE($GET(^PSDRUG($PIECE(DDRG,";"),0)),"^",3)["S"!($EXTRACT($PIECE($GET(^PSDRUG($PIECE(DDRG,";"),0)),"^",2),1,2)="XA")
QUIT
+13 SET ODRG=$PIECE(DDRG,";")
SET SEQN=+$PIECE(DDRG,";",3)
KILL PSOI
+14 NEW ID
SET ID=+$$GETVUID^XTID(50.68,,+$PIECE($GET(^PSDRUG(ODRG,"ND")),"^",3)_",")
+15 DO ID1
End DoDot:3
End DoDot:2
QUIT
+16 IF STA="ZNONVA"
Begin DoDot:2
+17 SET RXREC=$PIECE(PSOSD(STA,DNM),"^",10)
SET ODRG=$PIECE(^PS(55,PSODFN,"NVA",RXREC,0),"^",2)
SET ORN=$PIECE($GET(^(0)),"^",8)
SET ORTYP="N"
+18 IF ODRG
Begin DoDot:3
+19 IF $PIECE($GET(^PSDRUG(ODRG,0)),"^",3)["S"!($EXTRACT($PIECE($GET(^PSDRUG(ODRG,0)),"^",2),1,2)="XA")
QUIT
+20 SET DRNM=$PIECE(^PSDRUG(ODRG,0),"^")
SET DO=DO+1
DO ID
End DoDot:3
KILL ODRG
QUIT
+21 IF '$TEST
NEW PSOI,DDRG,ODRG,SEQN,DDRG,DRNM
SET PSOI=$PIECE(^PS(55,PSODFN,"NVA",RXREC,0),"^")
Begin DoDot:3
+22 SET DRNM=$PIECE(^PS(50.7,PSOI,0),"^")_" "_$PIECE(^PS(50.606,$PIECE(^(0),"^",2),0),"^")
+23 SET DDRG=$$DRG^PSSDSAPM(PSOI,"X")
IF '$PIECE(DDRG,";")
if '$$NVATST^PSODDPRE(PSOI,"X")
DO OIX
QUIT
+24 IF $PIECE($GET(^PSDRUG($PIECE(DDRG,";"),0)),"^",3)["S"!($EXTRACT($PIECE($GET(^PSDRUG($PIECE(DDRG,";"),0)),"^",2),1,2)="XA")
QUIT
+25 SET ODRG=$PIECE(DDRG,";")
SET SEQN=+$PIECE(DDRG,";",3)
SET DO=DO+1
KILL PSOI
+26 NEW ID
SET ID=+$$GETVUID^XTID(50.68,,+$PIECE($GET(^PSDRUG(ODRG,"ND")),"^",3)_",")
+27 DO ID1
End DoDot:3
End DoDot:2
QUIT
+28 SET RXREC=+PSOSD(STA,DNM)
+29 IF $PIECE($GET(PTY),";")="O"
IF $PIECE($GET(PTY),";",2)=RXREC
QUIT
+30 IF $PIECE($GET(^PSRX(RXREC,0)),"^",6)
SET ODRG=$PIECE(^PSRX(RXREC,0),"^",6)
Begin DoDot:2
+31 IF $PIECE($GET(^PSDRUG(ODRG,0)),"^",3)["S"!($EXTRACT($PIECE($GET(^PSDRUG(ODRG,0)),"^",2),1,2)="XA")
QUIT
+32 ;screen out duplicate therapy for local orders
IF STA="DISCONTINUED"
if $$DUPTHER^PSODDPRE(RXREC)
QUIT
+33 SET ORN=$PIECE($GET(^PSRX(RXREC,"OR1")),"^",2)
SET ORTYP="O"
SET DRNM=$PIECE(^PSDRUG(ODRG,0),"^")
SET DO=DO+1
DO ID
End DoDot:2
End DoDot:1
+34 KILL RXREC,ID,STA,DNM,SEQN,PSOI,PSODD,P1,P3,OR1,P2,PSODRUG,DD,DRNM,DDRG
+35 QUIT
ID NEW ID
SET ID=+$$GETVUID^XTID(50.68,,+$PIECE($GET(^PSDRUG(ODRG,"ND")),"^",3)_",")
+1 SET P1=$PIECE($GET(^PSDRUG(ODRG,"ND")),"^")
SET P2=$PIECE($GET(^("ND")),"^",3)
SET X=$$PROD0^PSNAPIS(P1,P2)
SET SEQN=+$PIECE(X,"^",7)
ID1 IF '$DATA(PSJDGCK)
SET ^TMP($JOB,LIST,"IN","PROFILE",ORTYP_";"_RXREC_";PROFILE;"_DO)=SEQN_"^"_ID_"^"_ODRG_"^"_DRNM_"^"_ORN_"^O"
KILL ID
+1 IF $DATA(PSJDGCK)
SET ^TMP($JOB,LIST,"IN","PROSPECTIVE",ORTYP_";"_RXREC_";PROSPECTIVE;"_DO)=SEQN_"^"_ID_"^"_ODRG_"^"_DRNM_"^"_ORN_"^O"
KILL ID
+2 QUIT
OIX SET ^TMP($JOB,LIST,"IN","EXCEPTIONS","OI",DRNM)=1_"^"_ORTYP_";"_RXREC_";PROFILE;"_DO
+1 KILL TU
+2 QUIT
REMOTE ;
+1 IF $TEXT(HAVEHDR^ORRDI1)']""
QUIT
+2 IF '$$HAVEHDR^ORRDI1
QUIT
+3 IF $DATA(^XTMP("ORRDI","OUTAGE INFO","DOWN"))
Begin DoDot:1
+4 IF $TEXT(REMOTE^PSORX1)]""
QUIT
+5 if (($Y+5)'>IOSL)
DO HD^PSODDPR2()
+6 WRITE !!,"Remote data not available - Only local order checks processed.",!
if (($Y+5)'>IOSL)
DO HD^PSODDPR2()
End DoDot:1
QUIT
+7 IF $PIECE($GET(^XTMP("ORRDI","PSOO",PSODFN,0)),"^",3)<0
WRITE !!,"Remote data not available - Only local order checks processed."
if (($Y+5)'>IOSL)
DO HD^PSODDPR2()
QUIT
+8 NEW PSORDI,RDIINST,RDIVUID,RDIRX,RDIDNAM,RDISTA,RDISIG,RDIDAYS,RDIQTY,RDIFILL,RDIEXP,RDIISS,RDIFILL,ZI
+9 NEW RDIREF,RDIPHYS,PSOPROD,PSOCLASS,DRNM,RDITMP,PSODC,IT,PSOICT,NDF,RDIDI,PSOPRODA,PSOFILE,PSOSIG,PSOSEQN,X
+10 IF '$GET(DT)
SET DT=$$DT^XLFDT
+11 SET PSORDI=0
+12 IF $TEXT(GET^ORRDI1)]""
SET PSORDI=$$GET^ORRDI1(PSODFN,"PSOO")
+13 IF PSORDI<1
QUIT
+14 IF '$DATA(^XTMP("ORRDI","PSOO",PSODFN))
QUIT
+15 KILL ^TMP($JOB,LIST,"OUT","REMOTE")
+16 DO PARSE
DO FILTER
+17 IF '$DATA(^TMP($JOB,LIST,"OUT","REMOTE"))
QUIT
+18 NEW DIC
DO REMO
+19 QUIT
REMO ;
+1 SET (PSOON,PSORDI)=0
FOR
SET PSORDI=$ORDER(^TMP($JOB,LIST,"OUT","REMOTE",PSORDI))
if 'PSORDI
QUIT
SET RDITMP=^(PSORDI)
Begin DoDot:1
+2 if $PIECE(RDITMP,"^",2)=""
QUIT
+3 ;screen out dc'd remotes
+4 IF $PIECE($GET(^TMP($JOB,LIST,"OUT","REMOTE",PSORDI)),"^",4)["DISC"
Begin DoDot:2
+5 KILL X,Y,X1,X2
+6 SET X=$PIECE(^TMP($JOB,LIST,"OUT","REMOTE",PSORDI),"^",6)
DO ^%DT
SET X1=Y
SET X2=(+$PIECE(^TMP($JOB,LIST,"OUT","REMOTE",PSORDI),"^",7)+7)
+7 DO C^%DTC
IF X<DT
SET PSOON=1
KILL X,Y,X1,X2
End DoDot:2
IF $GET(PSOON)
KILL PSOON
QUIT
+8 ;
+9 SET RDIVUID=$PIECE(RDITMP,"^",2)
SET RDIDNAM=$PIECE(RDITMP,"^",3)
+10 IF $ORDER(PDRG(0))
FOR ZI=0:0
SET ZI=$ORDER(PDRG(ZI))
if 'ZI
QUIT
IF $PIECE(^PSDRUG($PIECE(PDRG(ZI),"^"),0),"^")=RDIDNAM
SET INDD=+$GET(INDD)+1
SET ^TMP($JOB,"DD",INDD,0)=$PIECE(PDRG(ZI),"^")_"^"_RDIDNAM_"^^"_PSORDI_"Z;O"
+11 SET DO=$GET(DO)+1
DO GETIREF^XTID(50.68,.01,RDIVUID,"PSOSEQN",1)
IF 'PSOSEQN
SET ^TMP($JOB,LIST,"IN","PROFILE","R;"_PSORDI_";PROFILE;"_DO)=0_"^"_RDIVUID_"^0^"_RDIDNAM_"^^"
QUIT
+12 SET SEQN=""
SET SEQN=$ORDER(PSOSEQN(50.68,.01,SEQN))
if SEQN=""
QUIT
+13 SET P3=+SEQN
SET SEQN=$PIECE($$PROD0^PSNAPIS(,P3),"^",7)
+14 ;S ^TMP($J,LIST,"IN","PROFILE","R;"_PSORDI_";PROFILE;"_DO)=SEQN_"^"_RDIVUID_"^0^"_RDIDNAM_"^^"
+15 ;P785
SET ^TMP($JOB,LIST,"IN","PROFILE","R;"_PSORDI_";PROFILE;"_DO)=SEQN_"^"_RDIVUID_"^0^"_RDIDNAM_"^^O"
End DoDot:1
KILL PSOSEQN
+16 QUIT
+17 ;
PARSE ; PULL INFORMATION FROM ^XTMP
+1 NEW PSORDI,LOCAL,NEWISS,BADEXP,PSOPRE,PSO30,NEWDC,NEWEXP
+2 SET PSORDI=0
FOR
SET PSORDI=$ORDER(^XTMP("ORRDI","PSOO",PSODFN,PSORDI))
if 'PSORDI
QUIT
Begin DoDot:1
+3 SET RDISTA=$GET(^XTMP("ORRDI","PSOO",PSODFN,PSORDI,5,0))
+4 IF RDISTA="DELETED"
QUIT
+5 SET RDIINST=$GET(^XTMP("ORRDI","PSOO",PSODFN,PSORDI,1,0))
+6 SET RDIDNAM=$GET(^XTMP("ORRDI","PSOO",PSODFN,PSORDI,2,0))
+7 SET RDIVUID=$GET(^XTMP("ORRDI","PSOO",PSODFN,PSORDI,3,0))
+8 IF RDIVUID=""
QUIT
+9 DO GETPROD^PSOORRDI
+10 if $EXTRACT($GET(PSOCLASS),1,2)="XA"
QUIT
+11 SET RDIRX=$GET(^XTMP("ORRDI","PSOO",PSODFN,PSORDI,4,0))
+12 SET RDIQTY=$GET(^XTMP("ORRDI","PSOO",PSODFN,PSORDI,6,0))
+13 SET RDIDAYS=$PIECE(RDIQTY,";",2)
SET RDIQTY=$PIECE(RDIQTY,";")
+14 IF $EXTRACT(RDIDAYS)="D"
SET RDIDAYS=$PIECE(RDIDAYS,"D",2)
+15 SET RDIEXP=$GET(^XTMP("ORRDI","PSOO",PSODFN,PSORDI,7,0))
+16 SET RDIISS=$GET(^XTMP("ORRDI","PSOO",PSODFN,PSORDI,8,0))
+17 IF RDIEXP?."/"
SET BADEXP=1
Begin DoDot:2
+18 IF RDIISS?."/"
QUIT
+19 SET PSOPRE=$EXTRACT(DT)
IF $PIECE(RDIISS,"/",3)>($EXTRACT(DT,2,3)+1)
SET PSOPRE=PSOPRE-1
+20 SET NEWISS=PSOPRE_$PIECE(RDIISS,"/",3)_$PIECE(RDIISS,"/")_$PIECE(RDIISS,"/",2)
IF NEWISS>(DT-10000)
SET RDIEXP=RDIISS
SET BADEXP=0
End DoDot:2
IF BADEXP
QUIT
+21 IF RDISTA["EXPIRE"
SET PSO30=0
Begin DoDot:2
+22 SET PSOPRE=$EXTRACT(DT)
IF $PIECE(RDIEXP,"/",3)>($EXTRACT(DT,2,3)+1)
SET PSO30=1
QUIT
+23 SET NEWEXP=PSOPRE_$PIECE(RDIEXP,"/",3)_$PIECE(RDIEXP,"/")_$PIECE(RDIEXP,"/",2)
+24 SET X1=NEWEXP
SET X2=30
DO C^%DTC
IF X<DT
SET PSO30=1
End DoDot:2
IF PSO30
QUIT
+25 IF RDIRX'=""
SET LOCAL=0
DO CHKLOCAL
IF LOCAL
QUIT
+26 SET RDIFILL=$GET(^XTMP("ORRDI","PSOO",PSODFN,PSORDI,9,0))
+27 IF RDISTA["DISCONT"
SET PSO30=0
Begin DoDot:2
+28 SET PSOPRE=$EXTRACT(DT)
IF $PIECE(RDIFILL,"/",3)>($EXTRACT(DT,2,3)+1)
SET PSO30=1
QUIT
+29 SET NEWDC=PSOPRE_$PIECE(RDIFILL,"/",3)_$PIECE(RDIFILL,"/")_$PIECE(RDIFILL,"/",2)
+30 SET X1=NEWDC
SET X2=30+RDIDAYS
DO C^%DTC
IF X<DT
SET PSO30=1
End DoDot:2
IF PSO30
QUIT
+31 IF RDISTA["DRUG INTERACTION"
SET RDISTA="NON-VERIFIED"
+32 SET RDIREF=$GET(^XTMP("ORRDI","PSOO",PSODFN,PSORDI,10,0))
+33 SET RDIPHYS=$GET(^XTMP("ORRDI","PSOO",PSODFN,PSORDI,11,0))
+34 SET PSOSIG=""
FOR
SET PSOSIG=$ORDER(^XTMP("ORRDI","PSOO",PSODFN,PSORDI,14,PSOSIG))
if PSOSIG=""
QUIT
SET PSOSIG(PSOSIG)=^(PSOSIG)
+35 SET ^TMP($JOB,LIST,"OUT","REMOTE",PSORDI)=RDIINST_"^"_RDIVUID_"^"_RDIDNAM_"^"_RDISTA_"^"_RDIRX_"^"_RDIFILL_"^"_RDIDAYS_"^"_RDIQTY_"^"_RDIREF_"^"_RDIEXP_"^"_RDIPHYS_"^"_RDIISS
+36 SET PSOSIG=""
FOR
SET PSOSIG=$ORDER(PSOSIG(PSOSIG))
if PSOSIG=""
QUIT
SET ^TMP($JOB,LIST,"OUT","REMOTE",PSORDI,"SIG",PSOSIG)=PSOSIG(PSOSIG)
End DoDot:1
+37 QUIT
+38 ;
CHKLOCAL ; IF SAME RX NUMBER AND ISSUE DATE - LOCAL RX
+1 NEW PSOISS
+2 IF $DATA(^PSRX("B",RDIRX))
Begin DoDot:1
+3 NEW PSORX
+4 SET PSORX=$ORDER(^PSRX("B",RDIRX,""))
IF 'PSORX
QUIT
+5 SET PSOISS=$PIECE($GET(^PSRX(PSORX,0)),"^",13)
+6 SET PSOISS=$EXTRACT(PSOISS,4,5)_"/"_$EXTRACT(PSOISS,6,7)_"/"_$EXTRACT(PSOISS,2,3)
+7 IF PSOISS=RDIISS
SET LOCAL=1
QUIT
End DoDot:1
+8 QUIT
+9 ;
FILTER ; FOR SAME DRUG VUID FOR SAME SITE, KEEP 1 ENTRY - CHECK BY ACTIVE STATUS FIRST THEN BY GREATEST EXPIRATION DATE
+1 NEW XX,RDI,OLDEXP,RDIEXP,RDIEXP2,OLDEXP2,PSORDI,RDISTA,OLDSTA,OLDRDI,ZZ
+2 SET PSORDI=0
+3 FOR
SET PSORDI=$ORDER(^TMP($JOB,LIST,"OUT","REMOTE",PSORDI))
if 'PSORDI
QUIT
Begin DoDot:1
+4 SET XX=$GET(^TMP($JOB,LIST,"OUT","REMOTE",PSORDI))
SET RDIINST=$PIECE(XX,"^")
SET RDIVUID=$PIECE(XX,"^",2)
SET RDISTA=$PIECE(XX,"^",4)
SET RDIEXP=$PIECE(XX,"^",10)
if RDIINST=""
QUIT
if RDIVUID=""
QUIT
IF RDIEXP=""
QUIT
+5 IF $DATA(RDI(RDIINST,RDIVUID))
SET ZZ=RDI(RDIINST,RDIVUID)
Begin DoDot:2
+6 IF RDISTA="ACTIVE"!(RDISTA["SUSPEN")
Begin DoDot:3
+7 SET OLDSTA=$PIECE(ZZ,"^",2)
IF OLDSTA["ACTIVE"!(OLDSTA["SUSPEN")
DO CHKEXP
QUIT
+8 SET OLDRDI=$PIECE(ZZ,"^")
KILL ^TMP($JOB,LIST,"OUT","REMOTE",OLDRDI)
DO SETRDI
End DoDot:3
QUIT
+9 SET OLDSTA=$PIECE(ZZ,"^",2)
IF OLDSTA["ACTIVE"!(OLDSTA["SUSPEN")
KILL ^TMP($JOB,LIST,"OUT","REMOTE",PSORDI)
QUIT
+10 ; ALL OTHER STATUSES - KEEP BY GREATER EXPIRATION DATE
DO CHKEXP
End DoDot:2
QUIT
+11 DO SETRDI
End DoDot:1
+12 QUIT
+13 ;
CHKEXP ;
+1 NEW PSOPRE
+2 SET OLDEXP=$PIECE(ZZ,"^",3)
Begin DoDot:1
+3 SET PSOPRE=$EXTRACT(DT)
IF $PIECE(RDIEXP,"/",3)>($EXTRACT(DT,2,3)+1)
SET PSOPRE=PSOPRE-1
+4 SET RDIEXP2=PSOPRE_$PIECE(RDIEXP,"/",3)_$PIECE(RDIEXP,"/")_$PIECE(RDIEXP,"/",2)
+5 SET PSOPRE=$EXTRACT(DT)
IF $PIECE(OLDEXP,"/",3)>($EXTRACT(DT,2,3)+1)
SET PSOPRE=PSOPRE-1
+6 SET OLDEXP2=PSOPRE_$PIECE(OLDEXP,"/",3)_$PIECE(OLDEXP,"/")_$PIECE(OLDEXP,"/",2)
End DoDot:1
IF OLDEXP2>RDIEXP2
KILL ^TMP($JOB,"OUT","REMOTE",PSORDI)
QUIT
+7 SET OLDRDI=$PIECE(ZZ,"^")
KILL ^TMP($JOB,LIST,"OUT","REMOTE",OLDRDI)
DO SETRDI
+8 QUIT
+9 ;
SETRDI ;
+1 SET RDI(RDIINST,RDIVUID)=PSORDI_"^"_RDISTA_"^"_RDIEXP
+2 QUIT
CPRS(PSODFN,LIST,PDRG,PTY) ;
+1 ;PDRG - Drug array in format of PDRG(n)=IEN (#50) ^ Drug name
+2 ;PTY - P1;P2 where P1="I" for IP & "O" for OP (required), P2=Pharm order# (optional)
+3 IF '$GET(PSODFN)
WRITE !,"Patient UNDEFINED!",!
QUIT
+4 IF '$ORDER(PDRG(0))
WRITE !,"Dispense Drug(s) UNDEFINED!",!
QUIT
+5 IF '$DATA(LIST)
WRITE !,"Input Base UNDEFINED!",!
QUIT
+6 SET ^TMP($JOB,LIST,"IN","PING")=""
DO IN^PSSHRQ2(LIST)
IF $PIECE(^TMP($JOB,LIST,"OUT",0),"^")=-1
QUIT
+7 KILL ^TMP($JOB,"ORDERS"),^TMP($JOB,"DD"),^TMP($JOB,LIST)
NEW ZII,INDX,INDD,PSODUPSP,PSODUPSY,PSODUPLS,PSOFRMOR,PSOSUPNN
SET (INDX,INDD)=0
SET PSODUPSY=$GET(PTY)
SET PSODUPLS=LIST
SET PSOFRMOR=1
+8 ;build patient's drug profile outpat/inpat/non-va
+9 DO BLD^PSOORDRG
DO ENCHK^PSJORUT2(PSODFN,.INDX)
DO NVA^PSOORDRG
+10 ;dup drug check CPRS ONLY
+11 SET PSOICT=""
SET CNT=0
FOR ZII=0:0
SET ZII=$ORDER(PDRG(ZII))
if 'ZII
QUIT
if $$SUP^PSSDSAPI(+$PIECE(PDRG(ZII),"^"))
Begin DoDot:1
+12 SET PSOY=$PIECE(PDRG(ZII),"^")_"^"_$PIECE($GET(^PSDRUG($PIECE(PDRG(ZII),"^"),0)),"^")
SET PSOY(0)=$GET(^PSDRUG(PDRG(ZII),0))
SET PSOSUPNN=$PIECE(PDRG(ZII),"^",4)
+13 SET IEN=+PSOY
SET NAME=$PIECE(PSOY,"^",2)
SET DNM=0
KILL PSOX1,PSOY
+14 FOR
SET DNM=$ORDER(^TMP($JOB,"ORDERS",DNM))
if 'DNM
QUIT
IF NAME=$PIECE(^TMP($JOB,"ORDERS",DNM),"^",3)
Begin DoDot:2
+15 SET INDD=$GET(INDD)+1
SET ^TMP($JOB,"DD",INDD,0)=IEN_"^"_NAME_"^"_$PIECE(^TMP($JOB,"ORDERS",DNM),"^",4)_"^"_$PIECE(^(DNM),"^",5)
SET PSODUPSP(IEN,$SELECT(PSOSUPNN:PSOSUPNN,1:"ACCEPT"))=PSODUPSY
SET PSODUPSP(IEN,"NAME")=NAME
End DoDot:2
End DoDot:1
+16 KILL ^TMP($JOB,"ORDERS")
+17 DO ORD
+18 QUIT
DRG ;
+1 IF $$SUP^PSSDSAPI(IEN)
QUIT
+2 NEW ID,SEQN
SET PSODRUG("NDF")=$SELECT($GET(^PSDRUG(IEN,"ND"))]"":+^("ND")_"A"_$PIECE(^("ND"),"^",3),1:0)
+3 SET ID=$$GETVUID^XTID(50.68,,+$PIECE($GET(PSODRUG("NDF")),"A",2)_",")
+4 SET P1=$PIECE($GET(^PSDRUG(IEN,"ND")),"^")
SET P2=$PIECE($GET(^("ND")),"^",3)
SET X=$$PROD0^PSNAPIS(P1,P2)
SET SEQN=$PIECE(X,"^",7)
+5 IF '$DATA(PSJDGCK)
SET CNT=$GET(CNT)+1
SET ^TMP($JOB,LIST,"IN","PROSPECTIVE",$PIECE(PTY,";")_";"_$PIECE(PTY,";",2)_";PROSPECTIVE;"_CNT)=SEQN_"^"_+ID_"^"_IEN_"^"_NAME_$SELECT($GET(PSOFRMOR):"^"_PSOFRMNM,1:"")
+6 IF $DATA(PSJDGCK)
IF '$DATA(PSGDGCKF)
SET CNT=$GET(CNT)+1
SET ^TMP($JOB,LIST,"IN","PROSPECTIVE",$PIECE(PTY,";")_";"_$PIECE(PTY,";",2)_";PROSPECTIVE;"_CNT)=SEQN_"^"_+ID_"^"_IEN_"^"_NAME
+7 KILL ID,SEQN,P1,P2,X,DNM
+8 QUIT
+9 ;
DRGSUP ;Create "prospective" nodes for duplicate supply entries
+1 NEW PSODPSID,PSODPSQN,PSODPSP1,PSODPSP2,PSODPSP3,PSODPSXX,PSODPSLP,PSODPSNF,PSODPSCT,PSODPSC1,PSODPSNM,PSODPSOR
+2 SET PSODPSCT=0
+3 SET PSODPSC1=""
FOR
SET PSODPSC1=$ORDER(^TMP($JOB,PSODUPLS,"IN","PROSPECTIVE",PSODPSC1))
if PSODPSC1=""
QUIT
SET PSODPSP3=$PIECE(PSODPSC1,";",4)
IF PSODPSP3>PSODPSCT
SET PSODPSCT=PSODPSP3
+4 SET PSODPSLP=""
FOR
SET PSODPSLP=$ORDER(PSODUPSP(PSODPSLP))
if PSODPSLP=""
QUIT
Begin DoDot:1
+5 SET PSODPSOR=""
FOR
SET PSODPSOR=$ORDER(PSODUPSP(PSODPSLP,PSODPSOR))
if PSODPSOR=""
QUIT
if PSODPSOR'="NAME"
Begin DoDot:2
+6 SET PSODPSNM=$GET(PSODUPSP(PSODPSLP,"NAME"))
+7 SET PSODPSNF=$SELECT($GET(^PSDRUG(PSODPSLP,"ND"))]"":+^PSDRUG(PSODPSLP,"ND")_"A"_$PIECE(^PSDRUG(PSODPSLP,"ND"),"^",3),1:0)
+8 SET PSODPSID=$$GETVUID^XTID(50.68,,+$PIECE($GET(PSODPSNF),"A",2)_",")
+9 SET PSODPSP1=$PIECE($GET(^PSDRUG(PSODPSLP,"ND")),"^")
SET PSODPSP2=$PIECE($GET(^PSDRUG(PSODPSLP,"ND")),"^",3)
SET PSODPSXX=$$PROD0^PSNAPIS(PSODPSP1,PSODPSP2)
SET PSODPSQN=$PIECE(PSODPSXX,"^",7)
+10 SET PSODPSCT=$GET(PSODPSCT)+1
SET ^TMP($JOB,PSODUPLS,"IN","PROSPECTIVE",$PIECE(PSODUPSY,";")_";"_$PIECE(PSODUPSY,";",2)_";PROSPECTIVE;"_PSODPSCT)=PSODPSQN_"^"_+PSODPSID_"^"_PSODPSLP_"^"_$GET(PSODPSNM)_$SELECT(PSODPSOR="ACCEPT":"",1:"^"_PSODPSOR)
End DoDot:2
End DoDot:1
+11 QUIT
+12 ;
RVAGEN ;va generic for remote drugs
+1 NEW PSOVUID,PSONDF,PSOVAG,DIC
+2 SET PSOVUID=$PIECE(^TMP($JOB,"PSOPEPS","OUT","REMOTE",$PIECE(ON,";",2)),"^",2)
if '$GET(PSOVUID)
QUIT
+3 KILL PSORDIID
SET PSOVAGEN=""
DO GETIREF^XTID("50.68",".01",PSOVUID,"PSORDIID")
+4 SET PSONDF=$ORDER(PSORDIID(50.68,.01,""))
KILL PSORDIID
+5 IF +PSONDF
DO DATA^PSN50P68(+PSONDF,,"PSONDF")
Begin DoDot:1
+6 ;*484
SET PSOVAG=$PIECE($GET(^TMP($JOB,"PSONDF",+PSONDF,.05)),U,2)
+7 ;*484
NEW ZOT
+8 ;*484
SET ZOT=$SELECT($PIECE(ON,";")["C":1,$PIECE(ON,";")="O":2,$PIECE(ON,";")="R":3,$PIECE(ON,";")="P":4,1:5)
+9 ;*484
SET ZDGDG(SV,ZOT,PSOVAG,DRG)=ON_"^"_CT
SET ZZDGDG3(SV,PSOVAG,DRG)=""
+10 IF '$DATA(NSRT(SV,PSOVAG))
SET NSRT(SV,PSOVAG)=3
+11 IF '$TEST
SET $PIECE(NSRT(SV,PSOVAG),"^",1)=$PIECE(NSRT(SV,PSOVAG),"^",1)_",3"
End DoDot:1
+12 KILL ^TMP($JOB,"PSONDF")
+13 QUIT
