PSJHL4 ;BIR/RLW-DECODE HL7 /MESSSAGE FROM OE/RR ;16 Mar 99 / 4:55 PM
;;5.0;INPATIENT MEDICATIONS;**1,12,27,34,40,42,55,47,50,56,58,98,85,105,107,110,111,154,134,197,226,279,419,399,426**;16 DEC 97;Build 4
; Reference to $$EN^PSOHLNEW is supported by DBIA# 2188.
; Reference to ^PS(50.7 is supported by DBIA 2180.
; Reference to ^PS(51.2 is supported by DBIA 2178.
; 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.
;
EN(PSJMSG) ; Start
K ^TMP("PSJNVO",$J)
N ADCNT,SOLCNT,OCCNT
N ACKDATE,ADDITIVE,ADMINSTR,APPL,COMMENT,PSJHLDFN,DISPENSE,DOSE,DURATION,II,INSTR,J,JJ,JJJ,K,LOGIN,NEWORDER,NURSEACK,OBXFL,OCNARR,OCPROV,OCRSN,ORDER,PRIORITY,PSITEM,ORDCON,PROCOM,PSJORDER,PSREASON
N LOC,PROVIDER,PSPR,PSOC,PTR,QQ,REQST,ROUTE,RXON,RXORDER,SCHEDULE,SEGMENT,SOLUTION,STPDT,STRENGTH,TEXT,CLERK,INFRT,IVTYP,SCHTYP,PREON,NOO,ROC,FREQ,CLASS,PSJHLMTN,UNIT,UNITS,QFLG,VOLUME,TVOLUME,PSGP
N PSJASTP,FLDATE,FLCMNT,PSJFLAG,PSJYN,PRNTON,APPT,IVLIMIT,IVCAT,INTRMT,PSJINDI
S (ADCNT,SOLCNT,OCCNT,II,TVOLUME)="",(OBXFL,QFLG)=0,PSJHLMTN="ORR" F S II=$O(PSJMSG(II)) Q:'II D DECODE Q:QFLG D @FIELD(0) Q:$G(CLASS)="O" Q:QFLG
I ($G(CLASS)'="I")!(QFLG) G END
I ($G(PSOC)="NW")!($G(PSOC)="XO") N DIK,DA S DIK="^PS(53.1,",DA=NEWORDER D EN1^DIK L -^PS(53.1,NEWORDER)
I ($G(PSOC)="NW")!($G(PSOC)="XO") D EN1^PSJHL2(PSJHLDFN,$S(PSOC="NW":"OK",1:"XR"),NEWORDER_"P")
END ;
K ^TMP("PSJNVO",$J)
I (",S,A,")[(","_$G(PRIORITY)_",")!($G(SCHEDULE)="NOW")!($G(SCHEDULE)["STAT") D
. I $G(PRIORITY)="ZD",$G(PSGORD) D NOTIFY(PSGORD_$S(PSGORD["V":"V",PSGORD["U":"U",1:""),PSJHLDFN,$G(PRIORITY),$G(SCHEDULE))
. I $G(NEWORDER) D NOTIFY(NEWORDER_"P",PSJHLDFN,$G(PRIORITY),$G(SCHEDULE))
I $G(NEWORDER),$G(^PS(53.1,+NEWORDER,"DSS")) D NOCLDEF^PSJBCMA6(PSJHLDFN,+NEWORDER_"P")
Q
DECODE ; Parse into fields
K FIELD
N PSJCTR1 S PSJCTR1=""
S SEGMENT=$G(PSJMSG(II))
I $D(PSJMSG(II,1)),$P(SEGMENT,"|",1)="ORC" F S PSJCTR1=$O(PSJMSG(II,PSJCTR1)) Q:PSJCTR1="" D
. S SEGMENT=SEGMENT_PSJMSG(II,PSJCTR1) ;Handle CPRS "overflow" ORC nodes
I $D(PSJMSG(II,1)),$P(SEGMENT,"|",1)="OBX" S PSJCTR1="" F S PSJCTR1=$O(PSJMSG(II,PSJCTR1)) Q:PSJCTR1="" D
. S SEGMENT=SEGMENT_PSJMSG(II,PSJCTR1) ;Handle CPRS "overflow" OBX nodes
S J=0
F Q:$G(SEGMENT)="" D
.I SEGMENT["|" S FIELD(J)=$P(SEGMENT,"|"),SEGMENT=$E(SEGMENT,$L(FIELD(J))+2,$L(SEGMENT)),J=J+1 Q
.I SEGMENT'["|" S FIELD(J)=SEGMENT,SEGMENT="" Q
K PSJCTR1
Q
NOTIFY(ORDER,PSJHLDFN,PRIO,PSJSCHED) ; Send msg
N NTFYREAS,WARD,MGROUP,NTFSTAT,DRUG,DRIEN,PNAME,ORDATE,DO,PSG,XMY,VADPT,LASTFOUR,PSJSOK,CLINIC
Q:($G(PRIO)=""&($G(PSJSCHED)=""))
S DFN=PSJHLDFN D DEM^VADPT S LASTFOUR=$P($P(VADM(2),"^",2),"-",3)
S NTFYREAS=$S((",S,A,")[(","_PRIO_","):1,($G(PSJSCHED)="NOW"):2,($G(PSJSCHED)="STAT"):3,1:0) Q:'NTFYREAS
S PSJSOK=1
I ORDER["P" D PND
I ORDER["U" D UD
I ORDER["V" D IV
Q:PSJSOK=1
D XMD^PSJHL4A
Q
PND ; Pending
N WARD,WDPARM,MGRP
Q:'$D(^PS(53.1,+ORDER,0))
S CLINIC=$P($G(^PS(53.1,+ORDER,"DSS")),"^",1)
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)) Q:+WARD=0
.Q:$$SNDTSTW^PSJHL4A(PRIO,PSJSCHED,WARD)
.S WDPARM=$G(^PS(59.6,+WARD,0)),MGRP=$P(WDPARM,"^",30) Q:+MGRP=0
.S MGRP=$$GET1^DIQ(3.8,MGRP,.01) I MGRP]"" S XMY("G."_MGRP_"@"_$G(^XMB("NETNAME")))="",PSJSOK=0
S:'$$SNDTSTP^PSJHL4A(PRIO,PSJSCHED) MGROUP="G.PSJ STAT NOW PENDING ORDER@"_$G(^XMB("NETNAME")),XMY(MGROUP)="",PSJSOK=0
S NTFSTAT="PENDING"
N NDP2,ND0 S NDP2=$G(^PS(53.1,+ORDER,.2)),ND0=$G(^PS(53.1,+ORDER,0))
S DRIEN=+$P(NDP2,"^"),DO=$P(NDP2,"^",2),RTE=$P(ND0,"^",3),ORDATE=$P(ND0,"^",14)
S SCHED=$P($G(^PS(53.1,+ORDER,2)),"^")
Q
UD ; UD
N WARD,WDPARM,MGRP
Q:'$D(^PS(55,PSJHLDFN,5,+ORDER,0))
S CLINIC=$P($G(^PS(55,PSJHLDFN,5,+ORDER,8)),"^",1)
S WARD=$P($G(^PS(55,PSJHLDFN,5,+ORDER,0)),"^",23) I +WARD D
.S WARD=$O(^PS(59.6,"B",WARD,0)) Q:+WARD=0
.Q:$$SNDTSTW^PSJHL4A(PRIO,PSJSCHED,WARD)
.S WDPARM=$G(^PS(59.6,+WARD,0)),MGRP=$P(WDPARM,"^",30) Q:+MGRP=0
.S MGRP=$$GET1^DIQ(3.8,MGRP,.01) I MGRP]"" S XMY("G."_MGRP_"@"_$G(^XMB("NETNAME")))="",PSJSOK=0
S:'$$SNDTSTA^PSJHL4A(PRIO,PSJSCHED) MGROUP="G.PSJ STAT NOW ACTIVE ORDER@"_$G(^XMB("NETNAME")),XMY(MGROUP)="",PSJSOK=0
S NTFSTAT="ACTIVE"
N ND2,ND0 S ND0=$G(^PS(55,PSJHLDFN,5,+ORDER,0)),ND2=$G(^PS(55,PSJHLDFN,5,+ORDER,2)),NDP2=$G(^PS(55,PSJHLDFN,5,+ORDER,.2))
S DRIEN=+$P(NDP2,"^"),DO=$P(NDP2,"^",2),RTE=$P(ND0,"^",3),ORDATE=$P(ND0,"^",14)
S SCHED=$P(ND2,"^")
Q
IV ; IV
N WARD,WDPARM,MGRP
Q:'$D(^PS(55,PSJHLDFN,"IV",+ORDER,0))
S CLINIC=$P($G(^PS(55,PSJHLDFN,"IV",+ORDER,"DSS")),"^",1)
S WARD=$P($G(^PS(55,PSJHLDFN,"IV",+ORDER,0)),"^",22) I +WARD D
.S WARD=$O(^PS(59.6,"B",WARD,0)) Q:+WARD=0
.Q:$$SNDTSTW^PSJHL4A(PRIO,PSJSCHED,WARD)
.S WDPARM=$G(^PS(59.6,+WARD,0)),MGRP=$P(WDPARM,"^",30) Q:+MGRP=0
.S MGRP=$$GET1^DIQ(3.8,MGRP,.01) I MGRP]"" S XMY("G."_MGRP_"@"_$G(^XMB("NETNAME")))="",PSJSOK=0
S:'$$SNDTSTA^PSJHL4A(PRIO,PSJSCHED) MGROUP="G.PSJ STAT NOW ACTIVE ORDER@"_$G(^XMB("NETNAME")),XMY(MGROUP)="",PSJSOK=0
S NTFSTAT="ACTIVE"
N ND2,NDP2,ND0 S ND0=$G(^PS(55,PSJHLDFN,"IV",+ORDER,0)),ND2=$G(^PS(55,PSJHLDFN,"IV",+ORDER,2))
S NDP2=$G(^PS(55,PSJHLDFN,"IV",+ORDER,.2))
S DRIEN=$P(NDP2,"^"),DO=$P(NDP2,"^",2),RTE=$P(NDP2,"^",3)
S ORDATE=$P(ND2,"^"),SCHED=$P(ND0,"^",9)
Q
MSH ; Header
S PSOC=FIELD(8)
Q
PID ; ID
S PSJHLDFN=$$UNESC^ORHLESC(FIELD(3))
Q
PV1 ; Visit
N A
S CLASS=FIELD(2),LOC=$P(FIELD(3),"^"),APPT="" I $G(FIELD(44))]"" S APPT=+$$HL7TFM^XLFDT(FIELD(44))
I "IO"'[CLASS S PSREASON="Invalid patient class" Q
N QQ K PSJNVA S QQ=II F S QQ=$O(PSJMSG(QQ)) Q:'QQ D Q:$G(PSJNVA)
.S X=$G(PSJMSG(QQ))
.I $P(X,"|")="ZRN" S PSJNVA=1,CLASS="O" D EN^PSOHLNEW(.PSJMSG)
I $G(PSJNVA) K PSJNVA Q
I CLASS="O" N QQ S QQ=II F S QQ=$O(PSJMSG(QQ)) Q:'QQ I $P(PSJMSG(QQ),"|")="OBR" D Q:$P(PSJMSG(QQ),"|")="OBR"
.S RXON=$P(PSJMSG(QQ),"|",4) I RXON]"" S RXON=$P(RXON,"^") I "ABNPUV"[$E(RXON,$L(RXON)) S CLASS="I"
I CLASS="O" N QQ S QQ=II F S QQ=$O(PSJMSG(QQ)) Q:'QQ I $P(PSJMSG(QQ),"|")="ORC" D Q:$P(PSJMSG(QQ),"|")="ORC"
.S RXON=$P(PSJMSG(QQ),"|",4) I RXON]"" S RXON=$P(RXON,"^") I "ABNPUV"[$E(RXON,$L(RXON)) S CLASS="I"
I CLASS="O" N CHK,QQ S QQ=II F S QQ=$O(PSJMSG(QQ)) Q:'QQ I $P(PSJMSG(QQ),"|")="RXO" D Q:$P(PSJMSG(QQ),"|")="RXO"
.S CHK=$P(PSJMSG(QQ),"|",2),CHK=$S($P(CHK,"^",5)="IV":"IV",1:$P(CHK,"^",4))
.I CHK="IV" S CLASS="I" Q
.I 'CHK S PSREASON="Missing or Invalid Orderable Item",CLASS="I" Q
.I $P($G(^PS(50.7,CHK,0)),"^",3)=1 S CLASS="I" Q
D:CLASS="O" EN^PSOHLNEW(.PSJMSG)
Q
ORC ; Order
S TMPAT=""
S PSOC=FIELD(1)
S ORDER=FIELD(2)
I $G(PSREASON)]"" D ERROR^PSJHL9 Q
S PSJORDER=$P(FIELD(2),"^"),RXON=$P(FIELD(3),"^"),RXORDER=$S((RXON["N")!(RXON["P"):"^PS(53.1,"_+RXON_",",RXON["V":"^PS(55,"_PSJHLDFN_",""IV"","_+RXON_",",1:"^PS(55,"_PSJHLDFN_",5,"_+RXON_",")
;
; Resetting Nurse Verification Fields to sync-up CPRS & BCMA (Skips DC'd and Expired orders)
I PSOC'="DC",PSOC'="SS",$G(PSJHLDFN),$G(RXON),RXON["V"!(RXON["U") D
. N PSJORSTS
. S PSJORSTS=$S(RXON["V":$$GET1^DIQ(55.01,+RXON_","_PSJHLDFN,100,"I"),1:$$GET1^DIQ(55.06,+RXON_","_PSJHLDFN,28,"I"))
. I PSJORSTS="E"!(PSJORSTS="D") Q
. D DELNV^PSJUTL3(PSJHLDFN,RXON)
;
I PSOC="NA" D ASSIGN^PSJHL5 Q
S CLERK=+$G(FIELD(10))
S PROVIDER=+$G(FIELD(12)) D:PSOC="NW"
.I PROVIDER=0 S PSREASON="Invalid Provider" D ERROR^PSJHL9 Q
.I PROVIDER>0 S PSPR=$G(^VA(200,+PROVIDER,"PS")) I '$D(PSPR)!'(PSPR)!$S($P(PSPR,"^",4)="":0,1:$P(PSPR,"^",4)'>DT) S PSREASON="Invalid Provider" D ERROR^PSJHL9 Q
S UNITS=$P(FIELD(7),"^"),INSTR=$$UNESC^ORHLESC($P(FIELD(7),"^",8))
S:UNITS["&" DOSE=$P(UNITS,"&"),UNIT=$P(UNITS,"&",2),UNITS=$P(UNITS,"&",3) S:UNITS]"" UNITS=$$UNESC^ORHLESC(UNITS) S:$G(DOSE)]"" DOSE=$$UNESC^ORHLESC(DOSE)
S SCHEDULE=$P(FIELD(7),"^",2),PRIORITY=$P(FIELD(7),"^",6) S:SCHEDULE["PRN" SCHTYP="P"
I SCHEDULE["&" S ADMINS=$P(SCHEDULE,"&",2),SCHEDULE=$P(SCHEDULE,"&") S ADMINS=$TR(ADMINS," ","") S ADMINS=$S(ADMINS:ADMINS,1:"")
S SCHEDULE=$$UNESC^ORHLESC(SCHEDULE)
I SCHEDULE["@" S TMPAT=$$TMPAT^PSJHL4A(SCHEDULE)
I $G(TMPAT) S $P(SCHEDULE,"@",2)=TMPAT,ADMINS=TMPAT
S DURATION=$P(FIELD(7),"^",3),REQST=$P(FIELD(7),"^",4) S:REQST'="" REQST=+$E(+$$HL7TFM^XLFDT(REQST),1,12) S REQST=$$DATE2^PSJUTL2(REQST)
S PRIORITY=$S($G(PRIORITY)]"":PRIORITY,1:"R")
I $E(SCHEDULE,1)=" " S:$TR(SCHEDULE," ")="PRN" SCHEDULE="PRN" I '(SCHEDULE="PRN") S PSREASON="Invalid Schedule" D ERROR^PSJHL9 Q
S SCHTYP=$P(FIELD(7),"^",7)
I $G(SCHTYP)="D" S SCHTYP="C" ;Makes CPRS Day of Week consistent in behavior with backdoor order of Day of Week
S PRNTON=$P(FIELD(8),"^")
S NURSEACK=$G(FIELD(11))
S LOGIN=$G(FIELD(15)) S:LOGIN'="" LOGIN=+$E(+$$HL7TFM^XLFDT(FIELD(15)),1,12) S LOGIN=$$DATE2^PSJUTL2(LOGIN)
S:$G(NURSEACK)]"" ACKDATE=LOGIN
S ORDCON=$P($G(FIELD(16)),U) I ORDCON="A" S PSJASTP=$G(FIELD(9)) S:$G(PSJASTP)'="" PSJASTP=+$E(+$$HL7TFM^XLFDT(PSJASTP),1,12) S PSJASTP=$$DATE2^PSJUTL2(PSJASTP)
I (PSOC="CA")!(PSOC="DC") D CANCEL^PSJHL6 Q
I PSOC="HD" D HOLD^PSJHL6 Q
I PSOC="RL" D UNHOLD^PSJHL6 Q
I PSOC="ZV" D NURSEACK^PSJHL5 Q
I PSOC="SS" D STATUS^PSJHL5 Q
;Commented line below since ^PSJHL8 doesn't exist.
;I PSOC="Z@" N X S X="PSJHL8" X ^%ZOSF("TEST") I D PURGE^PSJHL8 Q
I PSOC="DE" S QFLG=1 Q
Q
OBR ; Flagging from CPRS.
S ORDER=FIELD(2)
S PSJORDER=$P(FIELD(2),"^"),RXON=$P(FIELD(3),"^"),RXORDER=$S((RXON["N")!(RXON["P"):"^PS(53.1,"_+RXON_",",RXON["V":"^PS(55,"_PSJHLDFN_",""IV"","_+RXON_",",1:"^PS(55,"_PSJHLDFN_",5,"_+RXON_",")
S PSJFLAG=FIELD(4)
S FLDATE=$G(FIELD(7)) S:FLDATE'="" FLDATE=+$E(+$$HL7TFM^XLFDT(FIELD(7)),1,12) S FLDATE=$$DATE2^PSJUTL2(FLDATE)
S CLERK=+$G(FIELD(16))
S PSJYN=$G(FIELD(24))
S FLCMNT=$$UNESC^ORHLESC($G(FIELD(13)))
I PSOC="ORU" D FLAG^PSJHL5
Q
RXC ; IV
D RXC^PSJHL4A
Q
RXO ; OP
D RXO^PSJHL4A
Q
RXR ; Route
S ROUTE=$P(FIELD(1),"^",4)
Q
OBX ; Obs.
D OBX^PSJHL4A
Q
NTE ; Note
D NTE^PSJHL4A
Q
ZRX ; Custom
D ZRX^PSJHL4A
Q
ZSC ;Service Connected - Not Used
Q
ZRN ;Non-VA Med (Herbal/OTC)
S CLASS="O" D EN^PSOHLNEW(.PSJMSG)
Q
DG1 ;Billing Awareness - Not used
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSJHL4 10304 printed Sep 23, 2025@19:43:05 Page 2
PSJHL4 ;BIR/RLW-DECODE HL7 /MESSSAGE FROM OE/RR ;16 Mar 99 / 4:55 PM
+1 ;;5.0;INPATIENT MEDICATIONS;**1,12,27,34,40,42,55,47,50,56,58,98,85,105,107,110,111,154,134,197,226,279,419,399,426**;16 DEC 97;Build 4
+2 ; Reference to $$EN^PSOHLNEW is supported by DBIA# 2188.
+3 ; Reference to ^PS(50.7 is supported by DBIA 2180.
+4 ; Reference to ^PS(51.2 is supported by DBIA 2178.
+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 ;
EN(PSJMSG) ; Start
+1 KILL ^TMP("PSJNVO",$JOB)
+2 NEW ADCNT,SOLCNT,OCCNT
+3 NEW ACKDATE,ADDITIVE,ADMINSTR,APPL,COMMENT,PSJHLDFN,DISPENSE,DOSE,DURATION,II,INSTR,J,JJ,JJJ,K,LOGIN,NEWORDER,NURSEACK,OBXFL,OCNARR,OCPROV,OCRSN,ORDER,PRIORITY,PSITEM,ORDCON,PROCOM,PSJORDER,PSREASON
+4 NEW LOC,PROVIDER,PSPR,PSOC,PTR,QQ,REQST,ROUTE,RXON,RXORDER,SCHEDULE,SEGMENT,SOLUTION,STPDT,STRENGTH,TEXT,CLERK,INFRT,IVTYP,SCHTYP,PREON,NOO,ROC,FREQ,CLASS,PSJHLMTN,UNIT,UNITS,QFLG,VOLUME,TVOLUME,PSGP
+5 NEW PSJASTP,FLDATE,FLCMNT,PSJFLAG,PSJYN,PRNTON,APPT,IVLIMIT,IVCAT,INTRMT,PSJINDI
+6 SET (ADCNT,SOLCNT,OCCNT,II,TVOLUME)=""
SET (OBXFL,QFLG)=0
SET PSJHLMTN="ORR"
FOR
SET II=$ORDER(PSJMSG(II))
if 'II
QUIT
DO DECODE
if QFLG
QUIT
DO @FIELD(0)
if $GET(CLASS)="O"
QUIT
if QFLG
QUIT
+7 IF ($GET(CLASS)'="I")!(QFLG)
GOTO END
+8 IF ($GET(PSOC)="NW")!($GET(PSOC)="XO")
NEW DIK,DA
SET DIK="^PS(53.1,"
SET DA=NEWORDER
DO EN1^DIK
LOCK -^PS(53.1,NEWORDER)
+9 IF ($GET(PSOC)="NW")!($GET(PSOC)="XO")
DO EN1^PSJHL2(PSJHLDFN,$SELECT(PSOC="NW":"OK",1:"XR"),NEWORDER_"P")
END ;
+1 KILL ^TMP("PSJNVO",$JOB)
+2 IF (",S,A,")[(","_$GET(PRIORITY)_",")!($GET(SCHEDULE)="NOW")!($GET(SCHEDULE)["STAT")
Begin DoDot:1
+3 IF $GET(PRIORITY)="ZD"
IF $GET(PSGORD)
DO NOTIFY(PSGORD_$SELECT(PSGORD["V":"V",PSGORD["U":"U",1:""),PSJHLDFN,$GET(PRIORITY),$GET(SCHEDULE))
+4 IF $GET(NEWORDER)
DO NOTIFY(NEWORDER_"P",PSJHLDFN,$GET(PRIORITY),$GET(SCHEDULE))
End DoDot:1
+5 IF $GET(NEWORDER)
IF $GET(^PS(53.1,+NEWORDER,"DSS"))
DO NOCLDEF^PSJBCMA6(PSJHLDFN,+NEWORDER_"P")
+6 QUIT
DECODE ; Parse into fields
+1 KILL FIELD
+2 NEW PSJCTR1
SET PSJCTR1=""
+3 SET SEGMENT=$GET(PSJMSG(II))
+4 IF $DATA(PSJMSG(II,1))
IF $PIECE(SEGMENT,"|",1)="ORC"
FOR
SET PSJCTR1=$ORDER(PSJMSG(II,PSJCTR1))
if PSJCTR1=""
QUIT
Begin DoDot:1
+5 ;Handle CPRS "overflow" ORC nodes
SET SEGMENT=SEGMENT_PSJMSG(II,PSJCTR1)
End DoDot:1
+6 IF $DATA(PSJMSG(II,1))
IF $PIECE(SEGMENT,"|",1)="OBX"
SET PSJCTR1=""
FOR
SET PSJCTR1=$ORDER(PSJMSG(II,PSJCTR1))
if PSJCTR1=""
QUIT
Begin DoDot:1
+7 ;Handle CPRS "overflow" OBX nodes
SET SEGMENT=SEGMENT_PSJMSG(II,PSJCTR1)
End DoDot:1
+8 SET J=0
+9 FOR
if $GET(SEGMENT)=""
QUIT
Begin DoDot:1
+10 IF SEGMENT["|"
SET FIELD(J)=$PIECE(SEGMENT,"|")
SET SEGMENT=$EXTRACT(SEGMENT,$LENGTH(FIELD(J))+2,$LENGTH(SEGMENT))
SET J=J+1
QUIT
+11 IF SEGMENT'["|"
SET FIELD(J)=SEGMENT
SET SEGMENT=""
QUIT
End DoDot:1
+12 KILL PSJCTR1
+13 QUIT
NOTIFY(ORDER,PSJHLDFN,PRIO,PSJSCHED) ; Send msg
+1 NEW NTFYREAS,WARD,MGROUP,NTFSTAT,DRUG,DRIEN,PNAME,ORDATE,DO,PSG,XMY,VADPT,LASTFOUR,PSJSOK,CLINIC
+2 if ($GET(PRIO)=""&($GET(PSJSCHED)=""))
QUIT
+3 SET DFN=PSJHLDFN
DO DEM^VADPT
SET LASTFOUR=$PIECE($PIECE(VADM(2),"^",2),"-",3)
+4 SET NTFYREAS=$SELECT((",S,A,")[(","_PRIO_","):1,($GET(PSJSCHED)="NOW"):2,($GET(PSJSCHED)="STAT"):3,1:0)
if 'NTFYREAS
QUIT
+5 SET PSJSOK=1
+6 IF ORDER["P"
DO PND
+7 IF ORDER["U"
DO UD
+8 IF ORDER["V"
DO IV
+9 if PSJSOK=1
QUIT
+10 DO XMD^PSJHL4A
+11 QUIT
PND ; Pending
+1 NEW WARD,WDPARM,MGRP
+2 if '$DATA(^PS(53.1,+ORDER,0))
QUIT
+3 SET CLINIC=$PIECE($GET(^PS(53.1,+ORDER,"DSS")),"^",1)
+4 SET WARD=$GET(^DPT(PSJHLDFN,.1))
IF WARD]""
Begin DoDot:1
+5 NEW DIC,X,Y
SET DIC="^DIC(42,"
SET DIC(0)="BOXZ"
SET X=WARD
DO ^DIC
SET WARD=+Y
if WARD=0
QUIT
+6 SET WARD=$ORDER(^PS(59.6,"B",WARD,0))
if +WARD=0
QUIT
+7 if $$SNDTSTW^PSJHL4A(PRIO,PSJSCHED,WARD)
QUIT
+8 SET WDPARM=$GET(^PS(59.6,+WARD,0))
SET MGRP=$PIECE(WDPARM,"^",30)
if +MGRP=0
QUIT
+9 SET MGRP=$$GET1^DIQ(3.8,MGRP,.01)
IF MGRP]""
SET XMY("G."_MGRP_"@"_$GET(^XMB("NETNAME")))=""
SET PSJSOK=0
End DoDot:1
+10 if '$$SNDTSTP^PSJHL4A(PRIO,PSJSCHED)
SET MGROUP="G.PSJ STAT NOW PENDING ORDER@"_$GET(^XMB("NETNAME"))
SET XMY(MGROUP)=""
SET PSJSOK=0
+11 SET NTFSTAT="PENDING"
+12 NEW NDP2,ND0
SET NDP2=$GET(^PS(53.1,+ORDER,.2))
SET ND0=$GET(^PS(53.1,+ORDER,0))
+13 SET DRIEN=+$PIECE(NDP2,"^")
SET DO=$PIECE(NDP2,"^",2)
SET RTE=$PIECE(ND0,"^",3)
SET ORDATE=$PIECE(ND0,"^",14)
+14 SET SCHED=$PIECE($GET(^PS(53.1,+ORDER,2)),"^")
+15 QUIT
UD ; UD
+1 NEW WARD,WDPARM,MGRP
+2 if '$DATA(^PS(55,PSJHLDFN,5,+ORDER,0))
QUIT
+3 SET CLINIC=$PIECE($GET(^PS(55,PSJHLDFN,5,+ORDER,8)),"^",1)
+4 SET WARD=$PIECE($GET(^PS(55,PSJHLDFN,5,+ORDER,0)),"^",23)
IF +WARD
Begin DoDot:1
+5 SET WARD=$ORDER(^PS(59.6,"B",WARD,0))
if +WARD=0
QUIT
+6 if $$SNDTSTW^PSJHL4A(PRIO,PSJSCHED,WARD)
QUIT
+7 SET WDPARM=$GET(^PS(59.6,+WARD,0))
SET MGRP=$PIECE(WDPARM,"^",30)
if +MGRP=0
QUIT
+8 SET MGRP=$$GET1^DIQ(3.8,MGRP,.01)
IF MGRP]""
SET XMY("G."_MGRP_"@"_$GET(^XMB("NETNAME")))=""
SET PSJSOK=0
End DoDot:1
+9 if '$$SNDTSTA^PSJHL4A(PRIO,PSJSCHED)
SET MGROUP="G.PSJ STAT NOW ACTIVE ORDER@"_$GET(^XMB("NETNAME"))
SET XMY(MGROUP)=""
SET PSJSOK=0
+10 SET NTFSTAT="ACTIVE"
+11 NEW ND2,ND0
SET ND0=$GET(^PS(55,PSJHLDFN,5,+ORDER,0))
SET ND2=$GET(^PS(55,PSJHLDFN,5,+ORDER,2))
SET NDP2=$GET(^PS(55,PSJHLDFN,5,+ORDER,.2))
+12 SET DRIEN=+$PIECE(NDP2,"^")
SET DO=$PIECE(NDP2,"^",2)
SET RTE=$PIECE(ND0,"^",3)
SET ORDATE=$PIECE(ND0,"^",14)
+13 SET SCHED=$PIECE(ND2,"^")
+14 QUIT
IV ; IV
+1 NEW WARD,WDPARM,MGRP
+2 if '$DATA(^PS(55,PSJHLDFN,"IV",+ORDER,0))
QUIT
+3 SET CLINIC=$PIECE($GET(^PS(55,PSJHLDFN,"IV",+ORDER,"DSS")),"^",1)
+4 SET WARD=$PIECE($GET(^PS(55,PSJHLDFN,"IV",+ORDER,0)),"^",22)
IF +WARD
Begin DoDot:1
+5 SET WARD=$ORDER(^PS(59.6,"B",WARD,0))
if +WARD=0
QUIT
+6 if $$SNDTSTW^PSJHL4A(PRIO,PSJSCHED,WARD)
QUIT
+7 SET WDPARM=$GET(^PS(59.6,+WARD,0))
SET MGRP=$PIECE(WDPARM,"^",30)
if +MGRP=0
QUIT
+8 SET MGRP=$$GET1^DIQ(3.8,MGRP,.01)
IF MGRP]""
SET XMY("G."_MGRP_"@"_$GET(^XMB("NETNAME")))=""
SET PSJSOK=0
End DoDot:1
+9 if '$$SNDTSTA^PSJHL4A(PRIO,PSJSCHED)
SET MGROUP="G.PSJ STAT NOW ACTIVE ORDER@"_$GET(^XMB("NETNAME"))
SET XMY(MGROUP)=""
SET PSJSOK=0
+10 SET NTFSTAT="ACTIVE"
+11 NEW ND2,NDP2,ND0
SET ND0=$GET(^PS(55,PSJHLDFN,"IV",+ORDER,0))
SET ND2=$GET(^PS(55,PSJHLDFN,"IV",+ORDER,2))
+12 SET NDP2=$GET(^PS(55,PSJHLDFN,"IV",+ORDER,.2))
+13 SET DRIEN=$PIECE(NDP2,"^")
SET DO=$PIECE(NDP2,"^",2)
SET RTE=$PIECE(NDP2,"^",3)
+14 SET ORDATE=$PIECE(ND2,"^")
SET SCHED=$PIECE(ND0,"^",9)
+15 QUIT
MSH ; Header
+1 SET PSOC=FIELD(8)
+2 QUIT
PID ; ID
+1 SET PSJHLDFN=$$UNESC^ORHLESC(FIELD(3))
+2 QUIT
PV1 ; Visit
+1 NEW A
+2 SET CLASS=FIELD(2)
SET LOC=$PIECE(FIELD(3),"^")
SET APPT=""
IF $GET(FIELD(44))]""
SET APPT=+$$HL7TFM^XLFDT(FIELD(44))
+3 IF "IO"'[CLASS
SET PSREASON="Invalid patient class"
QUIT
+4 NEW QQ
KILL PSJNVA
SET QQ=II
FOR
SET QQ=$ORDER(PSJMSG(QQ))
if 'QQ
QUIT
Begin DoDot:1
+5 SET X=$GET(PSJMSG(QQ))
+6 IF $PIECE(X,"|")="ZRN"
SET PSJNVA=1
SET CLASS="O"
DO EN^PSOHLNEW(.PSJMSG)
End DoDot:1
if $GET(PSJNVA)
QUIT
+7 IF $GET(PSJNVA)
KILL PSJNVA
QUIT
+8 IF CLASS="O"
NEW QQ
SET QQ=II
FOR
SET QQ=$ORDER(PSJMSG(QQ))
if 'QQ
QUIT
IF $PIECE(PSJMSG(QQ),"|")="OBR"
Begin DoDot:1
+9 SET RXON=$PIECE(PSJMSG(QQ),"|",4)
IF RXON]""
SET RXON=$PIECE(RXON,"^")
IF "ABNPUV"[$EXTRACT(RXON,$LENGTH(RXON))
SET CLASS="I"
End DoDot:1
if $PIECE(PSJMSG(QQ),"|")="OBR"
QUIT
+10 IF CLASS="O"
NEW QQ
SET QQ=II
FOR
SET QQ=$ORDER(PSJMSG(QQ))
if 'QQ
QUIT
IF $PIECE(PSJMSG(QQ),"|")="ORC"
Begin DoDot:1
+11 SET RXON=$PIECE(PSJMSG(QQ),"|",4)
IF RXON]""
SET RXON=$PIECE(RXON,"^")
IF "ABNPUV"[$EXTRACT(RXON,$LENGTH(RXON))
SET CLASS="I"
End DoDot:1
if $PIECE(PSJMSG(QQ),"|")="ORC"
QUIT
+12 IF CLASS="O"
NEW CHK,QQ
SET QQ=II
FOR
SET QQ=$ORDER(PSJMSG(QQ))
if 'QQ
QUIT
IF $PIECE(PSJMSG(QQ),"|")="RXO"
Begin DoDot:1
+13 SET CHK=$PIECE(PSJMSG(QQ),"|",2)
SET CHK=$SELECT($PIECE(CHK,"^",5)="IV":"IV",1:$PIECE(CHK,"^",4))
+14 IF CHK="IV"
SET CLASS="I"
QUIT
+15 IF 'CHK
SET PSREASON="Missing or Invalid Orderable Item"
SET CLASS="I"
QUIT
+16 IF $PIECE($GET(^PS(50.7,CHK,0)),"^",3)=1
SET CLASS="I"
QUIT
End DoDot:1
if $PIECE(PSJMSG(QQ),"|")="RXO"
QUIT
+17 if CLASS="O"
DO EN^PSOHLNEW(.PSJMSG)
+18 QUIT
ORC ; Order
+1 SET TMPAT=""
+2 SET PSOC=FIELD(1)
+3 SET ORDER=FIELD(2)
+4 IF $GET(PSREASON)]""
DO ERROR^PSJHL9
QUIT
+5 SET PSJORDER=$PIECE(FIELD(2),"^")
SET RXON=$PIECE(FIELD(3),"^")
SET RXORDER=$SELECT((RXON["N")!(RXON["P"):"^PS(53.1,"_+RXON_",",RXON["V":"^PS(55,"_PSJHLDFN_",""IV"","_+RXON_",",1:"^PS(55,"_PSJHLDFN_",5,"_+RXON_",")
+6 ;
+7 ; Resetting Nurse Verification Fields to sync-up CPRS & BCMA (Skips DC'd and Expired orders)
+8 IF PSOC'="DC"
IF PSOC'="SS"
IF $GET(PSJHLDFN)
IF $GET(RXON)
IF RXON["V"!(RXON["U")
Begin DoDot:1
+9 NEW PSJORSTS
+10 SET PSJORSTS=$SELECT(RXON["V":$$GET1^DIQ(55.01,+RXON_","_PSJHLDFN,100,"I"),1:$$GET1^DIQ(55.06,+RXON_","_PSJHLDFN,28,"I"))
+11 IF PSJORSTS="E"!(PSJORSTS="D")
QUIT
+12 DO DELNV^PSJUTL3(PSJHLDFN,RXON)
End DoDot:1
+13 ;
+14 IF PSOC="NA"
DO ASSIGN^PSJHL5
QUIT
+15 SET CLERK=+$GET(FIELD(10))
+16 SET PROVIDER=+$GET(FIELD(12))
if PSOC="NW"
Begin DoDot:1
+17 IF PROVIDER=0
SET PSREASON="Invalid Provider"
DO ERROR^PSJHL9
QUIT
+18 IF PROVIDER>0
SET PSPR=$GET(^VA(200,+PROVIDER,"PS"))
IF '$DATA(PSPR)!'(PSPR)!$SELECT($PIECE(PSPR,"^",4)="":0,1:$PIECE(PSPR,"^",4)'>DT)
SET PSREASON="Invalid Provider"
DO ERROR^PSJHL9
QUIT
End DoDot:1
+19 SET UNITS=$PIECE(FIELD(7),"^")
SET INSTR=$$UNESC^ORHLESC($PIECE(FIELD(7),"^",8))
+20 if UNITS["&"
SET DOSE=$PIECE(UNITS,"&")
SET UNIT=$PIECE(UNITS,"&",2)
SET UNITS=$PIECE(UNITS,"&",3)
if UNITS]""
SET UNITS=$$UNESC^ORHLESC(UNITS)
if $GET(DOSE)]""
SET DOSE=$$UNESC^ORHLESC(DOSE)
+21 SET SCHEDULE=$PIECE(FIELD(7),"^",2)
SET PRIORITY=$PIECE(FIELD(7),"^",6)
if SCHEDULE["PRN"
SET SCHTYP="P"
+22 IF SCHEDULE["&"
SET ADMINS=$PIECE(SCHEDULE,"&",2)
SET SCHEDULE=$PIECE(SCHEDULE,"&")
SET ADMINS=$TRANSLATE(ADMINS," ","")
SET ADMINS=$SELECT(ADMINS:ADMINS,1:"")
+23 SET SCHEDULE=$$UNESC^ORHLESC(SCHEDULE)
+24 IF SCHEDULE["@"
SET TMPAT=$$TMPAT^PSJHL4A(SCHEDULE)
+25 IF $GET(TMPAT)
SET $PIECE(SCHEDULE,"@",2)=TMPAT
SET ADMINS=TMPAT
+26 SET DURATION=$PIECE(FIELD(7),"^",3)
SET REQST=$PIECE(FIELD(7),"^",4)
if REQST'=""
SET REQST=+$EXTRACT(+$$HL7TFM^XLFDT(REQST),1,12)
SET REQST=$$DATE2^PSJUTL2(REQST)
+27 SET PRIORITY=$SELECT($GET(PRIORITY)]"":PRIORITY,1:"R")
+28 IF $EXTRACT(SCHEDULE,1)=" "
if $TRANSLATE(SCHEDULE," ")="PRN"
SET SCHEDULE="PRN"
IF '(SCHEDULE="PRN")
SET PSREASON="Invalid Schedule"
DO ERROR^PSJHL9
QUIT
+29 SET SCHTYP=$PIECE(FIELD(7),"^",7)
+30 ;Makes CPRS Day of Week consistent in behavior with backdoor order of Day of Week
IF $GET(SCHTYP)="D"
SET SCHTYP="C"
+31 SET PRNTON=$PIECE(FIELD(8),"^")
+32 SET NURSEACK=$GET(FIELD(11))
+33 SET LOGIN=$GET(FIELD(15))
if LOGIN'=""
SET LOGIN=+$EXTRACT(+$$HL7TFM^XLFDT(FIELD(15)),1,12)
SET LOGIN=$$DATE2^PSJUTL2(LOGIN)
+34 if $GET(NURSEACK)]""
SET ACKDATE=LOGIN
+35 SET ORDCON=$PIECE($GET(FIELD(16)),U)
IF ORDCON="A"
SET PSJASTP=$GET(FIELD(9))
if $GET(PSJASTP)'=""
SET PSJASTP=+$EXTRACT(+$$HL7TFM^XLFDT(PSJASTP),1,12)
SET PSJASTP=$$DATE2^PSJUTL2(PSJASTP)
+36 IF (PSOC="CA")!(PSOC="DC")
DO CANCEL^PSJHL6
QUIT
+37 IF PSOC="HD"
DO HOLD^PSJHL6
QUIT
+38 IF PSOC="RL"
DO UNHOLD^PSJHL6
QUIT
+39 IF PSOC="ZV"
DO NURSEACK^PSJHL5
QUIT
+40 IF PSOC="SS"
DO STATUS^PSJHL5
QUIT
+41 ;Commented line below since ^PSJHL8 doesn't exist.
+42 ;I PSOC="Z@" N X S X="PSJHL8" X ^%ZOSF("TEST") I D PURGE^PSJHL8 Q
+43 IF PSOC="DE"
SET QFLG=1
QUIT
+44 QUIT
OBR ; Flagging from CPRS.
+1 SET ORDER=FIELD(2)
+2 SET PSJORDER=$PIECE(FIELD(2),"^")
SET RXON=$PIECE(FIELD(3),"^")
SET RXORDER=$SELECT((RXON["N")!(RXON["P"):"^PS(53.1,"_+RXON_",",RXON["V":"^PS(55,"_PSJHLDFN_",""IV"","_+RXON_",",1:"^PS(55,"_PSJHLDFN_",5,"_+RXON_",")
+3 SET PSJFLAG=FIELD(4)
+4 SET FLDATE=$GET(FIELD(7))
if FLDATE'=""
SET FLDATE=+$EXTRACT(+$$HL7TFM^XLFDT(FIELD(7)),1,12)
SET FLDATE=$$DATE2^PSJUTL2(FLDATE)
+5 SET CLERK=+$GET(FIELD(16))
+6 SET PSJYN=$GET(FIELD(24))
+7 SET FLCMNT=$$UNESC^ORHLESC($GET(FIELD(13)))
+8 IF PSOC="ORU"
DO FLAG^PSJHL5
+9 QUIT
RXC ; IV
+1 DO RXC^PSJHL4A
+2 QUIT
RXO ; OP
+1 DO RXO^PSJHL4A
+2 QUIT
RXR ; Route
+1 SET ROUTE=$PIECE(FIELD(1),"^",4)
+2 QUIT
OBX ; Obs.
+1 DO OBX^PSJHL4A
+2 QUIT
NTE ; Note
+1 DO NTE^PSJHL4A
+2 QUIT
ZRX ; Custom
+1 DO ZRX^PSJHL4A
+2 QUIT
ZSC ;Service Connected - Not Used
+1 QUIT
ZRN ;Non-VA Med (Herbal/OTC)
+1 SET CLASS="O"
DO EN^PSOHLNEW(.PSJMSG)
+2 QUIT
DG1 ;Billing Awareness - Not used
+1 QUIT
