Routine: PSOHLNE1

PSOHLNE1 ;BIR/RTR-Parsing out segments from OERR ;01/20/95

 ;;7.0;OUTPATIENT PHARMACY;**1,9,46,71,98,111,117,131,157,181,143,235,239,225**;DEC 1997;Build 29

 ;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 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 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)

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)

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)

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

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

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

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

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

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

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

PSOHLNE1  ;BIR/RTR-Parsing out segments from OERR ;01/20/95

 +1       ;;7.0;OUTPATIENT PHARMACY;**1,9,46,71,98,111,117,131,157,181,143,235,239,225**;DEC 1997;Build 29

 +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      ;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

 +14      ;schedule

                               SET Q1(JJJ)=$PIECE(QQQ,"^",2)

 +15      ;duration

                               SET Q2(JJJ)=$PIECE(QQQ,"^",3)

 +16      ;start date

                               SET Q3(JJJ)=$PIECE(QQQ,"^",4)

                               IF Q3(JJJ)

                                   SET X=Q3(JJJ)

                                   SET Q3(JJJ)=$$HL7TFM^XLFDT(X)

                                   KILL X

 +17      ;end date

                               SET Q4(JJJ)=$PIECE(QQQ,"^",5)

 +18                           IF $GET(PRIOR)=""

                                   SET PRIOR=$PIECE(QQQ,"^",6)

 +19      ;conjunction

                               SET Q6(JJJ)=$PIECE(QQQ,"^",9)

 +20      ;sequencing

                               SET Q7(JJJ)=$PIECE(QQQ,"^",10)

 +21                           SET QTARRAY(JJJ)=Q1(JJJ)_"^"_Q2(JJJ)_"^"_Q3(JJJ)_"^"_Q4(JJJ)_"^^"_Q6(JJJ)_"^"_Q7(JJJ)

 +22                           SET QTARRAY2(JJJ)=$SELECT(PSOPOSSD:$PIECE(Q1I(JJJ),"&"),1:Q1I(JJJ))_"^"_$SELECT(PSOPOSSD:$PIECE(Q1I(JJJ),"&",3),1:"")

 +23                           IF PSOPOSSD

                                   SET $PIECE(QTARRAY(JJJ),"^",5)=$PIECE(Q1I(JJJ),"&",4)

 +24                           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)

 +25                           KILL PSOUNN

                           End DoDot:2

               End DoDot:1

               QUIT

 +26      ;For multiple ORC subscripts

 +27       SET (POVAR,POVAR1)=""

           SET (NNCK,NNN,NNNN)=0

           SET PSOIII=1

           SET MSG(ZZ,0)=$EXTRACT(MSG(ZZ),5,$LENGTH(MSG(ZZ)))

 +28       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

 +29                   IF $EXTRACT(MSG(ZZ,AAA),OOO)="|"

                           SET NNNN=NNNN+1

 +30                   SET POVAR1=$EXTRACT(MSG(ZZ,AAA),OOO)

 +31                   SET POLIM=POVAR

 +32                   SET POVAR=$SELECT(POVAR="":POVAR1,1:POVAR_POVAR1)

 +33      ;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 Q1(JJJ)=$PIECE(QTVAR(JJJ),"^",2)

 +6                    SET Q2(JJJ)=$PIECE(QTVAR(JJJ),"^",3)

 +7       ;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))

 +8                    SET Q3(JJJ)=$PIECE(QTVAR(JJJ),"^",4)

                       IF Q3(JJJ)

                           SET X=Q3(JJJ)

                           SET Q3(JJJ)=$$HL7TFM^XLFDT(X)

                           KILL X

 +9                    SET Q4(JJJ)=$PIECE(QTVAR(JJJ),"^",5)

 +10                   IF $GET(PRIOR)=""

                           SET PRIOR=$PIECE(QTVAR(JJJ),"^",6)

 +11                   SET Q6(JJJ)=$PIECE(QTVAR(JJJ),"^",9)

 +12                   SET Q7(JJJ)=$PIECE(QTVAR(JJJ),"^",10)

 +13                   SET QTARRAY(JJJ)=Q1(JJJ)_"^"_Q2(JJJ)_"^"_Q3(JJJ)_"^"_Q4(JJJ)_"^^"_Q6(JJJ)_"^"_Q7(JJJ)

 +14                   SET QTARRAY2(JJJ)=$SELECT(PSOPOSSD:$PIECE(Q1I(JJJ),"&"),1:Q1I(JJJ))_"^"_$SELECT(PSOPOSSD:$PIECE(Q1I(JJJ),"&",3),1:"")

 +15                   IF PSOPOSSD

                           SET $PIECE(QTARRAY(JJJ),"^",5)=$PIECE(Q1I(JJJ),"&",4)

 +16                   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)

 +17                   KILL PSOUNN

                   End DoDot:1

 +18       IF $GET(EFFECT)

               SET X=EFFECT

               SET EFFECT=$$HL7TFM^XLFDT(X)

               KILL X

 +19       DO NOW^%DTC

           SET PSOLOG=%

           IF '$GET(EFFECT)

               SET EFFECT=%

           KILL %

 +20       KILL MSG(ZZ,0)

 +21       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        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

PSOHLNE1.m