PSOORRDI ;BHAM-ISC/EJW - Remote Data Interoperability Order Checks ;04/25/05
;;7.0;OUTPATIENT PHARMACY;**207,243**;DEC 1997;Build 22
;
;External references to ^ORRDI1 supported by DBIA 4659
;External references to ^XTMP("ORRDI" supported by DBIA 4660
;External reference to ^PS(50.605 supported by DBIA 696
;External reference to ^PSDRUG supported by DBIA 221
;External reference to ^PS(56 supported by DBIA 2229
;External reference to ^PS(50.416 supported by DBIA 692
;External reference to DDIEX^PSNAPIS supported by DBIA 2574
REMOTE(PSODFN,DREN) ;
; Input: DFN: PATIENT file (#2) IEN
; : DREN: DRUG file (#50) IEN of order being checked
I $T(HAVEHDR^ORRDI1)']"" Q
I '$$HAVEHDR^ORRDI1 Q
I $D(^XTMP("ORRDI","OUTAGE INFO","DOWN")) Q
N PSORDI,RDIINST,RDIVUID,RDIRX,RDIDNAM,RDISTA,RDISIG,RDIDAYS,RDIQTY,RDIFILL,RDIEXP,RDIISS,RDIFILL,RDIREF,RDIPHYS,PSOPROD,PSOCLASS,DRNM,RDITMP,PSODC,IT,PSOICT,NDF,RDIDI,PSOPRODA,PSOFILE,PSOSIG
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,"PSORDI")
D PARSE,FILTER
I '$D(^TMP($J,"PSORDI")) Q
D DRGNAME ; GET VA PRODUCT FILE NAME FOR FILE 50 DRUG BEING CHECKED
S PSORDI="" F S PSORDI=$O(^TMP($J,"PSORDI",PSORDI)) Q:'PSORDI S RDITMP=^(PSORDI) D
.S RDIINST=$P(RDITMP,"^")
.S RDIVUID=$P(RDITMP,"^",2)
.I RDIVUID="" Q
.S RDIDNAM=$P(RDITMP,"^",3)
.S RDISTA=$P(RDITMP,"^",4)
.S RDIRX=$P(RDITMP,"^",5)
.S RDIFILL=$P(RDITMP,"^",6)
.S RDIDAYS=$P(RDITMP,"^",7) I $E(RDIDAYS)="D" S RDIDAYS=$P(RDIDAYS,"D",2)
.S RDIQTY=$P(RDITMP,"^",8)
.S RDIREF=$P(RDITMP,"^",9)
.S RDIEXP=$P(RDITMP,"^",10)
.S RDIPHYS=$P(RDITMP,"^",11)
.S RDIISS=$P(RDITMP,"^",12)
.S DRNM=$G(PSODRUG("NAME"))
.D GETPROD
.I DRNM'="" I PSODRUG("NAME")=DRNM S DD=$G(DD)+1,^TMP($J,"DD",DD,0)=PSODRUG("IEN")_"^"_PSODRUG("NAME")_"^"_"^"_RDIRX_"R;O"_"^"_RDIINST D Q:'$G(PSOPHI)
..S ^TMP($J,"DD",DD,1)=RDIDNAM_"^"_RDISTA_"^"_RDIFILL_"^"_RDIDAYS_"^"_RDIQTY_"^"_RDIREF_"^"_RDIEXP_"^"_RDIPHYS_"^"_RDIISS
..M ^TMP($J,"DD",DD,1)=^TMP($J,"PSORDI",PSORDI,"SIG")
.I PSODRUG("NAME")'=DRNM I PSODRUG("VA CLASS")]"",$E(PSODRUG("VA CLASS"),1,4)=$E(PSOCLASS,1,4) D
..I $E(PSODRUG("VA CLASS"),1,2)="HA",$E(PSOCLASS,1,2)="HA" Q
..S PSODC=$O(^PS(50.605,"B",PSODRUG("VA CLASS"),0)) Q:'PSODC
..S DC=$G(DC)+1,^TMP($J,"DC",DC,0)=PSODRUG("VA CLASS")
..S PSODC=$P(^PS(50.605,PSODC,0),"^",2),^TMP($J,"DC",DC,0)=^TMP($J,"DC",DC,0)_"^"_PSODC_"^"_RDIVUID_"^"_DRNM_"^"_"^"_RDIRX_"R;O"_"^"_RDIINST D
...S ^TMP($J,"DC",DC,1)=RDIDNAM_"^"_RDISTA_"^"_RDIFILL_"^"_RDIDAYS_"^"_RDIQTY_"^"_RDIREF_"^"_RDIEXP_"^"_RDIPHYS_"^"_RDIISS
...M ^TMP($J,"DC",DC,1)=^TMP($J,"PSORDI",PSORDI,"SIG")
.;drug interaction check
.K ^TMP($J,"PSOPROD")
.D DATA^PSN50P68(PSOPROD,,"PSOPROD")
.S NDF=+$G(^TMP($J,"PSOPROD",PSOPROD,.05))
.I NDF=0 Q
.S NDF=NDF_"A"_PSOPROD
.K ^TMP($J,"PSOPROD")
.S IT=0,PSOICT=""
.F S IT=$O(^PS(56,"APD",NDF,PSODRUG("NDF"),IT)) Q:'IT D
..Q:$$DDIEX^PSNAPIS($P(NDF,"A"),$P(NDF,"A",2))
..Q:$$DDIEX^PSNAPIS($P(PSODRUG("NDF"),"A"),$P(PSODRUG("NDF"),"A",2))
..Q:$P(^PS(56,IT,0),"^",7)&($P(^PS(56,IT,0),"^",7)<DT)
..I 'PSOICT S PSOICT=IT Q
..I $P($G(^PS(56,IT,0)),"^",4)=1 S PSOICT=IT Q
..Q
.I 'PSOICT Q
.S IT=PSOICT
.S RDIDI=$O(^TMP($J,"DI",999),-1) I 'RDIDI S RDIDI=0
.S RDIDI=$G(RDIDI)+1,^TMP($J,"DI",RDIDI,0)=RDIVUID_"^"_DRNM_"^"_IT_"^"_$S($P(^PS(56,IT,0),"^",4)=1:"CRITICAL",1:"SIGNIFICANT")_"^"
.S ^TMP($J,"DI",RDIDI,0)=^TMP($J,"DI",RDIDI,0)_$P(^PS(50.416,$P(^PS(56,IT,0),"^",2),0),"^")_"^"_$P(^PS(50.416,$P(^PS(56,IT,0),"^",3),0),"^")_"^"_""_"^"_RDIRX_"R;O"_"^"_RDIINST
.S ^TMP($J,"DI",RDIDI,1)=RDIDNAM_"^"_RDISTA_"^"_RDIFILL_"^"_RDIDAYS_"^"_RDIQTY_"^"_RDIREF_"^"_RDIEXP_"^"_RDIPHYS_"^"_RDIISS
.M ^TMP($J,"DI",RDIDI,1)=^TMP($J,"PSORDI",PSORDI,"SIG")
.M ^TMP($J,"DI"_PSODFN,RDIDI)=^TMP($J,"DI",RDIDI) ; SAVE FOR OUTPATIENT PHARMACY BACKDOOR DISPLAY
K ^TMP($J,"PSORDI")
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
.S RDIRX=$G(^XTMP("ORRDI","PSOO",PSODFN,PSORDI,4,0))
.S RDIQTY=$G(^XTMP("ORRDI","PSOO",PSODFN,PSORDI,6,0)),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
.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,"PSORDI",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,"PSORDI",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
;
VAPROD(PSOPROD) ; GET VA PRODUCT FILE NAME AND DRUG CLASS
S PSOCLASS=$$DCLCODE^PSNAPIS(,PSOPROD)
S DRNM=$P($$PROD0^PSNAPIS(,PSOPROD),"^")
Q
;
DRGNAME ;
N PSOY
S PSOY=DREN_"^"_$P($G(^PSDRUG(DREN,0)),"^"),PSOY(0)=$G(^PSDRUG(DREN,0))
S PSODRUG("IEN")=+PSOY,PSODRUG("VA CLASS")=$P(PSOY(0),"^",2)
S PSODRUG("NDF")=$S($G(^PSDRUG(+PSOY,"ND"))]"":+^("ND")_"A"_$P(^("ND"),"^",3),1:0)
I PSODRUG("NDF")=0 Q
S PSOPROD=$P(PSODRUG("NDF"),"A",2) I PSOPROD D VAPROD(PSOPROD) S PSODRUG("NAME")=DRNM
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,"PSORDI",PSORDI)) Q:'PSORDI D
.S XX=$G(^TMP($J,"PSORDI",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,"PSORDI",OLDRDI) D SETRDI
..S OLDSTA=$P(ZZ,"^",2) I OLDSTA["ACTIVE"!(OLDSTA["SUSPEN") K ^TMP($J,"PSORDI",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,"PSORDI",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,"PSORDI",OLDRDI) D SETRDI
Q
;
SETRDI ;
S RDI(RDIINST,RDIVUID)=PSORDI_"^"_RDISTA_"^"_RDIEXP
Q
;
GETPROD ;
S PSOFILE=50.68
S DRNM="",PSOCLASS="",PSOPROD=0
N PSOPR
K PSOPRODA
N DIC
D GETIREF^XTID(PSOFILE,.01,RDIVUID,"PSOPRODA",1) I 'PSOPRODA Q
S PSOPR="" F S PSOPR=$O(PSOPRODA(PSOFILE,.01,PSOPR)) Q:PSOPR="" D Q:DRNM'="" Q:PSOCLASS'=""
.I +(PSOPRODA(PSOFILE,.01,PSOPR)) S PSOPROD=+PSOPR D VAPROD(PSOPROD) Q
.I +(PSOPRODA(PSOFILE,.01,PSOPR))=0 I '$O(PSOPRODA(PSOFILE,.01,PSOPR)) S PSOPROD=+PSOPR D VAPROD(PSOPROD) ; USE LAST ENTRY IF ALL ARE INACTIVE
Q
;
PSOORRDI ;BHAM-ISC/EJW - Remote Data Interoperability Order Checks ;04/25/05
+1 ;;7.0;OUTPATIENT PHARMACY;**207,243**;DEC 1997;Build 22
+2 ;
+3 ;External references to ^ORRDI1 supported by DBIA 4659
+4 ;External references to ^XTMP("ORRDI" supported by DBIA 4660
+5 ;External reference to ^PS(50.605 supported by DBIA 696
+6 ;External reference to ^PSDRUG supported by DBIA 221
+7 ;External reference to ^PS(56 supported by DBIA 2229
+8 ;External reference to ^PS(50.416 supported by DBIA 692
+9 ;External reference to DDIEX^PSNAPIS supported by DBIA 2574
REMOTE(PSODFN,DREN) ;
+1 ; Input: DFN: PATIENT file (#2) IEN
+2 ; : DREN: DRUG file (#50) IEN of order being checked
+3 IF $TEXT(HAVEHDR^ORRDI1)']""
QUIT
+4 IF '$$HAVEHDR^ORRDI1
QUIT
+5 IF $DATA(^XTMP("ORRDI","OUTAGE INFO","DOWN"))
QUIT
+6 NEW PSORDI,RDIINST,RDIVUID,RDIRX,RDIDNAM,RDISTA,RDISIG,RDIDAYS,RDIQTY,RDIFILL,RDIEXP,RDIISS,RDIFILL,RDIREF,RDIPHYS,PSOPROD,PSOCLASS,DRNM,RDITMP,PSODC,IT,PSOICT,NDF,RDIDI,PSOPRODA,PSOFILE,PSOSIG
+7 IF '$GET(DT)
SET DT=$$DT^XLFDT
+8 SET PSORDI=0
+9 IF $TEXT(GET^ORRDI1)]""
SET PSORDI=$$GET^ORRDI1(PSODFN,"PSOO")
+10 IF PSORDI<1
QUIT
+11 IF '$DATA(^XTMP("ORRDI","PSOO",PSODFN))
QUIT
+12 KILL ^TMP($JOB,"PSORDI")
+13 DO PARSE
DO FILTER
+14 IF '$DATA(^TMP($JOB,"PSORDI"))
QUIT
+15 ; GET VA PRODUCT FILE NAME FOR FILE 50 DRUG BEING CHECKED
DO DRGNAME
+16 SET PSORDI=""
FOR
SET PSORDI=$ORDER(^TMP($JOB,"PSORDI",PSORDI))
IF 'PSORDI
QUIT
SET RDITMP=^(PSORDI)
Begin DoDot:1
+17 SET RDIINST=$PIECE(RDITMP,"^")
+18 SET RDIVUID=$PIECE(RDITMP,"^",2)
+19 IF RDIVUID=""
QUIT
+20 SET RDIDNAM=$PIECE(RDITMP,"^",3)
+21 SET RDISTA=$PIECE(RDITMP,"^",4)
+22 SET RDIRX=$PIECE(RDITMP,"^",5)
+23 SET RDIFILL=$PIECE(RDITMP,"^",6)
+24 SET RDIDAYS=$PIECE(RDITMP,"^",7)
IF $EXTRACT(RDIDAYS)="D"
SET RDIDAYS=$PIECE(RDIDAYS,"D",2)
+25 SET RDIQTY=$PIECE(RDITMP,"^",8)
+26 SET RDIREF=$PIECE(RDITMP,"^",9)
+27 SET RDIEXP=$PIECE(RDITMP,"^",10)
+28 SET RDIPHYS=$PIECE(RDITMP,"^",11)
+29 SET RDIISS=$PIECE(RDITMP,"^",12)
+30 SET DRNM=$GET(PSODRUG("NAME"))
+31 DO GETPROD
+32 IF DRNM'=""
IF PSODRUG("NAME")=DRNM
SET DD=$GET(DD)+1
SET ^TMP($JOB,"DD",DD,0)=PSODRUG("IEN")_"^"_PSODRUG("NAME")_"^"_"^"_RDIRX_"R;O"_"^"_RDIINST
Begin DoDot:2
+33 SET ^TMP($JOB,"DD",DD,1)=RDIDNAM_"^"_RDISTA_"^"_RDIFILL_"^"_RDIDAYS_"^"_RDIQTY_"^"_RDIREF_"^"_RDIEXP_"^"_RDIPHYS_"^"_RDIISS
+34 MERGE ^TMP($JOB,"DD",DD,1)=^TMP($JOB,"PSORDI",PSORDI,"SIG")
End DoDot:2
IF '$GET(PSOPHI)
QUIT
+35 IF PSODRUG("NAME")'=DRNM
IF PSODRUG("VA CLASS")]""
IF $EXTRACT(PSODRUG("VA CLASS"),1,4)=$EXTRACT(PSOCLASS,1,4)
Begin DoDot:2
+36 IF $EXTRACT(PSODRUG("VA CLASS"),1,2)="HA"
IF $EXTRACT(PSOCLASS,1,2)="HA"
QUIT
+37 SET PSODC=$ORDER(^PS(50.605,"B",PSODRUG("VA CLASS"),0))
IF 'PSODC
QUIT
+38 SET DC=$GET(DC)+1
SET ^TMP($JOB,"DC",DC,0)=PSODRUG("VA CLASS")
+39 SET PSODC=$PIECE(^PS(50.605,PSODC,0),"^",2)
SET ^TMP($JOB,"DC",DC,0)=^TMP($JOB,"DC",DC,0)_"^"_PSODC_"^"_RDIVUID_"^"_DRNM_"^"_"^"_RDIRX_"R;O"_"^"_RDIINST
Begin DoDot:3
+40 SET ^TMP($JOB,"DC",DC,1)=RDIDNAM_"^"_RDISTA_"^"_RDIFILL_"^"_RDIDAYS_"^"_RDIQTY_"^"_RDIREF_"^"_RDIEXP_"^"_RDIPHYS_"^"_RDIISS
+41 MERGE ^TMP($JOB,"DC",DC,1)=^TMP($JOB,"PSORDI",PSORDI,"SIG")
End DoDot:3
End DoDot:2
+42 ;drug interaction check
+43 KILL ^TMP($JOB,"PSOPROD")
+44 DO DATA^PSN50P68(PSOPROD,,"PSOPROD")
+45 SET NDF=+$GET(^TMP($JOB,"PSOPROD",PSOPROD,.05))
+46 IF NDF=0
QUIT
+47 SET NDF=NDF_"A"_PSOPROD
+48 KILL ^TMP($JOB,"PSOPROD")
+49 SET IT=0
SET PSOICT=""
+50 FOR
SET IT=$ORDER(^PS(56,"APD",NDF,PSODRUG("NDF"),IT))
IF 'IT
QUIT
Begin DoDot:2
+51 IF $$DDIEX^PSNAPIS($PIECE(NDF,"A"),$PIECE(NDF,"A",2))
QUIT
+52 IF $$DDIEX^PSNAPIS($PIECE(PSODRUG("NDF"),"A"),$PIECE(PSODRUG("NDF"),"A",2))
QUIT
+53 IF $PIECE(^PS(56,IT,0),"^",7)&($PIECE(^PS(56,IT,0),"^",7)<DT)
QUIT
+54 IF 'PSOICT
SET PSOICT=IT
QUIT
+55 IF $PIECE($GET(^PS(56,IT,0)),"^",4)=1
SET PSOICT=IT
QUIT
+56 QUIT
End DoDot:2
+57 IF 'PSOICT
QUIT
+58 SET IT=PSOICT
+59 SET RDIDI=$ORDER(^TMP($JOB,"DI",999),-1)
IF 'RDIDI
SET RDIDI=0
+60 SET RDIDI=$GET(RDIDI)+1
SET ^TMP($JOB,"DI",RDIDI,0)=RDIVUID_"^"_DRNM_"^"_IT_"^"_$SELECT($PIECE(^PS(56,IT,0),"^",4)=1:"CRITICAL",1:"SIGNIFICANT")_"^"
+61 SET ^TMP($JOB,"DI",RDIDI,0)=^TMP($JOB,"DI",RDIDI,0)_$PIECE(^PS(50.416,$PIECE(^PS(56,IT,0),"^",2),0),"^")_"^"_$PIECE(^PS(50.416,$PIECE(^PS(56,IT,0),"^",3),0),"^")_"^"_""_"^"_RDIRX_"R;O"_"^"_RDIINST
+62 SET ^TMP($JOB,"DI",RDIDI,1)=RDIDNAM_"^"_RDISTA_"^"_RDIFILL_"^"_RDIDAYS_"^"_RDIQTY_"^"_RDIREF_"^"_RDIEXP_"^"_RDIPHYS_"^"_RDIISS
+63 MERGE ^TMP($JOB,"DI",RDIDI,1)=^TMP($JOB,"PSORDI",PSORDI,"SIG")
+64 ; SAVE FOR OUTPATIENT PHARMACY BACKDOOR DISPLAY
MERGE ^TMP($JOB,"DI"_PSODFN,RDIDI)=^TMP($JOB,"DI",RDIDI)
End DoDot:1
+65 KILL ^TMP($JOB,"PSORDI")
+66 QUIT
+67 ;
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 SET RDIRX=$GET(^XTMP("ORRDI","PSOO",PSODFN,PSORDI,4,0))
+10 SET RDIQTY=$GET(^XTMP("ORRDI","PSOO",PSODFN,PSORDI,6,0))
SET RDIDAYS=$PIECE(RDIQTY,";",2)
SET RDIQTY=$PIECE(RDIQTY,";")
+11 IF $EXTRACT(RDIDAYS)="D"
SET RDIDAYS=$PIECE(RDIDAYS,"D",2)
+12 SET RDIEXP=$GET(^XTMP("ORRDI","PSOO",PSODFN,PSORDI,7,0))
+13 SET RDIISS=$GET(^XTMP("ORRDI","PSOO",PSODFN,PSORDI,8,0))
+14 IF RDIEXP?."/"
SET BADEXP=1
Begin DoDot:2
+15 IF RDIISS?."/"
QUIT
+16 SET PSOPRE=$EXTRACT(DT)
IF $PIECE(RDIISS,"/",3)>($EXTRACT(DT,2,3)+1)
SET PSOPRE=PSOPRE-1
+17 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
+18 IF RDISTA["EXPIRE"
SET PSO30=0
Begin DoDot:2
+19 SET PSOPRE=$EXTRACT(DT)
IF $PIECE(RDIEXP,"/",3)>($EXTRACT(DT,2,3)+1)
SET PSO30=1
QUIT
+20 SET NEWEXP=PSOPRE_$PIECE(RDIEXP,"/",3)_$PIECE(RDIEXP,"/")_$PIECE(RDIEXP,"/",2)
+21 SET X1=NEWEXP
SET X2=30
DO C^%DTC
IF X<DT
SET PSO30=1
End DoDot:2
IF PSO30
QUIT
+22 IF RDIRX'=""
SET LOCAL=0
DO CHKLOCAL
IF LOCAL
QUIT
+23 SET RDIFILL=$GET(^XTMP("ORRDI","PSOO",PSODFN,PSORDI,9,0))
+24 IF RDISTA["DISCONT"
SET PSO30=0
Begin DoDot:2
+25 SET PSOPRE=$EXTRACT(DT)
IF $PIECE(RDIFILL,"/",3)>($EXTRACT(DT,2,3)+1)
SET PSO30=1
QUIT
+26 SET NEWDC=PSOPRE_$PIECE(RDIFILL,"/",3)_$PIECE(RDIFILL,"/")_$PIECE(RDIFILL,"/",2)
+27 SET X1=NEWDC
SET X2=30+RDIDAYS
DO C^%DTC
IF X<DT
SET PSO30=1
End DoDot:2
IF PSO30
QUIT
+28 SET RDIREF=$GET(^XTMP("ORRDI","PSOO",PSODFN,PSORDI,10,0))
+29 SET RDIPHYS=$GET(^XTMP("ORRDI","PSOO",PSODFN,PSORDI,11,0))
+30 SET PSOSIG=""
FOR
SET PSOSIG=$ORDER(^XTMP("ORRDI","PSOO",PSODFN,PSORDI,14,PSOSIG))
IF PSOSIG=""
QUIT
SET PSOSIG(PSOSIG)=^(PSOSIG)
+31 SET ^TMP($JOB,"PSORDI",PSORDI)=RDIINST_"^"_RDIVUID_"^"_RDIDNAM_"^"_RDISTA_"^"_RDIRX_"^"_RDIFILL_"^"_RDIDAYS_"^"_RDIQTY_"^"_RDIREF_"^"_RDIEXP_"^"_RDIPHYS_"^"_RDIISS
+32 SET PSOSIG=""
FOR
SET PSOSIG=$ORDER(PSOSIG(PSOSIG))
IF PSOSIG=""
QUIT
SET ^TMP($JOB,"PSORDI",PSORDI,"SIG",PSOSIG)=PSOSIG(PSOSIG)
End DoDot:1
+33 QUIT
+34 ;
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 ;
VAPROD(PSOPROD) ; GET VA PRODUCT FILE NAME AND DRUG CLASS
+1 SET PSOCLASS=$$DCLCODE^PSNAPIS(,PSOPROD)
+2 SET DRNM=$PIECE($$PROD0^PSNAPIS(,PSOPROD),"^")
+3 QUIT
+4 ;
DRGNAME ;
+1 NEW PSOY
+2 SET PSOY=DREN_"^"_$PIECE($GET(^PSDRUG(DREN,0)),"^")
SET PSOY(0)=$GET(^PSDRUG(DREN,0))
+3 SET PSODRUG("IEN")=+PSOY
SET PSODRUG("VA CLASS")=$PIECE(PSOY(0),"^",2)
+4 SET PSODRUG("NDF")=$SELECT($GET(^PSDRUG(+PSOY,"ND"))]"":+^("ND")_"A"_$PIECE(^("ND"),"^",3),1:0)
+5 IF PSODRUG("NDF")=0
QUIT
+6 SET PSOPROD=$PIECE(PSODRUG("NDF"),"A",2)
IF PSOPROD
DO VAPROD(PSOPROD)
SET PSODRUG("NAME")=DRNM
+7 QUIT
+8 ;
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,"PSORDI",PSORDI))
IF 'PSORDI
QUIT
Begin DoDot:1
+4 SET XX=$GET(^TMP($JOB,"PSORDI",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,"PSORDI",OLDRDI)
DO SETRDI
End DoDot:3
QUIT
+9 SET OLDSTA=$PIECE(ZZ,"^",2)
IF OLDSTA["ACTIVE"!(OLDSTA["SUSPEN")
KILL ^TMP($JOB,"PSORDI",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,"PSORDI",PSORDI)
QUIT
+7 SET OLDRDI=$PIECE(ZZ,"^")
KILL ^TMP($JOB,"PSORDI",OLDRDI)
DO SETRDI
+8 QUIT
+9 ;
SETRDI ;
+1 SET RDI(RDIINST,RDIVUID)=PSORDI_"^"_RDISTA_"^"_RDIEXP
+2 QUIT
+3 ;
GETPROD ;
+1 SET PSOFILE=50.68
+2 SET DRNM=""
SET PSOCLASS=""
SET PSOPROD=0
+3 NEW PSOPR
+4 KILL PSOPRODA
+5 NEW DIC
+6 DO GETIREF^XTID(PSOFILE,.01,RDIVUID,"PSOPRODA",1)
IF 'PSOPRODA
QUIT
+7 SET PSOPR=""
FOR
SET PSOPR=$ORDER(PSOPRODA(PSOFILE,.01,PSOPR))
IF PSOPR=""
QUIT
Begin DoDot:1
+8 IF +(PSOPRODA(PSOFILE,.01,PSOPR))
SET PSOPROD=+PSOPR
DO VAPROD(PSOPROD)
QUIT
+9 ; USE LAST ENTRY IF ALL ARE INACTIVE
IF +(PSOPRODA(PSOFILE,.01,PSOPR))=0
IF '$ORDER(PSOPRODA(PSOFILE,.01,PSOPR))
SET PSOPROD=+PSOPR
DO VAPROD(PSOPROD)
End DoDot:1
IF DRNM'=""
QUIT
IF PSOCLASS'=""
QUIT
+10 QUIT
+11 ;
