- PSOHLSNC ;BIR/RTR - Send CHCS message to CPRS ;07/03/02
- ;;7.0;OUTPATIENT PHARMACY;**111,157,143,225**;DEC 1997;Build 29
- ;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
- ;
- ;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,PSOSEGMT,PSOHENT,PSOHPRO,PSOHIM,PSOHPC,PSOHPCTX,PSOHRT,PSOHRTE,PSOHRTEN,PSOHRTX,Y,DA,DIQ,DR
- 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)=""
- . S DXDESC=$$GET1^DIQ(80,$P(VDG,U,1)_",",10),PSOXFLD(1)=LP
- . S PSOXFLD(3)=$P(VDG,U,1)_U_DXDESC_U_"80"_U_$$GET1^DIQ(80,$P(VDG,U,1)_",",.01)_U_DXDESC_U_"ICD9"
- . D SEG
- Q
- ORC ;Build ORC segment
- 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)
- 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)
- 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
- PSOHLSNC ;BIR/RTR - Send CHCS message to CPRS ;07/03/02
- +1 ;;7.0;OUTPATIENT PHARMACY;**111,157,143,225**;DEC 1997;Build 29
- +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 ;
- +9 ;PSOPND=Internal number from 52.41
- +10 ;PSOPNDST=Order Control Code Status
- +11 ;PSOPNDPT=Pharmacy Status
- +12 ;
- EN(PSOPND,PSOPNDST,PSOPNDPT) ;
- +1 NEW MSG,PSOHLIP,PSOHLIPX,PSOHLIPC,PSOHLTTL,PSOHUTL,PSOHND,PSOHNDD,PSOHNDU,PSONFLD,PSOXFLD,PSOLIMIT,PSONJJ,PSOHJJ,PSOHCT,PSOSEGMT,PSOHENT,PSOHPRO,PSOHIM,PSOHPC,PSOHPCTX,PSOHRT,PSOHRTE,PSOHRTEN,PSOHRTX,Y,DA,DIQ,DR
- +2 IF $GET(PSOPND)=""!($GET(PSOPNDST)="")
- QUIT
- +3 IF '$DATA(^PS(52.41,+$GET(PSOPND),0))
- QUIT
- +4 SET PSONFLD="F PSONJJ=0:1:PSOLIMIT S PSOXFLD(PSONJJ)="""""
- +5 SET PSOHCT=1
- +6 DO INIT^PSOHLSN
- +7 DO PID
- DO PV1
- DO ORC
- DO RXO
- DO RXE
- DO RXR
- DO ZRX
- DO DG1
- DO ZCL
- +8 DO MSG^XQOR("PS EVSEND OR",.MSG)
- +9 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 SET DXDESC=$$GET1^DIQ(80,$PIECE(VDG,U,1)_",",10)
- SET PSOXFLD(1)=LP
- +11 SET PSOXFLD(3)=$PIECE(VDG,U,1)_U_DXDESC_U_"80"_U_$$GET1^DIQ(80,$PIECE(VDG,U,1)_",",.01)_U_DXDESC_U_"ICD9"
- +12 DO SEG
- End DoDot:1
- +13 QUIT
- ORC ;Build ORC segment
- +1 SET PSOLIMIT=15
- XECUTE PSONFLD
- +2 SET PSOXFLD(0)="ORC"
- +3 SET PSOXFLD(1)=$GET(PSOPNDST)
- +4 SET PSOXFLD(3)=PSOPND_"S^PS"
- +5 SET PSOXFLD(5)=$GET(PSOPNDPT)
- +6 SET X=$PIECE($GET(^PS(52.41,PSOPND,0)),"^",6)
- IF X
- SET PSOXFLD(9)=$$FMTHL7^XLFDT(X)
- +7 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")),"^")
- +8 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")),"^")
- +9 KILL ^UTILITY("DIQ1",$JOB)
- +10 SET X=$PIECE($GET(^PS(52.41,PSOPND,0)),"^",12)
- IF X
- SET PSOXFLD(15)=$$FMTHL7^XLFDT(X)
- +11 DO SEG
- +12 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 SET PSOXFLD(22)=$PIECE(^PS(52.41,PSOPND,0),"^",22)
- +13 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)
- +14 ;Create RXE segment, can possibly go over 245 in length
- +15 SET PSOHCT=PSOHCT+1
- +16 SET (PSOHLIPX,PSOHLIPC,PSOHLTTL)=0
- SET PSOHLIP=""
- FOR
- SET PSOHLIP=$ORDER(PSOXFLD(PSOHLIP))
- IF PSOHLIP=""
- QUIT
- Begin DoDot:1
- +17 IF PSOHLIP
- SET PSOXFLD(PSOHLIP)="|"_PSOXFLD(PSOHLIP)
- +18 IF PSOHLTTL+$LENGTH(PSOXFLD(PSOHLIP))<246
- Begin DoDot:2
- +19 IF 'PSOHLIPX
- SET MSG(PSOHCT)=$GET(MSG(PSOHCT))_PSOXFLD(PSOHLIP)
- QUIT
- +20 SET MSG(PSOHCT,PSOHLIPX)=$GET(MSG(PSOHCT,PSOHLIPX))_PSOXFLD(PSOHLIP)
- End DoDot:2
- SET PSOHLTTL=PSOHLTTL+$LENGTH(PSOXFLD(PSOHLIP))
- QUIT
- +21 SET PSOHLICP=245-PSOHLTTL
- +22 IF 'PSOHLIPX
- Begin DoDot:2
- +23 SET MSG(PSOHCT)=$GET(MSG(PSOHCT))_$EXTRACT(PSOXFLD(PSOHLIP),1,PSOHLICP)
- +24 SET PSOHLIPX=1
- SET MSG(PSOHCT,PSOHLIPX)=$EXTRACT(PSOXFLD(PSOHLIP),(PSOHLICP+1),999)
- End DoDot:2
- SET PSOHLTTL=$LENGTH(MSG(PSOHCT,PSOHLIPX))
- QUIT
- +25 SET MSG(PSOHCT,PSOHLIPX)=$GET(MSG(PSOHCT,PSOHLIPX))_$EXTRACT(PSOXFLD(PSOHLIP),1,PSOHLICP)
- +26 SET PSOHLIPX=PSOHLIPX+1
- SET MSG(PSOHCT,PSOHLIPX)=$EXTRACT(PSOXFLD(PSOHLIP),(PSOHLICP+1),999)
- +27 SET PSOHLTTL=$LENGTH(MSG(PSOHCT,PSOHLIPX))
- End DoDot:1
- +28 ;Set NTE segments
- +29 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
- +30 IF $GET(^PS(52.41,PSOPND,3,PSOHPC,0))=""
- QUIT
- +31 IF 'PSOHPCT
- SET MSG(PSOHCT)="NTE|6||"_$GET(^PS(52.41,PSOPND,3,PSOHPC,0))
- SET PSOHPCT=1
- QUIT
- +32 SET MSG(PSOHCT,PSOHPCT)=$GET(^PS(52.41,PSOPND,3,PSOHPC,0))
- SET PSOHPCT=PSOHPCT+1
- End DoDot:1
- +33 IF 'PSOHPCT
- SET PSOHCT=PSOHCT-1
- +34 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
- +35 IF $GET(^PS(52.41,PSOPND,"SIG",PSOHPC,0))=""
- QUIT
- +36 IF 'PSOHPCT
- SET MSG(PSOHCT)="NTE|21||"_$GET(^PS(52.41,PSOPND,"SIG",PSOHPC,0))
- SET PSOHPCT=1
- QUIT
- +37 SET MSG(PSOHCT,PSOHPCT)=$GET(^PS(52.41,PSOPND,"SIG",PSOHPC,0))
- SET PSOHPCT=PSOHPCT+1
- End DoDot:1
- +38 IF 'PSOHPCT
- SET MSG(PSOHCT)="NTE|21||"_"No SIG available"
- +39 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
