- 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 Feb 18, 2025@23:56:13 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