source: WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJHL2.m@ 613

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?)