PSJHL2 ;BIR/RLW-PATIENT ID AND VISIT SEGMENTS ;22 Nov 1999 9:27 AM
;;5.0; INPATIENT MEDICATIONS ;**1,18,16,23,28,42,50,70,58,100,102,110,111,112,144,141,134**;16 DEC 97;Build 124
;
; Reference to ^PS(55 is supported by DBIA# 2191.
; Reference to ^ORERR is supported by DBIA# 2187.
; Reference to ^ORHLESC IS supported by DBIA# 4922.
;
EN1(PSJHLDFN,PSOC,PSJORDER,PSREASON) ; start here
; passed in are PSJHLDFN (patient ien)
; PSJORDER* (order_file (N,P,V, etc))
; PSOC* (order control code - NW for new order, OK to return filler number to OE/RR, OC for order canceled, SC for status change)
; PSREASON* (text reason)
; *=optional, only required if an order segment is also to be generated
START ;
K ^TMP("PSJHLS",$J,"PS")
N CLERK,J,LIMIT,NAME,NEXT,NODE1,NODE2,NODE4,NOO,PSJCLEAR,PSJHINST,PSJHLSDT,PROVIDER,PSJI,ROOMBED,RXORDER,STATUS,UNDO,VERIFY,WARD,PSGST,DUR
S RXORDER=PSJORDER,PSJORDER=$S((PSJORDER["N")!(PSJORDER["P"):"^PS(53.1,"_+PSJORDER,PSJORDER["V":"^PS(55,"_PSJHLDFN_",""IV"","_+PSJORDER,1:"^PS(55,"_PSJHLDFN_",5,"_+PSJORDER)_","
I RXORDER["P",$P($G(@(PSJORDER_"0)")),U,15)'=PSJHLDFN S ORDCON="Patient does not match/PSJHL2" S X="ORERR" X ^%ZOSF("TEST") I D EN^ORERR(ORDCON) Q
S UNDO=$S("OC^CR"[PSOC:1,1:0)
D INIT,PID,PV1,ORC
D @$S("SN^SC^OC^OD^DR^CR^OH^OR^XX^ZC^XR"[PSOC:"EN1^PSJHL3(PSJHLDFN,PSOC,PSJORDER)",1:"CALL^PSJHLU(PSJI)")
I UNDO D UNDO
K ^TMP("PSJHLS",$J,"PS"),FIELD
Q
;
INIT ; initialize HL7 variables, set master file identification segment
; PSJHLMTN = message type - ORR for messages sent as a response to an OE/RR event; ORM for "unsolicited" messages.
S PSJI=0,PSJHLMTN=$S($G(PSJHLMTN)]"":PSJHLMTN,1:"ORM")
D INIT^PSJHLU
S LIMIT=17 X PSJCLEAR
S FIELD(0)="MSH",FIELD(1)="^~\&",FIELD(2)="PHARMACY",FIELD(3)=$G(PSJHINST),FIELD(8)=PSJHLMTN
D SEGMENT^PSJHLU(LIMIT),DISPLAY
Q
;
PID ; get patient data, format PID SEGMENT
S LIMIT=22 X PSJCLEAR
S FIELD(0)="PID"
S FIELD(3)=PSJHLDFN
N DFN S DFN=PSJHLDFN D DEM^VADPT S FIELD(5)=VADM(1)
I '$G(PSJBCBU) S FIELD(5)=$$ESC^ORHLESC(FIELD(5))
D SEGMENT^PSJHLU(LIMIT),DISPLAY
Q
;
PV1 ; get patient visit information, format PV1 segment
N PSJAPPT
S LIMIT=50 X PSJCLEAR
S FIELD(0)="PV1"
I PSJHLMTN="ORR" S FIELD(3)=LOC
I PSJHLMTN="ORM" D
.S LOC="",WARD=$G(^DPT(PSJHLDFN,.1)),LOC=$S($G(WARD)]"":$O(^SC("B",WARD,LOC)),1:LOC)
.I $G(LOC)="" D
.. N A
.. I RXORDER["P",($G(^PS(53.1,+RXORDER,"DSS"))) S A=^("DSS"),LOC=$P(A,"^"),PSJAPPT=$P(A,"^",2)
.. I RXORDER["V",($G(^PS(55,PSJHLDFN,"IV",+RXORDER,"DSS"))) S A=^("DSS"),LOC=$P(A,"^"),PSJAPPT=$P(A,"^",2)
.. I RXORDER["U",$G(^PS(55,PSJHLDFN,5,+RXORDER,8)) S A=^(8),LOC=$P(A,"^"),PSJAPPT=$P(A,"^",2)
.I $G(LOC)]"" S ROOMBED=$G(^DPT(PSJHLDFN,.101)) S LOC=LOC_"^"_$S($G(PSJBCBU):ROOMBED,1:$$ESC^ORHLESC(ROOMBED))
.S FIELD(3)=LOC I $G(PSJAPPT)]"" S FIELD(44)=$$FMTHL7^XLFDT(PSJAPPT)
S FIELD(2)=$S($G(CLASS)="O":CLASS,1:"I")
I FIELD(2)="I" N DFN S DFN=PSJHLDFN D INP^VADPT S FIELD(19)=VAIN(1)
D SEGMENT^PSJHLU(LIMIT),DISPLAY
Q
;
ORC ; order control segment
S LIMIT=18 X PSJCLEAR
Q:'$D(PSJORDER)!'$D(PSOC)
S NODE1=$G(@(PSJORDER_"0)")),NODE2=$G(@(PSJORDER_"2)"))
S NODE4=$G(@(PSJORDER_"4)"))
I $G(PSGST)="" N PSGST D
.S PSGST=$P($G(NODE1),"^",7)
S FIELD(0)="ORC"
S FIELD(1)=PSOC
S FIELD(2)=$S(PSOC="SN":"",1:$P(NODE1,"^",21))_"^OR" I $P(FIELD(2),"^")=0 S $P(FIELD(2),"^")="" ; IV orders are created with a zero in the oerr order number, for some reason
S FIELD(3)=RXORDER_"^PS"
; translate Pharmacy status code to HL7 status code, set in FIELD(5)
S STATUS=$S($G(PSJEXPOE):"E",(($P(NODE1,"^",17)]"")&(RXORDER["V")):($P(NODE1,"^",17)),($P(NODE1,"^",9)]""):$P(NODE1,"^",9),$G(PSIVCOPY):"DE",1:"")
;BHW;Remedy HD0000000086717;If the order has a pending number, send pending status even if current status is Active.
I STATUS="A",RXORDER["P" S STATUS="N" D @STATUS S STATUS="A"
E D @STATUS
I STATUS="U",RXORDER["P" S FIELD(3)="^PS"
S FIELD(7)="^"_$S(RXORDER["V":$P(NODE1,"^",9)_"&"_$P(NODE1,"^",11),1:$P(NODE2,"^")_"&"_$P(NODE2,"^",5))_"^^^^^"_$G(PSGST)
S FIELD(9)=$S(RXORDER["V":$$FMTHL7^XLFDT($P(NODE2,"^")),1:$$FMTHL7^XLFDT($P(NODE1,"^",16)))
S CLERK=$S(RXORDER["V":$P(NODE2,"^",11),1:$P(NODE4,"^",7))
S NAME=$P($G(^VA(200,+CLERK,0)),"^")
S FIELD(10)=CLERK_"^"_$S($G(PSJBCBU):NAME,1:$$ESC^ORHLESC(NAME))
I PSOC="ZV"!($G(PSJBCBU)) S VERIFY=$P($G(NODE4),"^"),FIELD(11)=VERIFY_"^"_$S($G(PSJBCBU):$P($G(^VA(200,+VERIFY,0)),"^"),1:$$ESC^ORHLESC($P($G(^VA(200,+VERIFY,0)),"^"))),FIELD(9)=$$FMTHL7^XLFDT($P(NODE4,"^",2))
S PROVIDER=$S($G(PSJDCPRV)]"":$G(PSJDCPRV),RXORDER["V":$P(NODE1,"^",6),1:$P(NODE1,"^",2)) K PSJDCPRV
S NAME=$P($G(^VA(200,+PROVIDER,0)),"^")
S FIELD(12)=PROVIDER_"^"_NAME
S FIELD(15)=$S(RXORDER["V":$$FMTHL7^XLFDT($P(NODE1,"^",2)),1:$$FMTHL7^XLFDT($P(NODE2,"^",2)))
I $S(RXORDER["V":$P(NODE2,"^",8)="R",1:$P(NODE1,"^",24)="R")
; PSJ*5*141 - If this is a renewal order, update FIELD(10) with the person who entered the renewal order.
N FIELD9 S FIELD9=$$FMTHL7^XLFDT($$LASTREN^PSJLMPRI(PSJHLDFN,RXORDER)) I FIELD9>FIELD(9) S FIELD(9)=FIELD9,FIELD(15)=FIELD9,FIELD(10)=$$LASTRNBY^PSJLMPRI(PSJHLDFN,RXORDER)
S NOO=$S(PSJORDER["IV":$G(P("NAT")),(($G(PSJNOO)="")&($G(P("NAT"))]"")):$G(P("NAT")),1:$G(PSJNOO)),PSREASON=$S(NOO="D":"",1:$G(PSREASON))
S FIELD(16)=NOO_U_$S(NOO="P":"Telephoned",NOO="D":"Duplicate",NOO="X":"Rejected",NOO="A":"Auto",NOO="S":"Service Correction",NOO="W":"Written",NOO="V":"Verbal",NOO="E":"Physician Entered",NOO="I":"Policy",1:"")_U_"99ORN"_U_U_$G(PSREASON)_U
D SEGMENT^PSJHLU(LIMIT),DISPLAY
Q
;
DISPLAY ; just for testing
I $G(MSGTEST) W ! F NEXT=0:1:LIMIT W FIELD(NEXT)_"|"
Q
UNDO ;Undo Renew if Pending Renewal is dc'd
I RXORDER["P",(STATUS="D"),($G(PSJNOO)'="A"),($P(NODE1,U,24)="R") D ENBKOUT^PSJOREN(PSJHLDFN,RXORDER)
Q
;
A S FIELD(5)="CM" Q ; active
D S FIELD(5)="DC" Q ; discontinued
I S FIELD(5)="IP" Q ; incomplete
N S FIELD(5)="IP" Q ; non-verified
U S FIELD(5)="ZX" Q ; unreleased
P S FIELD(5)="IP" Q ; pending
DE S FIELD(5)="RP" Q ; discontinued (edit)
E S FIELD(5)="ZE" Q ; expired
H S FIELD(5)="HD" Q ; hold
R S FIELD(5)="ZZ" Q ; renewed
RE S FIELD(5)="CM" Q ; reinstated
DR S FIELD(5)="DC" Q ; discontinued (renewal)
O S FIELD(5)="HD" Q ; on call (is this kind of like HOLD?)
PSJHL2 ;BIR/RLW-PATIENT ID AND VISIT SEGMENTS ;22 Nov 1999 9:27 AM
+1 ;;5.0; INPATIENT MEDICATIONS ;**1,18,16,23,28,42,50,70,58,100,102,110,111,112,144,141,134**;16 DEC 97;Build 124
+2 ;
+3 ; Reference to ^PS(55 is supported by DBIA# 2191.
+4 ; Reference to ^ORERR is supported by DBIA# 2187.
+5 ; Reference to ^ORHLESC IS supported by DBIA# 4922.
+6 ;
EN1(PSJHLDFN,PSOC,PSJORDER,PSREASON) ; start here
+1 ; passed in are PSJHLDFN (patient ien)
+2 ; PSJORDER* (order_file (N,P,V, etc))
+3 ; PSOC* (order control code - NW for new order, OK to return filler number to OE/RR, OC for order canceled, SC for status change)
+4 ; PSREASON* (text reason)
+5 ; *=optional, only required if an order segment is also to be generated
START ;
+1 KILL ^TMP("PSJHLS",$JOB,"PS")
+2 NEW CLERK,J,LIMIT,NAME,NEXT,NODE1,NODE2,NODE4,NOO,PSJCLEAR,PSJHINST,PSJHLSDT,PROVIDER,PSJI,ROOMBED,RXORDER,STATUS,UNDO,VERIFY,WARD,PSGST,DUR
+3 SET RXORDER=PSJORDER
SET PSJORDER=$SELECT((PSJORDER["N")!(PSJORDER["P"):"^PS(53.1,"_+PSJORDER,PSJORDER["V":"^PS(55,"_PSJHLDFN_",""IV"","_+PSJORDER,1:"^PS(55,"_PSJHLDFN_",5,"_+PSJORDER)_","
+4 IF RXORDER["P"
IF $PIECE($GET(@(PSJORDER_"0)")),U,15)'=PSJHLDFN
SET ORDCON="Patient does not match/PSJHL2"
SET X="ORERR"
XECUTE ^%ZOSF("TEST")
IF $TEST
DO EN^ORERR(ORDCON)
QUIT
+5 SET UNDO=$SELECT("OC^CR"[PSOC:1,1:0)
+6 DO INIT
DO PID
DO PV1
DO ORC
+7 DO @$SELECT("SN^SC^OC^OD^DR^CR^OH^OR^XX^ZC^XR"[PSOC:"EN1^PSJHL3(PSJHLDFN,PSOC,PSJORDER)",1:"CALL^PSJHLU(PSJI)")
+8 IF UNDO
DO UNDO
+9 KILL ^TMP("PSJHLS",$JOB,"PS"),FIELD
+10 QUIT
+11 ;
INIT ; initialize HL7 variables, set master file identification segment
+1 ; PSJHLMTN = message type - ORR for messages sent as a response to an OE/RR event; ORM for "unsolicited" messages.
+2 SET PSJI=0
SET PSJHLMTN=$SELECT($GET(PSJHLMTN)]"":PSJHLMTN,1:"ORM")
+3 DO INIT^PSJHLU
+4 SET LIMIT=17
XECUTE PSJCLEAR
+5 SET FIELD(0)="MSH"
SET FIELD(1)="^~\&"
SET FIELD(2)="PHARMACY"
SET FIELD(3)=$GET(PSJHINST)
SET FIELD(8)=PSJHLMTN
+6 DO SEGMENT^PSJHLU(LIMIT)
DO DISPLAY
+7 QUIT
+8 ;
PID ; get patient data, format PID SEGMENT
+1 SET LIMIT=22
XECUTE PSJCLEAR
+2 SET FIELD(0)="PID"
+3 SET FIELD(3)=PSJHLDFN
+4 NEW DFN
SET DFN=PSJHLDFN
DO DEM^VADPT
SET FIELD(5)=VADM(1)
+5 IF '$GET(PSJBCBU)
SET FIELD(5)=$$ESC^ORHLESC(FIELD(5))
+6 DO SEGMENT^PSJHLU(LIMIT)
DO DISPLAY
+7 QUIT
+8 ;
PV1 ; get patient visit information, format PV1 segment
+1 NEW PSJAPPT
+2 SET LIMIT=50
XECUTE PSJCLEAR
+3 SET FIELD(0)="PV1"
+4 IF PSJHLMTN="ORR"
SET FIELD(3)=LOC
+5 IF PSJHLMTN="ORM"
Begin DoDot:1
+6 SET LOC=""
SET WARD=$GET(^DPT(PSJHLDFN,.1))
SET LOC=$SELECT($GET(WARD)]"":$ORDER(^SC("B",WARD,LOC)),1:LOC)
+7 IF $GET(LOC)=""
Begin DoDot:2
+8 NEW A
+9 IF RXORDER["P"
IF ($GET(^PS(53.1,+RXORDER,"DSS")))
SET A=^("DSS")
SET LOC=$PIECE(A,"^")
SET PSJAPPT=$PIECE(A,"^",2)
+10 IF RXORDER["V"
IF ($GET(^PS(55,PSJHLDFN,"IV",+RXORDER,"DSS")))
SET A=^("DSS")
SET LOC=$PIECE(A,"^")
SET PSJAPPT=$PIECE(A,"^",2)
+11 IF RXORDER["U"
IF $GET(^PS(55,PSJHLDFN,5,+RXORDER,8))
SET A=^(8)
SET LOC=$PIECE(A,"^")
SET PSJAPPT=$PIECE(A,"^",2)
End DoDot:2
+12 IF $GET(LOC)]""
SET ROOMBED=$GET(^DPT(PSJHLDFN,.101))
SET LOC=LOC_"^"_$SELECT($GET(PSJBCBU):ROOMBED,1:$$ESC^ORHLESC(ROOMBED))
+13 SET FIELD(3)=LOC
IF $GET(PSJAPPT)]""
SET FIELD(44)=$$FMTHL7^XLFDT(PSJAPPT)
End DoDot:1
+14 SET FIELD(2)=$SELECT($GET(CLASS)="O":CLASS,1:"I")
+15 IF FIELD(2)="I"
NEW DFN
SET DFN=PSJHLDFN
DO INP^VADPT
SET FIELD(19)=VAIN(1)
+16 DO SEGMENT^PSJHLU(LIMIT)
DO DISPLAY
+17 QUIT
+18 ;
ORC ; order control segment
+1 SET LIMIT=18
XECUTE PSJCLEAR
+2 IF '$DATA(PSJORDER)!'$DATA(PSOC)
QUIT
+3 SET NODE1=$GET(@(PSJORDER_"0)"))
SET NODE2=$GET(@(PSJORDER_"2)"))
+4 SET NODE4=$GET(@(PSJORDER_"4)"))
+5 IF $GET(PSGST)=""
NEW PSGST
Begin DoDot:1
+6 SET PSGST=$PIECE($GET(NODE1),"^",7)
End DoDot:1
+7 SET FIELD(0)="ORC"
+8 SET FIELD(1)=PSOC
+9 ; IV orders are created with a zero in the oerr order number, for some reason
SET FIELD(2)=$SELECT(PSOC="SN":"",1:$PIECE(NODE1,"^",21))_"^OR"
IF $PIECE(FIELD(2),"^")=0
SET $PIECE(FIELD(2),"^")=""
+10 SET FIELD(3)=RXORDER_"^PS"
+11 ; translate Pharmacy status code to HL7 status code, set in FIELD(5)
+12 SET STATUS=$SELECT($GET(PSJEXPOE):"E",(($PIECE(NODE1,"^",17)]"")&(RXORDER["V")):($PIECE(NODE1,"^",17)),($PIECE(NODE1,"^",9)]""):$PIECE(NODE1,"^",9),$GET(PSIVCOPY):"DE",1:"")
+13 ;BHW;Remedy HD0000000086717;If the order has a pending number, send pending status even if current status is Active.
+14 IF STATUS="A"
IF RXORDER["P"
SET STATUS="N"
DO @STATUS
SET STATUS="A"
+15 IF '$TEST
DO @STATUS
+16 IF STATUS="U"
IF RXORDER["P"
SET FIELD(3)="^PS"
+17 SET FIELD(7)="^"_$SELECT(RXORDER["V":$PIECE(NODE1,"^",9)_"&"_$PIECE(NODE1,"^",11),1:$PIECE(NODE2,"^")_"&"_$PIECE(NODE2,"^",5))_"^^^^^"_$GET(PSGST)
+18 SET FIELD(9)=$SELECT(RXORDER["V":$$FMTHL7^XLFDT($PIECE(NODE2,"^")),1:$$FMTHL7^XLFDT($PIECE(NODE1,"^",16)))
+19 SET CLERK=$SELECT(RXORDER["V":$PIECE(NODE2,"^",11),1:$PIECE(NODE4,"^",7))
+20 SET NAME=$PIECE($GET(^VA(200,+CLERK,0)),"^")
+21 SET FIELD(10)=CLERK_"^"_$SELECT($GET(PSJBCBU):NAME,1:$$ESC^ORHLESC(NAME))
+22 IF PSOC="ZV"!($GET(PSJBCBU))
SET VERIFY=$PIECE($GET(NODE4),"^")
SET FIELD(11)=VERIFY_"^"_$SELECT($GET(PSJBCBU):$PIECE($GET(^VA(200,+VERIFY,0)),"^"),1:$$ESC^ORHLESC($PIECE($GET(^VA(200,+VERIFY,0)),"^")))
SET FIELD(9)=$$FMTHL7^XLFDT($PIECE(NODE4,"^",2))
+23 SET PROVIDER=$SELECT($GET(PSJDCPRV)]"":$GET(PSJDCPRV),RXORDER["V":$PIECE(NODE1,"^",6),1:$PIECE(NODE1,"^",2))
KILL PSJDCPRV
+24 SET NAME=$PIECE($GET(^VA(200,+PROVIDER,0)),"^")
+25 SET FIELD(12)=PROVIDER_"^"_NAME
+26 SET FIELD(15)=$SELECT(RXORDER["V":$$FMTHL7^XLFDT($PIECE(NODE1,"^",2)),1:$$FMTHL7^XLFDT($PIECE(NODE2,"^",2)))
+27 IF $SELECT(RXORDER["V":$PIECE(NODE2,"^",8)="R",1:$PIECE(NODE1,"^",24)="R")
+28 ; PSJ*5*141 - If this is a renewal order, update FIELD(10) with the person who entered the renewal order.
+29 NEW FIELD9
SET FIELD9=$$FMTHL7^XLFDT($$LASTREN^PSJLMPRI(PSJHLDFN,RXORDER))
IF FIELD9>FIELD(9)
SET FIELD(9)=FIELD9
SET FIELD(15)=FIELD9
SET FIELD(10)=$$LASTRNBY^PSJLMPRI(PSJHLDFN,RXORDER)
+30 SET NOO=$SELECT(PSJORDER["IV":$GET(P("NAT")),(($GET(PSJNOO)="")&($GET(P("NAT"))]"")):$GET(P("NAT")),1:$GET(PSJNOO))
SET PSREASON=$SELECT(NOO="D":"",1:$GET(PSREASON))
+31 SET FIELD(16)=NOO_U_$SELECT(NOO="P":"Telephoned",NOO="D":"Duplicate",NOO="X":"Rejected",NOO="A":"Auto",NOO="S":"Service Correction",NOO="W":"Written",NOO="V":"Verbal",NOO="E":"Physician Entered",NOO="I":"Policy",1:"")_U_"99ORN"_U_U_$GET(PSREASO
N)_U
+32 DO SEGMENT^PSJHLU(LIMIT)
DO DISPLAY
+33 QUIT
+34 ;
DISPLAY ; just for testing
+1 IF $GET(MSGTEST)
WRITE !
FOR NEXT=0:1:LIMIT
WRITE FIELD(NEXT)_"|"
+2 QUIT
UNDO ;Undo Renew if Pending Renewal is dc'd
+1 IF RXORDER["P"
IF (STATUS="D")
IF ($GET(PSJNOO)'="A")
IF ($PIECE(NODE1,U,24)="R")
DO ENBKOUT^PSJOREN(PSJHLDFN,RXORDER)
+2 QUIT
+3 ;
A ; active
SET FIELD(5)="CM"
QUIT
D ; discontinued
SET FIELD(5)="DC"
QUIT
I ; incomplete
SET FIELD(5)="IP"
QUIT
N ; non-verified
SET FIELD(5)="IP"
QUIT
U ; unreleased
SET FIELD(5)="ZX"
QUIT
P ; pending
SET FIELD(5)="IP"
QUIT
DE ; discontinued (edit)
SET FIELD(5)="RP"
QUIT
E ; expired
SET FIELD(5)="ZE"
QUIT
H ; hold
SET FIELD(5)="HD"
QUIT
R ; renewed
SET FIELD(5)="ZZ"
QUIT
RE ; reinstated
SET FIELD(5)="CM"
QUIT
DR ; discontinued (renewal)
SET FIELD(5)="DC"
QUIT
O ; on call (is this kind of like HOLD?)
SET FIELD(5)="HD"
QUIT
