- 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**;DEC 1997;Build 3
- ;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_"^^"
- 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 14595 printed Jan 18, 2025@03:27:36 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**;DEC 1997;Build 3
- +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 SET ^TMP($JOB,LIST,"IN","PROFILE","R;"_PSORDI_";PROFILE;"_DO)=SEQN_"^"_RDIVUID_"^0^"_RDIDNAM_"^^"
- End DoDot:1
- KILL PSOSEQN
- +15 QUIT
- +16 ;
- 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