PSOHLSNC ;BIR/RTR - Send CHCS message to CPRS ;07/03/02
;;7.0;OUTPATIENT PHARMACY;**111,157,143,225,404,755,771**;DEC 1997;Build 8
;External reference to ^PS(50.7 supported by DBIA 2223
;External reference to ^PS(51.2 supported by DBIA 2226
;External reference to ^PSDRUG( supported by DBIA 221
;External reference to ^PS(50.607 supported by DBIA 2221
;External reference to ^PS(50.606 supported by DBIA 2174
;External reference to EN^PSSUTIL1 supported by DBIA 3179
;External reference to ^ICDCODE sup DBIA 3990
;
;PSOPND=Internal number from 52.41
;PSOPNDST=Order Control Code Status
;PSOPNDPT=Pharmacy Status
;
EN(PSOPND,PSOPNDST,PSOPNDPT) ;
N MSG,PSOHLIP,PSOHLIPX,PSOHLIPC,PSOHLTTL,PSOHUTL,PSOHND,PSOHNDD,PSOHNDU,PSONFLD,PSOXFLD,PSOLIMIT,PSONJJ,PSOHJJ,PSOHCT
N PSOSEGMT,PSOHENT,PSOHPRO,PSOHIM,PSOHPC,PSOHPCTX,PSOHRT,PSOHRTE,PSOHRTEN,PSOHRTX,Y,DA,DIQ,DR,PSOWRDT,PSOHITM,PSOHLICP,PSOHPCT
I $G(PSOPND)=""!($G(PSOPNDST)="") Q
I '$D(^PS(52.41,+$G(PSOPND),0)) Q
S PSONFLD="F PSONJJ=0:1:PSOLIMIT S PSOXFLD(PSONJJ)="""""
S PSOHCT=1
D INIT^PSOHLSN
D PID,PV1,ORC,RXO,RXE,RXR,ZRX,DG1,ZCL
D MSG^XQOR("PS EVSEND OR",.MSG)
Q
PID ;Build PID segment
S PSOLIMIT=5 X PSONFLD
;What about this ICN number?
S PSOXFLD(0)="PID"
S PSOXFLD(3)=$P($G(^PS(52.41,PSOPND,0)),"^",2)
D SEG
Q
PV1 ;Build PV1 segment
S PSOLIMIT=19 X PSONFLD
S PSOXFLD(0)="PV1"
S PSOXFLD(2)="O"
I $P($G(^PS(52.41,PSOPND,0)),"^",13) S PSOXFLD(3)=$P(^(0),"^",13)
D SEG
Q
DG1 ;Build DG1 segment
;future use; chcs does not send ICD-9 codes.
Q:'$D(^PS(52.41,PSOPND,"ICD"))
S PSOLIMIT=4 X PSONFLD
S PSOXFLD(0)="DG1"
N LP,VDG,FLAG,DXDESC,DG
S FLAG="",PSOXFLD(4)="",PSOXFLD(2)=""
F LP=1:1:8 Q:'$D(^PS(52.41,PSOPND,"ICD",LP,0)) D
. S VDG="",VDG=^PS(52.41,PSOPND,"ICD",LP,0) Q:$P(VDG,U,1)=""
. S (DG,DXDESC)=""
. N PSOARRY,PSOICDD,PSOICDDX ;*404
. S PSOICDDX=$$ICDDX^ICDCODE($P(VDG,U,1)) ;*404
. S PSOICDD=$$ICDD^ICDCODE($P(PSOICDDX,U,2),"PSOARRY"),PSOXFLD(1)=LP ;*404
. S DXDESC=PSOARRY(1) ;*404
. S PSOXFLD(3)=$P(VDG,U,1)_U_DXDESC_U_"80"_U_$P(PSOICDDX,U,2)_U_DXDESC_U_"ICD9" ;*404
. D SEG
Q
ORC ;Build ORC segment
N X
S PSOLIMIT=15 X PSONFLD
S PSOXFLD(0)="ORC"
S PSOXFLD(1)=$G(PSOPNDST)
S PSOXFLD(3)=PSOPND_"S^PS"
S PSOXFLD(5)=$G(PSOPNDPT)
S X=$P($G(^PS(52.41,PSOPND,0)),"^",6) I X S PSOXFLD(9)=$$FMTHL7^XLFDT(X)
S PSOHENT=$P($G(^PS(52.41,PSOPND,0)),"^",4) I PSOHENT K ^UTILITY("DIQ1",$J) S DIC=200,DR=.01,DA=PSOHENT,DIQ(0)="E" D EN^DIQ1 S PSOXFLD(10)=PSOHENT_"^"_$P($G(^UTILITY("DIQ1",$J,200,PSOHENT,.01,"E")),"^")
S PSOHPRO=$P($G(^PS(52.41,PSOPND,0)),"^",5) I PSOHPRO K ^UTILITY("DIQ1",$J) S DIC=200,DR=.01,DA=PSOHPRO,DIQ(0)="E" D EN^DIQ1 S PSOXFLD(12)=PSOHPRO_"^"_$P($G(^UTILITY("DIQ1",$J,200,PSOHPRO,.01,"E")),"^")
K ^UTILITY("DIQ1",$J),DIQ,DIC,DA,DR
S X=$P($G(^PS(52.41,PSOPND,0)),"^",12) I X S PSOXFLD(15)=$$FMTHL7^XLFDT(X)
D SEG
Q
RXO ;Build RXO segment
S PSOLIMIT=1 X PSONFLD
S PSOXFLD(0)="RXO"
S PSOHITM=$P($G(^PS(52.41,PSOPND,0)),"^",8)
S PSOXFLD(1)=$S($G(PSOHITM):"^^^"_PSOHITM_"^"_$P($G(^PS(50.7,+$G(PSOHITM),0)),"^")_" "_$P($G(^PS(50.606,+$P($G(^(0)),"^",2),0)),"^")_"^99PSP",1:"^^^^^")
D SEG
Q
RXE ;Build RXE segment
K PSOXFLD S PSOLIMIT=26 X PSONFLD
S PSOXFLD(0)="RXE"
;No Quantity Timing, since the Sig is entered as free text
S PSOHNDD=$P($G(^PS(52.41,PSOPND,0)),"^",9)
S PSOHND="" I PSOHNDD S PSOHND=$G(^PSDRUG(PSOHNDD,"ND"))
S PSOXFLD(2)=$S($P(PSOHND,"^")&($P(PSOHND,"^",3)):$P(PSOHND,"^")_"."_$P(PSOHND,"^",3)_"^"_$P(PSOHND,"^",2)_"^"_"99NDF",1:"^^")_"^"_$G(PSOHNDD)_"^"_$S($G(PSOHNDD):$P($G(^PSDRUG(PSOHNDD,0)),"^"),1:"")_"^"_"99PSD"
I $P(PSOHND,"^"),$P(PSOHND,"^",3) D
.I $T(^PSNAPIS)]"" S PSOHNDU=$$DFSU^PSNAPIS($P(PSOHND,"^"),$P(PSOHND,"^",3)) S PSOXFLD(5)="^^^"_$P($G(PSOHNDU),"^",5)_"^"_$P($G(PSOHNDU),"^",6)_"^"_"99PSU"
I $G(PSOHITM) S PSOXFLD(6)="^^^"_$P($G(^PS(50.7,$G(PSOHITM),0)),"^",2)_"^"_$P($G(^PS(50.606,+$P($G(^PS(50.7,$G(PSOHITM),0)),"^",2),0)),"^")_"^"_"99PSF"
S PSOXFLD(10)=$P(^PS(52.41,PSOPND,0),"^",10)
S PSOXFLD(12)=$P(^PS(52.41,PSOPND,0),"^",11)
I $$GET1^DIQ(52.49,PSOIEN,95.1,"I"),$$CS^PSOERXA0(PSOHNDD) D ;P755 Check if CS and send DEA# ; P771-Get DEA from File #52.48 matched to NEW DEA #'S (#53.21) field in NEW PERSON (#200)
. N PSOERXPRV S PSOERXPRV=$$GET1^DIQ(52.49,PSOIEN,2.1,"I") I PSOERXPRV S PSOXFLD(13)=$$GET1^DIQ(52.48,+PSOERXPRV,1.6)
S PSOXFLD(22)=$P(^PS(52.41,PSOPND,0),"^",22)
I $G(PSOHNDD) S PSOHUTL=$$EN^PSSUTIL1(PSOHNDD) S PSOXFLD(25)=$S($E($P(PSOHUTL,"|"),1)=".":"0",1:"")_$P(PSOHUTL,"|"),PSOXFLD(26)=$P(PSOHUTL,"|",2)
;Create RXE segment, can possibly go over 245 in length
S PSOHCT=PSOHCT+1
S (PSOHLIPX,PSOHLIPC,PSOHLTTL)=0,PSOHLIP="" F S PSOHLIP=$O(PSOXFLD(PSOHLIP)) Q:PSOHLIP="" D
.I PSOHLIP S PSOXFLD(PSOHLIP)="|"_PSOXFLD(PSOHLIP)
.I PSOHLTTL+$L(PSOXFLD(PSOHLIP))<246 D S PSOHLTTL=PSOHLTTL+$L(PSOXFLD(PSOHLIP)) Q
..I 'PSOHLIPX S MSG(PSOHCT)=$G(MSG(PSOHCT))_PSOXFLD(PSOHLIP) Q
..S MSG(PSOHCT,PSOHLIPX)=$G(MSG(PSOHCT,PSOHLIPX))_PSOXFLD(PSOHLIP)
.S PSOHLICP=245-PSOHLTTL
.I 'PSOHLIPX D S PSOHLTTL=$L(MSG(PSOHCT,PSOHLIPX)) Q
..S MSG(PSOHCT)=$G(MSG(PSOHCT))_$E(PSOXFLD(PSOHLIP),1,PSOHLICP)
..S PSOHLIPX=1,MSG(PSOHCT,PSOHLIPX)=$E(PSOXFLD(PSOHLIP),(PSOHLICP+1),999)
.S MSG(PSOHCT,PSOHLIPX)=$G(MSG(PSOHCT,PSOHLIPX))_$E(PSOXFLD(PSOHLIP),1,PSOHLICP)
.S PSOHLIPX=PSOHLIPX+1,MSG(PSOHCT,PSOHLIPX)=$E(PSOXFLD(PSOHLIP),(PSOHLICP+1),999)
.S PSOHLTTL=$L(MSG(PSOHCT,PSOHLIPX))
;Set NTE segments
S PSOHPCT=0,PSOHCT=PSOHCT+1 I $O(^PS(52.41,PSOPND,3,0)) F PSOHPC=0:0 S PSOHPC=$O(^PS(52.41,PSOPND,3,PSOHPC)) Q:'PSOHPC D
.I $G(^PS(52.41,PSOPND,3,PSOHPC,0))="" Q
.I 'PSOHPCT S MSG(PSOHCT)="NTE|6||"_$G(^PS(52.41,PSOPND,3,PSOHPC,0)) S PSOHPCT=1 Q
.S MSG(PSOHCT,PSOHPCT)=$G(^PS(52.41,PSOPND,3,PSOHPC,0)),PSOHPCT=PSOHPCT+1
I 'PSOHPCT S PSOHCT=PSOHCT-1
S PSOHCT=PSOHCT+1,PSOHPCT=0 I $O(^PS(52.41,PSOPND,"SIG",0)) F PSOHPC=0:0 S PSOHPC=$O(^PS(52.41,PSOPND,"SIG",PSOHPC)) Q:'PSOHPC D
.I $G(^PS(52.41,PSOPND,"SIG",PSOHPC,0))="" Q
.I 'PSOHPCT S MSG(PSOHCT)="NTE|21||"_$G(^PS(52.41,PSOPND,"SIG",PSOHPC,0)) S PSOHPCT=1 Q
.S MSG(PSOHCT,PSOHPCT)=$G(^PS(52.41,PSOPND,"SIG",PSOHPC,0)),PSOHPCT=PSOHPCT+1
I 'PSOHPCT S MSG(PSOHCT)="NTE|21||"_"No SIG available"
Q
RXR ;Build RXR segment
S PSOHRTX="" F PSOHRT=0:0 S PSOHRT=$O(^PS(52.41,PSOPND,1,PSOHRT)) Q:'PSOHRT D
.S PSOHRTX=1
.S PSOLIMIT=1 X PSONFLD
.S PSOXFLD(0)="RXR"
.S PSOHRTEN=""
.S PSOHRTE=$P($G(^PS(52.41,PSOPND,1,PSOHRT,1)),"^",8) I PSOHRTE,$D(^PS(51.2,PSOHRTE,0)) S PSOHRTEN=$P($G(^(0)),"^")
.S PSOXFLD(1)="^^^"_$G(PSOHRTE)_"^"_$G(PSOHRTEN)_"^"_"99PSR"
.D SEG
I '$G(PSOHRTX) S PSOLIMIT=1 X PSONFLD S PSOXFLD(0)="RXR",PSOXFLD(1)="^^^^^99PSR" D SEG
Q
ZRX ;Build ZRX segment
S PSOLIMIT=6 X PSONFLD
S PSOXFLD(0)="ZRX"
S PSOXFLD(3)="N"
S PSOXFLD(4)=$P($G(^PS(52.41,PSOPND,0)),"^",17)
D SEG
Q
ZCL ;Build ZCL segment
N I,JJJ,INODE,EI
S PSOXFLD(0)="ZCL",PSOLIMIT=3 X PSONFLD
I $D(^PS(52.41,PSOPND,"ICD")) D
.F I=1:1:8 D
..Q:'$D(^PS(52.41,PSOPND,"ICD",I,0))
..S INODE="",INODE=^PS(52.41,PSOPND,"ICD",I,0)
..F JJJ=2:1:9 S EI=$P(INODE,U,JJJ) D
...S PSOXFLD(1)=I,PSOXFLD(2)=JJJ-1,PSOXFLD(3)=EI
...;I JJJ=4 S EI=$S(EI=1:"SC",EI=0:"NSC",1:"") S PSOXFLD(3)=EI
...D SEG
E D ;if no ICD node, send one ZCL segment
.S PSOXFLD(0)="ZCL",PSOXFLD(1)=1,PSOXFLD(2)=3
.S PSOXFLD(3)=$S($P(^PS(52.41,PSOPND,0),"^",16)="SC":1,$P(^(0),"^",16)="NSC":0,1:"")
.D SEG
.Q:'$D(^PS(52.41,PSOPND,"IBQ"))
.S EI=^PS(52.41,PSOPND,"IBQ")
.F I=2,3,4,1,5,6,7 S PSOXFLD(3)=$P(EI,U,I) D
.. S PSOXFLD(2)=$S(I=2:1,I=3:2,I=4:4,I=1:5,I=5:6,I=6:7,I=7:8,1:"") D SEG
Q
ZSC ;Build ZSC segment
S PSOLIMIT=6 X PSONFLD
S PSOXFLD(0)="ZSC"
S PSOXFLD(1)=$S($P(^PS(52.41,PSOPND,0),"^",16)="SC":1,$P(^(0),"^",16)="NSC":0,1:"")
S PSOXFLD(2)=$P($G(^PS(52.41,PSOPND,"IBQ")),"^"),PSOXFLD(3)=$P($G(^("IBQ")),"^",2),PSOXFLD(4)=$P($G(^("IBQ")),"^",3),PSOXFLD(5)=$P($G(^("IBQ")),"^",4),PSOXFLD(6)=$P($G(^("IBQ")),"^",5),PSOXFLD(7)=$P($G(^("IBQ")),"^",6)
D SEG
Q
SEG ;
S PSOSEGMT="" F PSOHJJ=0:1:PSOLIMIT S PSOSEGMT=$S(PSOSEGMT="":PSOXFLD(PSOHJJ),1:PSOSEGMT_"|"_PSOXFLD(PSOHJJ))
S PSOHCT=PSOHCT+1,MSG(PSOHCT)=PSOSEGMT
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOHLSNC 8219 printed Sep 23, 2025@20:06:39 Page 2
PSOHLSNC ;BIR/RTR - Send CHCS message to CPRS ;07/03/02
+1 ;;7.0;OUTPATIENT PHARMACY;**111,157,143,225,404,755,771**;DEC 1997;Build 8
+2 ;External reference to ^PS(50.7 supported by DBIA 2223
+3 ;External reference to ^PS(51.2 supported by DBIA 2226
+4 ;External reference to ^PSDRUG( supported by DBIA 221
+5 ;External reference to ^PS(50.607 supported by DBIA 2221
+6 ;External reference to ^PS(50.606 supported by DBIA 2174
+7 ;External reference to EN^PSSUTIL1 supported by DBIA 3179
+8 ;External reference to ^ICDCODE sup DBIA 3990
+9 ;
+10 ;PSOPND=Internal number from 52.41
+11 ;PSOPNDST=Order Control Code Status
+12 ;PSOPNDPT=Pharmacy Status
+13 ;
EN(PSOPND,PSOPNDST,PSOPNDPT) ;
+1 NEW MSG,PSOHLIP,PSOHLIPX,PSOHLIPC,PSOHLTTL,PSOHUTL,PSOHND,PSOHNDD,PSOHNDU,PSONFLD,PSOXFLD,PSOLIMIT,PSONJJ,PSOHJJ,PSOHCT
+2 NEW PSOSEGMT,PSOHENT,PSOHPRO,PSOHIM,PSOHPC,PSOHPCTX,PSOHRT,PSOHRTE,PSOHRTEN,PSOHRTX,Y,DA,DIQ,DR,PSOWRDT,PSOHITM,PSOHLICP,PSOHPCT
+3 IF $GET(PSOPND)=""!($GET(PSOPNDST)="")
QUIT
+4 IF '$DATA(^PS(52.41,+$GET(PSOPND),0))
QUIT
+5 SET PSONFLD="F PSONJJ=0:1:PSOLIMIT S PSOXFLD(PSONJJ)="""""
+6 SET PSOHCT=1
+7 DO INIT^PSOHLSN
+8 DO PID
DO PV1
DO ORC
DO RXO
DO RXE
DO RXR
DO ZRX
DO DG1
DO ZCL
+9 DO MSG^XQOR("PS EVSEND OR",.MSG)
+10 QUIT
PID ;Build PID segment
+1 SET PSOLIMIT=5
XECUTE PSONFLD
+2 ;What about this ICN number?
+3 SET PSOXFLD(0)="PID"
+4 SET PSOXFLD(3)=$PIECE($GET(^PS(52.41,PSOPND,0)),"^",2)
+5 DO SEG
+6 QUIT
PV1 ;Build PV1 segment
+1 SET PSOLIMIT=19
XECUTE PSONFLD
+2 SET PSOXFLD(0)="PV1"
+3 SET PSOXFLD(2)="O"
+4 IF $PIECE($GET(^PS(52.41,PSOPND,0)),"^",13)
SET PSOXFLD(3)=$PIECE(^(0),"^",13)
+5 DO SEG
+6 QUIT
DG1 ;Build DG1 segment
+1 ;future use; chcs does not send ICD-9 codes.
+2 if '$DATA(^PS(52.41,PSOPND,"ICD"))
QUIT
+3 SET PSOLIMIT=4
XECUTE PSONFLD
+4 SET PSOXFLD(0)="DG1"
+5 NEW LP,VDG,FLAG,DXDESC,DG
+6 SET FLAG=""
SET PSOXFLD(4)=""
SET PSOXFLD(2)=""
+7 FOR LP=1:1:8
if '$DATA(^PS(52.41,PSOPND,"ICD",LP,0))
QUIT
Begin DoDot:1
+8 SET VDG=""
SET VDG=^PS(52.41,PSOPND,"ICD",LP,0)
if $PIECE(VDG,U,1)=""
QUIT
+9 SET (DG,DXDESC)=""
+10 ;*404
NEW PSOARRY,PSOICDD,PSOICDDX
+11 ;*404
SET PSOICDDX=$$ICDDX^ICDCODE($PIECE(VDG,U,1))
+12 ;*404
SET PSOICDD=$$ICDD^ICDCODE($PIECE(PSOICDDX,U,2),"PSOARRY")
SET PSOXFLD(1)=LP
+13 ;*404
SET DXDESC=PSOARRY(1)
+14 ;*404
SET PSOXFLD(3)=$PIECE(VDG,U,1)_U_DXDESC_U_"80"_U_$PIECE(PSOICDDX,U,2)_U_DXDESC_U_"ICD9"
+15 DO SEG
End DoDot:1
+16 QUIT
ORC ;Build ORC segment
+1 NEW X
+2 SET PSOLIMIT=15
XECUTE PSONFLD
+3 SET PSOXFLD(0)="ORC"
+4 SET PSOXFLD(1)=$GET(PSOPNDST)
+5 SET PSOXFLD(3)=PSOPND_"S^PS"
+6 SET PSOXFLD(5)=$GET(PSOPNDPT)
+7 SET X=$PIECE($GET(^PS(52.41,PSOPND,0)),"^",6)
IF X
SET PSOXFLD(9)=$$FMTHL7^XLFDT(X)
+8 SET PSOHENT=$PIECE($GET(^PS(52.41,PSOPND,0)),"^",4)
IF PSOHENT
KILL ^UTILITY("DIQ1",$JOB)
SET DIC=200
SET DR=.01
SET DA=PSOHENT
SET DIQ(0)="E"
DO EN^DIQ1
SET PSOXFLD(10)=PSOHENT_"^"_$PIECE($GET(^UTILITY("DIQ1",$JOB,200,PSOHENT,.01,"E")),"^")
+9 SET PSOHPRO=$PIECE($GET(^PS(52.41,PSOPND,0)),"^",5)
IF PSOHPRO
KILL ^UTILITY("DIQ1",$JOB)
SET DIC=200
SET DR=.01
SET DA=PSOHPRO
SET DIQ(0)="E"
DO EN^DIQ1
SET PSOXFLD(12)=PSOHPRO_"^"_$PIECE($GET(^UTILITY("DIQ1",$JOB,200,PSOHPRO,.01,"E")),"^")
+10 KILL ^UTILITY("DIQ1",$JOB),DIQ,DIC,DA,DR
+11 SET X=$PIECE($GET(^PS(52.41,PSOPND,0)),"^",12)
IF X
SET PSOXFLD(15)=$$FMTHL7^XLFDT(X)
+12 DO SEG
+13 QUIT
RXO ;Build RXO segment
+1 SET PSOLIMIT=1
XECUTE PSONFLD
+2 SET PSOXFLD(0)="RXO"
+3 SET PSOHITM=$PIECE($GET(^PS(52.41,PSOPND,0)),"^",8)
+4 SET PSOXFLD(1)=$SELECT($GET(PSOHITM):"^^^"_PSOHITM_"^"_$PIECE($GET(^PS(50.7,+$GET(PSOHITM),0)),"^")_" "_$PIECE($GET(^PS(50.606,+$PIECE($GET(^(0)),"^",2),0)),"^")_"^99PSP",1:"^^^^^")
+5 DO SEG
+6 QUIT
RXE ;Build RXE segment
+1 KILL PSOXFLD
SET PSOLIMIT=26
XECUTE PSONFLD
+2 SET PSOXFLD(0)="RXE"
+3 ;No Quantity Timing, since the Sig is entered as free text
+4 SET PSOHNDD=$PIECE($GET(^PS(52.41,PSOPND,0)),"^",9)
+5 SET PSOHND=""
IF PSOHNDD
SET PSOHND=$GET(^PSDRUG(PSOHNDD,"ND"))
+6 SET PSOXFLD(2)=$SELECT($PIECE(PSOHND,"^")&($PIECE(PSOHND,"^",3)):$PIECE(PSOHND,"^")_"."_$PIECE(PSOHND,"^",3)_"^"_$PIECE(PSOHND,"^",2)_"^"_"99NDF",1:"^^")_"^"_$GET(PSOHNDD)_"^"_$SELECT($GET(PSOHNDD):$PIECE(...
... $GET(^PSDRUG(PSOHNDD,0)),"^"),1:"")_"^"_"99PSD"
+7 IF $PIECE(PSOHND,"^")
IF $PIECE(PSOHND,"^",3)
Begin DoDot:1
+8 IF $TEXT(^PSNAPIS)]""
SET PSOHNDU=$$DFSU^PSNAPIS($PIECE(PSOHND,"^"),$PIECE(PSOHND,"^",3))
SET PSOXFLD(5)="^^^"_$PIECE($GET(PSOHNDU),"^",5)_"^"_$PIECE($GET(PSOHNDU),"^",6)_"^"_"99PSU"
End DoDot:1
+9 IF $GET(PSOHITM)
SET PSOXFLD(6)="^^^"_$PIECE($GET(^PS(50.7,$GET(PSOHITM),0)),"^",2)_"^"_$PIECE($GET(^PS(50.606,+$PIECE($GET(^PS(50.7,$GET(PSOHITM),0)),"^",2),0)),"^")_"^"_"99PSF"
+10 SET PSOXFLD(10)=$PIECE(^PS(52.41,PSOPND,0),"^",10)
+11 SET PSOXFLD(12)=$PIECE(^PS(52.41,PSOPND,0),"^",11)
+12 ;P755 Check if CS and send DEA# ; P771-Get DEA from File #52.48 matched to NEW DEA #'S (#53.21) field in NEW PERSON (#200)
IF $$GET1^DIQ(52.49,PSOIEN,95.1,"I")
IF $$CS^PSOERXA0(PSOHNDD)
Begin DoDot:1
+13 NEW PSOERXPRV
SET PSOERXPRV=$$GET1^DIQ(52.49,PSOIEN,2.1,"I")
IF PSOERXPRV
SET PSOXFLD(13)=$$GET1^DIQ(52.48,+PSOERXPRV,1.6)
End DoDot:1
+14 SET PSOXFLD(22)=$PIECE(^PS(52.41,PSOPND,0),"^",22)
+15 IF $GET(PSOHNDD)
SET PSOHUTL=$$EN^PSSUTIL1(PSOHNDD)
SET PSOXFLD(25)=$SELECT($EXTRACT($PIECE(PSOHUTL,"|"),1)=".":"0",1:"")_$PIECE(PSOHUTL,"|")
SET PSOXFLD(26)=$PIECE(PSOHUTL,"|",2)
+16 ;Create RXE segment, can possibly go over 245 in length
+17 SET PSOHCT=PSOHCT+1
+18 SET (PSOHLIPX,PSOHLIPC,PSOHLTTL)=0
SET PSOHLIP=""
FOR
SET PSOHLIP=$ORDER(PSOXFLD(PSOHLIP))
if PSOHLIP=""
QUIT
Begin DoDot:1
+19 IF PSOHLIP
SET PSOXFLD(PSOHLIP)="|"_PSOXFLD(PSOHLIP)
+20 IF PSOHLTTL+$LENGTH(PSOXFLD(PSOHLIP))<246
Begin DoDot:2
+21 IF 'PSOHLIPX
SET MSG(PSOHCT)=$GET(MSG(PSOHCT))_PSOXFLD(PSOHLIP)
QUIT
+22 SET MSG(PSOHCT,PSOHLIPX)=$GET(MSG(PSOHCT,PSOHLIPX))_PSOXFLD(PSOHLIP)
End DoDot:2
SET PSOHLTTL=PSOHLTTL+$LENGTH(PSOXFLD(PSOHLIP))
QUIT
+23 SET PSOHLICP=245-PSOHLTTL
+24 IF 'PSOHLIPX
Begin DoDot:2
+25 SET MSG(PSOHCT)=$GET(MSG(PSOHCT))_$EXTRACT(PSOXFLD(PSOHLIP),1,PSOHLICP)
+26 SET PSOHLIPX=1
SET MSG(PSOHCT,PSOHLIPX)=$EXTRACT(PSOXFLD(PSOHLIP),(PSOHLICP+1),999)
End DoDot:2
SET PSOHLTTL=$LENGTH(MSG(PSOHCT,PSOHLIPX))
QUIT
+27 SET MSG(PSOHCT,PSOHLIPX)=$GET(MSG(PSOHCT,PSOHLIPX))_$EXTRACT(PSOXFLD(PSOHLIP),1,PSOHLICP)
+28 SET PSOHLIPX=PSOHLIPX+1
SET MSG(PSOHCT,PSOHLIPX)=$EXTRACT(PSOXFLD(PSOHLIP),(PSOHLICP+1),999)
+29 SET PSOHLTTL=$LENGTH(MSG(PSOHCT,PSOHLIPX))
End DoDot:1
+30 ;Set NTE segments
+31 SET PSOHPCT=0
SET PSOHCT=PSOHCT+1
IF $ORDER(^PS(52.41,PSOPND,3,0))
FOR PSOHPC=0:0
SET PSOHPC=$ORDER(^PS(52.41,PSOPND,3,PSOHPC))
if 'PSOHPC
QUIT
Begin DoDot:1
+32 IF $GET(^PS(52.41,PSOPND,3,PSOHPC,0))=""
QUIT
+33 IF 'PSOHPCT
SET MSG(PSOHCT)="NTE|6||"_$GET(^PS(52.41,PSOPND,3,PSOHPC,0))
SET PSOHPCT=1
QUIT
+34 SET MSG(PSOHCT,PSOHPCT)=$GET(^PS(52.41,PSOPND,3,PSOHPC,0))
SET PSOHPCT=PSOHPCT+1
End DoDot:1
+35 IF 'PSOHPCT
SET PSOHCT=PSOHCT-1
+36 SET PSOHCT=PSOHCT+1
SET PSOHPCT=0
IF $ORDER(^PS(52.41,PSOPND,"SIG",0))
FOR PSOHPC=0:0
SET PSOHPC=$ORDER(^PS(52.41,PSOPND,"SIG",PSOHPC))
if 'PSOHPC
QUIT
Begin DoDot:1
+37 IF $GET(^PS(52.41,PSOPND,"SIG",PSOHPC,0))=""
QUIT
+38 IF 'PSOHPCT
SET MSG(PSOHCT)="NTE|21||"_$GET(^PS(52.41,PSOPND,"SIG",PSOHPC,0))
SET PSOHPCT=1
QUIT
+39 SET MSG(PSOHCT,PSOHPCT)=$GET(^PS(52.41,PSOPND,"SIG",PSOHPC,0))
SET PSOHPCT=PSOHPCT+1
End DoDot:1
+40 IF 'PSOHPCT
SET MSG(PSOHCT)="NTE|21||"_"No SIG available"
+41 QUIT
RXR ;Build RXR segment
+1 SET PSOHRTX=""
FOR PSOHRT=0:0
SET PSOHRT=$ORDER(^PS(52.41,PSOPND,1,PSOHRT))
if 'PSOHRT
QUIT
Begin DoDot:1
+2 SET PSOHRTX=1
+3 SET PSOLIMIT=1
XECUTE PSONFLD
+4 SET PSOXFLD(0)="RXR"
+5 SET PSOHRTEN=""
+6 SET PSOHRTE=$PIECE($GET(^PS(52.41,PSOPND,1,PSOHRT,1)),"^",8)
IF PSOHRTE
IF $DATA(^PS(51.2,PSOHRTE,0))
SET PSOHRTEN=$PIECE($GET(^(0)),"^")
+7 SET PSOXFLD(1)="^^^"_$GET(PSOHRTE)_"^"_$GET(PSOHRTEN)_"^"_"99PSR"
+8 DO SEG
End DoDot:1
+9 IF '$GET(PSOHRTX)
SET PSOLIMIT=1
XECUTE PSONFLD
SET PSOXFLD(0)="RXR"
SET PSOXFLD(1)="^^^^^99PSR"
DO SEG
+10 QUIT
ZRX ;Build ZRX segment
+1 SET PSOLIMIT=6
XECUTE PSONFLD
+2 SET PSOXFLD(0)="ZRX"
+3 SET PSOXFLD(3)="N"
+4 SET PSOXFLD(4)=$PIECE($GET(^PS(52.41,PSOPND,0)),"^",17)
+5 DO SEG
+6 QUIT
ZCL ;Build ZCL segment
+1 NEW I,JJJ,INODE,EI
+2 SET PSOXFLD(0)="ZCL"
SET PSOLIMIT=3
XECUTE PSONFLD
+3 IF $DATA(^PS(52.41,PSOPND,"ICD"))
Begin DoDot:1
+4 FOR I=1:1:8
Begin DoDot:2
+5 if '$DATA(^PS(52.41,PSOPND,"ICD",I,0))
QUIT
+6 SET INODE=""
SET INODE=^PS(52.41,PSOPND,"ICD",I,0)
+7 FOR JJJ=2:1:9
SET EI=$PIECE(INODE,U,JJJ)
Begin DoDot:3
+8 SET PSOXFLD(1)=I
SET PSOXFLD(2)=JJJ-1
SET PSOXFLD(3)=EI
+9 ;I JJJ=4 S EI=$S(EI=1:"SC",EI=0:"NSC",1:"") S PSOXFLD(3)=EI
+10 DO SEG
End DoDot:3
End DoDot:2
End DoDot:1
+11 ;if no ICD node, send one ZCL segment
IF '$TEST
Begin DoDot:1
+12 SET PSOXFLD(0)="ZCL"
SET PSOXFLD(1)=1
SET PSOXFLD(2)=3
+13 SET PSOXFLD(3)=$SELECT($PIECE(^PS(52.41,PSOPND,0),"^",16)="SC":1,$PIECE(^(0),"^",16)="NSC":0,1:"")
+14 DO SEG
+15 if '$DATA(^PS(52.41,PSOPND,"IBQ"))
QUIT
+16 SET EI=^PS(52.41,PSOPND,"IBQ")
+17 FOR I=2,3,4,1,5,6,7
SET PSOXFLD(3)=$PIECE(EI,U,I)
Begin DoDot:2
+18 SET PSOXFLD(2)=$SELECT(I=2:1,I=3:2,I=4:4,I=1:5,I=5:6,I=6:7,I=7:8,1:"")
DO SEG
End DoDot:2
End DoDot:1
+19 QUIT
ZSC ;Build ZSC segment
+1 SET PSOLIMIT=6
XECUTE PSONFLD
+2 SET PSOXFLD(0)="ZSC"
+3 SET PSOXFLD(1)=$SELECT($PIECE(^PS(52.41,PSOPND,0),"^",16)="SC":1,$PIECE(^(0),"^",16)="NSC":0,1:"")
+4 SET PSOXFLD(2)=$PIECE($GET(^PS(52.41,PSOPND,"IBQ")),"^")
SET PSOXFLD(3)=$PIECE($GET(^("IBQ")),"^",2)
SET PSOXFLD(4)=$PIECE($GET(^("IBQ")),"^",3)
SET PSOXFLD(5)=$PIECE($GET(^("IBQ")),"^",4)
SET PSOXFLD(6)=$PIECE($GET(^("IBQ")),"^",5)
SET PSOXFLD(7)=$PIECE($GET(^("IBQ")),"^",6)
+5 DO SEG
+6 QUIT
SEG ;
+1 SET PSOSEGMT=""
FOR PSOHJJ=0:1:PSOLIMIT
SET PSOSEGMT=$SELECT(PSOSEGMT="":PSOXFLD(PSOHJJ),1:PSOSEGMT_"|"_PSOXFLD(PSOHJJ))
+2 SET PSOHCT=PSOHCT+1
SET MSG(PSOHCT)=PSOSEGMT
+3 QUIT
