PSOHLDS2 ;BHAM ISC/PWC,SAB-Build HL7 Segments for automated interface ;11/22/06 3:24pm
;;7.0;OUTPATIENT PHARMACY;**156,198,255,200,268,305,336,434,282,531,524**;DEC 1997;Build 28
;DIWP supported by DBIA 10011
;^PS(50.606 supported by DBIA 2174
;^PS(50.7 supported by DBIA #2223
;^PS(51 supported by DBIA 2224
;^PS(51.2 supported by DBIA 2226
;^PS(55 supported by DBIA 2228
;^PSDRUG supported by DBIA 221
;^PS(54 supported by DBIA 2227
;Cont'd build HL7 segments
;
;*198 add check to insert spaces into PMI segments
;*255 add 2 new fields to RXE.21 (label name & VA PRINT NAME)
; and move NTEPMI tag to PSOHLDS4
;*305 send Notice of Privacy Practices in NTE9 - Modified to NTE9 as NTE8 already exist
;*524 add ZZZ segment for HAZ info to OPAI
;
RXE(PSI) ;pharmacy encoded order segment
Q:'$D(DFN) N RXE S RXE="" S $P(RXE,"|",1)=""""""
S $P(RXE,"|",2)=$S($P($G(^PSDRUG(IDGN,"ND")),"^",10)'="":$P(^("ND"),"^",10),($G(PSND1)&$G(PSND3)):$P($G(PSOXN2),"^",2),1:"""""")_CS_$G(PSND2)_CS_"99PSNDF"_CS_PSND1_"."_PSND3_"."_$G(IDGN)_CS_$P($G(^PSDRUG(IDGN,0)),"^")_CS_"99PSD"
S $P(RXE,"|",3)="" I $G(PSOXN)="" S PSOXN=""""""
S $P(RXE,"|",5)=PSOXN_CS_$S($G(UNIT)'="":$G(UNIT),1:"""""")_CS_"99PSU"
S POIPTR=$P($G(^PSRX(IRXN,"OR1")),"^") I POIPTR S PODOSE=$P($G(^PS(50.7,POIPTR,0)),"^",2),PODOSENM=$P($G(^PS(50.606,PODOSE,0)),"^")
I '$G(POIPTR) S PODOSE=$P($G(^PS(50.7,$P($G(^PSDRUG(IDGN,2)),"^"),0)),"^",2),PODOSENM=$P($G(^PS(50.606,PODOSE,0)),"^")
S TRADENM=$G(^PSRX(IRXN,"TN")),$P(RXE,"|",6)=PODOSE_CS_PODOSENM_CS_"99PSF"
S $P(RXE,"|",8)=MP,$P(RXE,"|",9)=TRADENM,$P(RXE,"|",10)=QTY
S $P(RXE,"|",11)=CS_$P($G(^PSDRUG(IDGN,660)),"^",8),$P(RXE,"|",12)=NRFL
S $P(RXE,"|",13)=DEAID,$P(RXE,"|",14)=VPHARMID_CS_$P(VPHARM,",",1)_CS_$P(VPHARM,",",2)
S $P(RXE,"|",15)=$P(^PSRX(IRXN,0),"^"),$P(RXE,"|",16)=RFRM,$P(RXE,"|",17)=NFLD
S $P(RXE,"|",18)=PRIORDT,$P(RXE,"|",31)=CSUB_RS_SCTALK_RS_OTLAN
S $P(RXE,"|",21)=CS_DRUG_RS_CS_$G(VANAME) ;*255
S ^TMP("PSO",$J,PSI)="RXE|"_RXE,PSI=PSI+1
K PODOSE,PODOSENM,POIPTR,TRADENM,UU
Q
RXD(PSI) ;pharmacy dispense segment
Q:'$D(DFN) N RXD,I
S WNS="" I $G(WARN) F I=1:1 S WW=$P(WARN,",",I) Q:WW="" S WNS=WNS_WW_CS_$S(WW'["N":^PS(54,WW,0),1:"")_RS
S RXD="RXD"_FS_$S($G(FPN):FPN,1:0)_FS_$S($P($G(^PSDRUG(IDGN,"ND")),"^",10)'="":$P(^("ND"),"^",10),($G(PSND1)&$G(PSND3)):$P($G(PSOXN2),"^",2),1:"""""")_CS_PSND2_CS_"99PSNDF" ;*531
S RXD=RXD_CS_PSND1_"."_PSND3_"."_$G(IDGN)_CS_$P($G(^PSDRUG(IDGN,0)),"^")_CS_"99PSD"
S RXD=RXD_FS_DISPDT_FS_FS_FS_FS_$P(^PSRX(IRXN,0),"^")_FS_NRFL
S RXD=RXD_FS_DEA_RS_PSONDC_FS_$S(FIN'="":FIN_CS_FIN1,1:"")_FS
S RXD=RXD_FS_DASPLY_FS_MW_FS_FS_CS_$S($G(CAP):"NON-SAFETY",1:"SAFETY")
S RXD=RXD_FS_FS_FS_FS_EXDT_FS_FS_FS_FS_FS_FS_WNS_FS_FS
S ^TMP("PSO",$J,PSI)=RXD,PSI=PSI+1
Q
RXR(PSI) ;pharmacy route segment
Q:'$D(DFN) N RXR S (PSROUTE,RTNAME)=""""""
F PSRTLP=0:0 S PSRTLP=$O(^PSRX(IRXN,6,PSRTLP)) Q:'PSRTLP D
.S PSROUTE=$P($G(^PSRX(IRXN,6,PSRTLP,0)),"^",7)
.I PSROUTE,$D(^PS(51.2,PSROUTE,0)) S RTNAME=$P(^PS(51.2,PSROUTE,0),"^")
I RTNAME="" K PSROUTE,RTNAME,PSRTLP Q
S RXR="RXR"_FS_$G(PSROUTE)_CS_$G(RTNAME)_CS_"99PSR"_FS_FS_FS_FS
S ^TMP("PSO",$J,PSI)=RXR,PSI=PSI+1
K PSROUTE,RTNAME,PSRTLP
Q
SIG K OT S SGY="" F P=1:1:$L(SIG," ") S X=$P(SIG," ",P) D:X]""
.I $D(^PS(51,"A",X)) D
..;PSO*7*282 Intended Use
..I $P($G(^PS(55,DFN,"LAN")),"^") S OT=$O(^PS(51,"B",X,0)) I OT,($P(^PS(51,OT,0),"^",4)<2)&($P($G(^PS(51,OT,4)),"^")]"") S X=$P(^PS(51,OT,4),"^") K OT Q
..;S %=^PS(51,"A",X),X=$P(%,"^") I $P(%,"^",2)]"" S Y=$P(SIG," ",P-1),Y=$E(Y,$L(Y)) S:Y>1 X=$P(%,"^",2)
.S SGY=SGY_X_" "
S X="",SGC=1 F J=1:1 S Z=$P(SGY," ",J) S:Z="" SGY(SGC)=X Q:Z="" S:$L(X)+$L(Z)'<$S($P(PSOPAR,"^",28):46,1:34) SGY(SGC)=X,SGC=SGC+1,X="" S X=X_Z_" "
SIGOLD I '$P(PSOPAR,"^",28) D K NHC
.K DIC,DR,DIQ,NHC S DIC=2,DA=DFN,DR=148,DIQ="NHC",DIQ(0)="I"
.D EN^DIQ1 K DIC,DR,DIQ
.I NHC(2,DFN,148,"I")="Y"!($P($G(^PS(55,DFN,40)),"^")) S SGC=SGC+1,SGY(SGC)="Expiration:________ Mfg:_________"
Q
;
PSOLBL3 ;RX must be defined (Internal), Check already done for OERR SIG
;Format OERR Sig for New and Old label stock
N CTCT,FFFF,LLIM,LLLL,LVAR,LVAR1,PPP,PPPP,SGCT,SIG9,ZZZZ,PSLONG,PPPP
S RX=IRXN
I $P($G(^PS(55,DFN,"LAN")),"^") N II D OTHL^PSOLBL3 G:$G(FND) FMSIG
S PSLONG=$S($P(PSOPAR,"^",28):46,1:34)
; NEXT LINE IF SIG IS MOVED BACK TO MULTIPLE
S PPPP=1 F PPP=0:0 S PPP=$O(^PSRX(RX,"SIG1",PPP)) Q:'PPP I $G(^PSRX(RX,"SIG1",PPP,0))'="" S SIG9(PPPP)=^(0) S PPPP=PPPP+1
;NEXT LINE IF 1ST FRONT DOOR SIG LINE LIVES IN BACK DOOR SPOT
FMSIG S (LVAR,LVAR1)="",LLLL=1
F FFFF=0:0 S FFFF=$O(SIG9(FFFF)) Q:'FFFF S SGCT=0 F ZZZZ=1:1:$L(SIG9(FFFF)) I $E(SIG9(FFFF),ZZZZ)=" "!($L(SIG9(FFFF))=ZZZZ) S SGCT=SGCT+1 D I $L(LVAR)>PSLONG S SGY(LLLL)=LLIM_" ",LLLL=LLLL+1,LVAR=LVAR1
.S LVAR1=$P(SIG9(FFFF)," ",(SGCT)),LLIM=LVAR,LVAR=$S(LVAR="":LVAR1,1:LVAR_" "_LVAR1)
I $G(LVAR)'="" S SGY(LLLL)=LVAR
I '$P(PSOPAR,"^",28) S SGC=0 F CTCT=0:0 S CTCT=$O(SGY(CTCT)) Q:'CTCT S SGC=SGC+1
I $O(OSGY(0)) D
.F I=0:0 S I=$O(SGY(I)) Q:'I I $G(OSGY(I))']"" S OSGY(I)=" "
.F I=0:0 S I=$O(OSGY(I)) Q:'I I $G(SGY(I))']"" S SGY(I)=" "
Q
NTE ;build NTE segment for SIG
;
Q:'$D(DFN)
; 1 = SIG
; 2 = PI Narrative
; 3 = Drug Warning
; 4 = Profile
; 5 = Drug Interaction
; 6 = Drug Allergy
; 7 = PMI Sheet (NTEPMI in PSOHLDS4)
; 8 = Medication Instructions
; 9 = Privacy Notification
;
K FLDX
D NTE1(.PSI) K FLDX D NTE2(.PSI) K FLDX D NTE3(.PSI) K FLDX
D NTE4(.PSI) K FLDX D NTE5(.PSI) K FLDX D NTE6(.PSI) K FLDX
Q
;
NTE1(PSI) ;SIG
S SIG=$P($G(^PSRX(IRXN,"SIG")),"^")
I $P($G(^PSRX(IRXN,"SIG")),"^",2) D PSOLBL3,SIGOLD
I '$P($G(^PSRX(IRXN,"SIG")),"^",2) D SIG
I $O(OSGY(0)) D G KNTE
.K DRR F DR=0:0 S DR=$O(SGY(DR)) Q:'DR S DRR=$G(DRR)+1
.S DRR=DRR+1,SGY(DRR)=FS_"Medication Instructions (LANGUAGE PREFERENCE)"
.K DRR F DR=0:0 S DR=$O(OSGY(DR)) Q:'DR S DRR=$G(DRR)+1
.S DRR=DRR+1,OSGY(DRR)=FS_"Medication Instructions (ENGLISH)"
.K DRR S ^TMP("PSO",$J,PSI)="NTE"_FS_1_FS_FS
.S CLD=1 F DR=0:0 S DR=$O(OSGY(DR)) Q:'DR D
..S:$L($G(^TMP("PSO",$J,PSI,CLD))_OSGY(DR))>245 CLD=CLD+1 S ^TMP("PSO",$J,PSI,CLD)=$G(^TMP("PSO",$J,PSI,CLD))_OSGY(DR)
.S PSI=PSI+1,^TMP("PSO",$J,PSI)="NTE"_FS_8_FS_FS
.S CLD=1 F DR=0:0 S DR=$O(SGY(DR)) Q:'DR D
..S:$L($G(^TMP("PSO",$J,PSI,CLD))_SGY(DR))>245 CLD=CLD+1 S ^TMP("PSO",$J,PSI,CLD)=$G(^TMP("PSO",$J,PSI,CLD))_SGY(DR)
K DRR F DR=0:0 S DR=$O(SGY(DR)) Q:'DR S DRR=$G(DRR)+1
S DRR=DRR+1,SGY(DRR)=FS_"Medication Instructions"
K DRR S ^TMP("PSO",$J,PSI)="NTE"_FS_1_FS_FS
S CLD=1 F DR=0:0 S DR=$O(SGY(DR)) Q:'DR D
.S:$L($G(^TMP("PSO",$J,PSI,CLD))_SGY(DR))>245 CLD=CLD+1 S ^TMP("PSO",$J,PSI,CLD)=$G(^TMP("PSO",$J,PSI,CLD))_SGY(DR)
KNTE S PSI=PSI+1 K DR,CLD,DRR,SIG,E,F,S,FLD1,X,Y,SGY,SGC,Z,DR,%,J,P,NT1,ST,EN,LTH
Q
LENGTH(NT1) ; compensate for length > 245
I $L(NT1)>245 S LTH=$E($L(NT1)/245,1) S:$L(NT1)#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 NT11=$E(NT1,ST,EN)
. S:WW=1 ^TMP("PSO",$J,PSI)=NT11 S:WW>1 ^TMP("PSO",$J,PSI,WW-1)=NT11
S:'$D(LTH) ^TMP("PSO",$J,PSI)=NT1 S PSI=PSI+1
Q
NTE2(PSI) ; Patient Narrative
K ^UTILITY($J,"W") S (DIWL,PSNACNT)=1,DIWR=45,DIWF="",(PSSIXFL,PSSEVFL)=0 F ZZ=0:0 S ZZ=$O(^PS(59,PSOSITE,6,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 ^TMP("PSO",$J,PSI,PSNACNT)=^UTILITY($J,"W",DIWL,LLL,0) S PSNACNT=PSNACNT+1,PSSIXFL=1
I PSSIXFL S ^TMP("PSO",$J,PSI)="NTE"_FS_2_FS_FS,^TMP("PSO",$J,PSI,PSNACNT)=" " S PSNACNT=PSNACNT+1,FLDX=1
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 ^TMP("PSO",$J,PSI,PSNACNT)=^UTILITY($J,"W",DIWL,LLL,0) S PSNACNT=PSNACNT+1,PSSEVFL=1
I PSSEVFL S ^TMP("PSO",$J,PSI,PSNACNT)=" " S PSNACNT=PSNACNT+1
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 ^TMP("PSO",$J,PSI,PSNACNT)=^UTILITY($J,"W",DIWL,LLL,0) S PSNACNT=PSNACNT+1
S:$D(FLDX) ^TMP("PSO",$J,PSI,PSNACNT-1)=^TMP("PSO",$J,PSI,PSNACNT-1)_FS_"Patient Narrative",PSI=PSI+1
K DIWF,DIWL,DIWR,LLL,PSNACNT,PSSEVFL,PSSIXFL,ZZ
Q
NTE3(PSI) ;Drug Warning Narrative
N NTE3,J,TEXT,W,CNT,PSSWSITE
S WARN=$P($G(^PSDRUG(IDGN,0)),"^",8)
S PSSWSITE=+$O(^PS(59.7,0))
I $P($G(^PS(59.7,PSSWSITE,10)),"^",11)="N" D
.S WARN=$$DRUG^PSSWRNA(IDGN,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(OLAN)) 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
NTE5(PSI) ;Drug Interactions
N NTE5 D:$D(DRI) START2^PSOHLDS3
S:$D(NTE5) ^TMP("PSO",$J,PSI)=NTE5_FS_"Drug Interactions",PSI=PSI+1
Q
NTE6(PSI) ;Drug Allergy Indications
N NTE6
Q:'$G(DAW)
D START3^PSOHLDS3
Q:NTE6=""
S ^TMP("PSO",$J,PSI)=NTE6_FS_"Drug Allergy Indications",PSI=PSI+1
Q
NTE9(PSI) ;Privacy Notification
N NTE9,PSOLAN
S NTE9="NTE"_FS_9_FS_FS,^TMP("PSO",$J,PSI)=NTE9
S PSOLAN=$P($G(^PS(55,DFN,"LAN")),"^",2)
I PSOLAN'=2 D
. S ^TMP("PSO",$J,PSI,1)="The VA Notice of Privacy Practices, IB 10-163, which outlines your privacy rights, is available online at http://www1.domain.ext/Health/ or you may obtain a copy by writing the VHA Privacy Office (19F2),"
. S ^TMP("PSO",$J,PSI,2)="810 Vermont Avenue NW, Washington, DC 20420."_FS_"Privacy Notification"
I PSOLAN=2 D
. S ^TMP("PSO",$J,PSI,1)="La Notificacion relacionada con las Politicas de Privacidad del Departamento de Asuntos del Veterano, IB 10-163, contiene los detalles acerca de sus derechos de privacidad y esta disponsible electronicamente"
. S ^TMP("PSO",$J,PSI,2)=" en la siguiente direccion: http://www1.domain.ext/Health/. Usted tambien puede conseguir una copia escribiendo a la Oficina de Privacidad del Departamento de Asuntos de Salud del Veterano, (19F2),"
. S ^TMP("PSO",$J,PSI,3)="810 Vermont Avenue NW, Washington, DC 20420."_FS_"Privacy Notification"
S PSI=PSI+1
Q
ZZZ(PSI) ;ZZZ segment for HL7 hazardous text ;*524
N DRIEN,HAZD,HAZH,VAR
S DRIEN=$P(^PSRX(IRXN,0),"^",6)
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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOHLDS2 11203 printed Sep 23, 2025@20:06:12 Page 2
PSOHLDS2 ;BHAM ISC/PWC,SAB-Build HL7 Segments for automated interface ;11/22/06 3:24pm
+1 ;;7.0;OUTPATIENT PHARMACY;**156,198,255,200,268,305,336,434,282,531,524**;DEC 1997;Build 28
+2 ;DIWP supported by DBIA 10011
+3 ;^PS(50.606 supported by DBIA 2174
+4 ;^PS(50.7 supported by DBIA #2223
+5 ;^PS(51 supported by DBIA 2224
+6 ;^PS(51.2 supported by DBIA 2226
+7 ;^PS(55 supported by DBIA 2228
+8 ;^PSDRUG supported by DBIA 221
+9 ;^PS(54 supported by DBIA 2227
+10 ;Cont'd build HL7 segments
+11 ;
+12 ;*198 add check to insert spaces into PMI segments
+13 ;*255 add 2 new fields to RXE.21 (label name & VA PRINT NAME)
+14 ; and move NTEPMI tag to PSOHLDS4
+15 ;*305 send Notice of Privacy Practices in NTE9 - Modified to NTE9 as NTE8 already exist
+16 ;*524 add ZZZ segment for HAZ info to OPAI
+17 ;
RXE(PSI) ;pharmacy encoded order segment
+1 if '$DATA(DFN)
QUIT
NEW RXE
SET RXE=""
SET $PIECE(RXE,"|",1)=""""""
+2 SET $PIECE(RXE,"|",2)=$SELECT($PIECE($GET(^PSDRUG(IDGN,"ND")),"^",10)'="":$PIECE(^("ND"),"^",10),($GET(PSND1)&...
... $GET(PSND3)):$PIECE($GET(PSOXN2),"^",2),1:"""""")_CS_$GET(PSND2)_CS_"99PSNDF"_CS_PSND1_"."_PSND3_"."_$GET(IDGN)_CS_$PIECE($GET(^PSDRUG(IDGN,0)),"^")_CS_"99PSD"
+3 SET $PIECE(RXE,"|",3)=""
IF $GET(PSOXN)=""
SET PSOXN=""""""
+4 SET $PIECE(RXE,"|",5)=PSOXN_CS_$SELECT($GET(UNIT)'="":$GET(UNIT),1:"""""")_CS_"99PSU"
+5 SET POIPTR=$PIECE($GET(^PSRX(IRXN,"OR1")),"^")
IF POIPTR
SET PODOSE=$PIECE($GET(^PS(50.7,POIPTR,0)),"^",2)
SET PODOSENM=$PIECE($GET(^PS(50.606,PODOSE,0)),"^")
+6 IF '$GET(POIPTR)
SET PODOSE=$PIECE($GET(^PS(50.7,$PIECE($GET(^PSDRUG(IDGN,2)),"^"),0)),"^",2)
SET PODOSENM=$PIECE($GET(^PS(50.606,PODOSE,0)),"^")
+7 SET TRADENM=$GET(^PSRX(IRXN,"TN"))
SET $PIECE(RXE,"|",6)=PODOSE_CS_PODOSENM_CS_"99PSF"
+8 SET $PIECE(RXE,"|",8)=MP
SET $PIECE(RXE,"|",9)=TRADENM
SET $PIECE(RXE,"|",10)=QTY
+9 SET $PIECE(RXE,"|",11)=CS_$PIECE($GET(^PSDRUG(IDGN,660)),"^",8)
SET $PIECE(RXE,"|",12)=NRFL
+10 SET $PIECE(RXE,"|",13)=DEAID
SET $PIECE(RXE,"|",14)=VPHARMID_CS_$PIECE(VPHARM,",",1)_CS_$PIECE(VPHARM,",",2)
+11 SET $PIECE(RXE,"|",15)=$PIECE(^PSRX(IRXN,0),"^")
SET $PIECE(RXE,"|",16)=RFRM
SET $PIECE(RXE,"|",17)=NFLD
+12 SET $PIECE(RXE,"|",18)=PRIORDT
SET $PIECE(RXE,"|",31)=CSUB_RS_SCTALK_RS_OTLAN
+13 ;*255
SET $PIECE(RXE,"|",21)=CS_DRUG_RS_CS_$GET(VANAME)
+14 SET ^TMP("PSO",$JOB,PSI)="RXE|"_RXE
SET PSI=PSI+1
+15 KILL PODOSE,PODOSENM,POIPTR,TRADENM,UU
+16 QUIT
RXD(PSI) ;pharmacy dispense segment
+1 if '$DATA(DFN)
QUIT
NEW RXD,I
+2 SET WNS=""
IF $GET(WARN)
FOR I=1:1
SET WW=$PIECE(WARN,",",I)
if WW=""
QUIT
SET WNS=WNS_WW_CS_$SELECT(WW'["N":^PS(54,WW,0),1:"")_RS
+3 ;*531
SET RXD="RXD"_FS_$SELECT($GET(FPN):FPN,1:0)_FS_$SELECT($PIECE($GET(^PSDRUG(IDGN,"ND")),"^",10)'="":$PIECE(^("ND"),"^",10),($GET(PSND1)&$GET(PSND3)):$PIECE($GET(PSOXN2),"^",2),1:"""""")_CS_PSND2_CS_"99PSNDF"
+4 SET RXD=RXD_CS_PSND1_"."_PSND3_"."_$GET(IDGN)_CS_$PIECE($GET(^PSDRUG(IDGN,0)),"^")_CS_"99PSD"
+5 SET RXD=RXD_FS_DISPDT_FS_FS_FS_FS_$PIECE(^PSRX(IRXN,0),"^")_FS_NRFL
+6 SET RXD=RXD_FS_DEA_RS_PSONDC_FS_$SELECT(FIN'="":FIN_CS_FIN1,1:"")_FS
+7 SET RXD=RXD_FS_DASPLY_FS_MW_FS_FS_CS_$SELECT($GET(CAP):"NON-SAFETY",1:"SAFETY")
+8 SET RXD=RXD_FS_FS_FS_FS_EXDT_FS_FS_FS_FS_FS_FS_WNS_FS_FS
+9 SET ^TMP("PSO",$JOB,PSI)=RXD
SET PSI=PSI+1
+10 QUIT
RXR(PSI) ;pharmacy route segment
+1 if '$DATA(DFN)
QUIT
NEW RXR
SET (PSROUTE,RTNAME)=""""""
+2 FOR PSRTLP=0:0
SET PSRTLP=$ORDER(^PSRX(IRXN,6,PSRTLP))
if 'PSRTLP
QUIT
Begin DoDot:1
+3 SET PSROUTE=$PIECE($GET(^PSRX(IRXN,6,PSRTLP,0)),"^",7)
+4 IF PSROUTE
IF $DATA(^PS(51.2,PSROUTE,0))
SET RTNAME=$PIECE(^PS(51.2,PSROUTE,0),"^")
End DoDot:1
+5 IF RTNAME=""
KILL PSROUTE,RTNAME,PSRTLP
QUIT
+6 SET RXR="RXR"_FS_$GET(PSROUTE)_CS_$GET(RTNAME)_CS_"99PSR"_FS_FS_FS_FS
+7 SET ^TMP("PSO",$JOB,PSI)=RXR
SET PSI=PSI+1
+8 KILL PSROUTE,RTNAME,PSRTLP
+9 QUIT
SIG KILL OT
SET SGY=""
FOR P=1:1:$LENGTH(SIG," ")
SET X=$PIECE(SIG," ",P)
if X]""
Begin DoDot:1
+1 IF $DATA(^PS(51,"A",X))
Begin DoDot:2
+2 ;PSO*7*282 Intended Use
+3 IF $PIECE($GET(^PS(55,DFN,"LAN")),"^")
SET OT=$ORDER(^PS(51,"B",X,0))
IF OT
IF ($PIECE(^PS(51,OT,0),"^",4)<2)&($PIECE($GET(^PS(51,OT,4)),"^")]"")
SET X=$PIECE(^PS(51,OT,4),"^")
KILL OT
QUIT
+4 ;S %=^PS(51,"A",X),X=$P(%,"^") I $P(%,"^",2)]"" S Y=$P(SIG," ",P-1),Y=$E(Y,$L(Y)) S:Y>1 X=$P(%,"^",2)
End DoDot:2
+5 SET SGY=SGY_X_" "
End DoDot:1
+6 SET X=""
SET SGC=1
FOR J=1:1
SET Z=$PIECE(SGY," ",J)
if Z=""
SET SGY(SGC)=X
if Z=""
QUIT
if $LENGTH(X)+$LENGTH(Z)'<$SELECT($PIECE(PSOPAR,"^",28)
SET SGY(SGC)=X
SET SGC=SGC+1
SET X=""
SET X=X_Z_" "
SIGOLD IF '$PIECE(PSOPAR,"^",28)
Begin DoDot:1
+1 KILL DIC,DR,DIQ,NHC
SET DIC=2
SET DA=DFN
SET DR=148
SET DIQ="NHC"
SET DIQ(0)="I"
+2 DO EN^DIQ1
KILL DIC,DR,DIQ
+3 IF NHC(2,DFN,148,"I")="Y"!($PIECE($GET(^PS(55,DFN,40)),"^"))
SET SGC=SGC+1
SET SGY(SGC)="Expiration:________ Mfg:_________"
End DoDot:1
KILL NHC
+4 QUIT
+5 ;
PSOLBL3 ;RX must be defined (Internal), Check already done for OERR SIG
+1 ;Format OERR Sig for New and Old label stock
+2 NEW CTCT,FFFF,LLIM,LLLL,LVAR,LVAR1,PPP,PPPP,SGCT,SIG9,ZZZZ,PSLONG,PPPP
+3 SET RX=IRXN
+4 IF $PIECE($GET(^PS(55,DFN,"LAN")),"^")
NEW II
DO OTHL^PSOLBL3
if $GET(FND)
GOTO FMSIG
+5 SET PSLONG=$SELECT($PIECE(PSOPAR,"^",28):46,1:34)
+6 ; NEXT LINE IF SIG IS MOVED BACK TO MULTIPLE
+7 SET PPPP=1
FOR PPP=0:0
SET PPP=$ORDER(^PSRX(RX,"SIG1",PPP))
if 'PPP
QUIT
IF $GET(^PSRX(RX,"SIG1",PPP,0))'=""
SET SIG9(PPPP)=^(0)
SET PPPP=PPPP+1
+8 ;NEXT LINE IF 1ST FRONT DOOR SIG LINE LIVES IN BACK DOOR SPOT
FMSIG SET (LVAR,LVAR1)=""
SET LLLL=1
+1 FOR FFFF=0:0
SET FFFF=$ORDER(SIG9(FFFF))
if 'FFFF
QUIT
SET SGCT=0
FOR ZZZZ=1:1:$LENGTH(SIG9(FFFF))
IF $EXTRACT(SIG9(FFFF),ZZZZ)=" "!($LENGTH(SIG9(FFFF))=ZZZZ)
SET SGCT=SGCT+1
Begin DoDot:1
+2 SET LVAR1=$PIECE(SIG9(FFFF)," ",(SGCT))
SET LLIM=LVAR
SET LVAR=$SELECT(LVAR="":LVAR1,1:LVAR_" "_LVAR1)
End DoDot:1
IF $LENGTH(LVAR)>PSLONG
SET SGY(LLLL)=LLIM_" "
SET LLLL=LLLL+1
SET LVAR=LVAR1
+3 IF $GET(LVAR)'=""
SET SGY(LLLL)=LVAR
+4 IF '$PIECE(PSOPAR,"^",28)
SET SGC=0
FOR CTCT=0:0
SET CTCT=$ORDER(SGY(CTCT))
if 'CTCT
QUIT
SET SGC=SGC+1
+5 IF $ORDER(OSGY(0))
Begin DoDot:1
+6 FOR I=0:0
SET I=$ORDER(SGY(I))
if 'I
QUIT
IF $GET(OSGY(I))']""
SET OSGY(I)=" "
+7 FOR I=0:0
SET I=$ORDER(OSGY(I))
if 'I
QUIT
IF $GET(SGY(I))']""
SET SGY(I)=" "
End DoDot:1
+8 QUIT
NTE ;build NTE segment for SIG
+1 ;
+2 if '$DATA(DFN)
QUIT
+3 ; 1 = SIG
+4 ; 2 = PI Narrative
+5 ; 3 = Drug Warning
+6 ; 4 = Profile
+7 ; 5 = Drug Interaction
+8 ; 6 = Drug Allergy
+9 ; 7 = PMI Sheet (NTEPMI in PSOHLDS4)
+10 ; 8 = Medication Instructions
+11 ; 9 = Privacy Notification
+12 ;
+13 KILL FLDX
+14 DO NTE1(.PSI)
KILL FLDX
DO NTE2(.PSI)
KILL FLDX
DO NTE3(.PSI)
KILL FLDX
+15 DO NTE4(.PSI)
KILL FLDX
DO NTE5(.PSI)
KILL FLDX
DO NTE6(.PSI)
KILL FLDX
+16 QUIT
+17 ;
NTE1(PSI) ;SIG
+1 SET SIG=$PIECE($GET(^PSRX(IRXN,"SIG")),"^")
+2 IF $PIECE($GET(^PSRX(IRXN,"SIG")),"^",2)
DO PSOLBL3
DO SIGOLD
+3 IF '$PIECE($GET(^PSRX(IRXN,"SIG")),"^",2)
DO SIG
+4 IF $ORDER(OSGY(0))
Begin DoDot:1
+5 KILL DRR
FOR DR=0:0
SET DR=$ORDER(SGY(DR))
if 'DR
QUIT
SET DRR=$GET(DRR)+1
+6 SET DRR=DRR+1
SET SGY(DRR)=FS_"Medication Instructions (LANGUAGE PREFERENCE)"
+7 KILL DRR
FOR DR=0:0
SET DR=$ORDER(OSGY(DR))
if 'DR
QUIT
SET DRR=$GET(DRR)+1
+8 SET DRR=DRR+1
SET OSGY(DRR)=FS_"Medication Instructions (ENGLISH)"
+9 KILL DRR
SET ^TMP("PSO",$JOB,PSI)="NTE"_FS_1_FS_FS
+10 SET CLD=1
FOR DR=0:0
SET DR=$ORDER(OSGY(DR))
if 'DR
QUIT
Begin DoDot:2
+11 if $LENGTH($GET(^TMP("PSO",$JOB,PSI,CLD))_OSGY(DR))>245
SET CLD=CLD+1
SET ^TMP("PSO",$JOB,PSI,CLD)=$GET(^TMP("PSO",$JOB,PSI,CLD))_OSGY(DR)
End DoDot:2
+12 SET PSI=PSI+1
SET ^TMP("PSO",$JOB,PSI)="NTE"_FS_8_FS_FS
+13 SET CLD=1
FOR DR=0:0
SET DR=$ORDER(SGY(DR))
if 'DR
QUIT
Begin DoDot:2
+14 if $LENGTH($GET(^TMP("PSO",$JOB,PSI,CLD))_SGY(DR))>245
SET CLD=CLD+1
SET ^TMP("PSO",$JOB,PSI,CLD)=$GET(^TMP("PSO",$JOB,PSI,CLD))_SGY(DR)
End DoDot:2
End DoDot:1
GOTO KNTE
+15 KILL DRR
FOR DR=0:0
SET DR=$ORDER(SGY(DR))
if 'DR
QUIT
SET DRR=$GET(DRR)+1
+16 SET DRR=DRR+1
SET SGY(DRR)=FS_"Medication Instructions"
+17 KILL DRR
SET ^TMP("PSO",$JOB,PSI)="NTE"_FS_1_FS_FS
+18 SET CLD=1
FOR DR=0:0
SET DR=$ORDER(SGY(DR))
if 'DR
QUIT
Begin DoDot:1
+19 if $LENGTH($GET(^TMP("PSO",$JOB,PSI,CLD))_SGY(DR))>245
SET CLD=CLD+1
SET ^TMP("PSO",$JOB,PSI,CLD)=$GET(^TMP("PSO",$JOB,PSI,CLD))_SGY(DR)
End DoDot:1
KNTE SET PSI=PSI+1
KILL DR,CLD,DRR,SIG,E,F,S,FLD1,X,Y,SGY,SGC,Z,DR,%,J,P,NT1,ST,EN,LTH
+1 QUIT
LENGTH(NT1) ; compensate for length > 245
+1 IF $LENGTH(NT1)>245
SET LTH=$EXTRACT($LENGTH(NT1)/245,1)
if $LENGTH(NT1)#245>0
SET LTH=LTH+1
FOR WW=1:1:LTH
Begin DoDot:1
+2 if WW=1
SET ST=1
SET EN=245
if WW>1
SET ST=(ST+245)
SET EN=(EN+245)
SET NT11=$EXTRACT(NT1,ST,EN)
+3 if WW=1
SET ^TMP("PSO",$JOB,PSI)=NT11
if WW>1
SET ^TMP("PSO",$JOB,PSI,WW-1)=NT11
End DoDot:1
+4 if '$DATA(LTH)
SET ^TMP("PSO",$JOB,PSI)=NT1
SET PSI=PSI+1
+5 QUIT
NTE2(PSI) ; Patient Narrative
+1 KILL ^UTILITY($JOB,"W")
SET (DIWL,PSNACNT)=1
SET DIWR=45
SET DIWF=""
SET (PSSIXFL,PSSEVFL)=0
FOR ZZ=0:0
SET ZZ=$ORDER(^PS(59,PSOSITE,6,ZZ))
if 'ZZ
QUIT
IF $DATA(^(ZZ,0))
SET X=^(0)
DO ^DIWP
+2 FOR LLL=0:0
SET LLL=$ORDER(^UTILITY($JOB,"W",DIWL,LLL))
if 'LLL
QUIT
SET ^TMP("PSO",$JOB,PSI,PSNACNT)=^UTILITY($JOB,"W",DIWL,LLL,0)
SET PSNACNT=PSNACNT+1
SET PSSIXFL=1
+3 IF PSSIXFL
SET ^TMP("PSO",$JOB,PSI)="NTE"_FS_2_FS_FS
SET ^TMP("PSO",$JOB,PSI,PSNACNT)=" "
SET PSNACNT=PSNACNT+1
SET FLDX=1
+4 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
+5 FOR LLL=0:0
SET LLL=$ORDER(^UTILITY($JOB,"W",DIWL,LLL))
if 'LLL
QUIT
SET ^TMP("PSO",$JOB,PSI,PSNACNT)=^UTILITY($JOB,"W",DIWL,LLL,0)
SET PSNACNT=PSNACNT+1
SET PSSEVFL=1
+6 IF PSSEVFL
SET ^TMP("PSO",$JOB,PSI,PSNACNT)=" "
SET PSNACNT=PSNACNT+1
+7 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
+8 FOR LLL=0:0
SET LLL=$ORDER(^UTILITY($JOB,"W",DIWL,LLL))
if 'LLL
QUIT
SET ^TMP("PSO",$JOB,PSI,PSNACNT)=^UTILITY($JOB,"W",DIWL,LLL,0)
SET PSNACNT=PSNACNT+1
+9 if $DATA(FLDX)
SET ^TMP("PSO",$JOB,PSI,PSNACNT-1)=^TMP("PSO",$JOB,PSI,PSNACNT-1)_FS_"Patient Narrative"
SET PSI=PSI+1
+10 KILL DIWF,DIWL,DIWR,LLL,PSNACNT,PSSEVFL,PSSIXFL,ZZ
+11 QUIT
NTE3(PSI) ;Drug Warning Narrative
+1 NEW NTE3,J,TEXT,W,CNT,PSSWSITE
+2 SET WARN=$PIECE($GET(^PSDRUG(IDGN,0)),"^",8)
+3 SET PSSWSITE=+$ORDER(^PS(59.7,0))
+4 IF $PIECE($GET(^PS(59.7,PSSWSITE,10)),"^",11)="N"
Begin DoDot:1
+5 SET WARN=$$DRUG^PSSWRNA(IDGN,DFN)
End DoDot:1
+6 IF WARN=""
QUIT
+7 SET NTE3="NTE"_FS_3_FS_FS
SET ^TMP("PSO",$JOB,PSI)=NTE3
SET CNT=1
+8 FOR J=1:1
SET W=$PIECE(WARN,",",J)
if W=""
QUIT
Begin DoDot:1
+9 if CNT>1
SET ^TMP("PSO",$JOB,PSI,CNT-1)=^TMP("PSO",$JOB,PSI,CNT-1)_"\.sp\"
+10 SET TEXT=$$WTEXT^PSSWRNA(W,$GET(OLAN))
IF TEXT'=""
SET FLDX=1
Begin DoDot:2
+11 IF $LENGTH(TEXT)<245
SET ^TMP("PSO",$JOB,PSI,CNT)=TEXT
SET CNT=CNT+1
QUIT
+12 NEW LTH,ST,EN,TXT,WW
+13 SET LTH=$EXTRACT($LENGTH(TEXT)/245,1)
if $LENGTH(TEXT)#245>0
SET LTH=LTH+1
+14 FOR WW=1:1:LTH
Begin DoDot:3
+15 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)
+16 SET ^TMP("PSO",$JOB,PSI,CNT)=TXT
SET CNT=CNT+1
End DoDot:3
End DoDot:2
End DoDot:1
+17 IF $GET(FLDX)
Begin DoDot:1
+18 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"
+19 IF '$TEST
SET ^TMP("PSO",$JOB,PSI,CNT)=FS_"Drug Warning Narrative"
End DoDot:1
SET PSI=PSI+1
+20 QUIT
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
NTE5(PSI) ;Drug Interactions
+1 NEW NTE5
if $DATA(DRI)
DO START2^PSOHLDS3
+2 if $DATA(NTE5)
SET ^TMP("PSO",$JOB,PSI)=NTE5_FS_"Drug Interactions"
SET PSI=PSI+1
+3 QUIT
NTE6(PSI) ;Drug Allergy Indications
+1 NEW NTE6
+2 if '$GET(DAW)
QUIT
+3 DO START3^PSOHLDS3
+4 if NTE6=""
QUIT
+5 SET ^TMP("PSO",$JOB,PSI)=NTE6_FS_"Drug Allergy Indications"
SET PSI=PSI+1
+6 QUIT
NTE9(PSI) ;Privacy Notification
+1 NEW NTE9,PSOLAN
+2 SET NTE9="NTE"_FS_9_FS_FS
SET ^TMP("PSO",$JOB,PSI)=NTE9
+3 SET PSOLAN=$PIECE($GET(^PS(55,DFN,"LAN")),"^",2)
+4 IF PSOLAN'=2
Begin DoDot:1
+5 SET ^TMP("PSO",$JOB,PSI,1)="The VA Notice of Privacy Practices, IB 10-163, which outlines your privacy rights, is available online at http://www1.domain.ext/Health/ or you may obtain a copy by writing the VHA Privacy Office (19F2),"
+6 SET ^TMP("PSO",$JOB,PSI,2)="810 Vermont Avenue NW, Washington, DC 20420."_FS_"Privacy Notification"
End DoDot:1
+7 IF PSOLAN=2
Begin DoDot:1
+8 SET ^TMP("PSO",$JOB,PSI,1)="La Notificacion relacionada con las Politicas de Privacidad del Departamento de Asuntos del Veterano, IB 10-163, contiene los detalles acerca de sus derechos de privacidad y esta disponsible electronicamente"
+9 SET ^TMP("PSO",$JOB,PSI,2)=" en la siguiente direccion: http://www1.domain.ext/Health/. Usted tambien puede conseguir una copia escribiendo a la Oficina de Privacidad del Departamento de Asuntos de Salud del Veterano, (19F2),"
+10 SET ^TMP("PSO",$JOB,PSI,3)="810 Vermont Avenue NW, Washington, DC 20420."_FS_"Privacy Notification"
End DoDot:1
+11 SET PSI=PSI+1
+12 QUIT
ZZZ(PSI) ;ZZZ segment for HL7 hazardous text ;*524
+1 NEW DRIEN,HAZD,HAZH,VAR
+2 SET DRIEN=$PIECE(^PSRX(IRXN,0),"^",6)
+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
