PSOHLNE2 ;BIR/RTR-Parsing out more OERR segments ;8/13/08 2:43pm
;;7.0;OUTPATIENT PHARMACY;**1,7,59,46,225,305,391**;DEC 1997;Build 13
;External reference to DG(40.8 supported by DBIA 728
;External reference to PS(50.606 supported by DBIA 2174
;External reference to PS(50.7 supported by DBIA 2223
;External reference to PSDRUG( supported by DBIA 221
;External reference to PS(55 supported by DBIA 2228
;External reference to SC( supported by DBIA 2675
;External reference to EN^ORERR supported by DBIA 2187
;
EN ;RXO segment on new orders with multiple subscripts
S (POVAR,POVAR1)="",(NNN,NNNN)=0,PSOIII=1,MSG(ZZ,0)=$E(MSG(ZZ),5,$L(MSG(ZZ)))
S AAA="" F S AAA=$O(MSG(ZZ,AAA)) Q:AAA="" S NNN=0 F OOO=1:1:$L(MSG(ZZ,AAA)) S NNN=NNN+1 D D:$G(POVAR1)="|" PARSE
.I $E(MSG(ZZ,AAA),OOO)="|" S NNNN=NNNN+1
.S POVAR1=$E(MSG(ZZ,AAA),OOO)
.S POLIM=POVAR
.S POVAR=$S(POVAR="":POVAR1,1:POVAR_POVAR1)
I $G(POVAR)'="" I NNNN=13!(NNNN=12) S PSOREFIL=POVAR
K MSG(ZZ,0)
Q
PARSE ;
I NNNN=1 S PSORDITE=$P(POLIM,"^",4) G SET
I NNNN=10 S PSODDRUG=$P(POLIM,"^",4) I $G(PSODDRUG),('$D(^PSDRUG(PSODDRUG,0))) S PSODDRUG="" G SET
I NNNN=10 S DDR=1 G SET
I NNNN=11 S PSOXQTY=POLIM G SET
I NNNN=13 S PSOREFIL=POLIM G SET
I NNNN=17 S PSODYSPL=POLIM
SET S (POVAR,POLIM)="" Q
;
OBXX ;Parse out OBX segments
S OCOUNT=OCOUNT+1
S (POVAR,POVAR)="",(NNCK,NNN,NNNN)=0,PSOIII=1,MSG(ZZ,0)=$E(MSG(ZZ),5,$L(MSG(ZZ)))
S AAA="" F S AAA=$O(MSG(ZZ,AAA)) Q:AAA="" S NNN=0 F OOO=1:1:$L(MSG(ZZ,AAA)) S NNN=NNN+1 D D:$G(POVAR1)="&"&(NNNN=4) OPARSE D:$G(POVAR1)="|" OPARSE
.I $E(MSG(ZZ,AAA),OOO)="|" S NNNN=NNNN+1
.S POVAR1=$E(MSG(ZZ,AAA),OOO)
.S POLIM=POVAR
.S POVAR=$S(POVAR="":POVAR1,1:POVAR_POVAR1)
I $G(POVAR)'="" I NNNN=4!(NNNN=5) S NNCK=NNCK+1 S OBXAR(OCOUNT,NNCK)=POVAR
K MSG(ZZ,0)
F OOO=2:1 Q:'$D(OBXAR(OCOUNT,OOO)) S OBXAR(OCOUNT,1)=OBXAR(OCOUNT,1)_"&"_OBXAR(OCOUNT,OOO) K OBXAR(OCOUNT,OOO)
Q
OPARSE ;
I NNNN=4,$G(POVAR1)="&" S NNCK=NNCK+1,OBXAR(OCOUNT,NNCK)=$G(POLIM) G OSET
I NNNN=5 S NNCK=NNCK+1 S OBXAR(OCOUNT,NNCK)=$G(POLIM)
OSET S (POVAR,POLIM)="" Q
;
PURGE ;Purge order initiated by CPRS
N DA,PREER,PRG,PPG,PND,PRGFLAG,PURGCOMM,PEER,PURGPV1,PURGPID,PURGORC,PURGRX,PURGPLC,PRGSTAT,PSCC,PSARC,PSCA,PSACOUNT,PURGEXRX,PLAST,PURGLTH,PURGNODE
S PSOMSORR=1
S PRGFLAG=0
I $G(PSOFILNM),$G(PSOFILNM)'["S" S PURGRX=PSOFILNM G PRX
S PND=+$G(PSOFILNM) I PND D G PDNO
.I '$D(^PS(52.41,PND,0)) Q
.I $G(PDFN),$G(PDFN)'=$P($G(^PS(52.41,PND,0)),"^",2) S PURGCOMM="Patient does not match" D PDERR Q
.S PRGSTAT=$P($G(^PS(52.41,PND,0)),"^",3) I PRGSTAT="NW"!(PRGSTAT="RNW")!(PRGSTAT="HD") S PRGFLAG=1 Q
.K DIK S DA=PND,DIK="^PS(52.41," D ^DIK K DIK Q
S PURGCOMM="Order was not located by Pharmacy."
D PDERR G PDNO
PDERR D EN^ORERR(PURGCOMM,.MSG)
Q
PDNO F PEER=0:0 S PEER=$O(MSG(PEER)) Q:'PEER S:$P(MSG(PEER),"|")="PV1" PURGPV1=MSG(PEER) S:$P(MSG(PEER),"|")="PID" PURGPID=MSG(PEER) S:$P(MSG(PEER),"|")="ORC"&($G(PURGORC)="") PURGORC=MSG(PEER)
N MSG,PSOHINST D INIT^PSOHLSN S MSG(2)=$G(PURGPID),MSG(3)=$G(PURGPV1),MSG(4)="ORC|"_$S($G(PRGFLAG):"ZU",1:"ZR")_"|"_$G(OR("PLACE"))_$S($G(PLACERXX):";"_PLACERXX,1:"")_"^OR"_"|"_$S($P($G(PURGORC),"|",4)'="":$P(PURGORC,"|",4),1:"")
F PREER=11,13 I $P($G(PURGORC),"|",PREER)'="" S $P(MSG(4),"|",PREER)=$P($G(PURGORC),"|",PREER)
S $P(MSG(4),"|",17)="^^^^"_$S($G(PRGFLAG):"Unable to Purge order.",1:"OK to Purge order.")_"^"
D SEND^PSOHLSN
PURGEX K PSOMSORR Q
PRX ;Purge from PSRX here
I '$D(^PSRX(PURGRX,0)) G PDNO
I $G(PDFN),$G(PDFN)'=$P($G(^PSRX(PURGRX,0)),"^",2) S PURGCOMM="Patient does not match" D PDERR G PDNO
I '$P($G(^PSRX(PURGRX,"ARC")),"^") S PRGFLAG=1 G PDNO
;purge from PSRX
S PURGEXRX=$P(^PSRX(PURGRX,0),"^")
S PSOSUSPA=1 K DIK S DA=PURGRX,PSCC=$P($G(^PSRX(PURGRX,0)),"^",2),DIK="^PSRX(" D ^DIK K DIK,PSOSUSPA
I $D(^PS(55,+$G(PSCC),0)) S DA(1)=PSCC,DIK="^PS(55,"_DA(1)_",""P""," F PSCA=0:0 S PSCA=$O(^PS(55,+$G(PSCC),"P",PSCA)) Q:'PSCA I ^PS(55,+$G(PSCC),"P",PSCA,0)=PURGRX S DA=PSCA D ^DIK K DA,DIK
I $D(^PS(52.4,PURGRX,0)) S DA=PURGRX,DIK="^PS(52.4," D ^DIK K DA,DIK
S DA=$O(^PS(52.5,"B",PURGRX,"")) I DA S DIK="^PS(52.5," D ^DIK K DIK,DA
I '$G(DT) S DT=$$DT^XLFDT
I '$G(PSCC) G PUQUIT
I '$D(^PS(55,PSCC,"ARC",DT)) S DA=PSCC,DIE=55,DR="101///"_DT,DR(2,55.13)="1///"_$G(PURGEXRX) D ^DIE K DIE G PUQUIT
S PLAST=0 F PSARC=0:0 S PSARC=$O(^PS(55,PSCC,"ARC",DT,1,PSARC)) Q:'PSARC S PLAST=PSARC
I $G(PLAST),$D(^PS(55,PSCC,"ARC",DT,1,PLAST,0)) S PURGNODE=^PS(55,PSCC,"ARC",DT,1,PLAST,0) S PURGLTH=$L(PURGNODE) I $G(PURGLTH),PURGLTH<220 S ^PS(55,PSCC,"ARC",DT,1,PLAST,0)=PURGNODE_$S($E(PURGNODE,PURGLTH)'="*":"*",1:"")_PURGEXRX G PUQUIT
S DA=PSCC,DIE=55,DR="101///"_DT,DR(2,55.13)="1///"_$G(PURGEXRX) D ^DIE K DIE
PUQUIT G PDNO
;
REF ; Refill request from CPRS
N PSORXFL,PSORFX,REFXXX,REFCOM,REFCOMXX,REFEER,REFPV1,REFPID,REFORC,RREER,RFLOOP,REFSEG,RFTYPE,REFILLER,REFVR,PSOERR,PSODUZ,PSOAUTOF
I $G(PSOFILNM),$G(PSOFILNM)'["S" S PSORXFL=PSOFILNM G REFRX
I $G(PSOFILNM) S PSORFX=+$G(PSOFILNM) D S REFXXX=1 G REFSND
.I '$D(^PS(52.41,PSORFX,0)) S (REFCOMXX,REFCOM)="Order was not located by Pharmacy." D REFERR Q
.I $G(PDFN),$G(PDFN)'=$P($G(^PS(52.41,PSORFX,0)),"^",2) S (REFCOMXX,REFCOM)="Patient does not match." D REFERR Q
.I $P($G(^PS(52.41,PSORFX,0)),"^",3)="RF" S REFCOM="Refill has already been requested." Q
.S REFCOM="Refill request not allowed on Pending order."
S (REFCOMXX,REFCOM)="Order was not located by Pharmacy." D REFERR S REFXXX=1 G REFSND
REFERR D EN^ORERR(REFCOMXX,.MSG)
Q
REFSND ; Add code here if response message is ever required
Q
REFRX ;
I $O(^PS(52.41,"ARF",PSORXFL,0)) S REFXXX=1,REFCOM="Refill request already exists." G REFSND
I '$D(^PSRX(PSORXFL,0)) S (REFCOMXX,REFCOM)="Order was not located by Pharmacy." D REFERR S REFXXX=1 G REFSND
I $G(PDFN),$G(PDFN)'=$P($G(^PSRX(PSORXFL,0)),"^",2) S (REFCOMXX,REFCOM)="Patient does not match." D REFERR S REFXXX=1 G REFSND
F RFLOOP=0:0 S RFLOOP=$O(MSG(RFLOOP)) Q:'RFLOOP S REFSEG=$G(MSG(RFLOOP)),RFTYPE=$P(REFSEG,"|")_"Z" S REFSEG=$E(REFSEG,5,$L(REFSEG)) I RFTYPE="PIDZ"!(RFTYPE="PV1Z")!(RFTYPE="ORCZ")!(RFTYPE="ZRXZ") D @RFTYPE
I '$G(PLACER) S REFXXX=1,REFCOM="Unable to process refill request." G REFSND
I $G(REFILLER),$G(REFILLER)'=$G(PSORXFL) S REFCOMXX="Filler number mismatch" D REFERR S REFXXX=1,REFCOM="Unable to process refill request." G REFSND
;
; Auto Refill, file to Prescription file #52, if key exists and at
; least one key holder and if CPRS Automated refill flag is on.
S PSOAUTOF=0
I $D(^XUSEC("PSOAUTRF")),$O(^XUSEC("PSOAUTRF",0)),$$GET1^DIQ(59.7,1,40.16,"I") D
. S PSOERR=""
. D REF^PSOATRFC(PSOFILNM,.PSOERR)
. D:$D(PSOERR)>1 MAILMSG^PSOATRFC($G(PDFN),PSOFILNM,.PSOERR)
. ; If no error msg array, then refill was filed in the Prescription
. ; file #52 so quit, Else file refill to Pending file #52.41
. S:$D(PSOERR)<2 PSOAUTOF=1
Q:PSOAUTOF
;
; Manual Refill, file to Pending Outpatient Orders file #52.41
K DD,DO S DIC="^PS(52.41,",DIC(0)="L",X=PLACER,DIC("DR")="1////"_$G(DFN)_";2////"_"RF"_";4////"_$G(ENTERED)_";5////"_$G(PROV) D FILE^DICN K DIC,DR I Y<0 S REFXXX=1,REFCOM="Unable to process refill request." G REFSND
S PENDING=+Y S $P(^PS(52.41,PENDING,0),"^",13)=$G(LOCATION),$P(^(0),"^",17)=$S($G(ROUTING)'="":$G(ROUTING),1:"W"),$P(^(0),"^",19)=$G(PSORXFL),$P(^(0),"^",20)="F",$P(^(0),"^",14)="R"
S $P(^PS(52.41,PENDING,0),"^",8)=$P($G(^PSRX(PSORXFL,"OR1")),"^"),$P(^PS(52.41,PENDING,0),"^",9)=$P($G(^PSRX(PSORXFL,0)),"^",6)
S $P(^PS(52.41,PENDING,"INI"),"^")=$G(PSINPTR) D NOW^%DTC S $P(^PS(52.41,PENDING,0),"^",12)=% K %
K DIK S DA=PENDING,DIK="^PS(52.41," D IX1^DIK K DIK
G REFSND
PIDZ ;
S DFN=+$P(REFSEG,"|",3)
Q
PV1Z ;
S LOCATION=+$P(+$P(REFSEG,"|",3),"^")
S:'$D(^SC(LOCATION,0)) LOCATION=""
S INPTRX=0 I $G(LOCATION) S PSINPTR=$P($G(^SC(LOCATION,0)),"^",4) I PSINPTR Q
I $G(LOCATION) S INPTRX=$P($G(^SC(LOCATION,0)),"^",15)
I '$G(INPTRX) S INPTRX=$O(^DG(40.8,0))
I '$G(DT) S DT=$$DT^XLFDT
S PSINPTR=+$$SITE^VASITE(DT,INPTRX)
Q
ORCZ ;
S PLACER=+$P(REFSEG,"|",2),REFILLER=+$P(REFSEG,"|",3),ENTERED=+$P(REFSEG,"|",10),PROV=+$P(REFSEG,"|",12)
Q
ZRXZ ;
S ROUTING=$P(REFSEG,"|",4)
Q
STUFF ;
S PSOVRBD=$P($G(^PS(50.7,+$G(PSORDITE),0)),"^",2)
I '$G(PSOVRBD) K PSOVRBD Q
S PSOVRB=$P($G(^PS(50.606,PSOVRBD,"MISC")),"^")
F EE=0:0 S EE=$O(^PS(52.41,PENDING,1,EE)) Q:'EE S $P(^PS(52.41,PENDING,1,EE,1),"^",10)=$$UNESC^ORHLESC($G(PSOVRB))
K PSOVRBD,PSONUNN,PSONUN,PSOVRB
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOHLNE2 8549 printed Oct 16, 2024@18:30:35 Page 2
PSOHLNE2 ;BIR/RTR-Parsing out more OERR segments ;8/13/08 2:43pm
+1 ;;7.0;OUTPATIENT PHARMACY;**1,7,59,46,225,305,391**;DEC 1997;Build 13
+2 ;External reference to DG(40.8 supported by DBIA 728
+3 ;External reference to PS(50.606 supported by DBIA 2174
+4 ;External reference to PS(50.7 supported by DBIA 2223
+5 ;External reference to PSDRUG( supported by DBIA 221
+6 ;External reference to PS(55 supported by DBIA 2228
+7 ;External reference to SC( supported by DBIA 2675
+8 ;External reference to EN^ORERR supported by DBIA 2187
+9 ;
EN ;RXO segment on new orders with multiple subscripts
+1 SET (POVAR,POVAR1)=""
SET (NNN,NNNN)=0
SET PSOIII=1
SET MSG(ZZ,0)=$EXTRACT(MSG(ZZ),5,$LENGTH(MSG(ZZ)))
+2 SET AAA=""
FOR
SET AAA=$ORDER(MSG(ZZ,AAA))
if AAA=""
QUIT
SET NNN=0
FOR OOO=1:1:$LENGTH(MSG(ZZ,AAA))
SET NNN=NNN+1
Begin DoDot:1
+3 IF $EXTRACT(MSG(ZZ,AAA),OOO)="|"
SET NNNN=NNNN+1
+4 SET POVAR1=$EXTRACT(MSG(ZZ,AAA),OOO)
+5 SET POLIM=POVAR
+6 SET POVAR=$SELECT(POVAR="":POVAR1,1:POVAR_POVAR1)
End DoDot:1
if $GET(POVAR1)="|"
DO PARSE
+7 IF $GET(POVAR)'=""
IF NNNN=13!(NNNN=12)
SET PSOREFIL=POVAR
+8 KILL MSG(ZZ,0)
+9 QUIT
PARSE ;
+1 IF NNNN=1
SET PSORDITE=$PIECE(POLIM,"^",4)
GOTO SET
+2 IF NNNN=10
SET PSODDRUG=$PIECE(POLIM,"^",4)
IF $GET(PSODDRUG)
IF ('$DATA(^PSDRUG(PSODDRUG,0)))
SET PSODDRUG=""
GOTO SET
+3 IF NNNN=10
SET DDR=1
GOTO SET
+4 IF NNNN=11
SET PSOXQTY=POLIM
GOTO SET
+5 IF NNNN=13
SET PSOREFIL=POLIM
GOTO SET
+6 IF NNNN=17
SET PSODYSPL=POLIM
SET SET (POVAR,POLIM)=""
QUIT
+1 ;
OBXX ;Parse out OBX segments
+1 SET OCOUNT=OCOUNT+1
+2 SET (POVAR,POVAR)=""
SET (NNCK,NNN,NNNN)=0
SET PSOIII=1
SET MSG(ZZ,0)=$EXTRACT(MSG(ZZ),5,$LENGTH(MSG(ZZ)))
+3 SET AAA=""
FOR
SET AAA=$ORDER(MSG(ZZ,AAA))
if AAA=""
QUIT
SET NNN=0
FOR OOO=1:1:$LENGTH(MSG(ZZ,AAA))
SET NNN=NNN+1
Begin DoDot:1
+4 IF $EXTRACT(MSG(ZZ,AAA),OOO)="|"
SET NNNN=NNNN+1
+5 SET POVAR1=$EXTRACT(MSG(ZZ,AAA),OOO)
+6 SET POLIM=POVAR
+7 SET POVAR=$SELECT(POVAR="":POVAR1,1:POVAR_POVAR1)
End DoDot:1
if $GET(POVAR1)="&"&(NNNN=4)
DO OPARSE
if $GET(POVAR1)="|"
DO OPARSE
+8 IF $GET(POVAR)'=""
IF NNNN=4!(NNNN=5)
SET NNCK=NNCK+1
SET OBXAR(OCOUNT,NNCK)=POVAR
+9 KILL MSG(ZZ,0)
+10 FOR OOO=2:1
if '$DATA(OBXAR(OCOUNT,OOO))
QUIT
SET OBXAR(OCOUNT,1)=OBXAR(OCOUNT,1)_"&"_OBXAR(OCOUNT,OOO)
KILL OBXAR(OCOUNT,OOO)
+11 QUIT
OPARSE ;
+1 IF NNNN=4
IF $GET(POVAR1)="&"
SET NNCK=NNCK+1
SET OBXAR(OCOUNT,NNCK)=$GET(POLIM)
GOTO OSET
+2 IF NNNN=5
SET NNCK=NNCK+1
SET OBXAR(OCOUNT,NNCK)=$GET(POLIM)
OSET SET (POVAR,POLIM)=""
QUIT
+1 ;
PURGE ;Purge order initiated by CPRS
+1 NEW DA,PREER,PRG,PPG,PND,PRGFLAG,PURGCOMM,PEER,PURGPV1,PURGPID,PURGORC,PURGRX,PURGPLC,PRGSTAT,PSCC,PSARC,PSCA,PSACOUNT,PURGEXRX,PLAST,PURGLTH,PURGNODE
+2 SET PSOMSORR=1
+3 SET PRGFLAG=0
+4 IF $GET(PSOFILNM)
IF $GET(PSOFILNM)'["S"
SET PURGRX=PSOFILNM
GOTO PRX
+5 SET PND=+$GET(PSOFILNM)
IF PND
Begin DoDot:1
+6 IF '$DATA(^PS(52.41,PND,0))
QUIT
+7 IF $GET(PDFN)
IF $GET(PDFN)'=$PIECE($GET(^PS(52.41,PND,0)),"^",2)
SET PURGCOMM="Patient does not match"
DO PDERR
QUIT
+8 SET PRGSTAT=$PIECE($GET(^PS(52.41,PND,0)),"^",3)
IF PRGSTAT="NW"!(PRGSTAT="RNW")!(PRGSTAT="HD")
SET PRGFLAG=1
QUIT
+9 KILL DIK
SET DA=PND
SET DIK="^PS(52.41,"
DO ^DIK
KILL DIK
QUIT
End DoDot:1
GOTO PDNO
+10 SET PURGCOMM="Order was not located by Pharmacy."
+11 DO PDERR
GOTO PDNO
PDERR DO EN^ORERR(PURGCOMM,.MSG)
+1 QUIT
PDNO FOR PEER=0:0
SET PEER=$ORDER(MSG(PEER))
if 'PEER
QUIT
if $PIECE(MSG(PEER),"|")="PV1"
SET PURGPV1=MSG(PEER)
if $PIECE(MSG(PEER),"|")="PID"
SET PURGPID=MSG(PEER)
if $PIECE(MSG(PEER),"|")="ORC"&($GET(PURGORC)="")
SET PURGORC=MSG(PEER)
+1 NEW MSG,PSOHINST
DO INIT^PSOHLSN
SET MSG(2)=$GET(PURGPID)
SET MSG(3)=$GET(PURGPV1)
SET MSG(4)="ORC|"_$SELECT($GET(PRGFLAG):"ZU",1:"ZR")_"|"_$GET(OR("PLACE"))_$SELECT($GET(PLACERXX):";"_PLACERXX,1:"")_"^OR"_"|"_$SELECT($PIECE($GET(PURGORC),"|",4)'="":$PIECE(PURGORC,"|",4),1:"")
+2 FOR PREER=11,13
IF $PIECE($GET(PURGORC),"|",PREER)'=""
SET $PIECE(MSG(4),"|",PREER)=$PIECE($GET(PURGORC),"|",PREER)
+3 SET $PIECE(MSG(4),"|",17)="^^^^"_$SELECT($GET(PRGFLAG):"Unable to Purge order.",1:"OK to Purge order.")_"^"
+4 DO SEND^PSOHLSN
PURGEX KILL PSOMSORR
QUIT
PRX ;Purge from PSRX here
+1 IF '$DATA(^PSRX(PURGRX,0))
GOTO PDNO
+2 IF $GET(PDFN)
IF $GET(PDFN)'=$PIECE($GET(^PSRX(PURGRX,0)),"^",2)
SET PURGCOMM="Patient does not match"
DO PDERR
GOTO PDNO
+3 IF '$PIECE($GET(^PSRX(PURGRX,"ARC")),"^")
SET PRGFLAG=1
GOTO PDNO
+4 ;purge from PSRX
+5 SET PURGEXRX=$PIECE(^PSRX(PURGRX,0),"^")
+6 SET PSOSUSPA=1
KILL DIK
SET DA=PURGRX
SET PSCC=$PIECE($GET(^PSRX(PURGRX,0)),"^",2)
SET DIK="^PSRX("
DO ^DIK
KILL DIK,PSOSUSPA
+7 IF $DATA(^PS(55,+$GET(PSCC),0))
SET DA(1)=PSCC
SET DIK="^PS(55,"_DA(1)_",""P"","
FOR PSCA=0:0
SET PSCA=$ORDER(^PS(55,+$GET(PSCC),"P",PSCA))
if 'PSCA
QUIT
IF ^PS(55,+$GET(PSCC),"P",PSCA,0)=PURGRX
SET DA=PSCA
DO ^DIK
KILL DA,DIK
+8 IF $DATA(^PS(52.4,PURGRX,0))
SET DA=PURGRX
SET DIK="^PS(52.4,"
DO ^DIK
KILL DA,DIK
+9 SET DA=$ORDER(^PS(52.5,"B",PURGRX,""))
IF DA
SET DIK="^PS(52.5,"
DO ^DIK
KILL DIK,DA
+10 IF '$GET(DT)
SET DT=$$DT^XLFDT
+11 IF '$GET(PSCC)
GOTO PUQUIT
+12 IF '$DATA(^PS(55,PSCC,"ARC",DT))
SET DA=PSCC
SET DIE=55
SET DR="101///"_DT
SET DR(2,55.13)="1///"_$GET(PURGEXRX)
DO ^DIE
KILL DIE
GOTO PUQUIT
+13 SET PLAST=0
FOR PSARC=0:0
SET PSARC=$ORDER(^PS(55,PSCC,"ARC",DT,1,PSARC))
if 'PSARC
QUIT
SET PLAST=PSARC
+14 IF $GET(PLAST)
IF $DATA(^PS(55,PSCC,"ARC",DT,1,PLAST,0))
SET PURGNODE=^PS(55,PSCC,"ARC",DT,1,PLAST,0)
SET PURGLTH=$LENGTH(PURGNODE)
IF $GET(PURGLTH)
IF PURGLTH<220
SET ^PS(55,PSCC,"ARC",DT,1,PLAST,0)=PURGNODE_$SELECT($EXTRACT(PURGNODE,PURGLTH)'="*":"*",1:"")_PURGEXRX
GOTO PUQUIT
+15 SET DA=PSCC
SET DIE=55
SET DR="101///"_DT
SET DR(2,55.13)="1///"_$GET(PURGEXRX)
DO ^DIE
KILL DIE
PUQUIT GOTO PDNO
+1 ;
REF ; Refill request from CPRS
+1 NEW PSORXFL,PSORFX,REFXXX,REFCOM,REFCOMXX,REFEER,REFPV1,REFPID,REFORC,RREER,RFLOOP,REFSEG,RFTYPE,REFILLER,REFVR,PSOERR,PSODUZ,PSOAUTOF
+2 IF $GET(PSOFILNM)
IF $GET(PSOFILNM)'["S"
SET PSORXFL=PSOFILNM
GOTO REFRX
+3 IF $GET(PSOFILNM)
SET PSORFX=+$GET(PSOFILNM)
Begin DoDot:1
+4 IF '$DATA(^PS(52.41,PSORFX,0))
SET (REFCOMXX,REFCOM)="Order was not located by Pharmacy."
DO REFERR
QUIT
+5 IF $GET(PDFN)
IF $GET(PDFN)'=$PIECE($GET(^PS(52.41,PSORFX,0)),"^",2)
SET (REFCOMXX,REFCOM)="Patient does not match."
DO REFERR
QUIT
+6 IF $PIECE($GET(^PS(52.41,PSORFX,0)),"^",3)="RF"
SET REFCOM="Refill has already been requested."
QUIT
+7 SET REFCOM="Refill request not allowed on Pending order."
End DoDot:1
SET REFXXX=1
GOTO REFSND
+8 SET (REFCOMXX,REFCOM)="Order was not located by Pharmacy."
DO REFERR
SET REFXXX=1
GOTO REFSND
REFERR DO EN^ORERR(REFCOMXX,.MSG)
+1 QUIT
REFSND ; Add code here if response message is ever required
+1 QUIT
REFRX ;
+1 IF $ORDER(^PS(52.41,"ARF",PSORXFL,0))
SET REFXXX=1
SET REFCOM="Refill request already exists."
GOTO REFSND
+2 IF '$DATA(^PSRX(PSORXFL,0))
SET (REFCOMXX,REFCOM)="Order was not located by Pharmacy."
DO REFERR
SET REFXXX=1
GOTO REFSND
+3 IF $GET(PDFN)
IF $GET(PDFN)'=$PIECE($GET(^PSRX(PSORXFL,0)),"^",2)
SET (REFCOMXX,REFCOM)="Patient does not match."
DO REFERR
SET REFXXX=1
GOTO REFSND
+4 FOR RFLOOP=0:0
SET RFLOOP=$ORDER(MSG(RFLOOP))
if 'RFLOOP
QUIT
SET REFSEG=$GET(MSG(RFLOOP))
SET RFTYPE=$PIECE(REFSEG,"|")_"Z"
SET REFSEG=$EXTRACT(REFSEG,5,$LENGTH(REFSEG))
IF RFTYPE="PIDZ"!(RFTYPE="PV1Z")!(RFTYPE="ORCZ")!(RFTYPE="ZRXZ")
DO @RFTYPE
+5 IF '$GET(PLACER)
SET REFXXX=1
SET REFCOM="Unable to process refill request."
GOTO REFSND
+6 IF $GET(REFILLER)
IF $GET(REFILLER)'=$GET(PSORXFL)
SET REFCOMXX="Filler number mismatch"
DO REFERR
SET REFXXX=1
SET REFCOM="Unable to process refill request."
GOTO REFSND
+7 ;
+8 ; Auto Refill, file to Prescription file #52, if key exists and at
+9 ; least one key holder and if CPRS Automated refill flag is on.
+10 SET PSOAUTOF=0
+11 IF $DATA(^XUSEC("PSOAUTRF"))
IF $ORDER(^XUSEC("PSOAUTRF",0))
IF $$GET1^DIQ(59.7,1,40.16,"I")
Begin DoDot:1
+12 SET PSOERR=""
+13 DO REF^PSOATRFC(PSOFILNM,.PSOERR)
+14 if $DATA(PSOERR)>1
DO MAILMSG^PSOATRFC($GET(PDFN),PSOFILNM,.PSOERR)
+15 ; If no error msg array, then refill was filed in the Prescription
+16 ; file #52 so quit, Else file refill to Pending file #52.41
+17 if $DATA(PSOERR)<2
SET PSOAUTOF=1
End DoDot:1
+18 if PSOAUTOF
QUIT
+19 ;
+20 ; Manual Refill, file to Pending Outpatient Orders file #52.41
+21 KILL DD,DO
SET DIC="^PS(52.41,"
SET DIC(0)="L"
SET X=PLACER
SET DIC("DR")="1////"_$GET(DFN)_";2////"_"RF"_";4////"_$GET(ENTERED)_";5////"_$GET(PROV)
DO FILE^DICN
KILL DIC,DR
IF Y<0
SET REFXXX=1
SET REFCOM="Unable to process refill request."
GOTO REFSND
+22 SET PENDING=+Y
SET $PIECE(^PS(52.41,PENDING,0),"^",13)=$GET(LOCATION)
SET $PIECE(^(0),"^",17)=$SELECT($GET(ROUTING)'="":$GET(ROUTING),1:"W")
SET $PIECE(^(0),"^",19)=$GET(PSORXFL)
SET $PIECE(^(0),"^",20)="F"
SET $PIECE(^(0),"^",14)="R"
+23 SET $PIECE(^PS(52.41,PENDING,0),"^",8)=$PIECE($GET(^PSRX(PSORXFL,"OR1")),"^")
SET $PIECE(^PS(52.41,PENDING,0),"^",9)=$PIECE($GET(^PSRX(PSORXFL,0)),"^",6)
+24 SET $PIECE(^PS(52.41,PENDING,"INI"),"^")=$GET(PSINPTR)
DO NOW^%DTC
SET $PIECE(^PS(52.41,PENDING,0),"^",12)=%
KILL %
+25 KILL DIK
SET DA=PENDING
SET DIK="^PS(52.41,"
DO IX1^DIK
KILL DIK
+26 GOTO REFSND
PIDZ ;
+1 SET DFN=+$PIECE(REFSEG,"|",3)
+2 QUIT
PV1Z ;
+1 SET LOCATION=+$PIECE(+$PIECE(REFSEG,"|",3),"^")
+2 if '$DATA(^SC(LOCATION,0))
SET LOCATION=""
+3 SET INPTRX=0
IF $GET(LOCATION)
SET PSINPTR=$PIECE($GET(^SC(LOCATION,0)),"^",4)
IF PSINPTR
QUIT
+4 IF $GET(LOCATION)
SET INPTRX=$PIECE($GET(^SC(LOCATION,0)),"^",15)
+5 IF '$GET(INPTRX)
SET INPTRX=$ORDER(^DG(40.8,0))
+6 IF '$GET(DT)
SET DT=$$DT^XLFDT
+7 SET PSINPTR=+$$SITE^VASITE(DT,INPTRX)
+8 QUIT
ORCZ ;
+1 SET PLACER=+$PIECE(REFSEG,"|",2)
SET REFILLER=+$PIECE(REFSEG,"|",3)
SET ENTERED=+$PIECE(REFSEG,"|",10)
SET PROV=+$PIECE(REFSEG,"|",12)
+2 QUIT
ZRXZ ;
+1 SET ROUTING=$PIECE(REFSEG,"|",4)
+2 QUIT
STUFF ;
+1 SET PSOVRBD=$PIECE($GET(^PS(50.7,+$GET(PSORDITE),0)),"^",2)
+2 IF '$GET(PSOVRBD)
KILL PSOVRBD
QUIT
+3 SET PSOVRB=$PIECE($GET(^PS(50.606,PSOVRBD,"MISC")),"^")
+4 FOR EE=0:0
SET EE=$ORDER(^PS(52.41,PENDING,1,EE))
if 'EE
QUIT
SET $PIECE(^PS(52.41,PENDING,1,EE,1),"^",10)=$$UNESC^ORHLESC($GET(PSOVRB))
+5 KILL PSOVRBD,PSONUNN,PSONUN,PSOVRB
+6 QUIT
