Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PSOHLDS1

PSOHLDS1.m

Go to the documentation of this file.
  1. 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
  1. ;HLFNC supp. by DBIA 10106
  1. ;PSNAPIS supp. by DBIA 2531
  1. ;VASITE supp. by DBIA 10112
  1. ;VADPT supp. by DBIA 10061
  1. ;EN^DIQ1 supp. by DBIA 100
  1. ;EN^VAFHLZTA supp. by DBIA 758
  1. ;PSDRUG supp. by DBIA 221
  1. ;PS(50.607 supp. by DBIA 2221
  1. ;PS(55 supp. by DBIA 2228
  1. ;DPT supp. by DBIA 3097
  1. ;SC supp. by DBIA 10040
  1. ;VA(200 supp. by DBIA 10060
  1. ;SCMSVUT5 supp. by DBIA 4347
  1. ;BLDPID^VAFCQRY supp. by DBIA 3630
  1. ;MAKEIT^VAFHLU supp. by DBIA 4346
  1. ;
  1. ;*232 allow for Do Not Mail
  1. ;*255 move NTEPMI to PSOHLDS4. fix "MP" node test to '=""
  1. ;*305 send Notice of Privacy Practices in NTE9 - Modified to NTE9 as NTE8 already exist
  1. ;*609 evaluate option 4 - LOCAL CERTIFIED MAIL
  1. ;*524 added ZZZ segment for hazardous drug information
  1. ;
  1. START ;
  1. D GETDATA
  1. D PID(.PSI),PV1(.PSI),PV2(.PSI),IAM^PSOHLDS4(.PSI),ORC^PSOHLDS4(.PSI)
  1. D NTE^PSOHLDS2,RXE^PSOHLDS2(.PSI),RXD^PSOHLDS2(.PSI)
  1. D NTEPMI^PSOHLDS4(.PSI),NTE9^PSOHLDS2(.PSI),RXR^PSOHLDS2(.PSI),ZZZ^PSOHLDS2(.PSI) ;*255 ;*524 added ZZZ segment for hazardous flags
  1. ; clean up data set by GETDATA
  1. K EBY,EBY1,EFDT,EXDT,FDT,PVDR,PVDR1,CSINER,CSINER1,SITE,SITADD,SITPHN
  1. K VPHARMID,VPHARM,DEAID,MW,QTY,DASPLY,OLAN,OTHLAN,PRIORDT,RFRM,NFLD,WARN
  1. K PSOXN,PSOXN2,PSND1,PSND2,PRODUCT,PSOPROD,UNIT,VANAME,DISPDT,PSONDC
  1. K DRUG
  1. Q
  1. GETDATA ; this is the place to set all data needed for several segments
  1. I $G(FP)="F"&('$G(FPN)) D ;original
  1. . S FDT=$P(^PSRX(IRXN,2),"^",2),VPHARMID=$P(^(2),"^",10),DISPDT=$P(^(2),"^",5),EXDT=$P(^(2),"^",6),PSONDC=$P(^(2),"^",7)
  1. . S PVDR=$P(^PSRX(IRXN,0),"^",4),QTY=$P(^(0),"^",7),DASPLY=$P(^(0),"^",8),MW=$P(^(0),"^",11),EBY=$P(^(0),"^",16)
  1. I $G(FP)="F"&($G(FPN)) D ;refill
  1. . 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))
  1. . S VPHARMID=$S($P(^PSRX(IRXN,1,FPN,0),"^",5)'="":$P(^(0),"^",5),1:$P(^PSRX(IRXN,2),"^",10))
  1. . 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))
  1. I $G(FP)="P"&($G(FPN)) D ;partial
  1. . 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)
  1. . 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)
  1. . S PSONDC=$S($P(^PSRX(IRXN,"P",FPN,0),"^",12):$P(^(0),"^",12),1:$P(^PSRX(IRXN,2),"^",7))
  1. S EFDT=$P(^PSRX(IRXN,2),"^",2) S:$G(EFDT) EFDT=$$HLDATE^HLFNC(EFDT,"DT")
  1. S ISDT=$P(^PSRX(IRXN,0),"^",13) S:$G(ISDT) ISDT=$$HLDATE^HLFNC(ISDT,"DT")
  1. ;*545
  1. S DEAID=$$PRDEA^XUSER(PVDR) K DIC,X,Y S DIC="^VA(200,",DIC(0)="N,Z",X=VPHARMID D ^DIC
  1. S VPHARM=$S(+Y:$$HLNAME^HLFNC($P(Y,"^",2)),1:"""""") K DIC,X,Y
  1. K DIC,X,Y S DIC="^VA(200,",DIC(0)="N,Z",X=EBY D ^DIC
  1. S EBY1=$S(+Y:$$HLNAME^HLFNC($P(Y,"^",2)),1:"""""") K DIC,X,Y
  1. K DIC,X,Y S DIC="^VA(200,",DIC(0)="N,Z",X=PVDR D ^DIC
  1. S PVDR1=$S(+Y:$$HLNAME^HLFNC($P(Y,"^",2)),1:"""""") K DIC,X,Y
  1. S PRIORDT=$P(^PSRX(IRXN,3),"^",4),PRIORDT=$$HLDATE^HLFNC(PRIORDT,"DT")
  1. S FDT=$$HLDATE^HLFNC(FDT,"DT")
  1. S:$G(DISPDT) DISPDT=$$HLDATE^HLFNC(DISPDT,"DT")
  1. S:$G(EXDT) EXDT=$$HLDATE^HLFNC(EXDT,"DT")
  1. S FIN=$P(^PSRX(IRXN,"OR1"),"^",5)
  1. K DIC,X,Y S DIC="^VA(200,",DIC(0)="N,Z",X=FIN D ^DIC
  1. S FIN1=$S(+Y:$$HLNAME^HLFNC($P(Y,"^",2)),1:"""""") K DIC,X,Y
  1. S SITE=$S($D(^PS(59,PSOSITE,0)):^(0),1:"")
  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:""))
  1. S CLN=+$P(^PSRX(IRXN,0),"^",5),CLN1=$S($D(^SC(CLN,0)):$P(^(0),"^",1),1:"UNKNOWN")
  1. S CSINER=$P(^PSRX(IRXN,3),"^",3)
  1. K DIC,X,Y S DIC="^VA(200,",DIC(0)="N,Z",X=CSINER D ^DIC
  1. S CSINER1=$S(+Y:$$HLNAME^HLFNC($P(Y,"^",2)),1:"""""") K DIC,X,Y
  1. D 6^VADPT
  1. S X=$S($D(^PS(55,DFN,0)):^(0),1:""),CAP=$P(X,"^",2)
  1. D MW(X,.MW,.MP) ;PSO*232
  1. I (($P(^PSRX(IRXN,"STA"),"^")>0)&($P(^("STA"),"^")'=2)&('$G(PSODBQ)))!'$G(^PSRX(IRXN,"IB")) S COPAY="NO COPAY"
  1. E S COPAY="COPAY"
  1. S NURSE=$S($P($G(^DPT(DFN,"NHC")),"^")="Y":1,$P($G(^PS(55,DFN,40)),"^"):1,1:0)
  1. S DATE=$$HLDATE^HLFNC(FDT) D NOW^%DTC S NOW=$$HLDATE^HLFNC(%,"TS")
  1. S OLAN=$P($G(^PS(55,DFN,"LAN")),"^",2),OTLAN="N" I OLAN=2 S OTLAN="Y"
  1. S CSUB1=$$GET1^DIQ(50,IDGN_",",3),CSUB="N" I $E(CSUB1,1)>1&($E(CSUB1,1)<6) S CSUB="Y"
  1. S SCTALK=+$G(^PS(55,"ASTALK",$P(^PSRX(IRXN,0),"^",2)))
  1. K DIC,DR,DIQ S DA=$P($$SITE^VASITE(),"^") I DA D
  1. .K PSOINST S DIC=4,DIQ(0)="I",DR=99,DIQ="PSOINST" D EN^DIQ1
  1. .S PSOINST=PSOINST(4,DA,99,"I") K DIC,DA,DR,DIQ,PSOINST(4)
  1. S DRUG=$$ZZ^PSOSUTL(IRXN),DEA=$P(^PSDRUG(IDGN,0),"^",3),WARN=$P($G(^(0)),"^",8)
  1. S PSND1=$P($G(^PSDRUG(IDGN,"ND")),"^"),PSND2=$P($G(^("ND")),"^",2),PSND3=$P($G(^("ND")),"^",3)
  1. K PSOXN,PSOXN2,PSOPROD
  1. I PSND1,PSND3 D
  1. .S PSOPROD=$$PROD2^PSNAPIS(PSND1,PSND3),VANAME=$P($G(PSOPROD),"^",1)
  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
  1. .S PSOXN2=$G(^PSNDF(PSND1,5,PSND3,2))
  1. .S PRODUCT=$G(^PSNDF(PSND1,5,PSND3,0))
  1. .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)),"^")
  1. S NFLD=0,UU="" F S UU=$O(^PSRX(IRXN,1,UU)) Q:UU="" S:$D(^PSRX(IRXN,1,UU,0)) NFLD=NFLD+1
  1. S NRFL=$P(^PSRX(IRXN,0),"^",9),RFRM=(NRFL-NFLD)
  1. Q
  1. PID(PSI) ;patient ID segment
  1. Q:'$D(DFN)!$D(PAS)
  1. S HLFS=HL1("FS"),HLECH=HL1("ECH"),HLQ=HL1("Q"),HLVER=HL1("VER")
  1. K PSPID,PSPID1
  1. D BLDPID^VAFCQRY(DFN,"","3,4,5,7,8,11,13",.PSPID,.HL1,.ERR)
  1. ; put PID in format needed for segment parser
  1. S PSPID=PSPID(1) K PSPID(1)
  1. S (X,Y)=1 F S X=+$O(PSPID(X)) Q:'X S PSPID(Y)=PSPID(X),Y=Y+1 K PSPID(X)
  1. ;parse PID into individual fields
  1. K PRSEPID D SEGPRSE^SCMSVUT5("PSPID","PRSEPID",HL1("FS"))
  1. ; parse address into individual components
  1. K ADDSEQ D SEQPRSE^SCMSVUT5($NA(PRSEPID(11)),"ADDSEQ",HL1("ECH"))
  1. ; build ZTA (Temporary Address)
  1. K X2 S X2=$$EN^VAFHLZTA(DFN,"1,2,3,4,5,6,7,",1)
  1. ; parse X2 (ZTA) into individual fields if temp add. exists
  1. D:'$$CHKTEMP^PSOBAI(DFN)
  1. . N BADA S BADA=$$CHKRX^PSOBAI(IRXN)
  1. . 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
  1. D:$$CHKTEMP^PSOBAI(DFN)
  1. . K PRSEZTA D SEGPRSE^SCMSVUT5("X2","PRSEZTA",HL1("FS"))
  1. . ; parse temporary address into individual components
  1. . K TMPADD D SEQPRSE^SCMSVUT5($NA(PRSEZTA(5)),"TMPADD",HL1("ECH"))
  1. . ; add temporary address as next repitition in PID segment
  1. . S SPOT=1+$O(ADDSEQ(""),-1)
  1. . M ADDSEQ(SPOT)=TMPADD(1)
  1. . S ADDSEQ(SPOT,7)="C"
  1. . S ADDSEQ(SPOT,9)=PRSEZTA(6)
  1. . S ADDSEQ(SPOT,12,1)=PRSEZTA(3)
  1. . S ADDSEQ(SPOT,12,2)=PRSEZTA(4)
  1. . ;move address sequence back into parse PID segment
  1. ; rebuild PID segment
  1. K PRSEPID(11) M PRSEPID(11)=ADDSEQ
  1. K PSPID1 D MAKEIT^VAFHLU("PID",.PRSEPID,.PSPID1,.PSPID1)
  1. ;put rebuilt PID into format used by $$EN^VAFCQRY
  1. K PSPID S PSPID(1)=PSPID1
  1. S X=0,Y=2 F S X=+$O(PSPID1(X)) Q:'X S PSPID(Y)=PSPID1(X) S Y=Y+1
  1. S CNT=0 F I=1:1 Q:'$D(PSPID(I)) D
  1. . I I=1 S ^TMP("PSO",$J,PSI)=PSPID(I) Q
  1. . S CNT=CNT+1 S ^TMP("PSO",$J,PSI,CNT)=PSPID(I)
  1. S PSI=PSI+1
  1. S PAS=1
  1. K PSPID,PSPID1,PRSEPID,PRSEZTA,SPOT,TMPADD,ADDSEQ
  1. Q
  1. PV1(PSI) ;patient visit segment
  1. Q:'$D(DFN)!$D(PAS1)
  1. N PV1 ;hardcoded to letter O for Outpatient (Patient class)
  1. S PV1="PV1"_FS_FS_"O"_FS
  1. S ^TMP("PSO",$J,PSI)=PV1
  1. S PSI=PSI+1,PAS1=1
  1. Q
  1. PV2(PSI) ;patient visit segment (additional information)
  1. ;PATIENT STATUS AND COPAY
  1. Q:'$D(DFN)!$D(PAS2)
  1. N PV2 S PV2=""
  1. S $P(PV2,"|",24)=$P($G(^PS(53,+$P($G(^PSRX(IRXN,0)),"^",3),0)),"^",2)_"~"_COPAY_FS
  1. S ^TMP("PSO",$J,PSI)="PV2|"_PV2
  1. S PSI=PSI+1,PAS2=1
  1. Q
  1. ;
  1. MW(PS55,MW,MP) ;Return Mail/Window and MP expanded text ;PSO*232
  1. I MW="W"!(MW="") D ;*255
  1. . S MP=$S($P($G(^PSRX(IRXN,"MP")),"^")'="":$P(^("MP"),"^"),1:"""""")
  1. . S MW="WINDOW"
  1. I MW="M" D
  1. . S MP=""""""
  1. . S PS55=$P(PS55,"^",3)
  1. . I $$GET1^DIQ(52,IRXN,100.2,"I")]"" S PS55=$$GET1^DIQ(52,IRXN,100.2,"I") ;p753
  1. . ;PSO*7*609 Added evalution of option 4 to return "CERTIFIED MAIL" in the $S clause
  1. . S MW=$S(PS55=1:"CERTIFIED MAIL",PS55=4:"CERTIFIED MAIL",PS55=2:"DO NOT MAIL",1:"REGULAR MAIL")
  1. Q