PSOHLINC ;BIR/RTR - Process incoming order messages from CHCS ;06/17/02
;;7.0;OUTPATIENT PHARMACY;**111,143**;DEC 1997
;
EN ;Process incoming outpatient order messages
N PSOXLONG,PSOHDFOR,PSOHLTAG,PSOHBDS,PSOHMSG,PSOHLMIS,PSOHLRS,PSOHEID,PSOHEIDS,PSOHFSP,PSOHLNOP,PSOXHI,PSOHLZ,PSOHLZC,PSOHLRXO,PSOXMH,PSOHY,PSOEXMS,PSOEXXQ,PSOHG,PSOBH,X,Y
I '$G(DT) S DT=$$DT^XLFDT
S (PSOXLONG,PSOHLRXO,PSOHLNOP,PSOHDFOR)=0
S PSOHFSP=$E(HL("ECH"),1)
K PSOHLMIS
F PSOXHI=1:1 K PSOHB X HLNEXT Q:HLQUIT'>0!(PSOHLNOP)!(PSOHDFOR)!(PSOXLONG) S PSOHB=HLNODE,PSOXMH=$E(PSOHB,1,3) D
.S PSOHG=0 F S PSOHG=$O(HLNODE(PSOHG)) Q:'PSOHG!(PSOHLNOP)!(PSOHDFOR)!(PSOXLONG) S PSOHB(PSOHG)=HLNODE(PSOHG)
.I (PSOXMH'?3U),(PSOXMH'?2U1N) S PSOHDFOR=1 Q
.I $T(@PSOXMH)]"" D @PSOXMH
;Quit if not a Pharmacy message, no acknowledgements
I $G(PSOHLNOP) Q
I $G(PSOHY("OCC"))="CA" D ENDC^PSOHLDC Q
I PSOXLONG S PSOEXMS="Invalid NTE segment, greater than 245 characters." D NAK^PSOHLEXC Q
S (PSOHBDS,PSOEXXQ)=0
I PSOHDFOR S PSOEXMS="Invalid message structure." D NAK^PSOHLEXC Q
F PSOHMSG="MSH","PID","PV1","ORC","RXO" Q:PSOEXXQ I '$D(PSOHLMIS(PSOHMSG)) S PSOEXMS="Missing "_PSOHMSG_" segment." S PSOHBDS=1 D NAK^PSOHLEXC
;Quit if segment is missing
I $G(PSOEXXQ) Q
;Quit if not a Pharmacy message, no acknowledgements
;I $G(PSOHLNOP) Q
;check for data exceptions
D CHECK^PSOHLEXC
;PSOEXXQ set if a NAK was sent back
I $G(PSOEXXQ) Q
;Enter order into Pending Outpatient Orders file
D ADD^PSOHCPRS
;Send successful acknowledgement if PSOEXXQ not set
I '$G(PSOEXXQ) D ACK^PSOHLEXC
Q
;What about regular acknowledgements? handled by HL7 package somehow
Q
MSH ;Process MSH segment
I $P(PSOHB,HL("FS"),5)'="PSO RECEIVE" S PSOHLNOP=1
S PSOHLMIS("MSH")=""
Q
PID ;Process PID segment
D FORM
S PSOHY("PAT")=+$P(PSOHB,HL("FS"),3)
S PSOHLMIS("PID")=""
Q
PV1 ;Process PV1 segment
D FORM
S PSOHY("LOC")=+$P(PSOHB,HL("FS"),3)
S PSOHLMIS("PV1")=""
Q
DG1 ;Process DG1 segment ; future use
D FORM
S $P(PSOHY("ICD"),U,$P(PSOHB,HL("FS"),1))=$P(PSOHB,HL("FS"),3)
ZCL Q ;future use
;
ORC ;Process ORC segment
S PSOHLRXO=1 ;For future use in processing NTE's, if other segments get NTE(6) or (7)
D FORM
I $O(PSOHB(""))'="" D ORC^PSOHLINL Q
S PSOHY("OCC")=$P(PSOHB,HL("FS"))
;Set priority to Routine
S PSOHY("PRIOR")="R"
S PSOHY("CHNUM")=$P($P(PSOHB,HL("FS"),2),PSOHFSP)
D NOW^%DTC S PSOHY("EDT")=%
S X=$P(PSOHB,HL("FS"),9) D
.I X S PSOHY("SDT")=$$HL7TFM^XLFDT(X) Q
.S PSOHY("SDT")=$G(PSOHY("EDT"))
S PSOHY("ENTER")=+$P(PSOHB,HL("FS"),10)
S PSOHY("PROV")=+$P(PSOHB,HL("FS"),12)
S PSOHLMIS("ORC")=""
Q
RXO ;Process RXO segment
D FORM
I $O(PSOHB(""))'="" D RXO^PSOHLINL Q
S PSOHY("DRUG")=+$P(PSOHB,HL("FS"),10)
S PSOHY("QTY")=$P(PSOHB,HL("FS"),11)
S PSOHY("REF")=$P(PSOHB,HL("FS"),13)
S PSOHLMIS("RXO")=""
Q
RXR ;Process RXR segment
D FORM
Q
ZRX ;Process ZRX segment
D FORM
S PSOHY("PICK")=$S($P(PSOHB,HL("FS"),4)="M":"M",1:"W")
Q
NTE ;
D FORM
I $P(PSOHB,HL("FS"))=6 D COMM Q
I $P(PSOHB,HL("FS"))=7 D SIG Q
Q
COMM ;Process Provider Comments
I $O(PSOHB(""))'="" D COMM^PSOHLINL Q
K ^UTILITY($J,"W")
S X=$P(PSOHB,HL("FS"),3,999)
I $L(X)>245 S PSOXLONG=1 Q
S DIWL=1,DIWR=70,DIWF="" D ^DIWP
D ENCOMM^PSOHLINL
K ^UTILITY($J,"W")
Q
SIG ;Process SIG
I $O(PSOHB(""))'="" D SIG^PSOHLINL Q
K ^UTILITY($J,"W")
S X=$P(PSOHB,HL("FS"),3,999)
I $L(X)>245 S PSOXLONG=1 Q
S DIWL=1,DIWR=70,DIWF="" D ^DIWP
D ENSIG^PSOHLINL
K ^UTILITY($J,"W")
Q
FORM ;
S PSOHB=$E(PSOHB,(4+$L(HL("FS"))),$L(PSOHB))
Q
;AND IF YOU ADD PSOHLNEW TO THE PATCH, FIX THE HEADER OF THE 3 NODE TO MATCH HOW YOU DID IT IN PSOHCPRS. SINCE IT IS A WORD PROCESSING FIELD
; And maybe fix -1 problem if no related institution is found
; AND IF YOU PATCH PSOHLSN1, AT THE rxr POINT, INITIALIZE RTENAME AT THE BEGINNING OF EACH LOOP
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOHLINC 3926 printed Sep 23, 2025@20:06:18 Page 2
PSOHLINC ;BIR/RTR - Process incoming order messages from CHCS ;06/17/02
+1 ;;7.0;OUTPATIENT PHARMACY;**111,143**;DEC 1997
+2 ;
EN ;Process incoming outpatient order messages
+1 NEW PSOXLONG,PSOHDFOR,PSOHLTAG,PSOHBDS,PSOHMSG,PSOHLMIS,PSOHLRS,PSOHEID,PSOHEIDS,PSOHFSP,PSOHLNOP,PSOXHI,PSOHLZ,PSOHLZC,PSOHLRXO,PSOXMH,PSOHY,PSOEXMS,PSOEXXQ,PSOHG,PSOBH,X,Y
+2 IF '$GET(DT)
SET DT=$$DT^XLFDT
+3 SET (PSOXLONG,PSOHLRXO,PSOHLNOP,PSOHDFOR)=0
+4 SET PSOHFSP=$EXTRACT(HL("ECH"),1)
+5 KILL PSOHLMIS
+6 FOR PSOXHI=1:1
KILL PSOHB
XECUTE HLNEXT
if HLQUIT'>0!(PSOHLNOP)!(PSOHDFOR)!(PSOXLONG)
QUIT
SET PSOHB=HLNODE
SET PSOXMH=$EXTRACT(PSOHB,1,3)
Begin DoDot:1
+7 SET PSOHG=0
FOR
SET PSOHG=$ORDER(HLNODE(PSOHG))
if 'PSOHG!(PSOHLNOP)!(PSOHDFOR)!(PSOXLONG)
QUIT
SET PSOHB(PSOHG)=HLNODE(PSOHG)
+8 IF (PSOXMH'?3U)
IF (PSOXMH'?2U1N)
SET PSOHDFOR=1
QUIT
+9 IF $TEXT(@PSOXMH)]""
DO @PSOXMH
End DoDot:1
+10 ;Quit if not a Pharmacy message, no acknowledgements
+11 IF $GET(PSOHLNOP)
QUIT
+12 IF $GET(PSOHY("OCC"))="CA"
DO ENDC^PSOHLDC
QUIT
+13 IF PSOXLONG
SET PSOEXMS="Invalid NTE segment, greater than 245 characters."
DO NAK^PSOHLEXC
QUIT
+14 SET (PSOHBDS,PSOEXXQ)=0
+15 IF PSOHDFOR
SET PSOEXMS="Invalid message structure."
DO NAK^PSOHLEXC
QUIT
+16 FOR PSOHMSG="MSH","PID","PV1","ORC","RXO"
if PSOEXXQ
QUIT
IF '$DATA(PSOHLMIS(PSOHMSG))
SET PSOEXMS="Missing "_PSOHMSG_" segment."
SET PSOHBDS=1
DO NAK^PSOHLEXC
+17 ;Quit if segment is missing
+18 IF $GET(PSOEXXQ)
QUIT
+19 ;Quit if not a Pharmacy message, no acknowledgements
+20 ;I $G(PSOHLNOP) Q
+21 ;check for data exceptions
+22 DO CHECK^PSOHLEXC
+23 ;PSOEXXQ set if a NAK was sent back
+24 IF $GET(PSOEXXQ)
QUIT
+25 ;Enter order into Pending Outpatient Orders file
+26 DO ADD^PSOHCPRS
+27 ;Send successful acknowledgement if PSOEXXQ not set
+28 IF '$GET(PSOEXXQ)
DO ACK^PSOHLEXC
+29 QUIT
+30 ;What about regular acknowledgements? handled by HL7 package somehow
+31 QUIT
MSH ;Process MSH segment
+1 IF $PIECE(PSOHB,HL("FS"),5)'="PSO RECEIVE"
SET PSOHLNOP=1
+2 SET PSOHLMIS("MSH")=""
+3 QUIT
PID ;Process PID segment
+1 DO FORM
+2 SET PSOHY("PAT")=+$PIECE(PSOHB,HL("FS"),3)
+3 SET PSOHLMIS("PID")=""
+4 QUIT
PV1 ;Process PV1 segment
+1 DO FORM
+2 SET PSOHY("LOC")=+$PIECE(PSOHB,HL("FS"),3)
+3 SET PSOHLMIS("PV1")=""
+4 QUIT
DG1 ;Process DG1 segment ; future use
+1 DO FORM
+2 SET $PIECE(PSOHY("ICD"),U,$PIECE(PSOHB,HL("FS"),1))=$PIECE(PSOHB,HL("FS"),3)
ZCL ;future use
QUIT
+1 ;
ORC ;Process ORC segment
+1 ;For future use in processing NTE's, if other segments get NTE(6) or (7)
SET PSOHLRXO=1
+2 DO FORM
+3 IF $ORDER(PSOHB(""))'=""
DO ORC^PSOHLINL
QUIT
+4 SET PSOHY("OCC")=$PIECE(PSOHB,HL("FS"))
+5 ;Set priority to Routine
+6 SET PSOHY("PRIOR")="R"
+7 SET PSOHY("CHNUM")=$PIECE($PIECE(PSOHB,HL("FS"),2),PSOHFSP)
+8 DO NOW^%DTC
SET PSOHY("EDT")=%
+9 SET X=$PIECE(PSOHB,HL("FS"),9)
Begin DoDot:1
+10 IF X
SET PSOHY("SDT")=$$HL7TFM^XLFDT(X)
QUIT
+11 SET PSOHY("SDT")=$GET(PSOHY("EDT"))
End DoDot:1
+12 SET PSOHY("ENTER")=+$PIECE(PSOHB,HL("FS"),10)
+13 SET PSOHY("PROV")=+$PIECE(PSOHB,HL("FS"),12)
+14 SET PSOHLMIS("ORC")=""
+15 QUIT
RXO ;Process RXO segment
+1 DO FORM
+2 IF $ORDER(PSOHB(""))'=""
DO RXO^PSOHLINL
QUIT
+3 SET PSOHY("DRUG")=+$PIECE(PSOHB,HL("FS"),10)
+4 SET PSOHY("QTY")=$PIECE(PSOHB,HL("FS"),11)
+5 SET PSOHY("REF")=$PIECE(PSOHB,HL("FS"),13)
+6 SET PSOHLMIS("RXO")=""
+7 QUIT
RXR ;Process RXR segment
+1 DO FORM
+2 QUIT
ZRX ;Process ZRX segment
+1 DO FORM
+2 SET PSOHY("PICK")=$SELECT($PIECE(PSOHB,HL("FS"),4)="M":"M",1:"W")
+3 QUIT
NTE ;
+1 DO FORM
+2 IF $PIECE(PSOHB,HL("FS"))=6
DO COMM
QUIT
+3 IF $PIECE(PSOHB,HL("FS"))=7
DO SIG
QUIT
+4 QUIT
COMM ;Process Provider Comments
+1 IF $ORDER(PSOHB(""))'=""
DO COMM^PSOHLINL
QUIT
+2 KILL ^UTILITY($JOB,"W")
+3 SET X=$PIECE(PSOHB,HL("FS"),3,999)
+4 IF $LENGTH(X)>245
SET PSOXLONG=1
QUIT
+5 SET DIWL=1
SET DIWR=70
SET DIWF=""
DO ^DIWP
+6 DO ENCOMM^PSOHLINL
+7 KILL ^UTILITY($JOB,"W")
+8 QUIT
SIG ;Process SIG
+1 IF $ORDER(PSOHB(""))'=""
DO SIG^PSOHLINL
QUIT
+2 KILL ^UTILITY($JOB,"W")
+3 SET X=$PIECE(PSOHB,HL("FS"),3,999)
+4 IF $LENGTH(X)>245
SET PSOXLONG=1
QUIT
+5 SET DIWL=1
SET DIWR=70
SET DIWF=""
DO ^DIWP
+6 DO ENSIG^PSOHLINL
+7 KILL ^UTILITY($JOB,"W")
+8 QUIT
FORM ;
+1 SET PSOHB=$EXTRACT(PSOHB,(4+$LENGTH(HL("FS"))),$LENGTH(PSOHB))
+2 QUIT
+3 ;AND IF YOU ADD PSOHLNEW TO THE PATCH, FIX THE HEADER OF THE 3 NODE TO MATCH HOW YOU DID IT IN PSOHCPRS. SINCE IT IS A WORD PROCESSING FIELD
+4 ; And maybe fix -1 problem if no related institution is found
+5 ; AND IF YOU PATCH PSOHLSN1, AT THE rxr POINT, INITIALIZE RTENAME AT THE BEGINNING OF EACH LOOP
