PSOHLNE1 ;BIR/RTR-Parsing out segments from OERR ;Dec 31, 2019@13:34:16
;;7.0;OUTPATIENT PHARMACY;**1,9,46,71,98,111,117,131,157,181,143,235,239,225,391,441**;DEC 1997;Build 208
;External reference to EN^ORERR supported by DBIA 2187
;External reference to PS(50.607 supported by DBIA 2221
;External reference to OR(100 supported by DBIA 2219
;External reference to PSDRUG( supported by DBIA 221
;External reference VADPT supported by DBIA 10061
;
EN ;ORC segment
N Q1,Q2,Q3,Q4,Q5,Q6,Q7,PSOPOSSD
K PSOLQ1I,PSOLQ1II,PSOLQ1IX
I '$O(MSG(ZZ,0)) D
.S PSOOC="NW",PLACER=+$P(PSOSEG,"|",2),PLACERXX=+$P($P(PSOSEG,"|",2),";",2),ENTERED=$P(PSOSEG,"|",10),PROV=$P(PSOSEG,"|",12)
.S X=$P(PSOSEG,"|",15) S EFFECT=$$HL7TFM^XLFDT(X) K X
.D NOW^%DTC S PSOLOG=% K %
.;S RSN=$P(PSOSEG,"|",16)
.S ORCSEG=$P(PSOSEG,"|",7),QCOUNT=1 Q:$G(ORCSEG)'["~"
.F JJ=1:1:$L(ORCSEG) S:$E(ORCSEG,JJ)="~" QCOUNT=QCOUNT+1
I '$O(MSG(ZZ,0)) D Q
.F JJJ=1:1:QCOUNT S QQQ=$P(ORCSEG,"~",JJJ) D:QQQ'=""
..S PSOPOSSD=$S($P($P(QQQ,"^"),"&"):1,1:0) ;PSOPOSSD=1 if possible dose
..S Q9(JJJ)=$P(QQQ,"^")
..S Q1I(JJJ)=$S(PSOPOSSD:$P(QQQ,"^"),1:$P(QQQ,"^",8)),PSOLQ1IX(JJJ)=$P($P(QQQ,"^"),"&",5) S PSOLQ1I(JJJ)=$P(QQQ,"^",8),PSOLQ1II(JJJ)=PSOPOSSD ;ORC piece 1 if Possible Dosage, ORC piece 8 if Local Possible Dosage
..S Q1(JJJ)=$P(QQQ,"^",2) ;schedule
..S Q2(JJJ)=$P(QQQ,"^",3) ;duration
..S Q3(JJJ)=$P(QQQ,"^",4) I Q3(JJJ) S X=Q3(JJJ) S Q3(JJJ)=$$HL7TFM^XLFDT(X) K X ;start date
..S Q4(JJJ)=$P(QQQ,"^",5) ;end date
..S:$G(PRIOR)="" PRIOR=$P(QQQ,"^",6)
..S Q6(JJJ)=$P(QQQ,"^",9) ;conjunction
..S Q7(JJJ)=$P(QQQ,"^",10) ;sequencing
..S QTARRAY(JJJ)=Q1(JJJ)_"^"_Q2(JJJ)_"^"_Q3(JJJ)_"^"_Q4(JJJ)_"^^"_Q6(JJJ)_"^"_Q7(JJJ)
..S QTARRAY2(JJJ)=$S(PSOPOSSD:$P(Q1I(JJJ),"&"),1:Q1I(JJJ))_"^"_$S(PSOPOSSD:$P(Q1I(JJJ),"&",3),1:"")
..I PSOPOSSD S $P(QTARRAY(JJJ),"^",5)=$P(Q1I(JJJ),"&",4)
..I PSOPOSSD S PSOUNN=$P(Q1I(JJJ),"&",2) I PSOUNN'="" S PSOUNN=$O(^PS(50.607,"B",PSOUNN,0)) S $P(QTARRAY(JJJ),"^",9)=$G(PSOUNN)
..K PSOUNN
;For multiple ORC subscripts
S (POVAR,POVAR1)="",(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=6) PARSE 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 NNNN=6 I $G(POVAR1)="~"!($G(POVAR1)="|")
END ;16 OF ORC?
;I $G(POVAR)'="" I NNNN=14!(NNNN=15) S EFFECT=$G(POVAR)
S QCOUNT=0 F JJJ=0:0 S JJJ=$O(QTVAR(JJJ)) Q:'JJJ I $L($G(QTVAR(JJJ))) S QCOUNT=QCOUNT+1 D
.S PSOPOSSD=$S($P($P(QTVAR(JJJ),"^"),"&"):1,1:0) ;PSOPOSSD =1 if possible dose
.S Q1I(JJJ)=$S(PSOPOSSD:$P(QTVAR(JJJ),"^"),1:$P(QTVAR(JJJ),"^",8)),PSOLQ1IX(JJJ)=$P($P(QTVAR(JJJ),"^"),"&",5) S PSOLQ1I(JJJ)=$P(QTVAR(JJJ),"^",8),PSOLQ1II(JJJ)=PSOPOSSD ;piece 1 if possible dose, piece 8 if not
.S Q9(JJJ)=$P(QTVAR(JJJ),"^")
.S Q1(JJJ)=$P(QTVAR(JJJ),"^",2)
.S Q2(JJJ)=$P(QTVAR(JJJ),"^",3)
.;S Q2(JJJ)=$S($E($P(QTVAR(JJJ),"^",3)):"D"_$P(QTVAR(JJJ),"^",3),$E($P(QTVAR(JJJ),"^",3))=0:"D"_$P(QTVAR(JJJ),"^",3),1:$P(QTVAR(JJJ),"^",3))
.S Q3(JJJ)=$P(QTVAR(JJJ),"^",4) I Q3(JJJ) S X=Q3(JJJ) S Q3(JJJ)=$$HL7TFM^XLFDT(X) K X
.S Q4(JJJ)=$P(QTVAR(JJJ),"^",5)
.S:$G(PRIOR)="" PRIOR=$P(QTVAR(JJJ),"^",6)
.S Q6(JJJ)=$P(QTVAR(JJJ),"^",9)
.S Q7(JJJ)=$P(QTVAR(JJJ),"^",10)
.S QTARRAY(JJJ)=Q1(JJJ)_"^"_Q2(JJJ)_"^"_Q3(JJJ)_"^"_Q4(JJJ)_"^^"_Q6(JJJ)_"^"_Q7(JJJ)
.S QTARRAY2(JJJ)=$S(PSOPOSSD:$P(Q1I(JJJ),"&"),1:Q1I(JJJ))_"^"_$S(PSOPOSSD:$P(Q1I(JJJ),"&",3),1:"")
.I PSOPOSSD S $P(QTARRAY(JJJ),"^",5)=$P(Q1I(JJJ),"&",4)
.I PSOPOSSD S PSOUNN=$P(Q1I(JJJ),"&",2) I PSOUNN'="" S PSOUNN=$O(^PS(50.607,"B",PSOUNN,0)) S $P(QTARRAY(JJJ),"^",9)=$G(PSOUNN)
.K PSOUNN
I $G(EFFECT) S X=EFFECT S EFFECT=$$HL7TFM^XLFDT(X) K X
D NOW^%DTC S PSOLOG=% S:'$G(EFFECT) EFFECT=% K %
K MSG(ZZ,0)
Q
PARSE I NNNN=1 S PSOOC="NW" G SET
I NNNN=2 S PLACER=+$G(POLIM),PLACERXX=+$P($G(POLIM),";",2) G SET
I NNNN=3!(NNNN=4)!(NNNN=5) G SET
I NNNN=6,$G(POVAR1)="~" S NNCK=NNCK+1,QTVAR(NNCK)=$G(POLIM) G SET
I NNNN=7 S NNCK=NNCK+1 S QTVAR(NNCK)=$G(POLIM) G SET
I NNNN=8!(NNNN=9) G SET
I NNNN=10 S ENTERED=$G(POLIM) G SET
I NNNN=11 G SET
I NNNN=12 S PROV=$G(POLIM) G SET
I NNNN=13!(NNNN=14) G SET
I NNNN=15 S EFFECT=$G(POLIM)
SET S (POVAR,POLIM)="" Q
;
EXP ;
;Q:'$G(OR("PLACE"))
Q:'$G(PSOFILNM)
S PSOMSORR=1
N PSOSSMES S PSOSSMES="CPRSUP"
I $G(PSOFILNM),$G(PSOFILNM)["S" S LL=+$G(PSOFILNM) I $D(^PS(52.41,LL,0)),$P($G(^(0)),"^",3)'="RF" G EXPEN
S LL=$G(PSOFILNM) I 'LL!('$D(^PSRX(+$G(LL),0))) S COMM="Order was not located by Pharmacy" D EN^ORERR(COMM,.MSG) D G EXPQ
.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)
.N MSG,PSOHINST D INIT^PSOHLSN S MSG(2)=$G(PSERRPID),MSG(3)=$G(PSERRPV1),MSG(4)="ORC|DE|"_$G(OR("PLACE"))_$S($G(PLACERXX):";"_PLACERXX,1:"")_"^OR"_"|"_$S($P($G(PSERRORC),"|",4)'="":$P(PSERRORC,"|",4),1:"") S:$G(COMM)'="" MSG(5)="NTE|16||"_COMM
.D SEND^PSOHLSN
Q:'$D(^PSRX(LL,0))
I +$P($G(^PSRX(LL,2)),"^",6)<DT D
.;Reset PSOSSMES if status changes, so HDR gets updated in PSOHLSN1
.I +$P($G(^PSRX(LL,"STA")),"^")<12!($P($G(^("STA")),"^")=16) S $P(^PSRX(LL,"STA"),"^")=11 D ECAN^PSOUTL(LL) S PSOSSMES="CPRSVDEF"
S GG=+$P($G(^PSRX(LL,"STA")),"^")
;S AA=$S(GG=3:"OH",GG=12:"OD",GG=13:"OC",GG=14:"OD",GG=15:"OD",GG=16:"OH",1:"SC"),AAA=$S(GG=0:"CM",GG=1:"IP",GG=4:"IP",GG=5:"ZS",GG=11:"ZE",1:"")
S AA="SC",AAA=$S(GG=0:"CM",GG=2:"CM",GG=1:"IP",GG=4:"IP",GG=5:"ZS",GG=3:"HD",GG=16:"HD",GG=11:"ZE",1:"DC")
D EN^PSOHLSN1(LL,AA,AAA,"")
K PSOSSMES
EXPQ K LL,GG,AA,AAA,PSOMSORR Q
EXPEN ;SS on Pending orders
S AA=$P($G(^PS(52.41,LL,0)),"^",3)
S AAA=$S(AA="DC"!(AA="DE"):"DC",AA="HD":"HD",1:"IP")
D EN^PSOHLSN(OR("PLACE"),"SC",AAA)
G EXPQ
;
OID ;Check for 1 to 1 match from Dispense Drug to Orderable Item
N PSOCDD,PSOCDDI,PSOCDDIZ
Q:'$G(PSORDITE)
K PSOCDDIZ
S (PSOCDD,PSOCDDI)=0
F S PSOCDD=$O(^PSDRUG("ASP",PSORDITE,PSOCDD)) Q:'PSOCDD I $S('$P($G(^PSDRUG(PSOCDD,"I")),"^"):1,DT'>$P($G(^("I")),"^"):1,1:0),$P($G(^PSDRUG(PSOCDD,2)),"^",3)["O" S PSOCDDI=PSOCDDI+1,PSOCDDIZ=PSOCDD
I PSOCDDI'=1 Q
S PSOQWX=$G(PSOCDDIZ)
Q
CP ;ZSC segment (replaced by ZCL segment)
S SERV=$S($P(PSOSEG,"|")=1:"SC",$P(PSOSEG,"|")=0:"NSC",1:$P(PSOSEG,"|"))
S PSOIBY=$P(PSOSEG,"|",2)_"^"_$P(PSOSEG,"|",3)_"^"_$P(PSOSEG,"|",4)_"^"_$P(PSOSEG,"|",5)_"^"_$P(PSOSEG,"|",6)_"^"_$P(PSOSEG,"|",7)_"^"_$P(PSOSEG,"|",8)
Q
;
ZCL ;ZCL segment - SC/EI related to ICDs
N SEQ,SEQ2,SEQ3 S SEQ3=$P(PSOSEG,"|",2),SEQ2=$P(PSOSEG,"|",1)
S:'$D(PSOICD(SEQ2)) PSOICD(SEQ2)=""
S $P(PSOICD(SEQ2),"^",(SEQ3+1))=$P(PSOSEG,"|",3) ;set sc/ei for ICD node
D SCP^PSORN52D K PSOSCA
S:'$D(PSOIBY) PSOIBY=""
I PSOSCP<50 D ;set IBQ node variables if <50% SC
. Q:$P(PSOIBY,U,$S(SEQ3=1:2,SEQ3=2:3,SEQ3=4:4,SEQ3=5:1,SEQ3=6:5,SEQ3=7:6,SEQ3=8:7,1:""))>0
. S:SEQ3=1 $P(PSOIBY,U,2)=$P(PSOSEG,"|",3) ;AO
. S:SEQ3=2 $P(PSOIBY,U,3)=$P(PSOSEG,"|",3) ;IR
. S:SEQ3=3 SERV=$S($P(PSOSEG,"|",3)=1:"SC",$P(PSOSEG,"|",3)=0:"NSC",1:$P(PSOSEG,"|",3)) ;SC
. S:SEQ3=4 $P(PSOIBY,U,4)=$P(PSOSEG,"|",3) ;EC
. S:SEQ3=5 $P(PSOIBY,U,1)=$P(PSOSEG,"|",3) ;MST
. S:SEQ3=6 $P(PSOIBY,U,5)=$P(PSOSEG,"|",3) ;HNC
. S:SEQ3=7 $P(PSOIBY,U,6)=$P(PSOSEG,"|",3) ;CV
. S:SEQ3=8 $P(PSOIBY,U,7)=$P(PSOSEG,"|",3) ;SHAD
Q
MISX ;Mismatch patient on CPRS New Order
S RCOMM="Patient mismatch on New Order from CPRS." D EN^ORERR(RCOMM,.MSG) S NWFLAG=1 D RERROR^PSOHLSN D KL^PSOHLSIH
Q
MISRN ;Mismatch on CPRS renewal
N PSOCINV
I $G(PDFN)'=$P($G(^PSRX(+$G(PREV),0)),"^",2) D S PSOMO=1 Q
.S RCOMM="Patient mismatch on CPRS Renewal." D EN^ORERR(RCOMM,.MSG) S PSOXRP=1 D RERROR^PSOHLSN D KL^PSOHLSIH
S PSOCINV=+$P($G(^OR(100,+$G(PLACER),3)),"^",5)
I PSOCINV'=$P($G(^PSRX(+$G(PREV),"OR1")),"^",2) D S PSOMO=1 Q
.S RCOMM="Order mismatch on CPRS Renewal." D EN^ORERR(RCOMM,.MSG) S PSOCVI=1 D RERROR^PSOHLSN D KL^PSOHLSIH
Q
ZRX ;Process ZRX segment
I $P(PSOSEG,"|",3)="R" S PSOOC="RNW",PSRNFLAG=1
S PREV=$S(+$P(PSOSEG,"|"):+$P(PSOSEG,"|"),1:"")
I $P(PSOSEG,"|")["P"!($P(PSOSEG,"|")["S") S PFLAG=1
S NATURE=$P(PSOSEG,"|",2)
S PSORSO=$P(PSOSEG,"|",3)
S ROUTING=$P(PSOSEG,"|",4)
I ROUTING="" S ROUTING="M"
I $P(PSOSEG,"|",7) S DSIG=1
S PSOTITR=$P(PSOSEG,"|",8)
Q
CHCS ;Replace CHCS number with CPRS number in .01 field
N PSOHTMP
I $G(PDFN),PDFN'=+$P($G(^PS(52.41,+$G(PSOCHFFL),0)),"^",2) S COMM="Patient does not match" D EN^ORERR(COMM,.MSG) K PSOPLC,PSOFFL,PSOSND Q
I '$D(^PS(52.41,+$G(PSOCHFFL),0)) S COMM="Order was not located by Pharmacy" D EN^ORERR(COMM,.MSG) K PSOPLC,PSOFFL,PSOSND Q
S PSOHTMP=$P($G(^PS(52.41,+$G(PSOCHFFL),0)),"^")
I PSOHTMP'="" K ^PS(52.41,"B",PSOHTMP,+$G(PSOCHFFL))
S $P(^PS(52.41,+$G(PSOCHFFL),0),"^")=PSOPLC,^PS(52.41,"B",PSOPLC,+$G(PSOCHFFL))=""
S $P(^PS(52.41,+$G(PSOCHFFL),"EXT"),"^",2)=1
Q
CNT ;
S TAC=0 F TACA=0:0 S TACA=$O(^PSRX(PREV,"A",TACA)) Q:'TACA S TAC=TACA
S PAC=0 F PACA=0:0 S PACA=$O(^PSRX(PREV,1,PACA)) Q:'PACA S PAC=PACA
D NOW^%DTC S TAC=TAC+1,^PSRX(PREV,"A",0)="^52.3DA^"_TAC_"^"_TAC,^PSRX(PREV,"A",TAC,0)=%_"^"_"C"_"^"_$S(+$G(PROV):$G(PROV),1:+$G(ENTERED))_"^"_PAC_"^"_"Discontinued due to CPRS edit"
K TAC,PAC,TACA,PACA
Q
NTE ;
S WPCT=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
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOHLNE1 9738 printed Sep 23, 2025@20:06:20 Page 2
PSOHLNE1 ;BIR/RTR-Parsing out segments from OERR ;Dec 31, 2019@13:34:16
+1 ;;7.0;OUTPATIENT PHARMACY;**1,9,46,71,98,111,117,131,157,181,143,235,239,225,391,441**;DEC 1997;Build 208
+2 ;External reference to EN^ORERR supported by DBIA 2187
+3 ;External reference to PS(50.607 supported by DBIA 2221
+4 ;External reference to OR(100 supported by DBIA 2219
+5 ;External reference to PSDRUG( supported by DBIA 221
+6 ;External reference VADPT supported by DBIA 10061
+7 ;
EN ;ORC segment
+1 NEW Q1,Q2,Q3,Q4,Q5,Q6,Q7,PSOPOSSD
+2 KILL PSOLQ1I,PSOLQ1II,PSOLQ1IX
+3 IF '$ORDER(MSG(ZZ,0))
Begin DoDot:1
+4 SET PSOOC="NW"
SET PLACER=+$PIECE(PSOSEG,"|",2)
SET PLACERXX=+$PIECE($PIECE(PSOSEG,"|",2),";",2)
SET ENTERED=$PIECE(PSOSEG,"|",10)
SET PROV=$PIECE(PSOSEG,"|",12)
+5 SET X=$PIECE(PSOSEG,"|",15)
SET EFFECT=$$HL7TFM^XLFDT(X)
KILL X
+6 DO NOW^%DTC
SET PSOLOG=%
KILL %
+7 ;S RSN=$P(PSOSEG,"|",16)
+8 SET ORCSEG=$PIECE(PSOSEG,"|",7)
SET QCOUNT=1
if $GET(ORCSEG)'["~"
QUIT
+9 FOR JJ=1:1:$LENGTH(ORCSEG)
if $EXTRACT(ORCSEG,JJ)="~"
SET QCOUNT=QCOUNT+1
End DoDot:1
+10 IF '$ORDER(MSG(ZZ,0))
Begin DoDot:1
+11 FOR JJJ=1:1:QCOUNT
SET QQQ=$PIECE(ORCSEG,"~",JJJ)
if QQQ'=""
Begin DoDot:2
+12 ;PSOPOSSD=1 if possible dose
SET PSOPOSSD=$SELECT($PIECE($PIECE(QQQ,"^"),"&"):1,1:0)
+13 SET Q9(JJJ)=$PIECE(QQQ,"^")
+14 ;ORC piece 1 if Possible Dosage, ORC piece 8 if Local Possible Dosage
SET Q1I(JJJ)=$SELECT(PSOPOSSD:$PIECE(QQQ,"^"),1:$PIECE(QQQ,"^",8))
SET PSOLQ1IX(JJJ)=$PIECE($PIECE(QQQ,"^"),"&",5)
SET PSOLQ1I(JJJ)=$PIECE(QQQ,"^",8)
SET PSOLQ1II(JJJ)=PSOPOSSD
+15 ;schedule
SET Q1(JJJ)=$PIECE(QQQ,"^",2)
+16 ;duration
SET Q2(JJJ)=$PIECE(QQQ,"^",3)
+17 ;start date
SET Q3(JJJ)=$PIECE(QQQ,"^",4)
IF Q3(JJJ)
SET X=Q3(JJJ)
SET Q3(JJJ)=$$HL7TFM^XLFDT(X)
KILL X
+18 ;end date
SET Q4(JJJ)=$PIECE(QQQ,"^",5)
+19 if $GET(PRIOR)=""
SET PRIOR=$PIECE(QQQ,"^",6)
+20 ;conjunction
SET Q6(JJJ)=$PIECE(QQQ,"^",9)
+21 ;sequencing
SET Q7(JJJ)=$PIECE(QQQ,"^",10)
+22 SET QTARRAY(JJJ)=Q1(JJJ)_"^"_Q2(JJJ)_"^"_Q3(JJJ)_"^"_Q4(JJJ)_"^^"_Q6(JJJ)_"^"_Q7(JJJ)
+23 SET QTARRAY2(JJJ)=$SELECT(PSOPOSSD:$PIECE(Q1I(JJJ),"&"),1:Q1I(JJJ))_"^"_$SELECT(PSOPOSSD:$PIECE(Q1I(JJJ),"&",3),1:"")
+24 IF PSOPOSSD
SET $PIECE(QTARRAY(JJJ),"^",5)=$PIECE(Q1I(JJJ),"&",4)
+25 IF PSOPOSSD
SET PSOUNN=$PIECE(Q1I(JJJ),"&",2)
IF PSOUNN'=""
SET PSOUNN=$ORDER(^PS(50.607,"B",PSOUNN,0))
SET $PIECE(QTARRAY(JJJ),"^",9)=$GET(PSOUNN)
+26 KILL PSOUNN
End DoDot:2
End DoDot:1
QUIT
+27 ;For multiple ORC subscripts
+28 SET (POVAR,POVAR1)=""
SET (NNCK,NNN,NNNN)=0
SET PSOIII=1
SET MSG(ZZ,0)=$EXTRACT(MSG(ZZ),5,$LENGTH(MSG(ZZ)))
+29 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
+30 IF $EXTRACT(MSG(ZZ,AAA),OOO)="|"
SET NNNN=NNNN+1
+31 SET POVAR1=$EXTRACT(MSG(ZZ,AAA),OOO)
+32 SET POLIM=POVAR
+33 SET POVAR=$SELECT(POVAR="":POVAR1,1:POVAR_POVAR1)
+34 ;I NNNN=6 I $G(POVAR1)="~"!($G(POVAR1)="|")
End DoDot:1
if $GET(POVAR1)="~"&(NNNN=6)
DO PARSE
if $GET(POVAR1)="|"
DO PARSE
END ;16 OF ORC?
+1 ;I $G(POVAR)'="" I NNNN=14!(NNNN=15) S EFFECT=$G(POVAR)
+2 SET QCOUNT=0
FOR JJJ=0:0
SET JJJ=$ORDER(QTVAR(JJJ))
if 'JJJ
QUIT
IF $LENGTH($GET(QTVAR(JJJ)))
SET QCOUNT=QCOUNT+1
Begin DoDot:1
+3 ;PSOPOSSD =1 if possible dose
SET PSOPOSSD=$SELECT($PIECE($PIECE(QTVAR(JJJ),"^"),"&"):1,1:0)
+4 ;piece 1 if possible dose, piece 8 if not
SET Q1I(JJJ)=$SELECT(PSOPOSSD:$PIECE(QTVAR(JJJ),"^"),1:$PIECE(QTVAR(JJJ),"^",8))
SET PSOLQ1IX(JJJ)=$PIECE($PIECE(QTVAR(JJJ),"^"),"&",5)
SET PSOLQ1I(JJJ)=$PIECE(QTVAR(JJJ),"^",8)
SET PSOLQ1II(JJJ)=PSOPOSSD
+5 SET Q9(JJJ)=$PIECE(QTVAR(JJJ),"^")
+6 SET Q1(JJJ)=$PIECE(QTVAR(JJJ),"^",2)
+7 SET Q2(JJJ)=$PIECE(QTVAR(JJJ),"^",3)
+8 ;S Q2(JJJ)=$S($E($P(QTVAR(JJJ),"^",3)):"D"_$P(QTVAR(JJJ),"^",3),$E($P(QTVAR(JJJ),"^",3))=0:"D"_$P(QTVAR(JJJ),"^",3),1:$P(QTVAR(JJJ),"^",3))
+9 SET Q3(JJJ)=$PIECE(QTVAR(JJJ),"^",4)
IF Q3(JJJ)
SET X=Q3(JJJ)
SET Q3(JJJ)=$$HL7TFM^XLFDT(X)
KILL X
+10 SET Q4(JJJ)=$PIECE(QTVAR(JJJ),"^",5)
+11 if $GET(PRIOR)=""
SET PRIOR=$PIECE(QTVAR(JJJ),"^",6)
+12 SET Q6(JJJ)=$PIECE(QTVAR(JJJ),"^",9)
+13 SET Q7(JJJ)=$PIECE(QTVAR(JJJ),"^",10)
+14 SET QTARRAY(JJJ)=Q1(JJJ)_"^"_Q2(JJJ)_"^"_Q3(JJJ)_"^"_Q4(JJJ)_"^^"_Q6(JJJ)_"^"_Q7(JJJ)
+15 SET QTARRAY2(JJJ)=$SELECT(PSOPOSSD:$PIECE(Q1I(JJJ),"&"),1:Q1I(JJJ))_"^"_$SELECT(PSOPOSSD:$PIECE(Q1I(JJJ),"&",3),1:"")
+16 IF PSOPOSSD
SET $PIECE(QTARRAY(JJJ),"^",5)=$PIECE(Q1I(JJJ),"&",4)
+17 IF PSOPOSSD
SET PSOUNN=$PIECE(Q1I(JJJ),"&",2)
IF PSOUNN'=""
SET PSOUNN=$ORDER(^PS(50.607,"B",PSOUNN,0))
SET $PIECE(QTARRAY(JJJ),"^",9)=$GET(PSOUNN)
+18 KILL PSOUNN
End DoDot:1
+19 IF $GET(EFFECT)
SET X=EFFECT
SET EFFECT=$$HL7TFM^XLFDT(X)
KILL X
+20 DO NOW^%DTC
SET PSOLOG=%
if '$GET(EFFECT)
SET EFFECT=%
KILL %
+21 KILL MSG(ZZ,0)
+22 QUIT
PARSE IF NNNN=1
SET PSOOC="NW"
GOTO SET
+1 IF NNNN=2
SET PLACER=+$GET(POLIM)
SET PLACERXX=+$PIECE($GET(POLIM),";",2)
GOTO SET
+2 IF NNNN=3!(NNNN=4)!(NNNN=5)
GOTO SET
+3 IF NNNN=6
IF $GET(POVAR1)="~"
SET NNCK=NNCK+1
SET QTVAR(NNCK)=$GET(POLIM)
GOTO SET
+4 IF NNNN=7
SET NNCK=NNCK+1
SET QTVAR(NNCK)=$GET(POLIM)
GOTO SET
+5 IF NNNN=8!(NNNN=9)
GOTO SET
+6 IF NNNN=10
SET ENTERED=$GET(POLIM)
GOTO SET
+7 IF NNNN=11
GOTO SET
+8 IF NNNN=12
SET PROV=$GET(POLIM)
GOTO SET
+9 IF NNNN=13!(NNNN=14)
GOTO SET
+10 IF NNNN=15
SET EFFECT=$GET(POLIM)
SET SET (POVAR,POLIM)=""
QUIT
+1 ;
EXP ;
+1 ;Q:'$G(OR("PLACE"))
+2 if '$GET(PSOFILNM)
QUIT
+3 SET PSOMSORR=1
+4 NEW PSOSSMES
SET PSOSSMES="CPRSUP"
+5 IF $GET(PSOFILNM)
IF $GET(PSOFILNM)["S"
SET LL=+$GET(PSOFILNM)
IF $DATA(^PS(52.41,LL,0))
IF $PIECE($GET(^(0)),"^",3)'="RF"
GOTO EXPEN
+6 SET LL=$GET(PSOFILNM)
IF 'LL!('$DATA(^PSRX(+$GET(LL),0)))
SET COMM="Order was not located by Pharmacy"
DO EN^ORERR(COMM,.MSG)
Begin DoDot:1
+7 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)
+8 NEW MSG,PSOHINST
DO INIT^PSOHLSN
SET MSG(2)=$GET(PSERRPID)
SET MSG(3)=$GET(PSERRPV1)
SET MSG(4)="ORC|DE|"_$GET(OR("PLACE"))_$SELECT($GET(PLACERXX):";"_PLACERXX,1:"")_"^OR"_"|"_$SELECT($PIECE($GET(PSERRORC),"|",4)'="":$PIECE(PSERRORC,"|",4),1:"")
if $GET(COMM)'=""
SET MSG(5)="NTE|16||"_COMM
+9 DO SEND^PSOHLSN
End DoDot:1
GOTO EXPQ
+10 if '$DATA(^PSRX(LL,0))
QUIT
+11 IF +$PIECE($GET(^PSRX(LL,2)),"^",6)<DT
Begin DoDot:1
+12 ;Reset PSOSSMES if status changes, so HDR gets updated in PSOHLSN1
+13 IF +$PIECE($GET(^PSRX(LL,"STA")),"^")<12!($PIECE($GET(^("STA")),"^")=16)
SET $PIECE(^PSRX(LL,"STA"),"^")=11
DO ECAN^PSOUTL(LL)
SET PSOSSMES="CPRSVDEF"
End DoDot:1
+14 SET GG=+$PIECE($GET(^PSRX(LL,"STA")),"^")
+15 ;S AA=$S(GG=3:"OH",GG=12:"OD",GG=13:"OC",GG=14:"OD",GG=15:"OD",GG=16:"OH",1:"SC"),AAA=$S(GG=0:"CM",GG=1:"IP",GG=4:"IP",GG=5:"ZS",GG=11:"ZE",1:"")
+16 SET AA="SC"
SET AAA=$SELECT(GG=0:"CM",GG=2:"CM",GG=1:"IP",GG=4:"IP",GG=5:"ZS",GG=3:"HD",GG=16:"HD",GG=11:"ZE",1:"DC")
+17 DO EN^PSOHLSN1(LL,AA,AAA,"")
+18 KILL PSOSSMES
EXPQ KILL LL,GG,AA,AAA,PSOMSORR
QUIT
EXPEN ;SS on Pending orders
+1 SET AA=$PIECE($GET(^PS(52.41,LL,0)),"^",3)
+2 SET AAA=$SELECT(AA="DC"!(AA="DE"):"DC",AA="HD":"HD",1:"IP")
+3 DO EN^PSOHLSN(OR("PLACE"),"SC",AAA)
+4 GOTO EXPQ
+5 ;
OID ;Check for 1 to 1 match from Dispense Drug to Orderable Item
+1 NEW PSOCDD,PSOCDDI,PSOCDDIZ
+2 if '$GET(PSORDITE)
QUIT
+3 KILL PSOCDDIZ
+4 SET (PSOCDD,PSOCDDI)=0
+5 FOR
SET PSOCDD=$ORDER(^PSDRUG("ASP",PSORDITE,PSOCDD))
if 'PSOCDD
QUIT
IF $SELECT('$PIECE($GET(^PSDRUG(PSOCDD,"I")),"^"):1,DT'>$PIECE($GET(^("I")),"^"):1,1:0)
IF $PIECE($GET(^PSDRUG(PSOCDD,2)),"^",3)["O"
SET PSOCDDI=PSOCDDI+1
SET PSOCDDIZ=PSOCDD
+6 IF PSOCDDI'=1
QUIT
+7 SET PSOQWX=$GET(PSOCDDIZ)
+8 QUIT
CP ;ZSC segment (replaced by ZCL segment)
+1 SET SERV=$SELECT($PIECE(PSOSEG,"|")=1:"SC",$PIECE(PSOSEG,"|")=0:"NSC",1:$PIECE(PSOSEG,"|"))
+2 SET PSOIBY=$PIECE(PSOSEG,"|",2)_"^"_$PIECE(PSOSEG,"|",3)_"^"_$PIECE(PSOSEG,"|",4)_"^"_$PIECE(PSOSEG,"|",5)_"^"_$PIECE(PSOSEG,"|",6)_"^"_$PIECE(PSOSEG,"|",7)_"^"_$PIECE(PSOSEG,"|",8)
+3 QUIT
+4 ;
ZCL ;ZCL segment - SC/EI related to ICDs
+1 NEW SEQ,SEQ2,SEQ3
SET SEQ3=$PIECE(PSOSEG,"|",2)
SET SEQ2=$PIECE(PSOSEG,"|",1)
+2 if '$DATA(PSOICD(SEQ2))
SET PSOICD(SEQ2)=""
+3 ;set sc/ei for ICD node
SET $PIECE(PSOICD(SEQ2),"^",(SEQ3+1))=$PIECE(PSOSEG,"|",3)
+4 DO SCP^PSORN52D
KILL PSOSCA
+5 if '$DATA(PSOIBY)
SET PSOIBY=""
+6 ;set IBQ node variables if <50% SC
IF PSOSCP<50
Begin DoDot:1
+7 if $PIECE(PSOIBY,U,$SELECT(SEQ3=1
QUIT
+8 ;AO
if SEQ3=1
SET $PIECE(PSOIBY,U,2)=$PIECE(PSOSEG,"|",3)
+9 ;IR
if SEQ3=2
SET $PIECE(PSOIBY,U,3)=$PIECE(PSOSEG,"|",3)
+10 ;SC
if SEQ3=3
SET SERV=$SELECT($PIECE(PSOSEG,"|",3)=1:"SC",$PIECE(PSOSEG,"|",3)=0:"NSC",1:$PIECE(PSOSEG,"|",3))
+11 ;EC
if SEQ3=4
SET $PIECE(PSOIBY,U,4)=$PIECE(PSOSEG,"|",3)
+12 ;MST
if SEQ3=5
SET $PIECE(PSOIBY,U,1)=$PIECE(PSOSEG,"|",3)
+13 ;HNC
if SEQ3=6
SET $PIECE(PSOIBY,U,5)=$PIECE(PSOSEG,"|",3)
+14 ;CV
if SEQ3=7
SET $PIECE(PSOIBY,U,6)=$PIECE(PSOSEG,"|",3)
+15 ;SHAD
if SEQ3=8
SET $PIECE(PSOIBY,U,7)=$PIECE(PSOSEG,"|",3)
End DoDot:1
+16 QUIT
MISX ;Mismatch patient on CPRS New Order
+1 SET RCOMM="Patient mismatch on New Order from CPRS."
DO EN^ORERR(RCOMM,.MSG)
SET NWFLAG=1
DO RERROR^PSOHLSN
DO KL^PSOHLSIH
+2 QUIT
MISRN ;Mismatch on CPRS renewal
+1 NEW PSOCINV
+2 IF $GET(PDFN)'=$PIECE($GET(^PSRX(+$GET(PREV),0)),"^",2)
Begin DoDot:1
+3 SET RCOMM="Patient mismatch on CPRS Renewal."
DO EN^ORERR(RCOMM,.MSG)
SET PSOXRP=1
DO RERROR^PSOHLSN
DO KL^PSOHLSIH
End DoDot:1
SET PSOMO=1
QUIT
+4 SET PSOCINV=+$PIECE($GET(^OR(100,+$GET(PLACER),3)),"^",5)
+5 IF PSOCINV'=$PIECE($GET(^PSRX(+$GET(PREV),"OR1")),"^",2)
Begin DoDot:1
+6 SET RCOMM="Order mismatch on CPRS Renewal."
DO EN^ORERR(RCOMM,.MSG)
SET PSOCVI=1
DO RERROR^PSOHLSN
DO KL^PSOHLSIH
End DoDot:1
SET PSOMO=1
QUIT
+7 QUIT
ZRX ;Process ZRX segment
+1 IF $PIECE(PSOSEG,"|",3)="R"
SET PSOOC="RNW"
SET PSRNFLAG=1
+2 SET PREV=$SELECT(+$PIECE(PSOSEG,"|"):+$PIECE(PSOSEG,"|"),1:"")
+3 IF $PIECE(PSOSEG,"|")["P"!($PIECE(PSOSEG,"|")["S")
SET PFLAG=1
+4 SET NATURE=$PIECE(PSOSEG,"|",2)
+5 SET PSORSO=$PIECE(PSOSEG,"|",3)
+6 SET ROUTING=$PIECE(PSOSEG,"|",4)
+7 IF ROUTING=""
SET ROUTING="M"
+8 IF $PIECE(PSOSEG,"|",7)
SET DSIG=1
+9 SET PSOTITR=$PIECE(PSOSEG,"|",8)
+10 QUIT
CHCS ;Replace CHCS number with CPRS number in .01 field
+1 NEW PSOHTMP
+2 IF $GET(PDFN)
IF PDFN'=+$PIECE($GET(^PS(52.41,+$GET(PSOCHFFL),0)),"^",2)
SET COMM="Patient does not match"
DO EN^ORERR(COMM,.MSG)
KILL PSOPLC,PSOFFL,PSOSND
QUIT
+3 IF '$DATA(^PS(52.41,+$GET(PSOCHFFL),0))
SET COMM="Order was not located by Pharmacy"
DO EN^ORERR(COMM,.MSG)
KILL PSOPLC,PSOFFL,PSOSND
QUIT
+4 SET PSOHTMP=$PIECE($GET(^PS(52.41,+$GET(PSOCHFFL),0)),"^")
+5 IF PSOHTMP'=""
KILL ^PS(52.41,"B",PSOHTMP,+$GET(PSOCHFFL))
+6 SET $PIECE(^PS(52.41,+$GET(PSOCHFFL),0),"^")=PSOPLC
SET ^PS(52.41,"B",PSOPLC,+$GET(PSOCHFFL))=""
+7 SET $PIECE(^PS(52.41,+$GET(PSOCHFFL),"EXT"),"^",2)=1
+8 QUIT
CNT ;
+1 SET TAC=0
FOR TACA=0:0
SET TACA=$ORDER(^PSRX(PREV,"A",TACA))
if 'TACA
QUIT
SET TAC=TACA
+2 SET PAC=0
FOR PACA=0:0
SET PACA=$ORDER(^PSRX(PREV,1,PACA))
if 'PACA
QUIT
SET PAC=PACA
+3 DO NOW^%DTC
SET TAC=TAC+1
SET ^PSRX(PREV,"A",0)="^52.3DA^"_TAC_"^"_TAC
SET ^PSRX(PREV,"A",TAC,0)=%_"^"_"C"_"^"_$SELECT(+$GET(PROV):$GET(PROV),1:+$GET(ENTERED))_"^"_PAC_"^"_"Discontinued due to CPRS edit"
+4 KILL TAC,PAC,TACA,PACA
+5 QUIT
NTE ;
+1 SET WPCT=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:1
+2 IF $GET(MSG(LL,LLL))'=""
SET WPARRAY(WORDP,WPCT)=$GET(MSG(LL,LLL))
SET WPCT=WPCT+1
End DoDot:1
+3 QUIT
