Routine: PSJHL2

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

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

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

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

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

DISPLAY ; just for testing

 I $G(MSGTEST) W ! F NEXT=0:1:LIMIT W FIELD(NEXT)_"|"

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)

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

PSJHL2.m