- PSJHL4A ;BIR/RLW - CONTINUE DECODE HL7 /MESSSAGE FROM OE/RR ;Mar 05, 2020@08:52:28
- ;;5.0;INPATIENT MEDICATIONS ;**105,111,154,170,159,134,197,226,263,313,331,399,442**;16 DEC 97;Build 1
- ;
- ; 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,INACT,I,SELECTED,STRGTH
- 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 D
- ..S INACT=+$G(^PS(52.7,SOLUTION,"I")) I INACT,'(INACT>DT) Q ; IV Solution is INACTIVE
- ..I +VOLUME'=+$P(^PS(52.7,SOLUTION,0),U,3) Q ; IV Solution Volume does not Match
- ..S IVFL=$P($G(^PS(52.7,SOLUTION,0)),"^",13) I 'IVFL Q ; IV Solution Not Used in the IV Fluid Order
- ..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 D
- .S STRENGTH=$G(FIELD(3))_" "_$P($G(FIELD(4)),"^",5) D
- .S ADDITIVE="",SELECTED=0
- .F S ADDITIVE=$O(^PS(52.6,"AOI",PTR,ADDITIVE)) Q:'ADDITIVE D
- ..I $G(PSITEM)="" S PSITEM=PTR
- ..I $G(^PS(52.6,ADDITIVE,0))']"" Q
- ..S INACT=$G(^PS(52.6,ADDITIVE,"I")) I INACT,'(INACT>DT) Q ; IV Additive is INACTIVE
- ..S IVFL=$P($G(^PS(52.6,ADDITIVE,0)),"^",13) I 'IVFL Q ; IV Additive Not Used in the IV Fluid Order
- ..S STRGTH=$P($G(^PS(52.6,ADDITIVE,0)),"^",15)
- ..I 'SELECTED!(+$G(FIELD(3))&(+$G(FIELD(3))=+STRGTH)) S SELECTED=ADDITIVE
- ..;Store the bag data ("" = all bag, "S" = See comment, Numeric valure = bottle #)
- .I SELECTED D
- ..S ^TMP("PSJNVO",$J,"AD",0)=ADCNT
- ..S ^TMP("PSJNVO",$J,"AD",ADCNT,0)=SELECTED_"^"_STRENGTH_"^"_$S($P($G(FIELD(5)),U)="S":"See Comments",('+$P($G(FIELD(5)),U)):"",1:$P($G(FIELD(5)),U))
- I APPL="A",'$D(^TMP("PSJNVO",$J,"AD",ADCNT,0)) S PSREASON="Can't find matching additive" D ERROR^PSJHL9 Q
- 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 PSJINDI=$$UNESC^ORHLESC($G(FIELD(20))) ;*399-IND
- 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:"") S IVTYP=$S($G(PSGS0XT):"P",1:"A") S IVTYP=$S(IVCAT="I":"P",IVCAT="C":"A",1:$G(IVTYP))
- ; HD281238 - No longer checked for PREON before setting 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
- ..;p442 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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSJHL4A 9157 printed Feb 18, 2025@23:33:22 Page 2
- PSJHL4A ;BIR/RLW - CONTINUE DECODE HL7 /MESSSAGE FROM OE/RR ;Mar 05, 2020@08:52:28
- +1 ;;5.0;INPATIENT MEDICATIONS ;**105,111,154,170,159,134,197,226,263,313,331,399,442**;16 DEC 97;Build 1
- +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,INACT,I,SELECTED,STRGTH
- +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=""
- +5 FOR
- SET SOLUTION=$ORDER(^PS(52.7,"AOI",PTR,SOLUTION))
- if 'SOLUTION
- QUIT
- Begin DoDot:2
- +6 ; IV Solution is INACTIVE
- SET INACT=+$GET(^PS(52.7,SOLUTION,"I"))
- IF INACT
- IF '(INACT>DT)
- QUIT
- +7 ; IV Solution Volume does not Match
- IF +VOLUME'=+$PIECE(^PS(52.7,SOLUTION,0),U,3)
- QUIT
- +8 ; IV Solution Not Used in the IV Fluid Order
- SET IVFL=$PIECE($GET(^PS(52.7,SOLUTION,0)),"^",13)
- IF 'IVFL
- QUIT
- +9 SET ^TMP("PSJNVO",$JOB,"SOL",0)=SOLCNT
- +10 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
- +11 IF $GET(INFRT)]""
- SET X=INFRT
- DO ENI^PSJHLU
- SET INFRT=$GET(X)
- +12 IF APPL="A"
- SET ADCNT=ADCNT+1
- SET PTR=$PIECE(FIELD(2),"^",4)
- if 'PTR
- QUIT
- Begin DoDot:1
- +13 SET STRENGTH=$GET(FIELD(3))_" "_$PIECE($GET(FIELD(4)),"^",5)
- Begin DoDot:2
- End DoDot:2
- +14 SET ADDITIVE=""
- SET SELECTED=0
- +15 FOR
- SET ADDITIVE=$ORDER(^PS(52.6,"AOI",PTR,ADDITIVE))
- if 'ADDITIVE
- QUIT
- Begin DoDot:2
- +16 IF $GET(PSITEM)=""
- SET PSITEM=PTR
- +17 IF $GET(^PS(52.6,ADDITIVE,0))']""
- QUIT
- +18 ; IV Additive is INACTIVE
- SET INACT=$GET(^PS(52.6,ADDITIVE,"I"))
- IF INACT
- IF '(INACT>DT)
- QUIT
- +19 ; IV Additive Not Used in the IV Fluid Order
- SET IVFL=$PIECE($GET(^PS(52.6,ADDITIVE,0)),"^",13)
- IF 'IVFL
- QUIT
- +20 SET STRGTH=$PIECE($GET(^PS(52.6,ADDITIVE,0)),"^",15)
- +21 IF 'SELECTED!(+$GET(FIELD(3))&(+$GET(FIELD(3))=+STRGTH))
- SET SELECTED=ADDITIVE
- +22 ;Store the bag data ("" = all bag, "S" = See comment, Numeric valure = bottle #)
- End DoDot:2
- +23 IF SELECTED
- Begin DoDot:2
- +24 SET ^TMP("PSJNVO",$JOB,"AD",0)=ADCNT
- +25 SET ^TMP("PSJNVO",$JOB,"AD",ADCNT,0)=SELECTED_"^"_STRENGTH_"^"_$SELECT($PIECE($GET(FIELD(5)),U)="S":"See Comments",('+$PIECE($GET(FIELD(5)),U)):"",1:$PIECE($GET(FIELD(5)),U))
- End DoDot:2
- End DoDot:1
- +26 IF APPL="A"
- IF '$DATA(^TMP("PSJNVO",$JOB,"AD",ADCNT,0))
- SET PSREASON="Can't find matching additive"
- DO ERROR^PSJHL9
- QUIT
- +27 QUIT
- +28 ;
- 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 ;*399-IND
- SET PSJINDI=$$UNESC^ORHLESC($GET(FIELD(20)))
- +16 SET IVLIMIT=$PIECE($GET(PSJMSG(II)),"^",3)
- +17 if IVLIMIT["doses"
- SET IVLIMIT=$TRANSLATE(IVLIMIT,"doses","a")
- +18 QUIT
- +19 ;
- 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:"")
- SET IVTYP=$SELECT($GET(PSGS0XT):"P",1:"A")
- SET IVTYP=$SELECT(IVCAT="I":"P",IVCAT="C":"A",1:$GET(IVTYP))
- +4 ; HD281238 - No longer checked for PREON before setting IVTYP
- +5 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)))
- +6 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)))
- +7 IF 'ND
- IF ROC'="N"
- SET PSREASON="Invalid Pharmacy order number"
- DO ERROR^PSJHL9
- QUIT
- +8 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
- +9 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
- +10 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
- +11 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
- +12 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
- +13 if ROC'="R"
- DO VALID^PSJHL9
- if QFLG
- QUIT
- +14 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)
- +15 IF PRIORITY="ZD"
- DO VALID^PSJHL10
- SET QFLG=1
- QUIT
- +16 IF (PREON]"")&(ROC="E")
- DO EDITCK^PSJHL5
- if QFLG
- QUIT
- +17 DO NVO^PSJHL9
- +18 IF (PREON]"")&(ROC="R")
- DO RENEW^PSJHL7
- QUIT
- +19 IF (PREON]"")&(ROC="E")
- DO EDIT^PSJHL5
- +20 QUIT
- +21 ;
- 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 ;p442 S WARD=$O(^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