PSOHLINL ;BIR/RTR-Process HL7 segments greater than 245 ;07/12/02
;;7.0;OUTPATIENT PHARMACY;**111**;DEC 1997
;
ORC ;Process multiple ORC segments
S PSOHLTAG="ORCP"
D PROC
K PSOHLTAG
Q
PROC ;Process segments
N PSOHPVR,PSOHPVR1,PSOHNNCK,PSOHNNN,PSOHNNNN,PSOHIII,PSOHAA,PSOHLIM,PSOHBX
D RESET
I $G(PSOHLTAG)="ORCP" S PSOHY("PRIOR")="R" D NOW^%DTC S PSOHY("EDT")=%
S (PSOHPVR,PSOHPVR1)="",(PSOHNNCK,PSOHNNN,PSOHNNNN)=0,PSOHIII=1
S PSOHAA="" F S PSOHAA=$O(PSOHBX(PSOHAA)) Q:PSOHAA="" S PSOHNNN=0 F PSOHOO=1:1:$L(PSOHBX(PSOHAA)) S PSOHNNN=PSOHNNN+1 D D:$G(PSOHPVR1)=HL("FS") @PSOHLTAG
.I $E(PSOHBX(PSOHAA),PSOHOO)=HL("FS") S PSOHNNNN=PSOHNNNN+1
.S PSOHPVR1=$E(PSOHBX(PSOHAA),PSOHOO)
.S PSOHLIM=PSOHPVR
.S PSOHPVR=$S(PSOHPVR="":PSOHPVR1,1:PSOHPVR_PSOHPVR1)
I $G(PSOHPVR)'="" S PSOHLIM=PSOHPVR S PSOHNNNN=PSOHNNNN+1 D @PSOHLTAG
Q
ORCP ;
S PSOHLMIS("ORC")=""
I PSOHNNNN=1 S PSOHY("OCC")=$G(PSOHLIM) G ORCPQ
I PSOHNNNN=2 S PSOHY("CHNUM")=$P(PSOHLIM,PSOHFSP) G ORCPQ
I PSOHNNNN=9 S X=$G(PSOHLIM) D G ORCPQ
.I X S PSOHY("SDT")=$$HL7TFM^XLFDT(X) Q
.S PSOHY("SDT")=$G(PSOHY("EDT"))
I PSOHNNNN=10 S PSOHY("ENTER")=+$G(PSOHLIM)
I PSOHNNNN=12 S PSOHY("PROV")=+$G(PSOHLIM)
ORCPQ S (PSOHPVR,PSOHLIM)=""
Q
RXOP ;
S PSOHLMIS("RXO")=""
I PSOHNNNN=10 S PSOHY("DRUG")=+$G(PSOHLIM) G RXOPQ
I PSOHNNNN=11 S PSOHY("QTY")=$G(PSOHLIM) G RXOPQ
I PSOHNNNN=13 S PSOHY("REF")=$G(PSOHLIM)
RXOPQ S (PSOHPVR,PSOHLIM)=""
Q
RESET ;reset array
K PSOHBX
S PSOHX="" F S PSOHX=$O(PSOHB(PSOHX)) Q:PSOHX="" S PSOHBX((+$G(PSOHX)+1))=PSOHB(PSOHX)
S PSOHBX(0)=PSOHB
Q
RXO ;Process multiple RXO segments
S PSOHLTAG="RXOP"
D PROC
K PSOHLTAG
Q
COMM ;Process multiple NTE 6 (Provider comments)
K ^UTILITY($J,"W")
S X=$P(PSOHB,HL("FS"),3,999),DIWL=1,DIWR=70,DIWF="" D LTH Q:PSOXLONG D ^DIWP
S PSOHLZ="" F S PSOHLZ=$O(PSOHB("")) Q:PSOHLZ=""!(PSOXLONG) I $G(PSOHB(PSOHLZ))'="" S X=PSOHB(PSOHLZ),DIWL=1,DIWR=70,DIWF="" D LTH Q:PSOXLONG D ^DIWP
I PSOXLONG K ^UTILITY($J,"W") Q
D ENCOMM
K ^UTILITY($J,"W")
Q
SIG ;Process multiple NTE 7 (Sig)
K ^UTILITY($J,"W")
S X=$P(PSOHB,HL("FS"),3,999),DIWL=1,DIWR=70,DIWF="" D LTH Q:PSOXLONG D ^DIWP
S PSOHLZ="" F S PSOHLZ=$O(PSOHB("")) Q:PSOHLZ=""!(PSOXLONG) I $G(PSOHB(PSOHLZ))'="" S X=PSOHB(PSOHLZ),DIWL=1,DIWR=70,DIWF="" D LTH Q:PSOXLONG D ^DIWP
I PSOXLONG K ^UTILITY($J,"W") Q
D ENSIG
K ^UTILITY($J,"W")
Q
ENCOMM ;Enter provider comments into PSOHY array
S PSOHLZC=1
S PSOHLZ="" F S PSOHLZ=$O(^UTILITY($J,"W",1,PSOHLZ)) Q:PSOHLZ="" I $G(^(PSOHLZ,0))'="" D
.S PSOHY("PRCOM",PSOHLZC)=$G(^UTILITY($J,"W",1,PSOHLZ,0)),PSOHLZC=PSOHLZC+1
Q
ENSIG ;Enter Sig into PSOHY array
S PSOHLZC=1
S PSOHLZ="" F S PSOHLZ=$O(^UTILITY($J,"W",1,PSOHLZ)) Q:PSOHLZ="" I $G(^(PSOHLZ,0))'="" D
.S PSOHY("SIG",PSOHLZC)=$G(^UTILITY($J,"W",1,PSOHLZ,0)),PSOHLZC=PSOHLZC+1
Q
LTH ;
I $L(X)>245 S PSOXLONG=1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOHLINL 2922 printed Sep 23, 2025@20:06:19 Page 2
PSOHLINL ;BIR/RTR-Process HL7 segments greater than 245 ;07/12/02
+1 ;;7.0;OUTPATIENT PHARMACY;**111**;DEC 1997
+2 ;
ORC ;Process multiple ORC segments
+1 SET PSOHLTAG="ORCP"
+2 DO PROC
+3 KILL PSOHLTAG
+4 QUIT
PROC ;Process segments
+1 NEW PSOHPVR,PSOHPVR1,PSOHNNCK,PSOHNNN,PSOHNNNN,PSOHIII,PSOHAA,PSOHLIM,PSOHBX
+2 DO RESET
+3 IF $GET(PSOHLTAG)="ORCP"
SET PSOHY("PRIOR")="R"
DO NOW^%DTC
SET PSOHY("EDT")=%
+4 SET (PSOHPVR,PSOHPVR1)=""
SET (PSOHNNCK,PSOHNNN,PSOHNNNN)=0
SET PSOHIII=1
+5 SET PSOHAA=""
FOR
SET PSOHAA=$ORDER(PSOHBX(PSOHAA))
if PSOHAA=""
QUIT
SET PSOHNNN=0
FOR PSOHOO=1:1:$LENGTH(PSOHBX(PSOHAA))
SET PSOHNNN=PSOHNNN+1
Begin DoDot:1
+6 IF $EXTRACT(PSOHBX(PSOHAA),PSOHOO)=HL("FS")
SET PSOHNNNN=PSOHNNNN+1
+7 SET PSOHPVR1=$EXTRACT(PSOHBX(PSOHAA),PSOHOO)
+8 SET PSOHLIM=PSOHPVR
+9 SET PSOHPVR=$SELECT(PSOHPVR="":PSOHPVR1,1:PSOHPVR_PSOHPVR1)
End DoDot:1
if $GET(PSOHPVR1)=HL("FS")
DO @PSOHLTAG
+10 IF $GET(PSOHPVR)'=""
SET PSOHLIM=PSOHPVR
SET PSOHNNNN=PSOHNNNN+1
DO @PSOHLTAG
+11 QUIT
ORCP ;
+1 SET PSOHLMIS("ORC")=""
+2 IF PSOHNNNN=1
SET PSOHY("OCC")=$GET(PSOHLIM)
GOTO ORCPQ
+3 IF PSOHNNNN=2
SET PSOHY("CHNUM")=$PIECE(PSOHLIM,PSOHFSP)
GOTO ORCPQ
+4 IF PSOHNNNN=9
SET X=$GET(PSOHLIM)
Begin DoDot:1
+5 IF X
SET PSOHY("SDT")=$$HL7TFM^XLFDT(X)
QUIT
+6 SET PSOHY("SDT")=$GET(PSOHY("EDT"))
End DoDot:1
GOTO ORCPQ
+7 IF PSOHNNNN=10
SET PSOHY("ENTER")=+$GET(PSOHLIM)
+8 IF PSOHNNNN=12
SET PSOHY("PROV")=+$GET(PSOHLIM)
ORCPQ SET (PSOHPVR,PSOHLIM)=""
+1 QUIT
RXOP ;
+1 SET PSOHLMIS("RXO")=""
+2 IF PSOHNNNN=10
SET PSOHY("DRUG")=+$GET(PSOHLIM)
GOTO RXOPQ
+3 IF PSOHNNNN=11
SET PSOHY("QTY")=$GET(PSOHLIM)
GOTO RXOPQ
+4 IF PSOHNNNN=13
SET PSOHY("REF")=$GET(PSOHLIM)
RXOPQ SET (PSOHPVR,PSOHLIM)=""
+1 QUIT
RESET ;reset array
+1 KILL PSOHBX
+2 SET PSOHX=""
FOR
SET PSOHX=$ORDER(PSOHB(PSOHX))
if PSOHX=""
QUIT
SET PSOHBX((+$GET(PSOHX)+1))=PSOHB(PSOHX)
+3 SET PSOHBX(0)=PSOHB
+4 QUIT
RXO ;Process multiple RXO segments
+1 SET PSOHLTAG="RXOP"
+2 DO PROC
+3 KILL PSOHLTAG
+4 QUIT
COMM ;Process multiple NTE 6 (Provider comments)
+1 KILL ^UTILITY($JOB,"W")
+2 SET X=$PIECE(PSOHB,HL("FS"),3,999)
SET DIWL=1
SET DIWR=70
SET DIWF=""
DO LTH
if PSOXLONG
QUIT
DO ^DIWP
+3 SET PSOHLZ=""
FOR
SET PSOHLZ=$ORDER(PSOHB(""))
if PSOHLZ=""!(PSOXLONG)
QUIT
IF $GET(PSOHB(PSOHLZ))'=""
SET X=PSOHB(PSOHLZ)
SET DIWL=1
SET DIWR=70
SET DIWF=""
DO LTH
if PSOXLONG
QUIT
DO ^DIWP
+4 IF PSOXLONG
KILL ^UTILITY($JOB,"W")
QUIT
+5 DO ENCOMM
+6 KILL ^UTILITY($JOB,"W")
+7 QUIT
SIG ;Process multiple NTE 7 (Sig)
+1 KILL ^UTILITY($JOB,"W")
+2 SET X=$PIECE(PSOHB,HL("FS"),3,999)
SET DIWL=1
SET DIWR=70
SET DIWF=""
DO LTH
if PSOXLONG
QUIT
DO ^DIWP
+3 SET PSOHLZ=""
FOR
SET PSOHLZ=$ORDER(PSOHB(""))
if PSOHLZ=""!(PSOXLONG)
QUIT
IF $GET(PSOHB(PSOHLZ))'=""
SET X=PSOHB(PSOHLZ)
SET DIWL=1
SET DIWR=70
SET DIWF=""
DO LTH
if PSOXLONG
QUIT
DO ^DIWP
+4 IF PSOXLONG
KILL ^UTILITY($JOB,"W")
QUIT
+5 DO ENSIG
+6 KILL ^UTILITY($JOB,"W")
+7 QUIT
ENCOMM ;Enter provider comments into PSOHY array
+1 SET PSOHLZC=1
+2 SET PSOHLZ=""
FOR
SET PSOHLZ=$ORDER(^UTILITY($JOB,"W",1,PSOHLZ))
if PSOHLZ=""
QUIT
IF $GET(^(PSOHLZ,0))'=""
Begin DoDot:1
+3 SET PSOHY("PRCOM",PSOHLZC)=$GET(^UTILITY($JOB,"W",1,PSOHLZ,0))
SET PSOHLZC=PSOHLZC+1
End DoDot:1
+4 QUIT
ENSIG ;Enter Sig into PSOHY array
+1 SET PSOHLZC=1
+2 SET PSOHLZ=""
FOR
SET PSOHLZ=$ORDER(^UTILITY($JOB,"W",1,PSOHLZ))
if PSOHLZ=""
QUIT
IF $GET(^(PSOHLZ,0))'=""
Begin DoDot:1
+3 SET PSOHY("SIG",PSOHLZC)=$GET(^UTILITY($JOB,"W",1,PSOHLZ,0))
SET PSOHLZC=PSOHLZC+1
End DoDot:1
+4 QUIT
LTH ;
+1 IF $LENGTH(X)>245
SET PSOXLONG=1
+2 QUIT
