PSOHLDS1 ;BIR/LC,PWC-Build HL7 Segments for Automated Interface ; 2/5/10 10:01am
;;7.0;OUTPATIENT PHARMACY;**156,232,255,200,305,336,351,434,609,524,545,753**;DEC 1997;Build 53
;HLFNC supp. by DBIA 10106
;PSNAPIS supp. by DBIA 2531
;VASITE supp. by DBIA 10112
;VADPT supp. by DBIA 10061
;EN^DIQ1 supp. by DBIA 100
;EN^VAFHLZTA supp. by DBIA 758
;PSDRUG supp. by DBIA 221
;PS(50.607 supp. by DBIA 2221
;PS(55 supp. by DBIA 2228
;DPT supp. by DBIA 3097
;SC supp. by DBIA 10040
;VA(200 supp. by DBIA 10060
;SCMSVUT5 supp. by DBIA 4347
;BLDPID^VAFCQRY supp. by DBIA 3630
;MAKEIT^VAFHLU supp. by DBIA 4346
;
;*232 allow for Do Not Mail
;*255 move NTEPMI to PSOHLDS4. fix "MP" node test to '=""
;*305 send Notice of Privacy Practices in NTE9 - Modified to NTE9 as NTE8 already exist
;*609 evaluate option 4 - LOCAL CERTIFIED MAIL
;*524 added ZZZ segment for hazardous drug information
;
START ;
D GETDATA
D PID(.PSI),PV1(.PSI),PV2(.PSI),IAM^PSOHLDS4(.PSI),ORC^PSOHLDS4(.PSI)
D NTE^PSOHLDS2,RXE^PSOHLDS2(.PSI),RXD^PSOHLDS2(.PSI)
D NTEPMI^PSOHLDS4(.PSI),NTE9^PSOHLDS2(.PSI),RXR^PSOHLDS2(.PSI),ZZZ^PSOHLDS2(.PSI) ;*255 ;*524 added ZZZ segment for hazardous flags
; clean up data set by GETDATA
K EBY,EBY1,EFDT,EXDT,FDT,PVDR,PVDR1,CSINER,CSINER1,SITE,SITADD,SITPHN
K VPHARMID,VPHARM,DEAID,MW,QTY,DASPLY,OLAN,OTHLAN,PRIORDT,RFRM,NFLD,WARN
K PSOXN,PSOXN2,PSND1,PSND2,PRODUCT,PSOPROD,UNIT,VANAME,DISPDT,PSONDC
K DRUG
Q
GETDATA ; this is the place to set all data needed for several segments
I $G(FP)="F"&('$G(FPN)) D ;original
. S FDT=$P(^PSRX(IRXN,2),"^",2),VPHARMID=$P(^(2),"^",10),DISPDT=$P(^(2),"^",5),EXDT=$P(^(2),"^",6),PSONDC=$P(^(2),"^",7)
. S PVDR=$P(^PSRX(IRXN,0),"^",4),QTY=$P(^(0),"^",7),DASPLY=$P(^(0),"^",8),MW=$P(^(0),"^",11),EBY=$P(^(0),"^",16)
I $G(FP)="F"&($G(FPN)) D ;refill
. S FDT=$P(^PSRX(IRXN,1,FPN,0),"^"),MW=$P(^(0),"^",2),QTY=$P(^(0),"^",4),DASPLY=$P(^(0),"^",10),DISPDT=$P(^(0),"^",19),EXDT=$S($P(^(0),"^",15):$P(^(0),"^",15),1:$P(^PSRX(IRXN,2),"^",6))
. S VPHARMID=$S($P(^PSRX(IRXN,1,FPN,0),"^",5)'="":$P(^(0),"^",5),1:$P(^PSRX(IRXN,2),"^",10))
. S EBY=$S($P(^PSRX(IRXN,1,FPN,0),"^",5):$P(^(0),"^",5),1:$P(^(0),"^",7)),PVDR=$P(^(0),"^",17),PSONDC=$S($P($G(^PSRX(IRXN,1,FPN,1)),"^",3):$P(^(1),"^",3),1:$P(^PSRX(IRXN,2),"^",7))
I $G(FP)="P"&($G(FPN)) D ;partial
. S FDT=$P(^PSRX(IRXN,"P",FPN,0),"^"),MW=$P(^(0),"^",2),QTY=$P(^(0),"^",4),DASPLY=$P(^(0),"^",10),DISPDT=FDT,PVDR=$P(^(0),"^",17),EXDT=$P(^PSRX(IRXN,2),"^",6)
. S EBY=$S($P(^PSRX(IRXN,"P",FPN,0),"^",5):$P(^(0),"^",5),1:$P(^(0),"^",7)),VPHARMID=$S($P(^(0),"^",5)'="":$P(^(0),"^",5),1:$P(^PSRX(IRXN,2),"^",10)),PVDR=$P(^PSRX(IRXN,"P",FPN,0),"^",17)
. S PSONDC=$S($P(^PSRX(IRXN,"P",FPN,0),"^",12):$P(^(0),"^",12),1:$P(^PSRX(IRXN,2),"^",7))
S EFDT=$P(^PSRX(IRXN,2),"^",2) S:$G(EFDT) EFDT=$$HLDATE^HLFNC(EFDT,"DT")
S ISDT=$P(^PSRX(IRXN,0),"^",13) S:$G(ISDT) ISDT=$$HLDATE^HLFNC(ISDT,"DT")
;*545
S DEAID=$$PRDEA^XUSER(PVDR) K DIC,X,Y S DIC="^VA(200,",DIC(0)="N,Z",X=VPHARMID D ^DIC
S VPHARM=$S(+Y:$$HLNAME^HLFNC($P(Y,"^",2)),1:"""""") K DIC,X,Y
K DIC,X,Y S DIC="^VA(200,",DIC(0)="N,Z",X=EBY D ^DIC
S EBY1=$S(+Y:$$HLNAME^HLFNC($P(Y,"^",2)),1:"""""") K DIC,X,Y
K DIC,X,Y S DIC="^VA(200,",DIC(0)="N,Z",X=PVDR D ^DIC
S PVDR1=$S(+Y:$$HLNAME^HLFNC($P(Y,"^",2)),1:"""""") K DIC,X,Y
S PRIORDT=$P(^PSRX(IRXN,3),"^",4),PRIORDT=$$HLDATE^HLFNC(PRIORDT,"DT")
S FDT=$$HLDATE^HLFNC(FDT,"DT")
S:$G(DISPDT) DISPDT=$$HLDATE^HLFNC(DISPDT,"DT")
S:$G(EXDT) EXDT=$$HLDATE^HLFNC(EXDT,"DT")
S FIN=$P(^PSRX(IRXN,"OR1"),"^",5)
K DIC,X,Y S DIC="^VA(200,",DIC(0)="N,Z",X=FIN D ^DIC
S FIN1=$S(+Y:$$HLNAME^HLFNC($P(Y,"^",2)),1:"""""") K DIC,X,Y
S SITE=$S($D(^PS(59,PSOSITE,0)):^(0),1:"")
S PSZIP=$P(SITE,"^",5) S PSOHZIP=$S(PSZIP["-":PSZIP,1:$E(PSZIP,1,5)_$S($E(PSZIP,6,9)]"":"-"_$E(PSZIP,6,9),1:""))
S CLN=+$P(^PSRX(IRXN,0),"^",5),CLN1=$S($D(^SC(CLN,0)):$P(^(0),"^",1),1:"UNKNOWN")
S CSINER=$P(^PSRX(IRXN,3),"^",3)
K DIC,X,Y S DIC="^VA(200,",DIC(0)="N,Z",X=CSINER D ^DIC
S CSINER1=$S(+Y:$$HLNAME^HLFNC($P(Y,"^",2)),1:"""""") K DIC,X,Y
D 6^VADPT
S X=$S($D(^PS(55,DFN,0)):^(0),1:""),CAP=$P(X,"^",2)
D MW(X,.MW,.MP) ;PSO*232
I (($P(^PSRX(IRXN,"STA"),"^")>0)&($P(^("STA"),"^")'=2)&('$G(PSODBQ)))!'$G(^PSRX(IRXN,"IB")) S COPAY="NO COPAY"
E S COPAY="COPAY"
S NURSE=$S($P($G(^DPT(DFN,"NHC")),"^")="Y":1,$P($G(^PS(55,DFN,40)),"^"):1,1:0)
S DATE=$$HLDATE^HLFNC(FDT) D NOW^%DTC S NOW=$$HLDATE^HLFNC(%,"TS")
S OLAN=$P($G(^PS(55,DFN,"LAN")),"^",2),OTLAN="N" I OLAN=2 S OTLAN="Y"
S CSUB1=$$GET1^DIQ(50,IDGN_",",3),CSUB="N" I $E(CSUB1,1)>1&($E(CSUB1,1)<6) S CSUB="Y"
S SCTALK=+$G(^PS(55,"ASTALK",$P(^PSRX(IRXN,0),"^",2)))
K DIC,DR,DIQ S DA=$P($$SITE^VASITE(),"^") I DA D
.K PSOINST S DIC=4,DIQ(0)="I",DR=99,DIQ="PSOINST" D EN^DIQ1
.S PSOINST=PSOINST(4,DA,99,"I") K DIC,DA,DR,DIQ,PSOINST(4)
S DRUG=$$ZZ^PSOSUTL(IRXN),DEA=$P(^PSDRUG(IDGN,0),"^",3),WARN=$P($G(^(0)),"^",8)
S PSND1=$P($G(^PSDRUG(IDGN,"ND")),"^"),PSND2=$P($G(^("ND")),"^",2),PSND3=$P($G(^("ND")),"^",3)
K PSOXN,PSOXN2,PSOPROD
I PSND1,PSND3 D
.S PSOPROD=$$PROD2^PSNAPIS(PSND1,PSND3),VANAME=$P($G(PSOPROD),"^",1)
.I $T(^PSNAPIS)]"" S PSOXN=$$DFSU^PSNAPIS(PSND1,PSND3),UNIT=$P($G(PSOXN),"^",6) S PSOXN=$P($G(PSOXN),"^",5) S PSOXN2=$$PROD2^PSNAPIS(PSND1,PSND3) Q
.S PSOXN2=$G(^PSNDF(PSND1,5,PSND3,2))
.S PRODUCT=$G(^PSNDF(PSND1,5,PSND3,0))
.I $G(PRODUCT)'="" S PSOXN=+$P($G(^PSNDF(PSND1,2,+$P(PRODUCT,"^",2),3,+$P(PRODUCT,"^",3),4,+$P(PRODUCT,"^",4),0)),"^"),UNIT=$P($G(^PS(50.607,PSOXN,0)),"^")
S NFLD=0,UU="" F S UU=$O(^PSRX(IRXN,1,UU)) Q:UU="" S:$D(^PSRX(IRXN,1,UU,0)) NFLD=NFLD+1
S NRFL=$P(^PSRX(IRXN,0),"^",9),RFRM=(NRFL-NFLD)
Q
PID(PSI) ;patient ID segment
Q:'$D(DFN)!$D(PAS)
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^PSOBAI(DFN)
. N BADA S BADA=$$CHKRX^PSOBAI(IRXN)
. 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^PSOBAI(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 repitition 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
PV1(PSI) ;patient visit segment
Q:'$D(DFN)!$D(PAS1)
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,PAS1=1
Q
PV2(PSI) ;patient visit segment (additional information)
;PATIENT STATUS AND COPAY
Q:'$D(DFN)!$D(PAS2)
N PV2 S PV2=""
S $P(PV2,"|",24)=$P($G(^PS(53,+$P($G(^PSRX(IRXN,0)),"^",3),0)),"^",2)_"~"_COPAY_FS
S ^TMP("PSO",$J,PSI)="PV2|"_PV2
S PSI=PSI+1,PAS2=1
Q
;
MW(PS55,MW,MP) ;Return Mail/Window and MP expanded text ;PSO*232
I MW="W"!(MW="") D ;*255
. S MP=$S($P($G(^PSRX(IRXN,"MP")),"^")'="":$P(^("MP"),"^"),1:"""""")
. S MW="WINDOW"
I MW="M" D
. S MP=""""""
. S PS55=$P(PS55,"^",3)
. I $$GET1^DIQ(52,IRXN,100.2,"I")]"" S PS55=$$GET1^DIQ(52,IRXN,100.2,"I") ;p753
. ;PSO*7*609 Added evalution of option 4 to return "CERTIFIED MAIL" in the $S clause
. S MW=$S(PS55=1:"CERTIFIED MAIL",PS55=4:"CERTIFIED MAIL",PS55=2:"DO NOT MAIL",1:"REGULAR MAIL")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOHLDS1 8736 printed Sep 23, 2025@20:06:11 Page 2
PSOHLDS1 ;BIR/LC,PWC-Build HL7 Segments for Automated Interface ; 2/5/10 10:01am
+1 ;;7.0;OUTPATIENT PHARMACY;**156,232,255,200,305,336,351,434,609,524,545,753**;DEC 1997;Build 53
+2 ;HLFNC supp. by DBIA 10106
+3 ;PSNAPIS supp. by DBIA 2531
+4 ;VASITE supp. by DBIA 10112
+5 ;VADPT supp. by DBIA 10061
+6 ;EN^DIQ1 supp. by DBIA 100
+7 ;EN^VAFHLZTA supp. by DBIA 758
+8 ;PSDRUG supp. by DBIA 221
+9 ;PS(50.607 supp. by DBIA 2221
+10 ;PS(55 supp. by DBIA 2228
+11 ;DPT supp. by DBIA 3097
+12 ;SC supp. by DBIA 10040
+13 ;VA(200 supp. by DBIA 10060
+14 ;SCMSVUT5 supp. by DBIA 4347
+15 ;BLDPID^VAFCQRY supp. by DBIA 3630
+16 ;MAKEIT^VAFHLU supp. by DBIA 4346
+17 ;
+18 ;*232 allow for Do Not Mail
+19 ;*255 move NTEPMI to PSOHLDS4. fix "MP" node test to '=""
+20 ;*305 send Notice of Privacy Practices in NTE9 - Modified to NTE9 as NTE8 already exist
+21 ;*609 evaluate option 4 - LOCAL CERTIFIED MAIL
+22 ;*524 added ZZZ segment for hazardous drug information
+23 ;
START ;
+1 DO GETDATA
+2 DO PID(.PSI)
DO PV1(.PSI)
DO PV2(.PSI)
DO IAM^PSOHLDS4(.PSI)
DO ORC^PSOHLDS4(.PSI)
+3 DO NTE^PSOHLDS2
DO RXE^PSOHLDS2(.PSI)
DO RXD^PSOHLDS2(.PSI)
+4 ;*255 ;*524 added ZZZ segment for hazardous flags
DO NTEPMI^PSOHLDS4(.PSI)
DO NTE9^PSOHLDS2(.PSI)
DO RXR^PSOHLDS2(.PSI)
DO ZZZ^PSOHLDS2(.PSI)
+5 ; clean up data set by GETDATA
+6 KILL EBY,EBY1,EFDT,EXDT,FDT,PVDR,PVDR1,CSINER,CSINER1,SITE,SITADD,SITPHN
+7 KILL VPHARMID,VPHARM,DEAID,MW,QTY,DASPLY,OLAN,OTHLAN,PRIORDT,RFRM,NFLD,WARN
+8 KILL PSOXN,PSOXN2,PSND1,PSND2,PRODUCT,PSOPROD,UNIT,VANAME,DISPDT,PSONDC
+9 KILL DRUG
+10 QUIT
GETDATA ; this is the place to set all data needed for several segments
+1 ;original
IF $GET(FP)="F"&('$GET(FPN))
Begin DoDot:1
+2 SET FDT=$PIECE(^PSRX(IRXN,2),"^",2)
SET VPHARMID=$PIECE(^(2),"^",10)
SET DISPDT=$PIECE(^(2),"^",5)
SET EXDT=$PIECE(^(2),"^",6)
SET PSONDC=$PIECE(^(2),"^",7)
+3 SET PVDR=$PIECE(^PSRX(IRXN,0),"^",4)
SET QTY=$PIECE(^(0),"^",7)
SET DASPLY=$PIECE(^(0),"^",8)
SET MW=$PIECE(^(0),"^",11)
SET EBY=$PIECE(^(0),"^",16)
End DoDot:1
+4 ;refill
IF $GET(FP)="F"&($GET(FPN))
Begin DoDot:1
+5 SET FDT=$PIECE(^PSRX(IRXN,1,FPN,0),"^")
SET MW=$PIECE(^(0),"^",2)
SET QTY=$PIECE(^(0),"^",4)
SET DASPLY=$PIECE(^(0),"^",10)
SET DISPDT=$PIECE(^(0),"^",19)
SET EXDT=$SELECT($PIECE(^(0),"^",15):$PIECE(^(0),"^",15),1:$PIECE(^PSRX(IRXN,2),"^",6))
+6 SET VPHARMID=$SELECT($PIECE(^PSRX(IRXN,1,FPN,0),"^",5)'="":$PIECE(^(0),"^",5),1:$PIECE(^PSRX(IRXN,2),"^",10))
+7 SET EBY=$SELECT($PIECE(^PSRX(IRXN,1,FPN,0),"^",5):$PIECE(^(0),"^",5),1:$PIECE(^(0),"^",7))
SET PVDR=$PIECE(^(0),"^",17)
SET PSONDC=$SELECT($PIECE($GET(^PSRX(IRXN,1,FPN,1)),"^",3):$PIECE(^(1),"^",3),1:$PIECE(^PSRX(IRXN,2),"^",7))
End DoDot:1
+8 ;partial
IF $GET(FP)="P"&($GET(FPN))
Begin DoDot:1
+9 SET FDT=$PIECE(^PSRX(IRXN,"P",FPN,0),"^")
SET MW=$PIECE(^(0),"^",2)
SET QTY=$PIECE(^(0),"^",4)
SET DASPLY=$PIECE(^(0),"^",10)
SET DISPDT=FDT
SET PVDR=$PIECE(^(0),"^",17)
SET EXDT=$PIECE(^PSRX(IRXN,2),"^",6)
+10 SET EBY=$SELECT($PIECE(^PSRX(IRXN,"P",FPN,0),"^",5):$PIECE(^(0),"^",5),1:$PIECE(^(0),"^",7))
SET VPHARMID=$SELECT($PIECE(^(0),"^",5)'="":$PIECE(^(0),"^",5),1:$PIECE(^PSRX(IRXN,2),"^",10))
SET PVDR=$PIECE(^PSRX(IRXN,"P",FPN,0),"^",17)
+11 SET PSONDC=$SELECT($PIECE(^PSRX(IRXN,"P",FPN,0),"^",12):$PIECE(^(0),"^",12),1:$PIECE(^PSRX(IRXN,2),"^",7))
End DoDot:1
+12 SET EFDT=$PIECE(^PSRX(IRXN,2),"^",2)
if $GET(EFDT)
SET EFDT=$$HLDATE^HLFNC(EFDT,"DT")
+13 SET ISDT=$PIECE(^PSRX(IRXN,0),"^",13)
if $GET(ISDT)
SET ISDT=$$HLDATE^HLFNC(ISDT,"DT")
+14 ;*545
+15 SET DEAID=$$PRDEA^XUSER(PVDR)
KILL DIC,X,Y
SET DIC="^VA(200,"
SET DIC(0)="N,Z"
SET X=VPHARMID
DO ^DIC
+16 SET VPHARM=$SELECT(+Y:$$HLNAME^HLFNC($PIECE(Y,"^",2)),1:"""""")
KILL DIC,X,Y
+17 KILL DIC,X,Y
SET DIC="^VA(200,"
SET DIC(0)="N,Z"
SET X=EBY
DO ^DIC
+18 SET EBY1=$SELECT(+Y:$$HLNAME^HLFNC($PIECE(Y,"^",2)),1:"""""")
KILL DIC,X,Y
+19 KILL DIC,X,Y
SET DIC="^VA(200,"
SET DIC(0)="N,Z"
SET X=PVDR
DO ^DIC
+20 SET PVDR1=$SELECT(+Y:$$HLNAME^HLFNC($PIECE(Y,"^",2)),1:"""""")
KILL DIC,X,Y
+21 SET PRIORDT=$PIECE(^PSRX(IRXN,3),"^",4)
SET PRIORDT=$$HLDATE^HLFNC(PRIORDT,"DT")
+22 SET FDT=$$HLDATE^HLFNC(FDT,"DT")
+23 if $GET(DISPDT)
SET DISPDT=$$HLDATE^HLFNC(DISPDT,"DT")
+24 if $GET(EXDT)
SET EXDT=$$HLDATE^HLFNC(EXDT,"DT")
+25 SET FIN=$PIECE(^PSRX(IRXN,"OR1"),"^",5)
+26 KILL DIC,X,Y
SET DIC="^VA(200,"
SET DIC(0)="N,Z"
SET X=FIN
DO ^DIC
+27 SET FIN1=$SELECT(+Y:$$HLNAME^HLFNC($PIECE(Y,"^",2)),1:"""""")
KILL DIC,X,Y
+28 SET SITE=$SELECT($DATA(^PS(59,PSOSITE,0)):^(0),1:"")
+29 SET PSZIP=$PIECE(SITE,"^",5)
SET PSOHZIP=$SELECT(PSZIP["-":PSZIP,1:$EXTRACT(PSZIP,1,5)_$SELECT($EXTRACT(PSZIP,6,9)]"":"-"_$EXTRACT(PSZIP,6,9),1:""))
+30 SET CLN=+$PIECE(^PSRX(IRXN,0),"^",5)
SET CLN1=$SELECT($DATA(^SC(CLN,0)):$PIECE(^(0),"^",1),1:"UNKNOWN")
+31 SET CSINER=$PIECE(^PSRX(IRXN,3),"^",3)
+32 KILL DIC,X,Y
SET DIC="^VA(200,"
SET DIC(0)="N,Z"
SET X=CSINER
DO ^DIC
+33 SET CSINER1=$SELECT(+Y:$$HLNAME^HLFNC($PIECE(Y,"^",2)),1:"""""")
KILL DIC,X,Y
+34 DO 6^VADPT
+35 SET X=$SELECT($DATA(^PS(55,DFN,0)):^(0),1:"")
SET CAP=$PIECE(X,"^",2)
+36 ;PSO*232
DO MW(X,.MW,.MP)
+37 IF (($PIECE(^PSRX(IRXN,"STA"),"^")>0)&($PIECE(^("STA"),"^")'=2)&('$GET(PSODBQ)))!'$GET(^PSRX(IRXN,"IB"))
SET COPAY="NO COPAY"
+38 IF '$TEST
SET COPAY="COPAY"
+39 SET NURSE=$SELECT($PIECE($GET(^DPT(DFN,"NHC")),"^")="Y":1,$PIECE($GET(^PS(55,DFN,40)),"^"):1,1:0)
+40 SET DATE=$$HLDATE^HLFNC(FDT)
DO NOW^%DTC
SET NOW=$$HLDATE^HLFNC(%,"TS")
+41 SET OLAN=$PIECE($GET(^PS(55,DFN,"LAN")),"^",2)
SET OTLAN="N"
IF OLAN=2
SET OTLAN="Y"
+42 SET CSUB1=$$GET1^DIQ(50,IDGN_",",3)
SET CSUB="N"
IF $EXTRACT(CSUB1,1)>1&($EXTRACT(CSUB1,1)<6)
SET CSUB="Y"
+43 SET SCTALK=+$GET(^PS(55,"ASTALK",$PIECE(^PSRX(IRXN,0),"^",2)))
+44 KILL DIC,DR,DIQ
SET DA=$PIECE($$SITE^VASITE(),"^")
IF DA
Begin DoDot:1
+45 KILL PSOINST
SET DIC=4
SET DIQ(0)="I"
SET DR=99
SET DIQ="PSOINST"
DO EN^DIQ1
+46 SET PSOINST=PSOINST(4,DA,99,"I")
KILL DIC,DA,DR,DIQ,PSOINST(4)
End DoDot:1
+47 SET DRUG=$$ZZ^PSOSUTL(IRXN)
SET DEA=$PIECE(^PSDRUG(IDGN,0),"^",3)
SET WARN=$PIECE($GET(^(0)),"^",8)
+48 SET PSND1=$PIECE($GET(^PSDRUG(IDGN,"ND")),"^")
SET PSND2=$PIECE($GET(^("ND")),"^",2)
SET PSND3=$PIECE($GET(^("ND")),"^",3)
+49 KILL PSOXN,PSOXN2,PSOPROD
+50 IF PSND1
IF PSND3
Begin DoDot:1
+51 SET PSOPROD=$$PROD2^PSNAPIS(PSND1,PSND3)
SET VANAME=$PIECE($GET(PSOPROD),"^",1)
+52 IF $TEXT(^PSNAPIS)]""
SET PSOXN=$$DFSU^PSNAPIS(PSND1,PSND3)
SET UNIT=$PIECE($GET(PSOXN),"^",6)
SET PSOXN=$PIECE($GET(PSOXN),"^",5)
SET PSOXN2=$$PROD2^PSNAPIS(PSND1,PSND3)
QUIT
+53 SET PSOXN2=$GET(^PSNDF(PSND1,5,PSND3,2))
+54 SET PRODUCT=$GET(^PSNDF(PSND1,5,PSND3,0))
+55 IF $GET(PRODUCT)'=""
SET PSOXN=+$PIECE($GET(^PSNDF(PSND1,2,+$PIECE(PRODUCT,"^",2),3,+$PIECE(PRODUCT,"^",3),4,+$PIECE(PRODUCT,"^",4),0)),"^")
SET UNIT=$PIECE($GET(^PS(50.607,PSOXN,0)),"^")
End DoDot:1
+56 SET NFLD=0
SET UU=""
FOR
SET UU=$ORDER(^PSRX(IRXN,1,UU))
if UU=""
QUIT
if $DATA(^PSRX(IRXN,1,UU,0))
SET NFLD=NFLD+1
+57 SET NRFL=$PIECE(^PSRX(IRXN,0),"^",9)
SET RFRM=(NRFL-NFLD)
+58 QUIT
PID(PSI) ;patient ID segment
+1 if '$DATA(DFN)!$DATA(PAS)
QUIT
+2 SET HLFS=HL1("FS")
SET HLECH=HL1("ECH")
SET HLQ=HL1("Q")
SET HLVER=HL1("VER")
+3 KILL PSPID,PSPID1
+4 DO BLDPID^VAFCQRY(DFN,"","3,4,5,7,8,11,13",.PSPID,.HL1,.ERR)
+5 ; put PID in format needed for segment parser
+6 SET PSPID=PSPID(1)
KILL PSPID(1)
+7 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)
+8 ;parse PID into individual fields
+9 KILL PRSEPID
DO SEGPRSE^SCMSVUT5("PSPID","PRSEPID",HL1("FS"))
+10 ; parse address into individual components
+11 KILL ADDSEQ
DO SEQPRSE^SCMSVUT5($NAME(PRSEPID(11)),"ADDSEQ",HL1("ECH"))
+12 ; build ZTA (Temporary Address)
+13 KILL X2
SET X2=$$EN^VAFHLZTA(DFN,"1,2,3,4,5,6,7,",1)
+14 ; parse X2 (ZTA) into individual fields if temp add. exists
+15 if '$$CHKTEMP^PSOBAI(DFN)
Begin DoDot:1
+16 NEW BADA
SET BADA=$$CHKRX^PSOBAI(IRXN)
+17 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
+18 if $$CHKTEMP^PSOBAI(DFN)
Begin DoDot:1
+19 KILL PRSEZTA
DO SEGPRSE^SCMSVUT5("X2","PRSEZTA",HL1("FS"))
+20 ; parse temporary address into individual components
+21 KILL TMPADD
DO SEQPRSE^SCMSVUT5($NAME(PRSEZTA(5)),"TMPADD",HL1("ECH"))
+22 ; add temporary address as next repitition in PID segment
+23 SET SPOT=1+$ORDER(ADDSEQ(""),-1)
+24 MERGE ADDSEQ(SPOT)=TMPADD(1)
+25 SET ADDSEQ(SPOT,7)="C"
+26 SET ADDSEQ(SPOT,9)=PRSEZTA(6)
+27 SET ADDSEQ(SPOT,12,1)=PRSEZTA(3)
+28 SET ADDSEQ(SPOT,12,2)=PRSEZTA(4)
+29 ;move address sequence back into parse PID segment
End DoDot:1
+30 ; rebuild PID segment
+31 KILL PRSEPID(11)
MERGE PRSEPID(11)=ADDSEQ
+32 KILL PSPID1
DO MAKEIT^VAFHLU("PID",.PRSEPID,.PSPID1,.PSPID1)
+33 ;put rebuilt PID into format used by $$EN^VAFCQRY
+34 KILL PSPID
SET PSPID(1)=PSPID1
+35 SET X=0
SET Y=2
FOR
SET X=+$ORDER(PSPID1(X))
if 'X
QUIT
SET PSPID(Y)=PSPID1(X)
SET Y=Y+1
+36 SET CNT=0
FOR I=1:1
if '$DATA(PSPID(I))
QUIT
Begin DoDot:1
+37 IF I=1
SET ^TMP("PSO",$JOB,PSI)=PSPID(I)
QUIT
+38 SET CNT=CNT+1
SET ^TMP("PSO",$JOB,PSI,CNT)=PSPID(I)
End DoDot:1
+39 SET PSI=PSI+1
+40 SET PAS=1
+41 KILL PSPID,PSPID1,PRSEPID,PRSEZTA,SPOT,TMPADD,ADDSEQ
+42 QUIT
PV1(PSI) ;patient visit segment
+1 if '$DATA(DFN)!$DATA(PAS1)
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
SET PAS1=1
+6 QUIT
PV2(PSI) ;patient visit segment (additional information)
+1 ;PATIENT STATUS AND COPAY
+2 if '$DATA(DFN)!$DATA(PAS2)
QUIT
+3 NEW PV2
SET PV2=""
+4 SET $PIECE(PV2,"|",24)=$PIECE($GET(^PS(53,+$PIECE($GET(^PSRX(IRXN,0)),"^",3),0)),"^",2)_"~"_COPAY_FS
+5 SET ^TMP("PSO",$JOB,PSI)="PV2|"_PV2
+6 SET PSI=PSI+1
SET PAS2=1
+7 QUIT
+8 ;
MW(PS55,MW,MP) ;Return Mail/Window and MP expanded text ;PSO*232
+1 ;*255
IF MW="W"!(MW="")
Begin DoDot:1
+2 SET MP=$SELECT($PIECE($GET(^PSRX(IRXN,"MP")),"^")'="":$PIECE(^("MP"),"^"),1:"""""")
+3 SET MW="WINDOW"
End DoDot:1
+4 IF MW="M"
Begin DoDot:1
+5 SET MP=""""""
+6 SET PS55=$PIECE(PS55,"^",3)
+7 ;p753
IF $$GET1^DIQ(52,IRXN,100.2,"I")]""
SET PS55=$$GET1^DIQ(52,IRXN,100.2,"I")
+8 ;PSO*7*609 Added evalution of option 4 to return "CERTIFIED MAIL" in the $S clause
+9 SET MW=$SELECT(PS55=1:"CERTIFIED MAIL",PS55=4:"CERTIFIED MAIL",PS55=2:"DO NOT MAIL",1:"REGULAR MAIL")
End DoDot:1
+10 QUIT
