PSOHLDS5 ;BIR/MV - Misc HL7 function ; 23 Jan 2024 2:00 PM
;;7.0;OUTPATIENT PHARMACY;**643,728,742,774**;DEC 1997;Build 15
;External reference to ^PS(50.606 supported by DBIA 2174
;External reference to ^PS(50.7 supported by DBIA 2223
;External reference to ^PS(51.2 supported by DBIA 2226
;External reference to ^PS(54 supported by DBIA 2227
;External reference to ^PS(55 supported by DBIA 2228
;External reference to ^PS(59.7 is supported by DBIA 694
;External reference to ^PSDRUG supported by DBIA 221
;External reference to $$GETNDC^PSSNDCUT supported by DBIA 4707
;External reference to WTEXT^PSSWRNA supported by DBIA 4444
;External reference to DRUG^PSSWRNA supported by DBIA 4449
;External reference to EN^PSNPPIO supported by DBIA 3794
;External reference to BLDPID^VAFCQRY supported by DBIA 3630
;External reference to EN^VAFHLZTA supported by DBIA 758
;External reference to $$PROD2^PSNAPIS supported by DBIA 2531
HLSAVE(PSOLBL) ;Save HL data into PSOHLSV array
NEW X,X1,X2,X3
Q:'$D(PSOLBL)
F X=0:0 S X=$O(PSOLBL(X)) Q:'X Q:$D(PSOHLSV("COPAY STATUS")) D
.S PSOTXT=$G(PSOLBL(X)) Q:PSOTXT=""
.K X1,X2,X3
.I (PSOTXT["Rx# "),(PSOTXT[" Fill ") S X1=$P(PSOTXT," Fill ",2),X2=$P(X1," ") D Q
..S X3=$P(X2," of")-1 S PSOHLSV("FILL NUMBER")=$S(X3<0:0,1:X3)
.I PSOTXT["Days Supply:" S PSOHLSV("COPAY STATUS")=$S(PSOTXT["NO COPAY":"NO COPAY",PSOTXT["COPAY":"COPAY",1:"") I PSOTXT["NO COPAY" K PSOHLSV("COPAY NARR")
Q
;
HLSVNTE(PSONARR) ;Save HL data into Patient Narrative array
NEW X,PSOTXT,PSORF,PSONONRF,PSOCOPAY,PSOCNT
Q:'$D(PSONARR)
S (PSOCNT,PSORF,PSONONRF,PSOCOPAY)=0
F X=0:0 S X=$O(PSONARR(X)) Q:'X D
.S PSOTXT=$P($G(PSONARR(X)),U,4) Q:PSOTXT="HOST:END"
.I PSOTXT="HOST:NARRATIVE REFILLABLE RX" S PSOCNT=0,PSORF=1 Q
.I PSOTXT="HOST:NARRATIVE NON-REFILLABLE RX" S (PSOCNT,PSORF)=0,PSONONRF=1 Q
.I PSOTXT="HOST:NARRATIVE FOR COPAY DOCUMENT" S (PSOCNT,PSORF,PSONONRF)=0,PSOCOPAY=1 Q
.I PSORF S PSOCNT=PSOCNT+1,PSOHLSV("NARR REFILLABLE",PSOCNT)=PSOTXT
.I PSONONRF S PSOCNT=PSOCNT+1,PSOHLSV("NARR NON-REFILLABLE",PSOCNT)=PSOTXT
.I $G(PSOHLSV("COPAY STATUS")),PSOCOPAY S PSOCNT=PSOCNT+1,PSOHLSV("NARR COPAY",PSOCNT)=PSOTXT
Q
;
NTE2SV(CNT,NTECNT,PSOSITE) ; Patient Narrative
NEW X,DIW,DIWF,DIWI,DIWL,DIWR,DIWT,DIWTC,DIWX,FS,LLL,ZZ
Q:$G(PSOSITE)=""
S FS="^"
S CNT=+$G(CNT)+1,NTECNT=+$G(NTECNT)+1,^TMP("HLA",$J,CNT)="NTE"_FS_NTECNT_FS_FS_"Narrative" ; WLC *774* took out "Patient"
K ^UTILITY($J,"W") S DIWL=1,DIWR=78,DIWF="" F ZZ=0:0 S ZZ=$O(^PS(59,PSOSITE,6,ZZ)) Q:'ZZ I $D(^(ZZ,0)) S X=^(0) D ^DIWP
S CNT=CNT+1,NTECNT=NTECNT+1,^TMP("HLA",$J,CNT)="NTE"_FS_NTECNT_FS_FS_"HOST:NARRATIVE REFILLABLE RX"
F LLL=0:0 S LLL=$O(^UTILITY($J,"W",DIWL,LLL)) Q:'LLL S CNT=CNT+1,NTECNT=NTECNT+1,^TMP("HLA",$J,CNT)="NTE"_FS_NTECNT_FS_FS_^UTILITY($J,"W",DIWL,LLL,0)
;
S CNT=CNT+1,NTECNT=NTECNT+1,^TMP("HLA",$J,CNT)="NTE"_FS_NTECNT_FS_FS_"HOST:NARRATIVE NON-REFILLABLE RX"
S DIWL=1,DIWR=45,DIWF="" K ^UTILITY($J,"W") F ZZ=0:0 S ZZ=$O(^PS(59,PSOSITE,7,ZZ)) Q:'ZZ I $D(^(ZZ,0)) S X=^(0) D ^DIWP
F LLL=0:0 S LLL=$O(^UTILITY($J,"W",DIWL,LLL)) Q:'LLL S CNT=CNT+1,NTECNT=NTECNT+1,^TMP("HLA",$J,CNT)="NTE"_FS_NTECNT_FS_FS_^UTILITY($J,"W",DIWL,LLL,0)
;
S CNT=CNT+1,NTECNT=NTECNT+1,^TMP("HLA",$J,CNT)="NTE"_FS_NTECNT_FS_FS_"HOST:NARRATIVE FOR COPAY DOCUMENT"
S DIWL=1,DIWR=45,DIWF="" K ^UTILITY($J,"W") F ZZ=0:0 S ZZ=$O(^PS(59,PSOSITE,4,ZZ)) Q:'ZZ I $D(^(ZZ,0)) S X=^(0) D ^DIWP
F LLL=0:0 S LLL=$O(^UTILITY($J,"W",DIWL,LLL)) Q:'LLL S CNT=CNT+1,NTECNT=NTECNT+1,^TMP("HLA",$J,CNT)="NTE"_FS_NTECNT_FS_FS_^UTILITY($J,"W",DIWL,LLL,0)
;
S CNT=CNT+1,NTECNT=NTECNT+1,^TMP("HLA",$J,CNT)="NTE"_FS_NTECNT_FS_FS_"HOST:END"
Q
;
PID(PSI) ;patient ID segment
Q:'$D(DFN)!$D(PAS)
N X,Y,X2,CNT,I
S HLFS=HL1("FS"),HLECH=HL1("ECH"),HLQ=HL1("Q"),HLVER=HL1("VER")
K PSPID,PSPID1
D BLDPID^VAFCQRY(DFN,"","3,4,5,7,8,11,13",.PSPID,.HL1,.ERR)
; put PID in format needed for segment parser
S PSPID=PSPID(1) K PSPID(1)
S (X,Y)=1 F S X=+$O(PSPID(X)) Q:'X S PSPID(Y)=PSPID(X),Y=Y+1 K PSPID(X)
;parse PID into individual fields
K PRSEPID D SEGPRSE^SCMSVUT5("PSPID","PRSEPID",HL1("FS"))
; parse address into individual components
K ADDSEQ D SEQPRSE^SCMSVUT5($NA(PRSEPID(11)),"ADDSEQ",HL1("ECH"))
; build ZTA (Temporary Address)
K X2 S X2=$$EN^VAFHLZTA(DFN,"1,2,3,4,5,6,7,",1)
; parse X2 (ZTA) into individual fields if temp add. exists
D:'$$CHKTEMP(DFN)
. N BADA S BADA=$$CHKRX(DFN)
. I $P(BADA,"^"),'$P(BADA,"^",2),ADDSEQ(1,7)'["VAB" S BADA=$$GET1^DIQ(2,DFN_",",.121,"I") S:BADA ADDSEQ(1,7)="VAB"_BADA
D:$$CHKTEMP(DFN)
. K PRSEZTA D SEGPRSE^SCMSVUT5("X2","PRSEZTA",HL1("FS"))
. ; parse temporary address into individual components
. K TMPADD D SEQPRSE^SCMSVUT5($NA(PRSEZTA(5)),"TMPADD",HL1("ECH"))
. ; add temporary address as next repetition in PID segment
. S SPOT=1+$O(ADDSEQ(""),-1)
. M ADDSEQ(SPOT)=TMPADD(1)
. S ADDSEQ(SPOT,7)="C"
. S ADDSEQ(SPOT,9)=PRSEZTA(6)
. S ADDSEQ(SPOT,12,1)=PRSEZTA(3)
. S ADDSEQ(SPOT,12,2)=PRSEZTA(4)
. ;move address sequence back into parse PID segment
; rebuild PID segment
K PRSEPID(11) M PRSEPID(11)=ADDSEQ
K PSPID1 D MAKEIT^VAFHLU("PID",.PRSEPID,.PSPID1,.PSPID1)
;put rebuilt PID into format used by $$EN^VAFCQRY
K PSPID S PSPID(1)=PSPID1
S X=0,Y=2 F S X=+$O(PSPID1(X)) Q:'X S PSPID(Y)=PSPID1(X) S Y=Y+1
S CNT=0 F I=1:1 Q:'$D(PSPID(I)) D
. I I=1 S ^TMP("PSO",$J,PSI)=PSPID(I) Q
. S CNT=CNT+1 S ^TMP("PSO",$J,PSI,CNT)=PSPID(I)
S PSI=PSI+1
S PAS=1
K PSPID,PSPID1,PRSEPID,PRSEZTA,SPOT,TMPADD,ADDSEQ
Q
;
CHKRX(PSODFN) ;CHECK ADDRESS BY DFN
;Input: PSORX - PRESCRIPTION file (#52) IEN
;Output: PSOBADR - Bad Address Indicator_"^"_temporary address or not
N PSOBADR,PSOTEMP
S PSOBADR=""
S PSOBADR=$$BADADR^DGUTL3(PSODFN)
I PSOBADR S PSOTEMP=$$CHKTEMP(PSODFN)
S PSOBADR=PSOBADR_"^"_$G(PSOTEMP)
Q PSOBADR
;
CHKTEMP(PSODFN) ; see if active temporary address
;Input: PSODFN - PATIENT file (#2) IEN
N DFN,VAPA
S DFN=PSODFN,PSOTEMP=0
D 6^VADPT I +VAPA(9) S PSOTEMP=1
Q PSOTEMP
;
PV1(PSI) ;patient visit segment
Q:'$D(DFN)
N PV1 ;hardcoded to letter O for Outpatient (Patient class)
S PV1="PV1"_FS_FS_"O"_FS
S ^TMP("PSO",$J,PSI)=PV1
S PSI=PSI+1
Q
;
PV2(PSI) ;patient visit segment (additional information)
;PATIENT STATUS AND COPAY
Q:'$D(DFN)
N PV2 S PV2=""
S $P(PV2,"|",24)="UNKNOWN"_"~"_$G(PSOHLSV("COPAY STATUS"))_FS
S ^TMP("PSO",$J,PSI)="PV2|"_PV2
S PSI=PSI+1
Q
;
ORC(PSI) ;common order segment
N PSOROP3,PSOROP4,PSOHSITE,PSZIP,PSOHZIP
Q:'$D(DFN)
N ORC S ORC=""
S $P(ORC,"|",1)="NW"
S $P(ORC,"|",2)=$G(PSOHLSV("RX NUMBER"))_CS_"OP7.0"
S PSOROP3=$G(PSOHLSV("OUT REQ PHARMACIST"))
I PSOROP3'="" S PSOROP4=$$HLNAME^HLFNC(PSOROP3) S $P(ORC,"|",10)=CS_PSOROP4
S PSOROP3=$G(PSOHLSV("PROVIDER"))
I PSOROP3'="" S PSOROP4=$$HLNAME^HLFNC(PSOROP3) S $P(ORC,"|",12)=CS_PSOROP4
I $G(PSOONLAP)'="" S $P(ORC,"|",13)=PSOONLAP
S $P(ORC,"|",16)=$S($G(PSOHLSV("REQUEST TYPE"))="PR"!($G(PSOHLSV("REQUEST TYPE"))="OP"):"PARTIAL",1:"REFILL")
S PSOHSITE=$S($G(PSOSITE):$G(^PS(59,PSOSITE,0)),1:"")
S $P(ORC,"|",21)=$P(PSOHSITE,"^",1)_CS_CS_$P(PSOHSITE,"^",6)
S PSZIP=$P(PSOHSITE,"^",5),PSOHZIP=$S(PSZIP["-":PSZIP,1:$E(PSZIP,1,5)_$S($E(PSZIP,6,9)]"":"-"_$E(PSZIP,6,9),1:""))
S $P(ORC,"|",22)=$P(PSOHSITE,"^",2)_CS_CS_$P(PSOHSITE,"^",7)_CS_$S($D(^DIC(5,+$P(PSOHSITE,"^",8),0)):$P(^(0),"^",2),1:"UKN")_CS_PSOHZIP
S $P(ORC,"|",23)="("_$P(PSOHSITE,"^",3)_")"_$P(PSOHSITE,"^",4)
S ^TMP("PSO",$J,PSI)="ORC|"_ORC,PSI=PSI+1
Q
;
NTE2(PSI) ; Site Narratives
NEW X,CNT
S:'$D(FS) FS="^" S:'+$G(PSI) PSI=1 S CNT=0
I $S($G(PSOHLSV("NARR REFILLABLE",1))]"":1,$G(PSOHLSV("NARR NON-REFILLABLE",1))]"":1,$G(PSOHLSV("NARR COPAY",1))]"":1,1:0) D
.S ^TMP("PSO",$J,PSI)="NTE"_FS_2_FS_FS_"Patient Narrative"
F X=0:0 S X=$O(PSOHLSV("NARR REFILLABLE",X)) Q:'X D
.Q:$G(PSOHLSV("NARR REFILLABLE",X))=""
.S CNT=CNT+1
.S:CNT>1 ^TMP("PSO",$J,PSI,CNT-1)=^TMP("PSO",$J,PSI,CNT-1)_"\.sp\"
.S ^TMP("PSO",$J,PSI,CNT)=PSOHLSV("NARR REFILLABLE",X)
F X=0:0 S X=$O(PSOHLSV("NARR NON-REFILLABLE",X)) Q:'X D
.Q:$G(PSOHLSV("NARR NON-REFILLABLE",X))=""
.S CNT=CNT+1
.S:CNT>1 ^TMP("PSO",$J,PSI,CNT-1)=^TMP("PSO",$J,PSI,CNT-1)_"\.sp\"
.S ^TMP("PSO",$J,PSI,CNT)=PSOHLSV("NARR NON-REFILLABLE",X)
I $G(PSOHLSV("COPAY STATUS")) F X=0:0 S X=$O(PSOHLSV("NARR COPAY",X)) Q:'X D
.Q:$G(PSOHLSV("NARR COPAY",X))=""
.S CNT=CNT+1
.S:CNT>1 ^TMP("PSO",$J,PSI,CNT-1)=^TMP("PSO",$J,PSI,CNT-1)_"\.sp\"
.S ^TMP("PSO",$J,PSI,CNT)=PSOHLSV("NARR COPAY",X)
S:CNT PSI=PSI+1
Q
;
NTE1(PSI) ;SIG
N PSODR,PSODRR,PSOTSIG,PSOCLD M PSOTSIG=PSOHLSV("SIG")
K PSODRR F PSODR=0:0 S PSODR=$O(PSOTSIG(PSODR)) Q:'PSODR S PSODRR=$G(PSODRR)+1
Q:'$G(PSODRR)
S PSODRR=PSODRR+1,PSOTSIG(PSODRR)=FS_"Medication Instructions"
K PSODRR S ^TMP("PSO",$J,PSI)="NTE"_FS_1_FS_FS
S PSOCLD=1 F PSODR=0:0 S PSODR=$O(PSOTSIG(PSODR)) Q:'PSODR D
.S:$L($G(^TMP("PSO",$J,PSI,PSOCLD))_PSOTSIG(PSODR))>245 PSOCLD=PSOCLD+1 S ^TMP("PSO",$J,PSI,PSOCLD)=$G(^TMP("PSO",$J,PSI,PSOCLD))_PSOTSIG(PSODR)
S PSI=PSI+1
Q
;
NTE3(PSI) ;Drug Warning Narrative
N NTE3,J,TEXT,W,CNT,PSSWSITE,PSOLCDRG,WARN,FLDX
S PSOLCDRG=$G(PSOHLSV("L_DRUGIEN")) Q:'PSOLCDRG
S WARN=$P($G(^PSDRUG(PSOLCDRG,0)),"^",8)
S PSSWSITE=+$O(^PS(59.7,0))
I $P($G(^PS(59.7,PSSWSITE,10)),"^",11)="N" D
.S WARN=$$DRUG^PSSWRNA(PSOLCDRG,DFN)
I WARN="" Q
S NTE3="NTE"_FS_3_FS_FS,^TMP("PSO",$J,PSI)=NTE3,CNT=1
F J=1:1 S W=$P(WARN,",",J) Q:W="" D
. S:CNT>1 ^TMP("PSO",$J,PSI,CNT-1)=^TMP("PSO",$J,PSI,CNT-1)_"\.sp\"
. S TEXT=$$WTEXT^PSSWRNA(W,$G(PSOOLAN)) I TEXT'="" S FLDX=1 D
. . I $L(TEXT)<245 S ^TMP("PSO",$J,PSI,CNT)=TEXT,CNT=CNT+1 Q
. . N LTH,ST,EN,TXT,WW
. . S LTH=$E($L(TEXT)/245,1) S:$L(TEXT)#245>0 LTH=LTH+1
. . F WW=1:1:LTH D
. . . S:WW=1 ST=1,EN=245 S:WW>1 ST=(ST+245),EN=(EN+245) S TXT=$E(TEXT,ST,EN)
. . . S ^TMP("PSO",$J,PSI,CNT)=TXT,CNT=CNT+1
I $G(FLDX) D S PSI=PSI+1
. I $L(^TMP("PSO",$J,PSI,CNT-1)_FS_"Drug Warning Narrative")<245 S ^TMP("PSO",$J,PSI,CNT-1)=$G(^TMP("PSO",$J,PSI,CNT-1))_FS_"Drug Warning Narrative"
. E S ^TMP("PSO",$J,PSI,CNT)=FS_"Drug Warning Narrative"
Q
;
NTE4(PSI) ;Profile information
S PSODFN=DFN N NTE4
I $P(PSOPAR,"^",8) D START^PSOHLDS3
S:$D(NTE4) PSI=PSI+1
Q
;
RXE(PSI) ;
N PSOXN,PSOUNIT,PSOIPTR,PSODOSE,PSODOSEN,X,PSOVNAME,PSOXNDF1,PSORFRM,PRORFTOT,PSORFGIV,PSOSTALK,PSOCSUB,PSOCSUB1
S PSOVNAME="" I PSOND1,PSOND3 D
.S PSOVNAME=$P($$PROD2^PSNAPIS(PSOND1,PSOND3),"^")
.S (PSOXN,PSOXNDF1)=$$DFSU^PSNAPIS(PSOND1,PSOND3),PSOUNIT=$P($G(PSOXN),"^",6)
S PSOXN=$P($G(PSOXN),"^",5)
S PSOSTALK=+$G(^PS(55,"ASTALK",DFN))
S PSOCSUB1=$$GET1^DIQ(50,PSOLDRUG_",",3),PSOCSUB="N" I $E(PSOCSUB1,1)>1&($E(PSOCSUB1,1)<6) S PSOCSUB="Y"
N RXE S RXE="" S $P(RXE,"|",1)=""""""
S $P(RXE,"|",2)=$S($P($G(^PSDRUG(PSOLDRUG,"ND")),"^",10)'="":$P(^("ND"),"^",10),($G(PSOND1)&$G(PSOND3)):$P($G(PSOXN2),"^",2),1:"""""")_CS_$G(PSOND2)_CS_"99PSNDF"_CS_PSOND1_"."_PSOND3_"."_$G(PSOLDRUG)_CS_PSOLLNM_CS_"99PSD"
S $P(RXE,"|",3)="" I $G(PSOXN)="" S PSOXN=""""""
S $P(RXE,"|",5)=PSOXN_CS_$S($G(PSOUNIT)'="":$G(PSOUNIT),1:"""""")_CS_"99PSU"
S PSOIPTR=$P($G(^PSDRUG(PSOLDRUG,2)),"^") I PSOIPTR S PSODOSE=$P($G(^PS(50.7,PSOIPTR,0)),"^",2),PSODOSEN=$P($G(^PS(50.606,PSODOSE,0)),"^")
I 'PSOIPTR,$G(PSOXNDF1)'="" S PSODOSE=$P(PSOXNDF1,"^"),PSODOSEN=$P(PSOXNDF1,"^",2)
I $G(PSODOSE) S $P(RXE,"|",6)=PSODOSE_CS_PSODOSEN_CS_"99PSF"
I '$G(PSODOSE) S $P(RXE,"|",6)=""""""
S $P(RXE,"|",8)=""""""
S $P(RXE,"|",9)=""""""
S $P(RXE,"|",10)=$G(PSOHLSV("QUANTITY"))
S PSORFTOT=$G(PSOHLSV("TOTAL FILLS"))-1
S PSORFRM=$G(PSOHLSV("TOTAL FILLS"))-$G(PSOHLSV("FILL NUMBER"))
S PSORFGIV=$G(PSOHLSV("FILL NUMBER"))-1
S $P(RXE,"|",11)=CS_$P($G(^PSDRUG(PSOLDRUG,660)),"^",8),$P(RXE,"|",12)=PSORFTOT
S $P(RXE,"|",13)=""""""
S $P(RXE,"|",14)=""""""
S $P(RXE,"|",15)=$G(PSOHLSV("RX NUMBER")),$P(RXE,"|",16)=PSORFRM,$P(RXE,"|",17)=PSORFGIV
S $P(RXE,"|",18)=""""""
S $P(RXE,"|",21)=CS_PSOLLNM_RS_CS_PSOVNAME ;*255
S $P(RXE,"|",31)=PSOCSUB_RS_PSOSTALK_RS_PSOOTLAN
S ^TMP("PSO",$J,PSI)="RXE|"_RXE,PSI=PSI+1
Q
;
RXD(PSI) ;pharmacy dispense segment
N RXD,I,PSODEA,PSONDC,PSOHDT,PSORWARN,PSONDCL,PSONDCLS,PSONDCND
S PSODEA=$P($G(^PSDRUG(PSOLDRUG,0)),"^",3)
S PSORWARN=$P($G(^PSDRUG(PSOLDRUG,0)),"^",8)
S PSONDC=$P($G(^PSDRUG(PSOLDRUG,2)),"^",4)
I $G(PSOSITE) S PSONDCLS=0 D
.F PSONDCL=0:0 S PSONDCL=$O(^PSDRUG(PSOLDRUG,"NDCOP",PSONDCL)) Q:'PSONDCL!(PSONDCLS) D
..S PSONDCND=$G(^PSDRUG(PSOLDRUG,"NDCOP",PSONDCL,0))
..I $P(PSONDCND,"^")=PSOSITE S PSONDCLS=1 I $P(PSONDCND,"^",2)'="" S PSONDC=$P(PSONDCND,"^",2)
I PSONDC?11N S PSONDC=$$NDCFMT^PSSNDCUT(PSONDC)
I PSONDC'?5N1"-"4N1"-"2N S PSONDC=""
S WNS="" I $G(PSORWARN) F I=1:1 S WW=$P(PSORWARN,",",I) Q:WW="" S WNS=WNS_WW_CS_$S(WW'["N":^PS(54,WW,0),1:"")_RS
S RXD="RXD"_FS_""""""_FS_$S($P($G(^PSDRUG(PSOLDRUG,"ND")),"^",10)'="":$P(^("ND"),"^",10),($G(PSOND1)&$G(PSOND3)):$P($G(PSOXN2),"^",2),1:"""""")_CS_PSOND2_CS_"99PSNDF" ;*531
S RXD=RXD_CS_PSOND1_"."_PSOND3_"."_PSOLDRUG_CS_PSOLLNM_CS_"99PSD"
S PSOHDT=$$HLDATE^HLFNC(DT,"DT")
S RXD=RXD_FS_PSOHDT_FS_FS_FS_FS_$G(PSOHLSV("RX NUMBER"))_FS_($G(PSOHLSV("TOTAL FILLS"))-1)
S RXD=RXD_FS_PSODEA_RS_PSONDC_FS_""""""_FS
S RXD=RXD_FS_$G(PSOHLSV("DAYS SUPPLY"))_FS_$G(PSOHLSV("ROUTING"))_FS_FS_CS_$G(PSOHLSV("CAP"))
S RXD=RXD_FS_FS_FS_FS_""""""_FS_FS_FS_FS_FS_FS_WNS_FS_FS
S ^TMP("PSO",$J,PSI)=RXD,PSI=PSI+1
Q
;
NTEPMI(PSI) ;build NTE segment for PMI sheets ;*255
Q:'$D(DFN) N A,I,PREVLN,CURRLN,PMI,PSNMSG
S PMI=$$EN^PSNPPIO(PSOLDRUG,.PSNMSG)
Q:'$D(^TMP($J,"PSNPMI"))
;PSO*7*279 Add missing PMI ID(7) to NTE Segment
S ^TMP("PSO",$J,PSI)="NTE"_FS_7_FS_FS_^TMP($J,"PSNPMI",0)
K A S CNT1=1,CNT=0
F A="W","U","H","S","M","P","I","O","N","D","R" S CNT=CNT+1,A(CNT)=A
F I=1:1:11 I $D(^TMP($J,"PSNPMI",A(I))) D
.S CNT=$P(^TMP($J,"PSNPMI",A(I),0),"^",3)
.S (PREVLN,CURRLN)=""
.F J=1:1:CNT D
.. S ^TMP("PSO",$J,PSI,CNT1)=^TMP($J,"PSNPMI",A(I),J,0)
.. ;PSO*198 check if " " should be inserted
.. S CURRLN=^TMP("PSO",$J,PSI,CNT1)
.. S:CNT1>1 PREVLN=$S(CNT>1:^TMP("PSO",$J,PSI,CNT1-1),1:"")
.. I CNT1>1,$$SPACE^PSOHLDS3(PREVLN,CURRLN) D
... S ^TMP("PSO",$J,PSI,CNT1)=" "_^TMP("PSO",$J,PSI,CNT1)
.. I J=1 S $P(^TMP("PSO",$J,PSI,CNT1),":",1)="\H\"_$P(^TMP("PSO",$J,PSI,CNT1),":",1)_"\N\"
.. S CNT1=CNT1+1
S ^TMP("PSO",$J,PSI,CNT1-1)=^TMP("PSO",$J,PSI,CNT1-1)_FS_"Patient Medication Instructions"
S PSI=PSI+1 K A,I,J,CNT,CNT1,^TMP($J,"PSNPMI")
Q
;
RXR(PSI) ;pharmacy route segment
Q:'$D(DFN)
N RXR
S RXR="RXR"_FS
S ^TMP("PSO",$J,PSI)=RXR,PSI=PSI+1
Q
;
ZZZ(PSI) ;ZZZ segment for HL7 hazardous text ;*524
N DRIEN,HAZD,HAZH,VAR
S DRIEN=PSOLDRUG
S VAR=$$HAZ^PSSUTIL(DRIEN)
S HAZH=$P(VAR,"^",1)
S HAZH=$S(HAZH:"Y",1:"N")
S HAZD=$P(VAR,"^",2)
S HAZD=$S(HAZD:"Y",1:"N")
S ^TMP("PSO",$J,PSI)="ZZZ"_FS_FS_FS_FS_HAZH_FS_HAZD
S PSI=PSI+1
Q
;
SEND ;Send message to Host Site with Dispensing information from OPAI fill
N %,PSOPROT,PSODOMVR,PSORRDAT,HLARR,PSOHSIEN,PSOHSTYP,PSOHSSUB,PSOHSZ,PSOHSRX,DFN,PSODONE,PSOFOUR,PSOSRXD2,PSOSRXD3,PSOSRXD4,PSOSRXD7,PSOHFLAG,PSOHONE,PSOSRDEN,PSODND1,PSODND2,PSODND3,PSODNNOW,PSOHCNT
S HLARR=$NA(^TMP("HLS",$J)) K @HLARR
S PSOPROT="PSO DISP RX RDS-O13 EVENT"
S PSODOMVR=$P($G(^PSRXR(52.09,PSOPAID("IEN"),4)),"^",2)
S DFN=$P($G(^PSRXR(52.09,PSOPAID("IEN"),0)),"^",2)
D INIT^HLFNC2(PSOPROT,.HL)
D BLDPID^PSOTPHL2(DFN,"",.PSORRDAT,.HL,.ERR)
S PSOHSZ=$G(^PSRXR(52.09,PSOPAID("IEN"),0)),PSOFOUR=$G(^PSRXR(52.09,PSOPAID("IEN"),4)),PSOHONE=$G(^PSRXR(52.09,PSOPAID("IEN"),1))
S PSOHSIEN=$P(PSOHSZ,"^",15),PSOHSTYP=$S($P(PSOHSZ,"^",5)="PR":"PR",$P(PSOHSZ,"^",5)="OP":"PR",1:"RF"),PSOSRXD7=$P(PSOHSZ,"^",3),PSOSRXD4=$P(PSOHSZ,"^",7)
S PSOHSSUB=$S(PSOHSTYP="PR":$P(PSOHSZ,"^",14),1:$P(PSOHSZ,"^",13)),PSOHSRX=$P(PSOHSZ,"^",3)
S PSOHFLAG=0,PSOSRDEN=+$P(PSOHONE,"^",2),PSODND1=$P($G(^PSDRUG(PSOSRDEN,"ND")),"^"),PSODND2=$P($G(^("ND")),"^",2),PSODND3=$P($G(^("ND")),"^",3) I PSODND1,PSODND3 S PSOHFLAG=1
S PSOSRXD2=$S(PSOHFLAG:PSODND1_"."_PSODND3_"~"_$G(PSODND2)_"~"_"99NDF",1:"~~")_"~"_PSOSRDEN_"~"_$P($G(^PSDRUG(PSOSRDEN,0)),"^")_"~"_"99PSD"
D NOW^%DTC S PSODNNOW=$$HLDATE^HLFNC(%,"TS") S PSOSRXD3=PSODNNOW
S PSODONE=0
F PSOHCNT=1:1 D Q:PSODONE
.I '$D(PSORRDAT(PSOHCNT)) S PSODONE=1 Q
.S @HLARR@(1)=$G(@HLARR@(1))_PSORRDAT(PSOHCNT)
S @HLARR@(2)="ORC|"_PSOHSTYP_"|"_PSOHSRX_"~"_PSODOMVR_"||||||||"_$P(PSOHSZ,"^",11)_"|"_$P(PSOHSZ,"^",12)
S @HLARR@(3)="RXD|"_PSOHSSUB_"|"_PSOSRXD2_"|"_PSOSRXD3_"|"_PSOSRXD4_"|||"_PSOSRXD7_"||"_PSOHNDC_"||||"_PSOHSIEN_"|||||"_PSOHLOT_"|"_PSODEXP_"|"_PSOHMAN
S @HLARR@(4)="NTE|1|L|"_$P(PSOFOUR,"^")_"|"_$P(PSOFOUR,"^",3)_"|"_$P(PSOFOUR,"^",4)_"|"_$P(PSOFOUR,"^",5)
S @HLARR@(5)="RXR|~~~0~UNKNOWN~99PSR"
S HLP("SUBSCRIBER")="^^^^"_PSODOMVR
D GENERATE^HLMA(PSOPROT,"GM",1,.HL,"",.HLP)
K @HLARR
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOHLDS5 16994 printed Sep 23, 2025@20:06:15 Page 2
PSOHLDS5 ;BIR/MV - Misc HL7 function ; 23 Jan 2024 2:00 PM
+1 ;;7.0;OUTPATIENT PHARMACY;**643,728,742,774**;DEC 1997;Build 15
+2 ;External reference to ^PS(50.606 supported by DBIA 2174
+3 ;External reference to ^PS(50.7 supported by DBIA 2223
+4 ;External reference to ^PS(51.2 supported by DBIA 2226
+5 ;External reference to ^PS(54 supported by DBIA 2227
+6 ;External reference to ^PS(55 supported by DBIA 2228
+7 ;External reference to ^PS(59.7 is supported by DBIA 694
+8 ;External reference to ^PSDRUG supported by DBIA 221
+9 ;External reference to $$GETNDC^PSSNDCUT supported by DBIA 4707
+10 ;External reference to WTEXT^PSSWRNA supported by DBIA 4444
+11 ;External reference to DRUG^PSSWRNA supported by DBIA 4449
+12 ;External reference to EN^PSNPPIO supported by DBIA 3794
+13 ;External reference to BLDPID^VAFCQRY supported by DBIA 3630
+14 ;External reference to EN^VAFHLZTA supported by DBIA 758
+15 ;External reference to $$PROD2^PSNAPIS supported by DBIA 2531
HLSAVE(PSOLBL) ;Save HL data into PSOHLSV array
+1 NEW X,X1,X2,X3
+2 if '$DATA(PSOLBL)
QUIT
+3 FOR X=0:0
SET X=$ORDER(PSOLBL(X))
if 'X
QUIT
if $DATA(PSOHLSV("COPAY STATUS"))
QUIT
Begin DoDot:1
+4 SET PSOTXT=$GET(PSOLBL(X))
if PSOTXT=""
QUIT
+5 KILL X1,X2,X3
+6 IF (PSOTXT["Rx# ")
IF (PSOTXT[" Fill ")
SET X1=$PIECE(PSOTXT," Fill ",2)
SET X2=$PIECE(X1," ")
Begin DoDot:2
+7 SET X3=$PIECE(X2," of")-1
SET PSOHLSV("FILL NUMBER")=$SELECT(X3<0:0,1:X3)
End DoDot:2
QUIT
+8 IF PSOTXT["Days Supply:"
SET PSOHLSV("COPAY STATUS")=$SELECT(PSOTXT["NO COPAY":"NO COPAY",PSOTXT["COPAY":"COPAY",1:"")
IF PSOTXT["NO COPAY"
KILL PSOHLSV("COPAY NARR")
End DoDot:1
+9 QUIT
+10 ;
HLSVNTE(PSONARR) ;Save HL data into Patient Narrative array
+1 NEW X,PSOTXT,PSORF,PSONONRF,PSOCOPAY,PSOCNT
+2 if '$DATA(PSONARR)
QUIT
+3 SET (PSOCNT,PSORF,PSONONRF,PSOCOPAY)=0
+4 FOR X=0:0
SET X=$ORDER(PSONARR(X))
if 'X
QUIT
Begin DoDot:1
+5 SET PSOTXT=$PIECE($GET(PSONARR(X)),U,4)
if PSOTXT="HOST
QUIT
+6 IF PSOTXT="HOST:NARRATIVE REFILLABLE RX"
SET PSOCNT=0
SET PSORF=1
QUIT
+7 IF PSOTXT="HOST:NARRATIVE NON-REFILLABLE RX"
SET (PSOCNT,PSORF)=0
SET PSONONRF=1
QUIT
+8 IF PSOTXT="HOST:NARRATIVE FOR COPAY DOCUMENT"
SET (PSOCNT,PSORF,PSONONRF)=0
SET PSOCOPAY=1
QUIT
+9 IF PSORF
SET PSOCNT=PSOCNT+1
SET PSOHLSV("NARR REFILLABLE",PSOCNT)=PSOTXT
+10 IF PSONONRF
SET PSOCNT=PSOCNT+1
SET PSOHLSV("NARR NON-REFILLABLE",PSOCNT)=PSOTXT
+11 IF $GET(PSOHLSV("COPAY STATUS"))
IF PSOCOPAY
SET PSOCNT=PSOCNT+1
SET PSOHLSV("NARR COPAY",PSOCNT)=PSOTXT
End DoDot:1
+12 QUIT
+13 ;
NTE2SV(CNT,NTECNT,PSOSITE) ; Patient Narrative
+1 NEW X,DIW,DIWF,DIWI,DIWL,DIWR,DIWT,DIWTC,DIWX,FS,LLL,ZZ
+2 if $GET(PSOSITE)=""
QUIT
+3 SET FS="^"
+4 ; WLC *774* took out "Patient"
SET CNT=+$GET(CNT)+1
SET NTECNT=+$GET(NTECNT)+1
SET ^TMP("HLA",$JOB,CNT)="NTE"_FS_NTECNT_FS_FS_"Narrative"
+5 KILL ^UTILITY($JOB,"W")
SET DIWL=1
SET DIWR=78
SET DIWF=""
FOR ZZ=0:0
SET ZZ=$ORDER(^PS(59,PSOSITE,6,ZZ))
if 'ZZ
QUIT
IF $DATA(^(ZZ,0))
SET X=^(0)
DO ^DIWP
+6 SET CNT=CNT+1
SET NTECNT=NTECNT+1
SET ^TMP("HLA",$JOB,CNT)="NTE"_FS_NTECNT_FS_FS_"HOST:NARRATIVE REFILLABLE RX"
+7 FOR LLL=0:0
SET LLL=$ORDER(^UTILITY($JOB,"W",DIWL,LLL))
if 'LLL
QUIT
SET CNT=CNT+1
SET NTECNT=NTECNT+1
SET ^TMP("HLA",$JOB,CNT)="NTE"_FS_NTECNT_FS_FS_^UTILITY($JOB,"W",DIWL,LLL,0)
+8 ;
+9 SET CNT=CNT+1
SET NTECNT=NTECNT+1
SET ^TMP("HLA",$JOB,CNT)="NTE"_FS_NTECNT_FS_FS_"HOST:NARRATIVE NON-REFILLABLE RX"
+10 SET DIWL=1
SET DIWR=45
SET DIWF=""
KILL ^UTILITY($JOB,"W")
FOR ZZ=0:0
SET ZZ=$ORDER(^PS(59,PSOSITE,7,ZZ))
if 'ZZ
QUIT
IF $DATA(^(ZZ,0))
SET X=^(0)
DO ^DIWP
+11 FOR LLL=0:0
SET LLL=$ORDER(^UTILITY($JOB,"W",DIWL,LLL))
if 'LLL
QUIT
SET CNT=CNT+1
SET NTECNT=NTECNT+1
SET ^TMP("HLA",$JOB,CNT)="NTE"_FS_NTECNT_FS_FS_^UTILITY($JOB,"W",DIWL,LLL,0)
+12 ;
+13 SET CNT=CNT+1
SET NTECNT=NTECNT+1
SET ^TMP("HLA",$JOB,CNT)="NTE"_FS_NTECNT_FS_FS_"HOST:NARRATIVE FOR COPAY DOCUMENT"
+14 SET DIWL=1
SET DIWR=45
SET DIWF=""
KILL ^UTILITY($JOB,"W")
FOR ZZ=0:0
SET ZZ=$ORDER(^PS(59,PSOSITE,4,ZZ))
if 'ZZ
QUIT
IF $DATA(^(ZZ,0))
SET X=^(0)
DO ^DIWP
+15 FOR LLL=0:0
SET LLL=$ORDER(^UTILITY($JOB,"W",DIWL,LLL))
if 'LLL
QUIT
SET CNT=CNT+1
SET NTECNT=NTECNT+1
SET ^TMP("HLA",$JOB,CNT)="NTE"_FS_NTECNT_FS_FS_^UTILITY($JOB,"W",DIWL,LLL,0)
+16 ;
+17 SET CNT=CNT+1
SET NTECNT=NTECNT+1
SET ^TMP("HLA",$JOB,CNT)="NTE"_FS_NTECNT_FS_FS_"HOST:END"
+18 QUIT
+19 ;
PID(PSI) ;patient ID segment
+1 if '$DATA(DFN)!$DATA(PAS)
QUIT
+2 NEW X,Y,X2,CNT,I
+3 SET HLFS=HL1("FS")
SET HLECH=HL1("ECH")
SET HLQ=HL1("Q")
SET HLVER=HL1("VER")
+4 KILL PSPID,PSPID1
+5 DO BLDPID^VAFCQRY(DFN,"","3,4,5,7,8,11,13",.PSPID,.HL1,.ERR)
+6 ; put PID in format needed for segment parser
+7 SET PSPID=PSPID(1)
KILL PSPID(1)
+8 SET (X,Y)=1
FOR
SET X=+$ORDER(PSPID(X))
if 'X
QUIT
SET PSPID(Y)=PSPID(X)
SET Y=Y+1
KILL PSPID(X)
+9 ;parse PID into individual fields
+10 KILL PRSEPID
DO SEGPRSE^SCMSVUT5("PSPID","PRSEPID",HL1("FS"))
+11 ; parse address into individual components
+12 KILL ADDSEQ
DO SEQPRSE^SCMSVUT5($NAME(PRSEPID(11)),"ADDSEQ",HL1("ECH"))
+13 ; build ZTA (Temporary Address)
+14 KILL X2
SET X2=$$EN^VAFHLZTA(DFN,"1,2,3,4,5,6,7,",1)
+15 ; parse X2 (ZTA) into individual fields if temp add. exists
+16 if '$$CHKTEMP(DFN)
Begin DoDot:1
+17 NEW BADA
SET BADA=$$CHKRX(DFN)
+18 IF $PIECE(BADA,"^")
IF '$PIECE(BADA,"^",2)
IF ADDSEQ(1,7)'["VAB"
SET BADA=$$GET1^DIQ(2,DFN_",",.121,"I")
if BADA
SET ADDSEQ(1,7)="VAB"_BADA
End DoDot:1
+19 if $$CHKTEMP(DFN)
Begin DoDot:1
+20 KILL PRSEZTA
DO SEGPRSE^SCMSVUT5("X2","PRSEZTA",HL1("FS"))
+21 ; parse temporary address into individual components
+22 KILL TMPADD
DO SEQPRSE^SCMSVUT5($NAME(PRSEZTA(5)),"TMPADD",HL1("ECH"))
+23 ; add temporary address as next repetition in PID segment
+24 SET SPOT=1+$ORDER(ADDSEQ(""),-1)
+25 MERGE ADDSEQ(SPOT)=TMPADD(1)
+26 SET ADDSEQ(SPOT,7)="C"
+27 SET ADDSEQ(SPOT,9)=PRSEZTA(6)
+28 SET ADDSEQ(SPOT,12,1)=PRSEZTA(3)
+29 SET ADDSEQ(SPOT,12,2)=PRSEZTA(4)
+30 ;move address sequence back into parse PID segment
End DoDot:1
+31 ; rebuild PID segment
+32 KILL PRSEPID(11)
MERGE PRSEPID(11)=ADDSEQ
+33 KILL PSPID1
DO MAKEIT^VAFHLU("PID",.PRSEPID,.PSPID1,.PSPID1)
+34 ;put rebuilt PID into format used by $$EN^VAFCQRY
+35 KILL PSPID
SET PSPID(1)=PSPID1
+36 SET X=0
SET Y=2
FOR
SET X=+$ORDER(PSPID1(X))
if 'X
QUIT
SET PSPID(Y)=PSPID1(X)
SET Y=Y+1
+37 SET CNT=0
FOR I=1:1
if '$DATA(PSPID(I))
QUIT
Begin DoDot:1
+38 IF I=1
SET ^TMP("PSO",$JOB,PSI)=PSPID(I)
QUIT
+39 SET CNT=CNT+1
SET ^TMP("PSO",$JOB,PSI,CNT)=PSPID(I)
End DoDot:1
+40 SET PSI=PSI+1
+41 SET PAS=1
+42 KILL PSPID,PSPID1,PRSEPID,PRSEZTA,SPOT,TMPADD,ADDSEQ
+43 QUIT
+44 ;
CHKRX(PSODFN) ;CHECK ADDRESS BY DFN
+1 ;Input: PSORX - PRESCRIPTION file (#52) IEN
+2 ;Output: PSOBADR - Bad Address Indicator_"^"_temporary address or not
+3 NEW PSOBADR,PSOTEMP
+4 SET PSOBADR=""
+5 SET PSOBADR=$$BADADR^DGUTL3(PSODFN)
+6 IF PSOBADR
SET PSOTEMP=$$CHKTEMP(PSODFN)
+7 SET PSOBADR=PSOBADR_"^"_$GET(PSOTEMP)
+8 QUIT PSOBADR
+9 ;
CHKTEMP(PSODFN) ; see if active temporary address
+1 ;Input: PSODFN - PATIENT file (#2) IEN
+2 NEW DFN,VAPA
+3 SET DFN=PSODFN
SET PSOTEMP=0
+4 DO 6^VADPT
IF +VAPA(9)
SET PSOTEMP=1
+5 QUIT PSOTEMP
+6 ;
PV1(PSI) ;patient visit segment
+1 if '$DATA(DFN)
QUIT
+2 ;hardcoded to letter O for Outpatient (Patient class)
NEW PV1
+3 SET PV1="PV1"_FS_FS_"O"_FS
+4 SET ^TMP("PSO",$JOB,PSI)=PV1
+5 SET PSI=PSI+1
+6 QUIT
+7 ;
PV2(PSI) ;patient visit segment (additional information)
+1 ;PATIENT STATUS AND COPAY
+2 if '$DATA(DFN)
QUIT
+3 NEW PV2
SET PV2=""
+4 SET $PIECE(PV2,"|",24)="UNKNOWN"_"~"_$GET(PSOHLSV("COPAY STATUS"))_FS
+5 SET ^TMP("PSO",$JOB,PSI)="PV2|"_PV2
+6 SET PSI=PSI+1
+7 QUIT
+8 ;
ORC(PSI) ;common order segment
+1 NEW PSOROP3,PSOROP4,PSOHSITE,PSZIP,PSOHZIP
+2 if '$DATA(DFN)
QUIT
+3 NEW ORC
SET ORC=""
+4 SET $PIECE(ORC,"|",1)="NW"
+5 SET $PIECE(ORC,"|",2)=$GET(PSOHLSV("RX NUMBER"))_CS_"OP7.0"
+6 SET PSOROP3=$GET(PSOHLSV("OUT REQ PHARMACIST"))
+7 IF PSOROP3'=""
SET PSOROP4=$$HLNAME^HLFNC(PSOROP3)
SET $PIECE(ORC,"|",10)=CS_PSOROP4
+8 SET PSOROP3=$GET(PSOHLSV("PROVIDER"))
+9 IF PSOROP3'=""
SET PSOROP4=$$HLNAME^HLFNC(PSOROP3)
SET $PIECE(ORC,"|",12)=CS_PSOROP4
+10 IF $GET(PSOONLAP)'=""
SET $PIECE(ORC,"|",13)=PSOONLAP
+11 SET $PIECE(ORC,"|",16)=$SELECT($GET(PSOHLSV("REQUEST TYPE"))="PR"!($GET(PSOHLSV("REQUEST TYPE"))="OP"):"PARTIAL",1:"REFILL")
+12 SET PSOHSITE=$SELECT($GET(PSOSITE):$GET(^PS(59,PSOSITE,0)),1:"")
+13 SET $PIECE(ORC,"|",21)=$PIECE(PSOHSITE,"^",1)_CS_CS_$PIECE(PSOHSITE,"^",6)
+14 SET PSZIP=$PIECE(PSOHSITE,"^",5)
SET PSOHZIP=$SELECT(PSZIP["-":PSZIP,1:$EXTRACT(PSZIP,1,5)_$SELECT($EXTRACT(PSZIP,6,9)]"":"-"_$EXTRACT(PSZIP,6,9),1:""))
+15 SET $PIECE(ORC,"|",22)=$PIECE(PSOHSITE,"^",2)_CS_CS_$PIECE(PSOHSITE,"^",7)_CS_$SELECT($DATA(^DIC(5,+$PIECE(PSOHSITE,"^",8),0)):$PIECE(^(0),"^",2),1:"UKN")_CS_PSOHZIP
+16 SET $PIECE(ORC,"|",23)="("_$PIECE(PSOHSITE,"^",3)_")"_$PIECE(PSOHSITE,"^",4)
+17 SET ^TMP("PSO",$JOB,PSI)="ORC|"_ORC
SET PSI=PSI+1
+18 QUIT
+19 ;
NTE2(PSI) ; Site Narratives
+1 NEW X,CNT
+2 if '$DATA(FS)
SET FS="^"
if '+$GET(PSI)
SET PSI=1
SET CNT=0
+3 IF $SELECT($GET(PSOHLSV("NARR REFILLABLE",1))]"":1,$GET(PSOHLSV("NARR NON-REFILLABLE",1))]"":1,$GET(PSOHLSV("NARR COPAY",1))]"":1,1:0)
Begin DoDot:1
+4 SET ^TMP("PSO",$JOB,PSI)="NTE"_FS_2_FS_FS_"Patient Narrative"
End DoDot:1
+5 FOR X=0:0
SET X=$ORDER(PSOHLSV("NARR REFILLABLE",X))
if 'X
QUIT
Begin DoDot:1
+6 if $GET(PSOHLSV("NARR REFILLABLE",X))=""
QUIT
+7 SET CNT=CNT+1
+8 if CNT>1
SET ^TMP("PSO",$JOB,PSI,CNT-1)=^TMP("PSO",$JOB,PSI,CNT-1)_"\.sp\"
+9 SET ^TMP("PSO",$JOB,PSI,CNT)=PSOHLSV("NARR REFILLABLE",X)
End DoDot:1
+10 FOR X=0:0
SET X=$ORDER(PSOHLSV("NARR NON-REFILLABLE",X))
if 'X
QUIT
Begin DoDot:1
+11 if $GET(PSOHLSV("NARR NON-REFILLABLE",X))=""
QUIT
+12 SET CNT=CNT+1
+13 if CNT>1
SET ^TMP("PSO",$JOB,PSI,CNT-1)=^TMP("PSO",$JOB,PSI,CNT-1)_"\.sp\"
+14 SET ^TMP("PSO",$JOB,PSI,CNT)=PSOHLSV("NARR NON-REFILLABLE",X)
End DoDot:1
+15 IF $GET(PSOHLSV("COPAY STATUS"))
FOR X=0:0
SET X=$ORDER(PSOHLSV("NARR COPAY",X))
if 'X
QUIT
Begin DoDot:1
+16 if $GET(PSOHLSV("NARR COPAY",X))=""
QUIT
+17 SET CNT=CNT+1
+18 if CNT>1
SET ^TMP("PSO",$JOB,PSI,CNT-1)=^TMP("PSO",$JOB,PSI,CNT-1)_"\.sp\"
+19 SET ^TMP("PSO",$JOB,PSI,CNT)=PSOHLSV("NARR COPAY",X)
End DoDot:1
+20 if CNT
SET PSI=PSI+1
+21 QUIT
+22 ;
NTE1(PSI) ;SIG
+1 NEW PSODR,PSODRR,PSOTSIG,PSOCLD
MERGE PSOTSIG=PSOHLSV("SIG")
+2 KILL PSODRR
FOR PSODR=0:0
SET PSODR=$ORDER(PSOTSIG(PSODR))
if 'PSODR
QUIT
SET PSODRR=$GET(PSODRR)+1
+3 if '$GET(PSODRR)
QUIT
+4 SET PSODRR=PSODRR+1
SET PSOTSIG(PSODRR)=FS_"Medication Instructions"
+5 KILL PSODRR
SET ^TMP("PSO",$JOB,PSI)="NTE"_FS_1_FS_FS
+6 SET PSOCLD=1
FOR PSODR=0:0
SET PSODR=$ORDER(PSOTSIG(PSODR))
if 'PSODR
QUIT
Begin DoDot:1
+7 if $LENGTH($GET(^TMP("PSO",$JOB,PSI,PSOCLD))_PSOTSIG(PSODR))>245
SET PSOCLD=PSOCLD+1
SET ^TMP("PSO",$JOB,PSI,PSOCLD)=$GET(^TMP("PSO",$JOB,PSI,PSOCLD))_PSOTSIG(PSODR)
End DoDot:1
+8 SET PSI=PSI+1
+9 QUIT
+10 ;
NTE3(PSI) ;Drug Warning Narrative
+1 NEW NTE3,J,TEXT,W,CNT,PSSWSITE,PSOLCDRG,WARN,FLDX
+2 SET PSOLCDRG=$GET(PSOHLSV("L_DRUGIEN"))
if 'PSOLCDRG
QUIT
+3 SET WARN=$PIECE($GET(^PSDRUG(PSOLCDRG,0)),"^",8)
+4 SET PSSWSITE=+$ORDER(^PS(59.7,0))
+5 IF $PIECE($GET(^PS(59.7,PSSWSITE,10)),"^",11)="N"
Begin DoDot:1
+6 SET WARN=$$DRUG^PSSWRNA(PSOLCDRG,DFN)
End DoDot:1
+7 IF WARN=""
QUIT
+8 SET NTE3="NTE"_FS_3_FS_FS
SET ^TMP("PSO",$JOB,PSI)=NTE3
SET CNT=1
+9 FOR J=1:1
SET W=$PIECE(WARN,",",J)
if W=""
QUIT
Begin DoDot:1
+10 if CNT>1
SET ^TMP("PSO",$JOB,PSI,CNT-1)=^TMP("PSO",$JOB,PSI,CNT-1)_"\.sp\"
+11 SET TEXT=$$WTEXT^PSSWRNA(W,$GET(PSOOLAN))
IF TEXT'=""
SET FLDX=1
Begin DoDot:2
+12 IF $LENGTH(TEXT)<245
SET ^TMP("PSO",$JOB,PSI,CNT)=TEXT
SET CNT=CNT+1
QUIT
+13 NEW LTH,ST,EN,TXT,WW
+14 SET LTH=$EXTRACT($LENGTH(TEXT)/245,1)
if $LENGTH(TEXT)#245>0
SET LTH=LTH+1
+15 FOR WW=1:1:LTH
Begin DoDot:3
+16 if WW=1
SET ST=1
SET EN=245
if WW>1
SET ST=(ST+245)
SET EN=(EN+245)
SET TXT=$EXTRACT(TEXT,ST,EN)
+17 SET ^TMP("PSO",$JOB,PSI,CNT)=TXT
SET CNT=CNT+1
End DoDot:3
End DoDot:2
End DoDot:1
+18 IF $GET(FLDX)
Begin DoDot:1
+19 IF $LENGTH(^TMP("PSO",$JOB,PSI,CNT-1)_FS_"Drug Warning Narrative")<245
SET ^TMP("PSO",$JOB,PSI,CNT-1)=$GET(^TMP("PSO",$JOB,PSI,CNT-1))_FS_"Drug Warning Narrative"
+20 IF '$TEST
SET ^TMP("PSO",$JOB,PSI,CNT)=FS_"Drug Warning Narrative"
End DoDot:1
SET PSI=PSI+1
+21 QUIT
+22 ;
NTE4(PSI) ;Profile information
+1 SET PSODFN=DFN
NEW NTE4
+2 IF $PIECE(PSOPAR,"^",8)
DO START^PSOHLDS3
+3 if $DATA(NTE4)
SET PSI=PSI+1
+4 QUIT
+5 ;
RXE(PSI) ;
+1 NEW PSOXN,PSOUNIT,PSOIPTR,PSODOSE,PSODOSEN,X,PSOVNAME,PSOXNDF1,PSORFRM,PRORFTOT,PSORFGIV,PSOSTALK,PSOCSUB,PSOCSUB1
+2 SET PSOVNAME=""
IF PSOND1
IF PSOND3
Begin DoDot:1
+3 SET PSOVNAME=$PIECE($$PROD2^PSNAPIS(PSOND1,PSOND3),"^")
+4 SET (PSOXN,PSOXNDF1)=$$DFSU^PSNAPIS(PSOND1,PSOND3)
SET PSOUNIT=$PIECE($GET(PSOXN),"^",6)
End DoDot:1
+5 SET PSOXN=$PIECE($GET(PSOXN),"^",5)
+6 SET PSOSTALK=+$GET(^PS(55,"ASTALK",DFN))
+7 SET PSOCSUB1=$$GET1^DIQ(50,PSOLDRUG_",",3)
SET PSOCSUB="N"
IF $EXTRACT(PSOCSUB1,1)>1&($EXTRACT(PSOCSUB1,1)<6)
SET PSOCSUB="Y"
+8 NEW RXE
SET RXE=""
SET $PIECE(RXE,"|",1)=""""""
+9 SET $PIECE(RXE,"|",2)=$SELECT($PIECE($GET(^PSDRUG(PSOLDRUG,"ND")),"^",10)'="":$PIECE(^("ND"),"^",10),($GET(PSOND1)&$GET(PSOND3)):$PIECE(...
... $GET(PSOXN2),"^",2),1:"""""")_CS_$GET(PSOND2)_CS_"99PSNDF"_CS_PSOND1_"."_PSOND3_"."_$GET(PSOLDRUG)_CS_PSOLLNM_CS_"99PSD"
+10 SET $PIECE(RXE,"|",3)=""
IF $GET(PSOXN)=""
SET PSOXN=""""""
+11 SET $PIECE(RXE,"|",5)=PSOXN_CS_$SELECT($GET(PSOUNIT)'="":$GET(PSOUNIT),1:"""""")_CS_"99PSU"
+12 SET PSOIPTR=$PIECE($GET(^PSDRUG(PSOLDRUG,2)),"^")
IF PSOIPTR
SET PSODOSE=$PIECE($GET(^PS(50.7,PSOIPTR,0)),"^",2)
SET PSODOSEN=$PIECE($GET(^PS(50.606,PSODOSE,0)),"^")
+13 IF 'PSOIPTR
IF $GET(PSOXNDF1)'=""
SET PSODOSE=$PIECE(PSOXNDF1,"^")
SET PSODOSEN=$PIECE(PSOXNDF1,"^",2)
+14 IF $GET(PSODOSE)
SET $PIECE(RXE,"|",6)=PSODOSE_CS_PSODOSEN_CS_"99PSF"
+15 IF '$GET(PSODOSE)
SET $PIECE(RXE,"|",6)=""""""
+16 SET $PIECE(RXE,"|",8)=""""""
+17 SET $PIECE(RXE,"|",9)=""""""
+18 SET $PIECE(RXE,"|",10)=$GET(PSOHLSV("QUANTITY"))
+19 SET PSORFTOT=$GET(PSOHLSV("TOTAL FILLS"))-1
+20 SET PSORFRM=$GET(PSOHLSV("TOTAL FILLS"))-$GET(PSOHLSV("FILL NUMBER"))
+21 SET PSORFGIV=$GET(PSOHLSV("FILL NUMBER"))-1
+22 SET $PIECE(RXE,"|",11)=CS_$PIECE($GET(^PSDRUG(PSOLDRUG,660)),"^",8)
SET $PIECE(RXE,"|",12)=PSORFTOT
+23 SET $PIECE(RXE,"|",13)=""""""
+24 SET $PIECE(RXE,"|",14)=""""""
+25 SET $PIECE(RXE,"|",15)=$GET(PSOHLSV("RX NUMBER"))
SET $PIECE(RXE,"|",16)=PSORFRM
SET $PIECE(RXE,"|",17)=PSORFGIV
+26 SET $PIECE(RXE,"|",18)=""""""
+27 ;*255
SET $PIECE(RXE,"|",21)=CS_PSOLLNM_RS_CS_PSOVNAME
+28 SET $PIECE(RXE,"|",31)=PSOCSUB_RS_PSOSTALK_RS_PSOOTLAN
+29 SET ^TMP("PSO",$JOB,PSI)="RXE|"_RXE
SET PSI=PSI+1
+30 QUIT
+31 ;
RXD(PSI) ;pharmacy dispense segment
+1 NEW RXD,I,PSODEA,PSONDC,PSOHDT,PSORWARN,PSONDCL,PSONDCLS,PSONDCND
+2 SET PSODEA=$PIECE($GET(^PSDRUG(PSOLDRUG,0)),"^",3)
+3 SET PSORWARN=$PIECE($GET(^PSDRUG(PSOLDRUG,0)),"^",8)
+4 SET PSONDC=$PIECE($GET(^PSDRUG(PSOLDRUG,2)),"^",4)
+5 IF $GET(PSOSITE)
SET PSONDCLS=0
Begin DoDot:1
+6 FOR PSONDCL=0:0
SET PSONDCL=$ORDER(^PSDRUG(PSOLDRUG,"NDCOP",PSONDCL))
if 'PSONDCL!(PSONDCLS)
QUIT
Begin DoDot:2
+7 SET PSONDCND=$GET(^PSDRUG(PSOLDRUG,"NDCOP",PSONDCL,0))
+8 IF $PIECE(PSONDCND,"^")=PSOSITE
SET PSONDCLS=1
IF $PIECE(PSONDCND,"^",2)'=""
SET PSONDC=$PIECE(PSONDCND,"^",2)
End DoDot:2
End DoDot:1
+9 IF PSONDC?11N
SET PSONDC=$$NDCFMT^PSSNDCUT(PSONDC)
+10 IF PSONDC'?5N1"-"4N1"-"2N
SET PSONDC=""
+11 SET WNS=""
IF $GET(PSORWARN)
FOR I=1:1
SET WW=$PIECE(PSORWARN,",",I)
if WW=""
QUIT
SET WNS=WNS_WW_CS_$SELECT(WW'["N":^PS(54,WW,0),1:"")_RS
+12 ;*531
SET RXD="RXD"_FS_""""""_FS_$SELECT($PIECE($GET(^PSDRUG(PSOLDRUG,"ND")),"^",10)'="":$PIECE(^("ND"),"^",10),($GET(PSOND1)&$GET(PSOND3)):$PIECE($GET(PSOXN2),"^",2),1:"""""")_CS_PSOND2_CS_"99PSNDF"
+13 SET RXD=RXD_CS_PSOND1_"."_PSOND3_"."_PSOLDRUG_CS_PSOLLNM_CS_"99PSD"
+14 SET PSOHDT=$$HLDATE^HLFNC(DT,"DT")
+15 SET RXD=RXD_FS_PSOHDT_FS_FS_FS_FS_$GET(PSOHLSV("RX NUMBER"))_FS_($GET(PSOHLSV("TOTAL FILLS"))-1)
+16 SET RXD=RXD_FS_PSODEA_RS_PSONDC_FS_""""""_FS
+17 SET RXD=RXD_FS_$GET(PSOHLSV("DAYS SUPPLY"))_FS_$GET(PSOHLSV("ROUTING"))_FS_FS_CS_$GET(PSOHLSV("CAP"))
+18 SET RXD=RXD_FS_FS_FS_FS_""""""_FS_FS_FS_FS_FS_FS_WNS_FS_FS
+19 SET ^TMP("PSO",$JOB,PSI)=RXD
SET PSI=PSI+1
+20 QUIT
+21 ;
NTEPMI(PSI) ;build NTE segment for PMI sheets ;*255
+1 if '$DATA(DFN)
QUIT
NEW A,I,PREVLN,CURRLN,PMI,PSNMSG
+2 SET PMI=$$EN^PSNPPIO(PSOLDRUG,.PSNMSG)
+3 if '$DATA(^TMP($JOB,"PSNPMI"))
QUIT
+4 ;PSO*7*279 Add missing PMI ID(7) to NTE Segment
+5 SET ^TMP("PSO",$JOB,PSI)="NTE"_FS_7_FS_FS_^TMP($JOB,"PSNPMI",0)
+6 KILL A
SET CNT1=1
SET CNT=0
+7 FOR A="W","U","H","S","M","P","I","O","N","D","R"
SET CNT=CNT+1
SET A(CNT)=A
+8 FOR I=1:1:11
IF $DATA(^TMP($JOB,"PSNPMI",A(I)))
Begin DoDot:1
+9 SET CNT=$PIECE(^TMP($JOB,"PSNPMI",A(I),0),"^",3)
+10 SET (PREVLN,CURRLN)=""
+11 FOR J=1:1:CNT
Begin DoDot:2
+12 SET ^TMP("PSO",$JOB,PSI,CNT1)=^TMP($JOB,"PSNPMI",A(I),J,0)
+13 ;PSO*198 check if " " should be inserted
+14 SET CURRLN=^TMP("PSO",$JOB,PSI,CNT1)
+15 if CNT1>1
SET PREVLN=$SELECT(CNT>1:^TMP("PSO",$JOB,PSI,CNT1-1),1:"")
+16 IF CNT1>1
IF $$SPACE^PSOHLDS3(PREVLN,CURRLN)
Begin DoDot:3
+17 SET ^TMP("PSO",$JOB,PSI,CNT1)=" "_^TMP("PSO",$JOB,PSI,CNT1)
End DoDot:3
+18 IF J=1
SET $PIECE(^TMP("PSO",$JOB,PSI,CNT1),":",1)="\H\"_$PIECE(^TMP("PSO",$JOB,PSI,CNT1),":",1)_"\N\"
+19 SET CNT1=CNT1+1
End DoDot:2
End DoDot:1
+20 SET ^TMP("PSO",$JOB,PSI,CNT1-1)=^TMP("PSO",$JOB,PSI,CNT1-1)_FS_"Patient Medication Instructions"
+21 SET PSI=PSI+1
KILL A,I,J,CNT,CNT1,^TMP($JOB,"PSNPMI")
+22 QUIT
+23 ;
RXR(PSI) ;pharmacy route segment
+1 if '$DATA(DFN)
QUIT
+2 NEW RXR
+3 SET RXR="RXR"_FS
+4 SET ^TMP("PSO",$JOB,PSI)=RXR
SET PSI=PSI+1
+5 QUIT
+6 ;
ZZZ(PSI) ;ZZZ segment for HL7 hazardous text ;*524
+1 NEW DRIEN,HAZD,HAZH,VAR
+2 SET DRIEN=PSOLDRUG
+3 SET VAR=$$HAZ^PSSUTIL(DRIEN)
+4 SET HAZH=$PIECE(VAR,"^",1)
+5 SET HAZH=$SELECT(HAZH:"Y",1:"N")
+6 SET HAZD=$PIECE(VAR,"^",2)
+7 SET HAZD=$SELECT(HAZD:"Y",1:"N")
+8 SET ^TMP("PSO",$JOB,PSI)="ZZZ"_FS_FS_FS_FS_HAZH_FS_HAZD
+9 SET PSI=PSI+1
+10 QUIT
+11 ;
SEND ;Send message to Host Site with Dispensing information from OPAI fill
+1 NEW %,PSOPROT,PSODOMVR,PSORRDAT,HLARR,PSOHSIEN,PSOHSTYP,PSOHSSUB,PSOHSZ,PSOHSRX,DFN,PSODONE,PSOFOUR,PSOSRXD2,PSOSRXD3,PSOSRXD4,PSOSRXD7,PSOHFLAG,PSOHONE,PSOSRDEN,PSODND1,PSODND2,PSODND3,PSODNNOW,PSOHCNT
+2 SET HLARR=$NAME(^TMP("HLS",$JOB))
KILL @HLARR
+3 SET PSOPROT="PSO DISP RX RDS-O13 EVENT"
+4 SET PSODOMVR=$PIECE($GET(^PSRXR(52.09,PSOPAID("IEN"),4)),"^",2)
+5 SET DFN=$PIECE($GET(^PSRXR(52.09,PSOPAID("IEN"),0)),"^",2)
+6 DO INIT^HLFNC2(PSOPROT,.HL)
+7 DO BLDPID^PSOTPHL2(DFN,"",.PSORRDAT,.HL,.ERR)
+8 SET PSOHSZ=$GET(^PSRXR(52.09,PSOPAID("IEN"),0))
SET PSOFOUR=$GET(^PSRXR(52.09,PSOPAID("IEN"),4))
SET PSOHONE=$GET(^PSRXR(52.09,PSOPAID("IEN"),1))
+9 SET PSOHSIEN=$PIECE(PSOHSZ,"^",15)
SET PSOHSTYP=$SELECT($PIECE(PSOHSZ,"^",5)="PR":"PR",$PIECE(PSOHSZ,"^",5)="OP":"PR",1:"RF")
SET PSOSRXD7=$PIECE(PSOHSZ,"^",3)
SET PSOSRXD4=$PIECE(PSOHSZ,"^",7)
+10 SET PSOHSSUB=$SELECT(PSOHSTYP="PR":$PIECE(PSOHSZ,"^",14),1:$PIECE(PSOHSZ,"^",13))
SET PSOHSRX=$PIECE(PSOHSZ,"^",3)
+11 SET PSOHFLAG=0
SET PSOSRDEN=+$PIECE(PSOHONE,"^",2)
SET PSODND1=$PIECE($GET(^PSDRUG(PSOSRDEN,"ND")),"^")
SET PSODND2=$PIECE($GET(^("ND")),"^",2)
SET PSODND3=$PIECE($GET(^("ND")),"^",3)
IF PSODND1
IF PSODND3
SET PSOHFLAG=1
+12 SET PSOSRXD2=$SELECT(PSOHFLAG:PSODND1_"."_PSODND3_"~"_$GET(PSODND2)_"~"_"99NDF",1:"~~")_"~"_PSOSRDEN_"~"_$PIECE($GET(^PSDRUG(PSOSRDEN,0)),"^")_"~"_"99PSD"
+13 DO NOW^%DTC
SET PSODNNOW=$$HLDATE^HLFNC(%,"TS")
SET PSOSRXD3=PSODNNOW
+14 SET PSODONE=0
+15 FOR PSOHCNT=1:1
Begin DoDot:1
+16 IF '$DATA(PSORRDAT(PSOHCNT))
SET PSODONE=1
QUIT
+17 SET @HLARR@(1)=$GET(@HLARR@(1))_PSORRDAT(PSOHCNT)
End DoDot:1
if PSODONE
QUIT
+18 SET @HLARR@(2)="ORC|"_PSOHSTYP_"|"_PSOHSRX_"~"_PSODOMVR_"||||||||"_$PIECE(PSOHSZ,"^",11)_"|"_$PIECE(PSOHSZ,"^",12)
+19 SET @HLARR@(3)="RXD|"_PSOHSSUB_"|"_PSOSRXD2_"|"_PSOSRXD3_"|"_PSOSRXD4_"|||"_PSOSRXD7_"||"_PSOHNDC_"||||"_PSOHSIEN_"|||||"_PSOHLOT_"|"_PSODEXP_"|"_PSOHMAN
+20 SET @HLARR@(4)="NTE|1|L|"_$PIECE(PSOFOUR,"^")_"|"_$PIECE(PSOFOUR,"^",3)_"|"_$PIECE(PSOFOUR,"^",4)_"|"_$PIECE(PSOFOUR,"^",5)
+21 SET @HLARR@(5)="RXR|~~~0~UNKNOWN~99PSR"
+22 SET HLP("SUBSCRIBER")="^^^^"_PSODOMVR
+23 DO GENERATE^HLMA(PSOPROT,"GM",1,.HL,"",.HLP)
+24 KILL @HLARR
+25 QUIT
