PSJHL4A ;BIR/RLW-CONTINUE DECODE HL7 /MESSSAGE FROM OE/RR ;16 Mar 99 / 4:55 PM
;;5.0; INPATIENT MEDICATIONS ;**105,111,154,170,159,134,197**;16 DEC 97;Build 3
;
; Reference to ^PS(52.6 is supported by DBIA# 1231.
; Reference to ^PS(52.7 is supported by DBIA# 2173.
; Reference to ^PS(55 is supported by DBIA# 2191.
; Reference to ^PS(59.7 supported by DBIA #2181.
; Reference to ^ORHLESC is supported by DBIA# 4922.
; Reference to ^SC( is supported by DBIA# 10040.
; Reference to ^PS(51.1 is supported by DBIA# 2177.
; Reference to ^PS(50.7 is supported by DBIA #2180.
; Reference to ^PS(51.2 is supported by DBIA 2178.
;
RXC ; IV order
N IVFL
S APPL=FIELD(1)
I APPL["B" S SOLCNT=SOLCNT+1,PTR=$P(FIELD(2),"^",4) Q:'PTR S VOLUME=+FIELD(3)_" ML" D I '$D(^TMP("PSJNVO",$J,"SOL",SOLCNT,0)) D SOLSRCH
.S SOLUTION="" F S SOLUTION=$O(^PS(52.7,"AOI",PTR,SOLUTION)) Q:'SOLUTION S INACT=$G(^PS(52.7,SOLUTION,"I")) I 'INACT!(INACT>DT) I VOLUME=$P(^PS(52.7,SOLUTION,0),U,3) D
..S ^TMP("PSJNVO",$J,"SOL",0)=SOLCNT
..S ^TMP("PSJNVO",$J,"SOL",SOLCNT,0)=SOLUTION_"^"_VOLUME,TVOLUME=TVOLUME+(+VOLUME)
I $G(INFRT)]"" S X=INFRT D ENI^PSJHLU S INFRT=$G(X)
I APPL="A" S ADCNT=ADCNT+1,PTR=$P(FIELD(2),"^",4) Q:'PTR S STRENGTH=$G(FIELD(3))_" "_$P($G(FIELD(4)),"^",5) D I '$D(^TMP("PSJNVO",$J,"AD",ADCNT,0)) S PSREASON="Can't find matching additive" D ERROR^PSJHL9 Q
.S ADDITIVE="" F S ADDITIVE=$O(^PS(52.6,"AOI",PTR,ADDITIVE)) Q:'ADDITIVE S INACT=$G(^PS(52.6,ADDITIVE,"I")),IVFL=$P($G(^(0)),"^",13) I 'INACT!(INACT>DT),IVFL'=0 Q:$G(^PS(52.6,ADDITIVE,0))']"" D Q:ADDITIVE
..I $G(PSITEM)="" S PSITEM=PTR
..S ^TMP("PSJNVO",$J,"AD",0)=ADCNT
..S ^TMP("PSJNVO",$J,"AD",ADCNT,0)=ADDITIVE_"^"_STRENGTH
Q
;
RXO ;
I $O(PSJMSG(II,0)) D
.K SEGMENT
.N KK,JJ,XX
.S SEGMENT(1)=$G(PSJMSG(II))
.S KK=1,JJ="" F S JJ=$O(PSJMSG(II,JJ)) Q:'JJ S KK=KK+1,SEGMENT(KK)=$G(PSJMSG(II,JJ))
.S KK=1,JJ=0
.F Q:'$D(SEGMENT(KK)) D
..I SEGMENT(KK)["|" S FIELD(JJ)=$P(SEGMENT(KK),"|"),SEGMENT(KK)=$E(SEGMENT(KK),$L(FIELD(JJ))+2,$L(SEGMENT(KK))),JJ=JJ+1 Q
..I SEGMENT(KK)'["|" S FIELD(JJ)=SEGMENT(KK),KK=KK+1 Q:'$D(SEGMENT(KK)) D
...S XX=$P(SEGMENT(KK),"|"),SEGMENT(KK)=$E(SEGMENT(KK),$L(X)+2,$L(SEGMENT(KK))),FIELD(JJ)=FIELD(JJ)_XX,JJ=JJ+1
S APPL="",PSITEM=$S($P(FIELD(1),"^",5)="IV":"",1:$P(FIELD(1),"^",4))
S:$P(FIELD(1),"^",6)="ORD" PSITEM=""
S:$P(FIELD(1),"^",5)="IV" IVTYP="A",SCHTYP="C",INFRT=$G(FIELD(2))
S DISPENSE=$P($G(FIELD(10)),"^",4)
S IVLIMIT=$P($G(PSJMSG(II)),"^",3)
S:IVLIMIT["doses" IVLIMIT=$TR(IVLIMIT,"doses","a")
Q
;
OBX ;
S OBXFL=1,OCNARR=FIELD(5),OCPROV=CLERK,OCCNT=OCCNT+1
S ^TMP("PSJNVO",$J,10,0)=OCCNT
S ^TMP("PSJNVO",$J,10,OCCNT,0)=OCNARR
S ^TMP("PSJNVO",$J,10,OCCNT,1)=$$UNESC^ORHLESC($P($G(^VA(200,+OCPROV,0)),"^"))
Q
;
NTE ;
S TEXT=$S((FIELD(1)=6)&('OBXFL):"PROCOM",(FIELD(1)=7)&('OBXFL):"ADMINSTR",1:"OCRSN")
S @TEXT@(1)=$$UNESC^ORHLESC($G(FIELD(3)))
S K=1,J="" F S J=$O(PSJMSG(II,J)) Q:'J S K=K+1,@TEXT@(K)=$G(PSJMSG(II,J))
D:$D(OCRSN)
.S QQ=0 F S QQ=$O(OCRSN(QQ)) Q:'QQ S ^TMP("PSJNVO",$J,10,OCCNT,2,QQ,0)=OCRSN(QQ)
S OBXFL=0
Q
;
ZRX ;
N ND,ND2,CHK,FOLOR,STDT
S PREON=$G(FIELD(1)),ROC=$G(FIELD(3)),IVCAT=$G(FIELD(6))
S IVCAT=$S(",I,C,"[(","_IVCAT_","):IVCAT,1:"") I 'PREON S IVTYP=$S($G(PSGS0XT):"P",1:"A") S IVTYP=$S(IVCAT="I":"P",IVCAT="C":"A",1:$G(IVTYP))
S ND=$S((PREON["N")!(PREON["P"):$G(^PS(53.1,+PREON,0)),PREON["V":$G(^PS(55,PSJHLDFN,"IV",+PREON,0)),1:$G(^PS(55,PSJHLDFN,5,+PREON,0)))
S ND2=$S((PREON["N")!(PREON["P"):$G(^PS(53.1,+PREON,2)),PREON["V":$G(^PS(55,PSJHLDFN,"IV",+PREON,2)),1:$G(^PS(55,PSJHLDFN,5,+PREON,2)))
I 'ND I ROC'="N" S PSREASON="Invalid Pharmacy order number" D ERROR^PSJHL9 Q
I ND I ROC="R" S FOLOR=$S(PREON["V":$P(ND2,U,6),1:$P(ND,U,26)) I FOLOR S PSREASON="Duplicate Renewal Request" D ERROR^PSJHL9 Q
I ND I ROC="R" S CHK=$S(PREON["V":$P(ND,U,17),1:$P(ND,U,9)) I "AE"'[CHK S PSREASON="Pharmacy orders with a status of "_CHK_" may not be renewed" D ERROR^PSJHL9 Q
I $G(CHK)="E" I PREON'["V" D NOW^%DTC S X1=+$E(%,1,12),X2=-4 D C^%DTC S STDT=$S(PREON["V":$P(ND,U,3),1:$P(ND2,U,4)) I STDT'>X S PSREASON="Pharmacy orders expired longer than 4 days may not be renewed" D ERROR^PSJHL9 Q
I ND I ROC="E" S FOLOR=$S(PREON["V":$P(ND2,U,6),1:$P(ND,U,26)) I FOLOR S PSREASON="Pharmacy orders may only be edited ONCE" D ERROR^PSJHL9 Q
I ND I ROC="E" S CHK=$S(PREON["V":$P(ND,U,17),1:$P(ND,U,9)) I "DEHO"[CHK N CHKRTN S CHKRTN=CHK_"^PSJHL6" D @CHKRTN S PSREASON=PSREASON_" orders may not be edited" D ERROR^PSJHL9 Q
D:ROC'="R" VALID^PSJHL9 Q:QFLG
I $G(PSITEM)="",$D(^TMP("PSJNVO",$J,"SOL",1,0)) S PSITEM=$P($G(^PS(52.7,+^TMP("PSJNVO",$J,"SOL",1,0),0)),"^",11)
I PRIORITY="ZD" D VALID^PSJHL10 S QFLG=1 Q
I (PREON]"")&(ROC="E") D EDITCK^PSJHL5 Q:QFLG
D NVO^PSJHL9
I (PREON]"")&(ROC="R") D RENEW^PSJHL7 Q
I (PREON]"")&(ROC="E") D EDIT^PSJHL5
Q
;
SOLSRCH ;Find solution
N SSSS,SEG,ON,ROC,SOL,SOL2
F SSSS=II:0 S SSSS=$O(PSJMSG(SSSS)) Q:'SSSS I $P(PSJMSG(SSSS),"|")="ZRX" D Q
.S SEG=$G(PSJMSG(SSSS)),ON=$P(SEG,"|",2),ROC=$P(SEG,"|",4)
I $G(ROC)'="N" F SOL=0:0 S SOL=$O(^PS(55,PSJHLDFN,"IV",+ON,"SOL",SOL)) Q:'SOL S SOL2=$G(^PS(55,PSJHLDFN,"IV",+ON,"SOL",SOL,0)) I $D(^PS(52.7,"AOI",PTR,+SOL2))&($P(SOL2,U,2)=VOLUME) S SOLUTION=+SOL2 D SET Q
I 'SOLUTION S SOLUTION=$O(^PS(52.7,"AOI",PTR,SOLUTION)) D SET
Q
SET ;Set solution tmp nodes
Q:'+SOLUTION
S ^TMP("PSJNVO",$J,"SOL",0)=SOLCNT
S ^TMP("PSJNVO",$J,"SOL",SOLCNT,0)=SOLUTION_"^"_VOLUME,TVOLUME=TVOLUME+(+VOLUME)
Q
;
SNDTSTW(PRIO,PSJSCHED,WARD) ; Test to determine if mail message should be sent.
N SNPRIO,SNSCHD,SNOPT
S SNPRIO=$S(PRIO="S":"S",PRIO="A":"A",1:"R")
S SNSCHD=$S(PSJSCHED="STAT":"S",PSJSCHED="NOW":"N",1:"R")
S SNOPT=$P($G(^PS(59.6,WARD,0)),"^",32)
S:SNOPT="" SNOPT=$P($G(^PS(59.7,1,27)),"^",1)
Q:SNOPT="" 0
Q:SNOPT[SNPRIO 0
Q:SNOPT[SNSCHD 0
Q 1
;
SNDTSTP(PRIO,PSJSCHED) ; Test to determine if mail message should be sent.
N SNPRIO,SNSCHD,SNOPT
S SNPRIO=$S(PRIO="S":"S",PRIO="A":"A",1:"R")
S SNSCHD=$S(PSJSCHED="STAT":"S",PSJSCHED="NOW":"N",1:"R")
S SNOPT=$P($G(^PS(59.7,1,27)),"^",1)
Q:SNOPT="" 1
Q:SNOPT[SNPRIO 0
Q:SNOPT[SNSCHD 0
Q 1
;
SNDTSTA(PRIO,PSJSCHED) ; Test to determine if mail message should be sent.
N SNPRIO,SNSCHD,SNOPT
S SNPRIO=$S(PRIO="S":"S",PRIO="A":"A",1:"R")
S SNSCHD=$S(PSJSCHED="STAT":"S",PSJSCHED="NOW":"N",1:"R")
S SNOPT=$P($G(^PS(59.7,1,27)),"^",2)
S:SNOPT="" SNOPT=$P($G(^PS(59.7,1,27)),"^",1)
Q:SNOPT="" 1
Q:SNOPT[SNPRIO 0
Q:SNOPT[SNSCHD 0
Q 1
;
TMPAT(SCHEDULE) ; Extract admin times from schedule in format schedule@schedule
S TMPAT="" I SCHEDULE'["@" Q TMPAT
S TMPAT=$P(SCHEDULE,"@",2) I TMPAT]"" D
.N WARD S WARD=$G(^DPT(PSJHLDFN,.1)) I WARD]"" D
..N DIC,X,Y S DIC="^DIC(42,",DIC(0)="BOXZ",X=WARD D ^DIC S WARD=+Y Q:WARD=0
..S WARD=$O(^PS(59.6,"B",WARD,0))
.I '$D(^PS(51.1,"AC","PSJ",TMPAT)) S TMPAT="" Q
.N II I '$$DOW^PSIVUTL($P(SCHEDULE,"@")) S TMPAT="" Q
.N TMPIEN S TMPIEN=$O(^PS(51.1,"AC","PSJ",TMPAT,0)),TMPAT=$P($G(^PS(51.1,+TMPIEN,0)),"^",2) D
..I $P($G(^PS(51.1,+TMPIEN,1,+$G(WARD),0)),"^",2) S TMPAT=$P($G(^(0)),"^",2)
Q TMPAT
;
XMD ; Mailman call for NOTIFY^PSJHL4
; Input - PNAME = Patient Name
; RTE = Route
; DRUG = Drug Name
; WARD = Ward Name
; CLINIC = Clinic Location Name
; PRIO = CPRS Order Priority
S PNAME=$P($G(^DPT(+PSJHLDFN,0)),"^") S:$G(RTE) RTE=$P(^PS(51.2,+RTE,0),"^",3)
S DRUG=$S(DRIEN:$P($G(^PS(50.7,+DRIEN,0)),"^"),1:""),WARD=$G(^DPT(PSJHLDFN,.1))
I $G(CLINIC)'="" S CLINIC=$P($G(^SC(CLINIC,0)),"^",2) I CLINIC'="" S WARD=CLINIC
S XMDUZ="MEDICATIONS,INPATIENT",XMSUB=$G(WARD)
S XMSUB=XMSUB_"-"_NTFSTAT_" "_$S($G(PRIO)="A":"ASAP",$G(PRIO)="S":"STAT",$G(NTFYREAS)=2:"NOW",$G(NTFYREAS)=3:"STAT",1:"")_"-"
S XMSUB=XMSUB_$E(PNAME,1,65-$L(XMSUB))
S XMTEXT="PSG("
S PSG(1,0)="Inpatient Medications has received the following "_$S($G(PRIO)="A":"ASAP",$G(PRIO)="S":"STAT",$G(NTFYREAS)=2:"NOW",1:"")_" order ("_NTFSTAT_")"
S PSG(2,0)=""
S PSG(3,0)=" Patient: "_PNAME I $G(LASTFOUR) S PSG(3,0)=PSG(3,0)_" ("_LASTFOUR_")"
S PSG(4,0)="Order Information: "_DRUG_" "_DO_" "_RTE_" "_$G(PSJSCHED)
S PSG(5,0)=" Order Date: "_$$ENDTC^PSGMI(ORDATE)
D ^XMD
Q
PSJHL4A ;BIR/RLW-CONTINUE DECODE HL7 /MESSSAGE FROM OE/RR ;16 Mar 99 / 4:55 PM
+1 ;;5.0; INPATIENT MEDICATIONS ;**105,111,154,170,159,134,197**;16 DEC 97;Build 3
+2 ;
+3 ; Reference to ^PS(52.6 is supported by DBIA# 1231.
+4 ; Reference to ^PS(52.7 is supported by DBIA# 2173.
+5 ; Reference to ^PS(55 is supported by DBIA# 2191.
+6 ; Reference to ^PS(59.7 supported by DBIA #2181.
+7 ; Reference to ^ORHLESC is supported by DBIA# 4922.
+8 ; Reference to ^SC( is supported by DBIA# 10040.
+9 ; Reference to ^PS(51.1 is supported by DBIA# 2177.
+10 ; Reference to ^PS(50.7 is supported by DBIA #2180.
+11 ; Reference to ^PS(51.2 is supported by DBIA 2178.
+12 ;
RXC ; IV order
+1 NEW IVFL
+2 SET APPL=FIELD(1)
+3 IF APPL["B"
SET SOLCNT=SOLCNT+1
SET PTR=$PIECE(FIELD(2),"^",4)
IF 'PTR
QUIT
SET VOLUME=+FIELD(3)_" ML"
Begin DoDot:1
+4 SET SOLUTION=""
FOR
SET SOLUTION=$ORDER(^PS(52.7,"AOI",PTR,SOLUTION))
IF 'SOLUTION
QUIT
SET INACT=$GET(^PS(52.7,SOLUTION,"I"))
IF 'INACT!(INACT>DT)
IF VOLUME=$PIECE(^PS(52.7,SOLUTION,0),U,3)
Begin DoDot:2
+5 SET ^TMP("PSJNVO",$JOB,"SOL",0)=SOLCNT
+6 SET ^TMP("PSJNVO",$JOB,"SOL",SOLCNT,0)=SOLUTION_"^"_VOLUME
SET TVOLUME=TVOLUME+(+VOLUME)
End DoDot:2
End DoDot:1
IF '$DATA(^TMP("PSJNVO",$JOB,"SOL",SOLCNT,0))
DO SOLSRCH
+7 IF $GET(INFRT)]""
SET X=INFRT
DO ENI^PSJHLU
SET INFRT=$GET(X)
+8 IF APPL="A"
SET ADCNT=ADCNT+1
SET PTR=$PIECE(FIELD(2),"^",4)
IF 'PTR
QUIT
SET STRENGTH=$GET(FIELD(3))_" "_$PIECE($GET(FIELD(4)),"^",5)
Begin DoDot:1
+9 SET ADDITIVE=""
FOR
SET ADDITIVE=$ORDER(^PS(52.6,"AOI",PTR,ADDITIVE))
IF 'ADDITIVE
QUIT
SET INACT=$GET(^PS(52.6,ADDITIVE,"I"))
SET IVFL=$PIECE($GET(^(0)),"^",13)
IF 'INACT!(INACT>DT)
IF IVFL'=0
IF $GET(^PS(52.6,ADDITIVE,0))']""
QUIT
Begin DoDot:2
+10 IF $GET(PSITEM)=""
SET PSITEM=PTR
+11 SET ^TMP("PSJNVO",$JOB,"AD",0)=ADCNT
+12 SET ^TMP("PSJNVO",$JOB,"AD",ADCNT,0)=ADDITIVE_"^"_STRENGTH
End DoDot:2
IF ADDITIVE
QUIT
End DoDot:1
IF '$DATA(^TMP("PSJNVO",$JOB,"AD",ADCNT,0))
SET PSREASON="Can't find matching additive"
DO ERROR^PSJHL9
QUIT
+13 QUIT
+14 ;
RXO ;
+1 IF $ORDER(PSJMSG(II,0))
Begin DoDot:1
+2 KILL SEGMENT
+3 NEW KK,JJ,XX
+4 SET SEGMENT(1)=$GET(PSJMSG(II))
+5 SET KK=1
SET JJ=""
FOR
SET JJ=$ORDER(PSJMSG(II,JJ))
IF 'JJ
QUIT
SET KK=KK+1
SET SEGMENT(KK)=$GET(PSJMSG(II,JJ))
+6 SET KK=1
SET JJ=0
+7 FOR
IF '$DATA(SEGMENT(KK))
QUIT
Begin DoDot:2
+8 IF SEGMENT(KK)["|"
SET FIELD(JJ)=$PIECE(SEGMENT(KK),"|")
SET SEGMENT(KK)=$EXTRACT(SEGMENT(KK),$LENGTH(FIELD(JJ))+2,$LENGTH(SEGMENT(KK)))
SET JJ=JJ+1
QUIT
+9 IF SEGMENT(KK)'["|"
SET FIELD(JJ)=SEGMENT(KK)
SET KK=KK+1
IF '$DATA(SEGMENT(KK))
QUIT
Begin DoDot:3
+10 SET XX=$PIECE(SEGMENT(KK),"|")
SET SEGMENT(KK)=$EXTRACT(SEGMENT(KK),$LENGTH(X)+2,$LENGTH(SEGMENT(KK)))
SET FIELD(JJ)=FIELD(JJ)_XX
SET JJ=JJ+1
End DoDot:3
End DoDot:2
End DoDot:1
+11 SET APPL=""
SET PSITEM=$SELECT($PIECE(FIELD(1),"^",5)="IV":"",1:$PIECE(FIELD(1),"^",4))
+12 IF $PIECE(FIELD(1),"^",6)="ORD"
SET PSITEM=""
+13 IF $PIECE(FIELD(1),"^",5)="IV"
SET IVTYP="A"
SET SCHTYP="C"
SET INFRT=$GET(FIELD(2))
+14 SET DISPENSE=$PIECE($GET(FIELD(10)),"^",4)
+15 SET IVLIMIT=$PIECE($GET(PSJMSG(II)),"^",3)
+16 IF IVLIMIT["doses"
SET IVLIMIT=$TRANSLATE(IVLIMIT,"doses","a")
+17 QUIT
+18 ;
OBX ;
+1 SET OBXFL=1
SET OCNARR=FIELD(5)
SET OCPROV=CLERK
SET OCCNT=OCCNT+1
+2 SET ^TMP("PSJNVO",$JOB,10,0)=OCCNT
+3 SET ^TMP("PSJNVO",$JOB,10,OCCNT,0)=OCNARR
+4 SET ^TMP("PSJNVO",$JOB,10,OCCNT,1)=$$UNESC^ORHLESC($PIECE($GET(^VA(200,+OCPROV,0)),"^"))
+5 QUIT
+6 ;
NTE ;
+1 SET TEXT=$SELECT((FIELD(1)=6)&('OBXFL):"PROCOM",(FIELD(1)=7)&('OBXFL):"ADMINSTR",1:"OCRSN")
+2 SET @TEXT@(1)=$$UNESC^ORHLESC($GET(FIELD(3)))
+3 SET K=1
SET J=""
FOR
SET J=$ORDER(PSJMSG(II,J))
IF 'J
QUIT
SET K=K+1
SET @TEXT@(K)=$GET(PSJMSG(II,J))
+4 IF $DATA(OCRSN)
Begin DoDot:1
+5 SET QQ=0
FOR
SET QQ=$ORDER(OCRSN(QQ))
IF 'QQ
QUIT
SET ^TMP("PSJNVO",$JOB,10,OCCNT,2,QQ,0)=OCRSN(QQ)
End DoDot:1
+6 SET OBXFL=0
+7 QUIT
+8 ;
ZRX ;
+1 NEW ND,ND2,CHK,FOLOR,STDT
+2 SET PREON=$GET(FIELD(1))
SET ROC=$GET(FIELD(3))
SET IVCAT=$GET(FIELD(6))
+3 SET IVCAT=$SELECT(",I,C,"[(","_IVCAT_","):IVCAT,1:"")
IF 'PREON
SET IVTYP=$SELECT($GET(PSGS0XT):"P",1:"A")
SET IVTYP=$SELECT(IVCAT="I":"P",IVCAT="C":"A",1:$GET(IVTYP))
+4 SET ND=$SELECT((PREON["N")!(PREON["P"):$GET(^PS(53.1,+PREON,0)),PREON["V":$GET(^PS(55,PSJHLDFN,"IV",+PREON,0)),1:$GET(^PS(55,PSJHLDFN,5,+PREON,0)))
+5 SET ND2=$SELECT((PREON["N")!(PREON["P"):$GET(^PS(53.1,+PREON,2)),PREON["V":$GET(^PS(55,PSJHLDFN,"IV",+PREON,2)),1:$GET(^PS(55,PSJHLDFN,5,+PREON,2)))
+6 IF 'ND
IF ROC'="N"
SET PSREASON="Invalid Pharmacy order number"
DO ERROR^PSJHL9
QUIT
+7 IF ND
IF ROC="R"
SET FOLOR=$SELECT(PREON["V":$PIECE(ND2,U,6),1:$PIECE(ND,U,26))
IF FOLOR
SET PSREASON="Duplicate Renewal Request"
DO ERROR^PSJHL9
QUIT
+8 IF ND
IF ROC="R"
SET CHK=$SELECT(PREON["V":$PIECE(ND,U,17),1:$PIECE(ND,U,9))
IF "AE"'[CHK
SET PSREASON="Pharmacy orders with a status of "_CHK_" may not be renewed"
DO ERROR^PSJHL9
QUIT
+9 IF $GET(CHK)="E"
IF PREON'["V"
DO NOW^%DTC
SET X1=+$EXTRACT(%,1,12)
SET X2=-4
DO C^%DTC
SET STDT=$SELECT(PREON["V":$PIECE(ND,U,3),1:$PIECE(ND2,U,4))
IF STDT'>X
SET PSREASON="Pharmacy orders expired longer than 4 days may not be renewed"
DO ERROR^PSJHL9
QUIT
+10 IF ND
IF ROC="E"
SET FOLOR=$SELECT(PREON["V":$PIECE(ND2,U,6),1:$PIECE(ND,U,26))
IF FOLOR
SET PSREASON="Pharmacy orders may only be edited ONCE"
DO ERROR^PSJHL9
QUIT
+11 IF ND
IF ROC="E"
SET CHK=$SELECT(PREON["V":$PIECE(ND,U,17),1:$PIECE(ND,U,9))
IF "DEHO"[CHK
NEW CHKRTN
SET CHKRTN=CHK_"^PSJHL6"
DO @CHKRTN
SET PSREASON=PSREASON_" orders may not be edited"
DO ERROR^PSJHL9
QUIT
+12 IF ROC'="R"
DO VALID^PSJHL9
IF QFLG
QUIT
+13 IF $GET(PSITEM)=""
IF $DATA(^TMP("PSJNVO",$JOB,"SOL",1,0))
SET PSITEM=$PIECE($GET(^PS(52.7,+^TMP("PSJNVO",$JOB,"SOL",1,0),0)),"^",11)
+14 IF PRIORITY="ZD"
DO VALID^PSJHL10
SET QFLG=1
QUIT
+15 IF (PREON]"")&(ROC="E")
DO EDITCK^PSJHL5
IF QFLG
QUIT
+16 DO NVO^PSJHL9
+17 IF (PREON]"")&(ROC="R")
DO RENEW^PSJHL7
QUIT
+18 IF (PREON]"")&(ROC="E")
DO EDIT^PSJHL5
+19 QUIT
+20 ;
SOLSRCH ;Find solution
+1 NEW SSSS,SEG,ON,ROC,SOL,SOL2
+2 FOR SSSS=II:0
SET SSSS=$ORDER(PSJMSG(SSSS))
IF 'SSSS
QUIT
IF $PIECE(PSJMSG(SSSS),"|")="ZRX"
Begin DoDot:1
+3 SET SEG=$GET(PSJMSG(SSSS))
SET ON=$PIECE(SEG,"|",2)
SET ROC=$PIECE(SEG,"|",4)
End DoDot:1
QUIT
+4 IF $GET(ROC)'="N"
FOR SOL=0:0
SET SOL=$ORDER(^PS(55,PSJHLDFN,"IV",+ON,"SOL",SOL))
IF 'SOL
QUIT
SET SOL2=$GET(^PS(55,PSJHLDFN,"IV",+ON,"SOL",SOL,0))
IF $DATA(^PS(52.7,"AOI",PTR,+SOL2))&($PIECE(SOL2,U,2)=VOLUME)
SET SOLUTION=+SOL2
DO SET
QUIT
+5 IF 'SOLUTION
SET SOLUTION=$ORDER(^PS(52.7,"AOI",PTR,SOLUTION))
DO SET
+6 QUIT
SET ;Set solution tmp nodes
+1 IF '+SOLUTION
QUIT
+2 SET ^TMP("PSJNVO",$JOB,"SOL",0)=SOLCNT
+3 SET ^TMP("PSJNVO",$JOB,"SOL",SOLCNT,0)=SOLUTION_"^"_VOLUME
SET TVOLUME=TVOLUME+(+VOLUME)
+4 QUIT
+5 ;
SNDTSTW(PRIO,PSJSCHED,WARD) ; Test to determine if mail message should be sent.
+1 NEW SNPRIO,SNSCHD,SNOPT
+2 SET SNPRIO=$SELECT(PRIO="S":"S",PRIO="A":"A",1:"R")
+3 SET SNSCHD=$SELECT(PSJSCHED="STAT":"S",PSJSCHED="NOW":"N",1:"R")
+4 SET SNOPT=$PIECE($GET(^PS(59.6,WARD,0)),"^",32)
+5 IF SNOPT=""
SET SNOPT=$PIECE($GET(^PS(59.7,1,27)),"^",1)
+6 IF SNOPT=""
QUIT 0
+7 IF SNOPT[SNPRIO
QUIT 0
+8 IF SNOPT[SNSCHD
QUIT 0
+9 QUIT 1
+10 ;
SNDTSTP(PRIO,PSJSCHED) ; Test to determine if mail message should be sent.
+1 NEW SNPRIO,SNSCHD,SNOPT
+2 SET SNPRIO=$SELECT(PRIO="S":"S",PRIO="A":"A",1:"R")
+3 SET SNSCHD=$SELECT(PSJSCHED="STAT":"S",PSJSCHED="NOW":"N",1:"R")
+4 SET SNOPT=$PIECE($GET(^PS(59.7,1,27)),"^",1)
+5 IF SNOPT=""
QUIT 1
+6 IF SNOPT[SNPRIO
QUIT 0
+7 IF SNOPT[SNSCHD
QUIT 0
+8 QUIT 1
+9 ;
SNDTSTA(PRIO,PSJSCHED) ; Test to determine if mail message should be sent.
+1 NEW SNPRIO,SNSCHD,SNOPT
+2 SET SNPRIO=$SELECT(PRIO="S":"S",PRIO="A":"A",1:"R")
+3 SET SNSCHD=$SELECT(PSJSCHED="STAT":"S",PSJSCHED="NOW":"N",1:"R")
+4 SET SNOPT=$PIECE($GET(^PS(59.7,1,27)),"^",2)
+5 IF SNOPT=""
SET SNOPT=$PIECE($GET(^PS(59.7,1,27)),"^",1)
+6 IF SNOPT=""
QUIT 1
+7 IF SNOPT[SNPRIO
QUIT 0
+8 IF SNOPT[SNSCHD
QUIT 0
+9 QUIT 1
+10 ;
TMPAT(SCHEDULE) ; Extract admin times from schedule in format schedule@schedule
+1 SET TMPAT=""
IF SCHEDULE'["@"
QUIT TMPAT
+2 SET TMPAT=$PIECE(SCHEDULE,"@",2)
IF TMPAT]""
Begin DoDot:1
+3 NEW WARD
SET WARD=$GET(^DPT(PSJHLDFN,.1))
IF WARD]""
Begin DoDot:2
+4 NEW DIC,X,Y
SET DIC="^DIC(42,"
SET DIC(0)="BOXZ"
SET X=WARD
DO ^DIC
SET WARD=+Y
IF WARD=0
QUIT
+5 SET WARD=$ORDER(^PS(59.6,"B",WARD,0))
End DoDot:2
+6 IF '$DATA(^PS(51.1,"AC","PSJ",TMPAT))
SET TMPAT=""
QUIT
+7 NEW II
IF '$$DOW^PSIVUTL($PIECE(SCHEDULE,"@"))
SET TMPAT=""
QUIT
+8 NEW TMPIEN
SET TMPIEN=$ORDER(^PS(51.1,"AC","PSJ",TMPAT,0))
SET TMPAT=$PIECE($GET(^PS(51.1,+TMPIEN,0)),"^",2)
Begin DoDot:2
+9 IF $PIECE($GET(^PS(51.1,+TMPIEN,1,+$GET(WARD),0)),"^",2)
SET TMPAT=$PIECE($GET(^(0)),"^",2)
End DoDot:2
End DoDot:1
+10 QUIT TMPAT
+11 ;
XMD ; Mailman call for NOTIFY^PSJHL4
+1 ; Input - PNAME = Patient Name
+2 ; RTE = Route
+3 ; DRUG = Drug Name
+4 ; WARD = Ward Name
+5 ; CLINIC = Clinic Location Name
+6 ; PRIO = CPRS Order Priority
+7 SET PNAME=$PIECE($GET(^DPT(+PSJHLDFN,0)),"^")
IF $GET(RTE)
SET RTE=$PIECE(^PS(51.2,+RTE,0),"^",3)
+8 SET DRUG=$SELECT(DRIEN:$PIECE($GET(^PS(50.7,+DRIEN,0)),"^"),1:"")
SET WARD=$GET(^DPT(PSJHLDFN,.1))
+9 IF $GET(CLINIC)'=""
SET CLINIC=$PIECE($GET(^SC(CLINIC,0)),"^",2)
IF CLINIC'=""
SET WARD=CLINIC
+10 SET XMDUZ="MEDICATIONS,INPATIENT"
SET XMSUB=$GET(WARD)
+11 SET XMSUB=XMSUB_"-"_NTFSTAT_" "_$SELECT($GET(PRIO)="A":"ASAP",$GET(PRIO)="S":"STAT",$GET(NTFYREAS)=2:"NOW",$GET(NTFYREAS)=3:"STAT",1:"")_"-"
+12 SET XMSUB=XMSUB_$EXTRACT(PNAME,1,65-$LENGTH(XMSUB))
+13 SET XMTEXT="PSG("
+14 SET PSG(1,0)="Inpatient Medications has received the following "_$SELECT($GET(PRIO)="A":"ASAP",$GET(PRIO)="S":"STAT",$GET(NTFYREAS)=2:"NOW",1:"")_" order ("_NTFSTAT_")"
+15 SET PSG(2,0)=""
+16 SET PSG(3,0)=" Patient: "_PNAME
IF $GET(LASTFOUR)
SET PSG(3,0)=PSG(3,0)_" ("_LASTFOUR_")"
+17 SET PSG(4,0)="Order Information: "_DRUG_" "_DO_" "_RTE_" "_$GET(PSJSCHED)
+18 SET PSG(5,0)=" Order Date: "_$$ENDTC^PSGMI(ORDATE)
+19 DO ^XMD
+20 QUIT
