PSOHLNEW ;BIR/RTR - CPRS orders ;29-May-2012 14:50;PLS
;;7.0;OUTPATIENT PHARMACY;**1,7,15,46,71,98,111,124,117,131,146,132,1006,1009,143,223,235,148,239,249,225,1015**;DEC 1997;Build 62
;40.8-728,50-221,SC-2675,100-2219,50.7-2223,EN^ORERR-2187
;
; Modified - IHS/MSC/PLS - 10/26/07 - Added EN+31
; 07/21/10 - Added I $G(PLACER) at EN+31
; 08/06/10 - Line ZRN+4, New ZHM
EN(MSG) ;
N PSODDRUG,ENTERED,LOCATION,PLACER,PSOOC,ROUTE,NATURE,PREV,ROUTING,OO,OR,STAT,ZZ,DFN,COMM,QCOUNT,OCOUNT,Q1I,QTARRAY,QTARRAY2,EE,PP,XOFLAG,PSODYSPL,PSOFILNM
N ONEFLAG,SERV,WPCT,EFFECT,PROV,PENDING,RRX,PSOLQ1I,PSOLQ1II,PSOQWX,PSOLQ1IX,PSONVA,PSOICD,PSOSCP,EEE
N OBXAR,AA,II,SIG1,FILLER,COMM,GG,FF,JJ,JJJ,CT,LIM,VAR,VAR1,QQQ,PSRNFLAG,PSRNQFLG,RCOMM,XOFLAGZ,NWFLAG,PFLAG,PSINPTR,INPTRX,PSOIBN,PSOIBY
N DSIG,PSOCHFFL,PSOCVI,PSOMO,PSOXRP,NN,LL,LLL,WPARRAY,QTVAR,POVAR,POVAR1,ORCSEG,NNN,OOO,AAA,NNNN,POLIM,NNCK,PRIOR,IPPLACER,PLACERXX,EER,PSERRPID,PSERRPV1,PSERRORC,PSOEXFLG,PSOMSORR,PDFN,VAL
S (SEND,PSOSND,OCOUNT)=0 K PSOPLC,PSOFFL,PSORSO,PSOSUSZ
F OO=0:0 S OO=$O(MSG(OO)) Q:'OO!(SEND)!(PSOSND) D:$P(MSG(OO),"|")="PID" SPDFN I $P(MSG(OO),"|")="ORC",$P(MSG(OO),"|",2)'="NW",$P(MSG(OO),"|",2)'="XO" D
.S OR("STAT")=$P(MSG(OO),"|",2),OR("PLACE")=+$P(MSG(OO),"|",3),PLACERXX=+$P($P(MSG(OO),"|",3),";",2),OR("COMM")=$P(MSG(OO),"|",17),OR("USER")=$P(MSG(OO),"|",11) I $P(MSG(OO),"|",2)'="DE",$P(MSG(OO),"|",2)'="NA" S SEND=1 D FILL Q
.S PSOPLC=+$P(MSG(OO),"|",3),PSOFFL=+$P(MSG(OO),"|",4),PSOSND=1,PSOCHFFL=$P($P(MSG(OO),"|",4),"^")
I $G(OR("COMM"))["^" S OR("COMM")=$P(OR("COMM"),"^",5)
I PSOSND,$G(PSOCHFFL)["S",$G(OR("STAT"))="NA" D CHCS^PSOHLNE1 Q
I PSOSND,'$D(^PSRX(+$G(PSOFFL),0)) S COMM="Order was not located by Pharmacy" D EN^ORERR(COMM,.MSG) D KL Q
I PSOSND,$G(PDFN),PDFN'=+$P($G(^PSRX(+$G(PSOFFL),0)),"^",2) S COMM="Patient does not match" D EN^ORERR(COMM,.MSG) D KL Q
I PSOSND,$G(OR("STAT"))'="DE" N PSONAS S PSONAS=$S($P($G(^PSRX(PSOFFL,"OR1")),"^",2)="":1,1:0) S $P(^PSRX(PSOFFL,"OR1"),"^",2)=PSOPLC,^PSRX("APL",PSOPLC,PSOFFL)="" D:PSONAS EN^PSOHDR("PRES",PSOFFL) D KL Q
D KL
I SEND,$G(OR("STAT"))="Z@" G PURGE^PSOHLNE2
I SEND,$G(OR("STAT"))="ZF" G REF^PSOHLNE2
I SEND,$G(OR("STAT"))'="CA",$G(OR("STAT"))'="DC",$G(OR("STAT"))'="HD",$G(OR("STAT"))'="RL",$G(OR("STAT"))'="SS" S RCOMM="Invalid Order Control Code" D EN^ORERR(RCOMM,.MSG) Q
I SEND K SEND G:$G(OR("STAT"))="SS" ESTAT D EN^PSOORUTL(.OR) S PLACER=OR("PLACE"),STAT=OR("STAT"),COMM=OR("COMM") S PSOMSORR=1 D K PSOMSORR Q
.I $G(OR("FILLER"))="" D D ERROR^PSOHLSN Q
..F EER=0:0 S EER=$O(MSG(EER)) Q:'EER S:$P(MSG(EER),"|")="PV1" PSERRPV1=MSG(EER) S:$P(MSG(EER),"|")="PID" PSERRPID=MSG(EER) S:$P(MSG(EER),"|")="ORC"&($G(PSERRORC)="") PSERRORC=MSG(EER)
.I $P(OR("FILLER"),"^",2)="R" S FILLER=$P(OR("FILLER"),"^") D EN^PSOHLSN1(FILLER,STAT,$G(OR("PHARMST")),COMM) K:$G(PSOEXFLG) PSOMSORR,PLACERXX D:$G(PSOEXFLG) EN^PSOHLSN1(FILLER,"SC","ZE","") D:$G(PSOSUSZ) SUS^PSOORUT1 K PSOSUSZ Q
.D EN^PSOHLSN(PLACER,STAT,COMM) Q
D KL^PSOHLSIH S RRX=1 F ZZ=0:0 S ZZ=$O(MSG(ZZ)) Q:'ZZ S PSOSEG=$G(MSG(ZZ)),PSOTYPE=$P(PSOSEG,"|") S PSOSEG=$E(PSOSEG,5,$L(PSOSEG)) I PSOTYPE'="NTE" D @PSOTYPE
I $G(PSRNFLAG) S PSOMO=0 D MISRN^PSOHLNE1 I $G(PSOMO) Q
S PSRNQFLG=0 I $G(PSRNFLAG),$G(PREV) D I $G(PSRNQFLG) S RCOMM="Duplicate Renewal Request. Order rejected by Pharmacy." D EN^ORERR(RCOMM,.MSG) D RERROR^PSOHLSN D KL^PSOHLSIH Q
.I $P($G(^PSRX(PREV,"OR1")),"^",4) S PSRNQFLG=1 Q
.I $O(^PS(52.41,"AQ",PREV,0)) S PSRNQFLG=1
.I $G(XOFLAG),$G(DFN)'=$S($G(PFLAG):$P($G(^PS(52.41,+$G(PREV),0)),"^",2),1:$P($G(^PSRX(+$G(PREV),0)),"^",2)) S RCOMM="Patient mismatch on previous order." D EN^ORERR(RCOMM,.MSG) S XOFLAGZ=1 D RERROR^PSOHLSN D KL^PSOHLSIH Q
I $G(PLACER) I $G(DFN)'=+$P($G(^OR(100,+PLACER,0)),"^",2) G MISX^PSOHLNE1
I $G(PLACER) D NFILE
I $G(PLACER) D EN^APSPELRX(PLACER) ;IHS/MSC/PLS - 10/25/07 - ePrescribing interface
D KL^PSOHLSIH
Q
ESTAT ;
D EXP^PSOHLNE1
Q
MSH Q
PID S DFN=+$P(PSOSEG,"|",3)
Q
PV1 S LOCATION=+$P(+$P(PSOSEG,"|",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
OBR ;This segment is used to pass flagging information from CPRS.
D OBR^PSOHLNE4
Q
DG1 S $P(PSOICD($P(PSOSEG,"|",1)),"^")=$P($P(PSOSEG,"|",3),"^")
Q
ORC ;
Q:$P(PSOSEG,"|")="DE"
S:$P(PSOSEG,"|")="XO" XOFLAG=1 D ^PSOHLNE1 S:$G(PRIOR)="A" PRIOR="E" S:$G(PRIOR)="" PRIOR="R"
Q
;
RXO I $O(MSG(ZZ,0)) D ^PSOHLNE2 G RXOPS
S PSORDITE=$P($P(PSOSEG,"|"),"^",4)
S PSODDRUG=$P($P(PSOSEG,"|",10),"^",4) I $G(PSODDRUG) S:'$D(^PSDRUG(PSODDRUG,0)) PSODDRUG=""
S PSOXQTY=$P(PSOSEG,"|",11)
S PSOREFIL=$P(PSOSEG,"|",13)
S PSODYSPL=$P(PSOSEG,"|",17)
RXOPS S ONEFLAG=0,WPCT=1,LL=ZZ+1
I $P($G(MSG(LL)),"|")="NTE" D
.S ONEFLAG=1,WORDP=$S($P(MSG(LL),"|",2):$P(MSG(LL),"|",2),1:$P(MSG(LL),"|",3)) S:$P(MSG(LL),"|",4)'="" WPARRAY(WORDP,WPCT)=$P(MSG(LL),"|",4) S:$P(MSG(LL),"|",4)'="" WPCT=WPCT+1 F LLL=0:0 S LLL=$O(MSG(LL,LLL)) Q:'LLL D
..I $G(MSG(LL,LLL))'="" S WPARRAY(WORDP,WPCT)=$G(MSG(LL,LLL)),WPCT=WPCT+1
I ONEFLAG S LL=LL+1 I $P($G(MSG(LL)),"|")="NTE" D NTE^PSOHLNE1
K WORDP
Q
RXR I $P($P(PSOSEG,"|"),"^",4) S ROUTE(RRX)=$P($P(PSOSEG,"|"),"^",4) S RRX=RRX+1
Q
OBX I $O(MSG(ZZ,0)) D OBXX^PSOHLNE2 G OBXNTE
S OCOUNT=OCOUNT+1
S OBXAR(OCOUNT,1)=$P(PSOSEG,"|",5)
OBXNTE ;
D OBXNTE^PSOHLNE3
Q
ZRN S PSODSC=1_"^"_$P(PSOSEG,"|",2)
I $O(MSG(ZZ,0)) F T=0:0 S T=$O(MSG(ZZ,T)) Q:'T S PSODSC(T)=MSG(ZZ,T)
K T
;IHS/MSC/REC/PLS - 08/06/2010 - New fields for Med Rec
S MSCLD=$$HL7TFM^XLFDT($P(PSOSEG,"|",3)),MSCHMLST=$P(PSOSEG,"|",4),MSCHMLOC=$P(PSOSEG,"|",5)
Q
ZHM ;IHS/MCS/REC/PLS - 08/06/2010 - Reason field support for Med Rec
I $P(PSOSEG,"|")'="" S MSCRSN($P(PSOSEG,"|"))=$P(PSOSEG,"|",2)
Q
;
ZRX D ZRX^PSOHLNE1
Q
;
ZCL D ZCL^PSOHLNE1
Q
ZSC D CP^PSOHLNE1
Q
NFILE ;
I $G(PSODSC) D ^PSONVNEW Q ;adds non-va med to #55
;
K DD,DO,DIC S DLAYGO="52.41",DIC="^PS(52.41,",DIC(0)="L",X=PLACER,DIC("DR")="1////"_DFN_";2////"_PSOOC_";6////"_$G(EFFECT)_";12////"_$G(PSOXQTY)_";25////"_$G(PRIOR)
S DIC("DR")=DIC("DR")_";22////"_$G(PSORSO)_";22.1////"_$G(PREV)_";19////"_$G(ROUTING)_";17////"_$$UNESC^ORHLESC($G(SERV))_";7////"_$G(NATURE)_";13////"_$G(PSOREFIL)_";1.1////"_$G(LOCATION)_";117////"_$G(DSIG)
D FILE^DICN K DIC,DR I Y<0 Q
S PENDING=+Y
S $P(^PS(52.41,PENDING,0),"^",4)=$S($G(ENTERED):+$G(ENTERED),1:""),$P(^(0),"^",5)=$S($G(PROV):+$G(PROV),1:""),$P(^(0),"^",8)=$S($G(PSORDITE):+$G(PSORDITE),1:""),$P(^(0),"^",9)=$S($G(PSODDRUG):+$G(PSODDRUG),1:""),$P(^(0),"^",15)=$G(ROUTE)
S ^PS(52.41,PENDING,"IBQ")=$G(PSOIBY)
I $G(PSODYSPL)'="",$E(PSODYSPL)?1A S PSODYSPL=$E(PSODYSPL,2,$L(PSODYSPL))
S $P(^PS(52.41,PENDING,"INI"),"^")=$G(PSINPTR),$P(^(0),"^",12)=$G(PSOLOG),$P(^(0),"^",22)=$G(PSODYSPL)
I $G(QCOUNT) S ^PS(52.41,PENDING,1,0)="^52.413^"_QCOUNT_"^"_QCOUNT
S PSOQWX=$G(PSODDRUG) D:'$G(PSOQWX) OID^PSOHLNE1
F PP=0:0 S PP=$O(Q1I(PP)) Q:'PP S VAL=$S($G(PSOQWX)&($G(PSOLQ1II(PP))):Q1I(PP),$G(PSOQWX)&($G(PSOLQ1IX(PP))'="")&('$G(PSOLQ1II(PP))):PSOLQ1IX(PP),1:PSOLQ1I(PP)) S ^PS(52.41,PENDING,1,PP,0)=$$UNESC^ORHLESC(VAL)
F EE=0:0 S EE=$O(QTARRAY(EE)) Q:'EE S ^PS(52.41,PENDING,1,EE,1)=$$UNESC^ORHLESC(QTARRAY(EE)) S VAL=$S($G(PSOQWX)&($G(PSOLQ1II(EE))):$G(QTARRAY2(EE)),$G(PSOQWX)&($G(PSOLQ1IX(EE))'="")&('$G(PSOLQ1II(EE))):PSOLQ1IX(EE),1:$G(PSOLQ1I(EE))) D
.S ^PS(52.41,PENDING,1,EE,2)=$$UNESC^ORHLESC(VAL) S $P(^PS(52.41,PENDING,1,EE,1),"^",8)=+$G(ROUTE(EE))
S:$P($G(^PS(52.41,PENDING,1,1,1)),"^",3) $P(^PS(52.41,PENDING,0),"^",18)=$E($P($G(^PS(52.41,PENDING,1,1,1)),"^",3),1,7)
D STUFF^PSOHLNE2
D ^PSOHLPII
S LL=0 I $O(WPARRAY(6,0)) F LLL=0:0 S LLL=$O(WPARRAY(6,LLL)) Q:'LLL S LL=LL+1 S ^PS(52.41,PENDING,3,LL,0)=$$UNESC^ORHLESC($G(WPARRAY(6,LLL)))
I LL S ^PS(52.41,PENDING,3,0)="^52.42^"_LL_"^"_LL
S LL=0 I $O(WPARRAY(7,0)) F LLL=0:0 S LLL=$O(WPARRAY(7,LLL)) Q:'LLL S LL=LL+1 S ^PS(52.41,PENDING,"INS1",LL,0)=$$UNESC^ORHLESC($G(WPARRAY(7,LLL)))
I LL S ^PS(52.41,PENDING,"INS1",0)="^^"_LL_"^"_LL_"^"_$G(DT)_"^"
I $P($G(^PS(50.7,+$G(PSORDITE),"INS")),"^")'="" S $P(^PS(52.41,PENDING,"INS"),"^",2)=$S($O(^PS(52.41,PENDING,"INS1",0)):1,1:0)
I $G(OCOUNT) S ^PS(52.41,PENDING,"OBX",0)="^52.4118A^"_OCOUNT_"^"_OCOUNT F OCOUNT=1:1:OCOUNT D
.S ^PS(52.41,PENDING,"OBX",OCOUNT,0)=$$UNESC^ORHLESC($G(OBXAR(OCOUNT,1)))
.D USER^PSOORFI2(+$G(PROV)) S ^PS(52.41,PENDING,"OBX",OCOUNT,1)=$$UNESC^ORHLESC(USER1) K USER1
.S PSOBCT=1 F LLL=2:1 Q:'$D(OBXAR(OCOUNT,LLL)) S ^PS(52.41,PENDING,"OBX",OCOUNT,2,PSOBCT,0)=$$UNESC^ORHLESC(OBXAR(OCOUNT,LLL)),^PS(52.41,PENDING,"OBX",OCOUNT,2,0)="^^"_PSOBCT_"^"_PSOBCT_"^"_$G(DT)_"^"
D ^PSOHLPIS
K DIK S DIK="^PS(52.41,",DA=PENDING D IX^DIK
I $G(PSOOC)="RNW",$G(PREV),$D(^PSRX(+$G(PREV),0)) D EN^PSOHLSN1(PREV,"SC","ZZ","")
S PSOMSORR=1,IPPLACER=$P($G(^PS(52.41,PENDING,0)),"^") I IPPLACER D
.I '$G(XOFLAG) D EN^PSOHLSN(IPPLACER,"OK","IP") Q
.D EN^PSOHLSN(IPPLACER,"XR","IP") I $G(PFLAG) D DCP^PSOHLSN Q
.K PSOMSORR I $D(^PSRX(+$G(PREV),0)) D D EN^PSOHLSN1(PREV,"RP","","","A")
..S $P(^PSRX(PREV,"STA"),"^")=15,$P(^PSRX(PREV,3),"^",5)=DT,$P(^PSRX(PREV,3),"^",10)=$P(^PSRX(PREV,3),"^") ;;PSO*7*249
..D REVERSE^PSOBPSU1(PREV,,"DC",7),CAN^PSOTPCAN(PREV),CAN^PSOUTL(PREV)
..D CNT^PSOHLNE1
..D:$G(^PS(52.41,PENDING,1,1,0))=""&($P($G(^PS(52.41,PENDING,1,1,1)),"^")="")&($G(^PS(52.41,PENDING,"SIG",1,0))="")
...N FSIG,BSIG
...I '$P($G(^PSRX(PREV,"SIG")),"^",2),$P($G(^("SIG")),"^")'="" D
....D EN3^PSOUTLA1(PREV,70)
....I $G(BSIG(1))'="" S ^PS(52.41,PENDING,"SIG",1,0)=$$UNESC^ORHLESC($G(BSIG(1))) I $O(BSIG(1)) F EE=1:0 S EE=$O(BSIG(EE)) Q:'EE S ^PS(52.41,PENDING,"SIG",EE,0)=$$UNESC^ORHLESC($G(BSIG(EE)))
...I $P($G(^PSRX(PREV,"SIG")),"^",2),$G(^PSRX(PREV,"SIG1",1,0))'="" D
....D FSIG^PSOUTLA("R",PREV,70)
....I $G(FSIG(1))'="" S ^PS(52.41,PENDING,"SIG",1,0)=$$UNESC^ORHLESC($G(FSIG(1))) I $O(FSIG(1)) F EE=1:0 S EE=$O(FSIG(EE)) Q:'EE S ^PS(52.41,PENDING,"SIG",EE,0)=$$UNESC^ORHLESC($G(FSIG(EE)))
...F EE=0:0 S EE=$O(^PS(52.41,PENDING,"SIG",EE)) Q:'EE S ^PS(52.41,PENDING,"SIG",0)="^52.4124A^"_EE_"^"_EE
D CSET^PSODIAG
Q
SPDFN S PDFN=$P($G(MSG(OO)),"|",4) Q
KL K PSOPLC,PSOFFL,PSOSND
Q
FILL ;
S (PSOFILNM,OR("PSOFILNM"))=$P($P(MSG(OO),"|",4),"^")
Q
PSOHLNEW ;BIR/RTR - CPRS orders ;29-May-2012 14:50;PLS
+1 ;;7.0;OUTPATIENT PHARMACY;**1,7,15,46,71,98,111,124,117,131,146,132,1006,1009,143,223,235,148,239,249,225,1015**;DEC 1997;Build 62
+2 ;40.8-728,50-221,SC-2675,100-2219,50.7-2223,EN^ORERR-2187
+3 ;
+4 ; Modified - IHS/MSC/PLS - 10/26/07 - Added EN+31
+5 ; 07/21/10 - Added I $G(PLACER) at EN+31
+6 ; 08/06/10 - Line ZRN+4, New ZHM
EN(MSG) ;
+1 NEW PSODDRUG,ENTERED,LOCATION,PLACER,PSOOC,ROUTE,NATURE,PREV,ROUTING,OO,OR,STAT,ZZ,DFN,COMM,QCOUNT,OCOUNT,Q1I,QTARRAY,QTARRAY2,EE,PP,XOFLAG,PSODYSPL,PSOFILNM
+2 NEW ONEFLAG,SERV,WPCT,EFFECT,PROV,PENDING,RRX,PSOLQ1I,PSOLQ1II,PSOQWX,PSOLQ1IX,PSONVA,PSOICD,PSOSCP,EEE
+3 NEW OBXAR,AA,II,SIG1,FILLER,COMM,GG,FF,JJ,JJJ,CT,LIM,VAR,VAR1,QQQ,PSRNFLAG,PSRNQFLG,RCOMM,XOFLAGZ,NWFLAG,PFLAG,PSINPTR,INPTRX,PSOIBN,PSOIBY
+4 NEW DSIG,PSOCHFFL,PSOCVI,PSOMO,PSOXRP,NN,LL,LLL,WPARRAY,QTVAR,POVAR,POVAR1,ORCSEG,NNN,OOO,AAA,NNNN,POLIM,NNCK,PRIOR,IPPLACER,PLACERXX,EER,PSERRPID,PSERRPV1,PSERRORC,PSOEXFLG,PSOMSORR,PDFN,VAL
+5 SET (SEND,PSOSND,OCOUNT)=0
KILL PSOPLC,PSOFFL,PSORSO,PSOSUSZ
+6 FOR OO=0:0
SET OO=$ORDER(MSG(OO))
IF 'OO!(SEND)!(PSOSND)
QUIT
IF $PIECE(MSG(OO),"|")="PID"
DO SPDFN
IF $PIECE(MSG(OO),"|")="ORC"
IF $PIECE(MSG(OO),"|",2)'="NW"
IF $PIECE(MSG(OO),"|",2)'="XO"
Begin DoDot:1
+7 SET OR("STAT")=$PIECE(MSG(OO),"|",2)
SET OR("PLACE")=+$PIECE(MSG(OO),"|",3)
SET PLACERXX=+$PIECE($PIECE(MSG(OO),"|",3),";",2)
SET OR("COMM")=$PIECE(MSG(OO),"|",17)
SET OR("USER")=$PIECE(MSG(OO),"|",11)
IF $PIECE(MSG(OO),"|",2)'="DE"
IF $PIECE(MSG(OO),"|",2)'="NA"
SET SEND=1
DO FILL
QUIT
+8 SET PSOPLC=+$PIECE(MSG(OO),"|",3)
SET PSOFFL=+$PIECE(MSG(OO),"|",4)
SET PSOSND=1
SET PSOCHFFL=$PIECE($PIECE(MSG(OO),"|",4),"^")
End DoDot:1
+9 IF $GET(OR("COMM"))["^"
SET OR("COMM")=$PIECE(OR("COMM"),"^",5)
+10 IF PSOSND
IF $GET(PSOCHFFL)["S"
IF $GET(OR("STAT"))="NA"
DO CHCS^PSOHLNE1
QUIT
+11 IF PSOSND
IF '$DATA(^PSRX(+$GET(PSOFFL),0))
SET COMM="Order was not located by Pharmacy"
DO EN^ORERR(COMM,.MSG)
DO KL
QUIT
+12 IF PSOSND
IF $GET(PDFN)
IF PDFN'=+$PIECE($GET(^PSRX(+$GET(PSOFFL),0)),"^",2)
SET COMM="Patient does not match"
DO EN^ORERR(COMM,.MSG)
DO KL
QUIT
+13 IF PSOSND
IF $GET(OR("STAT"))'="DE"
NEW PSONAS
SET PSONAS=$SELECT($PIECE($GET(^PSRX(PSOFFL,"OR1")),"^",2)="":1,1:0)
SET $PIECE(^PSRX(PSOFFL,"OR1"),"^",2)=PSOPLC
SET ^PSRX("APL",PSOPLC,PSOFFL)=""
IF PSONAS
DO EN^PSOHDR("PRES",PSOFFL)
DO KL
QUIT
+14 DO KL
+15 IF SEND
IF $GET(OR("STAT"))="Z@"
GOTO PURGE^PSOHLNE2
+16 IF SEND
IF $GET(OR("STAT"))="ZF"
GOTO REF^PSOHLNE2
+17 IF SEND
IF $GET(OR("STAT"))'="CA"
IF $GET(OR("STAT"))'="DC"
IF $GET(OR("STAT"))'="HD"
IF $GET(OR("STAT"))'="RL"
IF $GET(OR("STAT"))'="SS"
SET RCOMM="Invalid Order Control Code"
DO EN^ORERR(RCOMM,.MSG)
QUIT
+18 IF SEND
KILL SEND
IF $GET(OR("STAT"))="SS"
GOTO ESTAT
DO EN^PSOORUTL(.OR)
SET PLACER=OR("PLACE")
SET STAT=OR("STAT")
SET COMM=OR("COMM")
SET PSOMSORR=1
Begin DoDot:1
+19 IF $GET(OR("FILLER"))=""
Begin DoDot:2
+20 FOR EER=0:0
SET EER=$ORDER(MSG(EER))
IF 'EER
QUIT
IF $PIECE(MSG(EER),"|")="PV1"
SET PSERRPV1=MSG(EER)
IF $PIECE(MSG(EER),"|")="PID"
SET PSERRPID=MSG(EER)
IF $PIECE(MSG(EER),"|")="ORC"&($GET(PSERRORC)="")
SET PSERRORC=MSG(EER)
End DoDot:2
DO ERROR^PSOHLSN
QUIT
+21 IF $PIECE(OR("FILLER"),"^",2)="R"
SET FILLER=$PIECE(OR("FILLER"),"^")
DO EN^PSOHLSN1(FILLER,STAT,$GET(OR("PHARMST")),COMM)
IF $GET(PSOEXFLG)
KILL PSOMSORR,PLACERXX
IF $GET(PSOEXFLG)
DO EN^PSOHLSN1(FILLER,"SC","ZE","")
IF $GET(PSOSUSZ)
DO SUS^PSOORUT1
KILL PSOSUSZ
QUIT
+22 DO EN^PSOHLSN(PLACER,STAT,COMM)
QUIT
End DoDot:1
KILL PSOMSORR
QUIT
+23 DO KL^PSOHLSIH
SET RRX=1
FOR ZZ=0:0
SET ZZ=$ORDER(MSG(ZZ))
IF 'ZZ
QUIT
SET PSOSEG=$GET(MSG(ZZ))
SET PSOTYPE=$PIECE(PSOSEG,"|")
SET PSOSEG=$EXTRACT(PSOSEG,5,$LENGTH(PSOSEG))
IF PSOTYPE'="NTE"
DO @PSOTYPE
+24 IF $GET(PSRNFLAG)
SET PSOMO=0
DO MISRN^PSOHLNE1
IF $GET(PSOMO)
QUIT
+25 SET PSRNQFLG=0
IF $GET(PSRNFLAG)
IF $GET(PREV)
Begin DoDot:1
+26 IF $PIECE($GET(^PSRX(PREV,"OR1")),"^",4)
SET PSRNQFLG=1
QUIT
+27 IF $ORDER(^PS(52.41,"AQ",PREV,0))
SET PSRNQFLG=1
+28 IF $GET(XOFLAG)
IF $GET(DFN)'=$SELECT($GET(PFLAG):$PIECE($GET(^PS(52.41,+$GET(PREV),0)),"^",2),1:$PIECE($GET(^PSRX(+$GET(PREV),0)),"^",2))
SET RCOMM="Patient mismatch on previous order."
DO EN^ORERR(RCOMM,.MSG)
SET XOFLAGZ=1
DO RERROR^PSOHLSN
DO KL^PSOHLSIH
QUIT
End DoDot:1
IF $GET(PSRNQFLG)
SET RCOMM="Duplicate Renewal Request. Order rejected by Pharmacy."
DO EN^ORERR(RCOMM,.MSG)
DO RERROR^PSOHLSN
DO KL^PSOHLSIH
QUIT
+29 IF $GET(PLACER)
IF $GET(DFN)'=+$PIECE($GET(^OR(100,+PLACER,0)),"^",2)
GOTO MISX^PSOHLNE1
+30 IF $GET(PLACER)
DO NFILE
+31 ;IHS/MSC/PLS - 10/25/07 - ePrescribing interface
IF $GET(PLACER)
DO EN^APSPELRX(PLACER)
+32 DO KL^PSOHLSIH
+33 QUIT
ESTAT ;
+1 DO EXP^PSOHLNE1
+2 QUIT
MSH QUIT
PID SET DFN=+$PIECE(PSOSEG,"|",3)
+1 QUIT
PV1 SET LOCATION=+$PIECE(+$PIECE(PSOSEG,"|",3),"^")
+1 IF '$DATA(^SC(LOCATION,0))
SET LOCATION=""
+2 SET INPTRX=0
IF $GET(LOCATION)
SET PSINPTR=$PIECE($GET(^SC(LOCATION,0)),"^",4)
IF PSINPTR
QUIT
+3 IF $GET(LOCATION)
SET INPTRX=$PIECE($GET(^SC(LOCATION,0)),"^",15)
+4 IF '$GET(INPTRX)
SET INPTRX=$ORDER(^DG(40.8,0))
+5 IF '$GET(DT)
SET DT=$$DT^XLFDT
+6 SET PSINPTR=+$$SITE^VASITE(DT,INPTRX)
+7 QUIT
OBR ;This segment is used to pass flagging information from CPRS.
+1 DO OBR^PSOHLNE4
+2 QUIT
DG1 SET $PIECE(PSOICD($PIECE(PSOSEG,"|",1)),"^")=$PIECE($PIECE(PSOSEG,"|",3),"^")
+1 QUIT
ORC ;
+1 IF $PIECE(PSOSEG,"|")="DE"
QUIT
+2 IF $PIECE(PSOSEG,"|")="XO"
SET XOFLAG=1
DO ^PSOHLNE1
IF $GET(PRIOR)="A"
SET PRIOR="E"
IF $GET(PRIOR)=""
SET PRIOR="R"
+3 QUIT
+4 ;
RXO IF $ORDER(MSG(ZZ,0))
DO ^PSOHLNE2
GOTO RXOPS
+1 SET PSORDITE=$PIECE($PIECE(PSOSEG,"|"),"^",4)
+2 SET PSODDRUG=$PIECE($PIECE(PSOSEG,"|",10),"^",4)
IF $GET(PSODDRUG)
IF '$DATA(^PSDRUG(PSODDRUG,0))
SET PSODDRUG=""
+3 SET PSOXQTY=$PIECE(PSOSEG,"|",11)
+4 SET PSOREFIL=$PIECE(PSOSEG,"|",13)
+5 SET PSODYSPL=$PIECE(PSOSEG,"|",17)
RXOPS SET ONEFLAG=0
SET WPCT=1
SET LL=ZZ+1
+1 IF $PIECE($GET(MSG(LL)),"|")="NTE"
Begin DoDot:1
+2 SET ONEFLAG=1
SET WORDP=$SELECT($PIECE(MSG(LL),"|",2):$PIECE(MSG(LL),"|",2),1:$PIECE(MSG(LL),"|",3))
IF $PIECE(MSG(LL),"|",4)'=""
SET WPARRAY(WORDP,WPCT)=$PIECE(MSG(LL),"|",4)
IF $PIECE(MSG(LL),"|",4)'=""
SET WPCT=WPCT+1
FOR LLL=0:0
SET LLL=$ORDER(MSG(LL,LLL))
IF 'LLL
QUIT
Begin DoDot:2
+3 IF $GET(MSG(LL,LLL))'=""
SET WPARRAY(WORDP,WPCT)=$GET(MSG(LL,LLL))
SET WPCT=WPCT+1
End DoDot:2
End DoDot:1
+4 IF ONEFLAG
SET LL=LL+1
IF $PIECE($GET(MSG(LL)),"|")="NTE"
DO NTE^PSOHLNE1
+5 KILL WORDP
+6 QUIT
RXR IF $PIECE($PIECE(PSOSEG,"|"),"^",4)
SET ROUTE(RRX)=$PIECE($PIECE(PSOSEG,"|"),"^",4)
SET RRX=RRX+1
+1 QUIT
OBX IF $ORDER(MSG(ZZ,0))
DO OBXX^PSOHLNE2
GOTO OBXNTE
+1 SET OCOUNT=OCOUNT+1
+2 SET OBXAR(OCOUNT,1)=$PIECE(PSOSEG,"|",5)
OBXNTE ;
+1 DO OBXNTE^PSOHLNE3
+2 QUIT
ZRN SET PSODSC=1_"^"_$PIECE(PSOSEG,"|",2)
+1 IF $ORDER(MSG(ZZ,0))
FOR T=0:0
SET T=$ORDER(MSG(ZZ,T))
IF 'T
QUIT
SET PSODSC(T)=MSG(ZZ,T)
+2 KILL T
+3 ;IHS/MSC/REC/PLS - 08/06/2010 - New fields for Med Rec
+4 SET MSCLD=$$HL7TFM^XLFDT($PIECE(PSOSEG,"|",3))
SET MSCHMLST=$PIECE(PSOSEG,"|",4)
SET MSCHMLOC=$PIECE(PSOSEG,"|",5)
+5 QUIT
ZHM ;IHS/MCS/REC/PLS - 08/06/2010 - Reason field support for Med Rec
+1 IF $PIECE(PSOSEG,"|")'=""
SET MSCRSN($PIECE(PSOSEG,"|"))=$PIECE(PSOSEG,"|",2)
+2 QUIT
+3 ;
ZRX DO ZRX^PSOHLNE1
+1 QUIT
+2 ;
ZCL DO ZCL^PSOHLNE1
+1 QUIT
ZSC DO CP^PSOHLNE1
+1 QUIT
NFILE ;
+1 ;adds non-va med to #55
IF $GET(PSODSC)
DO ^PSONVNEW
QUIT
+2 ;
+3 KILL DD,DO,DIC
SET DLAYGO="52.41"
SET DIC="^PS(52.41,"
SET DIC(0)="L"
SET X=PLACER
SET DIC("DR")="1////"_DFN_";2////"_PSOOC_";6////"_$GET(EFFECT)_";12////"_$GET(PSOXQTY)_";25////"_$GET(PRIOR)
+4 SET DIC("DR")=DIC("DR")_";22////"_$GET(PSORSO)_";22.1////"_$GET(PREV)_";19////"_$GET(ROUTING)_";17////"_$$UNESC^ORHLESC($GET(SERV))_";7////"_$GET(NATURE)_";13////"_$GET(PSOREFIL)_";1.1////"_$GET(LOCATION)_";117////"_$GET(DSIG)
+5 DO FILE^DICN
KILL DIC,DR
IF Y<0
QUIT
+6 SET PENDING=+Y
+7 SET $PIECE(^PS(52.41,PENDING,0),"^",4)=$SELECT($GET(ENTERED):+$GET(ENTERED),1:"")
SET $PIECE(^(0),"^",5)=$SELECT($GET(PROV):+$GET(PROV),1:"")
SET $PIECE(^(0),"^",8)=$SELECT($GET(PSORDITE):+$GET(PSORDITE),1:"")
SET $PIECE(^(0),"^",9)=$SELECT($GET(PSODDRUG):+$GET(PSODDRUG),1:"")
SET $PIECE(^(0),"^",15)=$GET(ROUTE)
+8 SET ^PS(52.41,PENDING,"IBQ")=$GET(PSOIBY)
+9 IF $GET(PSODYSPL)'=""
IF $EXTRACT(PSODYSPL)?1A
SET PSODYSPL=$EXTRACT(PSODYSPL,2,$LENGTH(PSODYSPL))
+10 SET $PIECE(^PS(52.41,PENDING,"INI"),"^")=$GET(PSINPTR)
SET $PIECE(^(0),"^",12)=$GET(PSOLOG)
SET $PIECE(^(0),"^",22)=$GET(PSODYSPL)
+11 IF $GET(QCOUNT)
SET ^PS(52.41,PENDING,1,0)="^52.413^"_QCOUNT_"^"_QCOUNT
+12 SET PSOQWX=$GET(PSODDRUG)
IF '$GET(PSOQWX)
DO OID^PSOHLNE1
+13 FOR PP=0:0
SET PP=$ORDER(Q1I(PP))
IF 'PP
QUIT
SET VAL=$SELECT($GET(PSOQWX)&($GET(PSOLQ1II(PP))):Q1I(PP),$GET(PSOQWX)&($GET(PSOLQ1IX(PP))'="")&('$GET(PSOLQ1II(PP))):PSOLQ1IX(PP),1:PSOLQ1I(PP))
SET ^PS(52.41,PENDING,1,PP,0)=$$UNESC^ORHLESC(VAL)
+14 FOR EE=0:0
SET EE=$ORDER(QTARRAY(EE))
IF 'EE
QUIT
SET ^PS(52.41,PENDING,1,EE,1)=$$UNESC^ORHLESC(QTARRAY(EE))
SET VAL=$SELECT($GET(PSOQWX)&($GET(PSOLQ1II(EE))):$GET(QTARRAY2(EE)),$GET(PSOQWX)&($GET(PSOLQ1IX(EE))'="")&('$GET(PSOLQ1II(EE))):PSOLQ1IX(EE),1:$GET(PSOLQ1I(EE)))
Begin DoDot:1
+15 SET ^PS(52.41,PENDING,1,EE,2)=$$UNESC^ORHLESC(VAL)
SET $PIECE(^PS(52.41,PENDING,1,EE,1),"^",8)=+$GET(ROUTE(EE))
End DoDot:1
+16 IF $PIECE($GET(^PS(52.41,PENDING,1,1,1)),"^",3)
SET $PIECE(^PS(52.41,PENDING,0),"^",18)=$EXTRACT($PIECE($GET(^PS(52.41,PENDING,1,1,1)),"^",3),1,7)
+17 DO STUFF^PSOHLNE2
+18 DO ^PSOHLPII
+19 SET LL=0
IF $ORDER(WPARRAY(6,0))
FOR LLL=0:0
SET LLL=$ORDER(WPARRAY(6,LLL))
IF 'LLL
QUIT
SET LL=LL+1
SET ^PS(52.41,PENDING,3,LL,0)=$$UNESC^ORHLESC($GET(WPARRAY(6,LLL)))
+20 IF LL
SET ^PS(52.41,PENDING,3,0)="^52.42^"_LL_"^"_LL
+21 SET LL=0
IF $ORDER(WPARRAY(7,0))
FOR LLL=0:0
SET LLL=$ORDER(WPARRAY(7,LLL))
IF 'LLL
QUIT
SET LL=LL+1
SET ^PS(52.41,PENDING,"INS1",LL,0)=$$UNESC^ORHLESC($GET(WPARRAY(7,LLL)))
+22 IF LL
SET ^PS(52.41,PENDING,"INS1",0)="^^"_LL_"^"_LL_"^"_$GET(DT)_"^"
+23 IF $PIECE($GET(^PS(50.7,+$GET(PSORDITE),"INS")),"^")'=""
SET $PIECE(^PS(52.41,PENDING,"INS"),"^",2)=$SELECT($ORDER(^PS(52.41,PENDING,"INS1",0)):1,1:0)
+24 IF $GET(OCOUNT)
SET ^PS(52.41,PENDING,"OBX",0)="^52.4118A^"_OCOUNT_"^"_OCOUNT
FOR OCOUNT=1:1:OCOUNT
Begin DoDot:1
+25 SET ^PS(52.41,PENDING,"OBX",OCOUNT,0)=$$UNESC^ORHLESC($GET(OBXAR(OCOUNT,1)))
+26 DO USER^PSOORFI2(+$GET(PROV))
SET ^PS(52.41,PENDING,"OBX",OCOUNT,1)=$$UNESC^ORHLESC(USER1)
KILL USER1
+27 SET PSOBCT=1
FOR LLL=2:1
IF '$DATA(OBXAR(OCOUNT,LLL))
QUIT
SET ^PS(52.41,PENDING,"OBX",OCOUNT,2,PSOBCT,0)=$$UNESC^ORHLESC(OBXAR(OCOUNT,LLL))
SET ^PS(52.41,PENDING,"OBX",OCOUNT,2,0)="^^"_PSOBCT_"^"_PSOBCT_"^"_$GET(DT)_"^"
End DoDot:1
+28 DO ^PSOHLPIS
+29 KILL DIK
SET DIK="^PS(52.41,"
SET DA=PENDING
DO IX^DIK
+30 IF $GET(PSOOC)="RNW"
IF $GET(PREV)
IF $DATA(^PSRX(+$GET(PREV),0))
DO EN^PSOHLSN1(PREV,"SC","ZZ","")
+31 SET PSOMSORR=1
SET IPPLACER=$PIECE($GET(^PS(52.41,PENDING,0)),"^")
IF IPPLACER
Begin DoDot:1
+32 IF '$GET(XOFLAG)
DO EN^PSOHLSN(IPPLACER,"OK","IP")
QUIT
+33 DO EN^PSOHLSN(IPPLACER,"XR","IP")
IF $GET(PFLAG)
DO DCP^PSOHLSN
QUIT
+34 KILL PSOMSORR
IF $DATA(^PSRX(+$GET(PREV),0))
Begin DoDot:2
+35 ;;PSO*7*249
SET $PIECE(^PSRX(PREV,"STA"),"^")=15
SET $PIECE(^PSRX(PREV,3),"^",5)=DT
SET $PIECE(^PSRX(PREV,3),"^",10)=$PIECE(^PSRX(PREV,3),"^")
+36 DO REVERSE^PSOBPSU1(PREV,,"DC",7)
DO CAN^PSOTPCAN(PREV)
DO CAN^PSOUTL(PREV)
+37 DO CNT^PSOHLNE1
+38 IF $GET(^PS(52.41,PENDING,1,1,0))=""&($PIECE($GET(^PS(52.41,PENDING,1,1,1)),"^")="")&($GET(^PS(52.41,PENDING,"SIG",1,0))="")
Begin DoDot:3
+39 NEW FSIG,BSIG
+40 IF '$PIECE($GET(^PSRX(PREV,"SIG")),"^",2)
IF $PIECE($GET(^("SIG")),"^")'=""
Begin DoDot:4
+41 DO EN3^PSOUTLA1(PREV,70)
+42 IF $GET(BSIG(1))'=""
SET ^PS(52.41,PENDING,"SIG",1,0)=$$UNESC^ORHLESC($GET(BSIG(1)))
IF $ORDER(BSIG(1))
FOR EE=1:0
SET EE=$ORDER(BSIG(EE))
IF 'EE
QUIT
SET ^PS(52.41,PENDING,"SIG",EE,0)=$$UNESC^ORHLESC($GET(BSIG(EE)))
End DoDot:4
+43 IF $PIECE($GET(^PSRX(PREV,"SIG")),"^",2)
IF $GET(^PSRX(PREV,"SIG1",1,0))'=""
Begin DoDot:4
+44 DO FSIG^PSOUTLA("R",PREV,70)
+45 IF $GET(FSIG(1))'=""
SET ^PS(52.41,PENDING,"SIG",1,0)=$$UNESC^ORHLESC($GET(FSIG(1)))
IF $ORDER(FSIG(1))
FOR EE=1:0
SET EE=$ORDER(FSIG(EE))
IF 'EE
QUIT
SET ^PS(52.41,PENDING,"SIG",EE,0)=$$UNESC^ORHLESC($GET(FSIG(EE)))
End DoDot:4
+46 FOR EE=0:0
SET EE=$ORDER(^PS(52.41,PENDING,"SIG",EE))
IF 'EE
QUIT
SET ^PS(52.41,PENDING,"SIG",0)="^52.4124A^"_EE_"^"_EE
End DoDot:3
End DoDot:2
DO EN^PSOHLSN1(PREV,"RP","","","A")
End DoDot:1
+47 DO CSET^PSODIAG
+48 QUIT
SPDFN SET PDFN=$PIECE($GET(MSG(OO)),"|",4)
QUIT
KL KILL PSOPLC,PSOFFL,PSOSND
+1 QUIT
FILL ;
+1 SET (PSOFILNM,OR("PSOFILNM"))=$PIECE($PIECE(MSG(OO),"|",4),"^")
+2 QUIT
