VAFCSB ;BIR/CMC-CONT ADT PROCESSOR TO RETRIGGER A08 or A04 MESSAGES WITH AL/AL (COMMIT/APPLICATION) ACKNOWLEDGEMENTS ;2/2/22 17:24
;;5.3;Registration;**707,756,825,876,902,926,967,1059,1071**;Aug 13, 1993;Build 4
;
;Reference to $$XAMDT^RAO7UTL1 is supported by IA #4875
;Reference to RESUTLS^LRPXAPI is supported by IA #4245
;Reference to PROF^PSO52API is supported by IA #4820
;
PV2() ;build pv2 segment
N PV2,LSTA,APPT,VASD,VAIP,VARP,VAROOT
S PV2=""
;get next outpatient appointment
K ^UTILITY("VASD",$J) S VASD("F")=DT D SDA^VADPT
S APPT=$P($G(^UTILITY("VASD",$J,1,"I")),"^")
I APPT'="" S $P(PV2,HL("FS"),9)=$$HLDATE^HLFNC(APPT)
;GET LAST ADMISSION DATE
K VAIP S VAIP("D")="LAST",VAIP("M")=0 D IN5^VADPT
; **825,CR_1184: for PV2-14, it will be re-set as the 15th piece
; in PV2 segment a few lines below
; I VAIP(2)="1^ADMISSION" S $P(PV2,HL("FS"),15)=$$HLDATE^HLFNC($P(VAIP(3),"^"))
I VAIP(2)="1^ADMISSION" S $P(PV2,HL("FS"),14)=$$HLDATE^HLFNC($P(VAIP(3),"^"))
;get last registration
S VAROOT="VARP"
D REG^VADPT
I $D(VARP(1,"I")),$G(VARP(1,"I"))>0 S $P(PV2,HL("FS"),46)=$$HLDATE^HLFNC($P(VARP(1,"I"),"^"),"DT"),$P(PV2,HL("FS"),24)="CR"
;**756 ^ ONLY RETURN DATE FOR LAST REGISTRATION AS HL7 STANDARD CAN ONLY HAVE DATE
I PV2'="" S PV2="PV2"_HL("FS")_PV2
Q PV2
;
PHARA() ;build obx to show active prescriptions
N RET S RET=""
I '$$PATCH^XPDUTL("PSS*1.0*101") Q RET
N PHARM,DGLIST
S PHARM="" D PROF^PSO52API(DFN,"DGLIST")
I +$G(^TMP($J,"DGLIST",DFN,0))>0 S PHARM="OBX"_HL("FS")_HL("FS")_"CE"_HL("FS")_"ACTIVE PRESCRIPTIONS"_HL("FS")_HL("FS")_"Y"
;**756 CE added as the data type
Q PHARM
;
SIG(DFN) ;**876 MVI_3467 (ckn) Build OBX for Self Identified Gender
N SIG,SIGE,SIGTMP,OBX S OBX=""
;I '$$PATCH^XPDUTL("DG*5.3*876") Q OBX
S DIC=2,DA=DFN,DR=".024",DIQ="SIGTMP",DIQ(0)="I,E,N" D EN^DIQ1
I '$D(SIGTMP) K DA,DR,DIQ Q OBX
S SIG=$G(SIGTMP(2,DFN,DR,"I")),SIGE=$G(SIGTMP(2,DFN,DR,"E"))
S OBX="OBX"_HL("FS")_HL("FS")_"CE"_HL("FS")_"SELF ID GENDER"_HL("FS")_HL("FS")_SIG_$E(HL("ECH"),1)_SIGE
K DA,DR,DIC,DIQ
Q OBX
;
DODF(DFN) ;**902 MVI_4898 (ckn) Build OBX for DOD fields
N DODTMP,DODEB,DODLEB,DODSRC,DODLUPD,DODSRCI,DODSRCE,CS,DODLNAM
N DODFNAM,DODMNAM,DODEBE,DODEBI,DODLEBE,DODLEBI,DODSRCCD
S CS=$E(HL("ECH")),SC=$E(HL("ECH"),4)
S DIC=2,DA=DFN,DR=".352;.353;.354;.355",DIQ="DODTMP",DIQ(0)="I,E,N" D EN^DIQ1
S DODSRCI=$G(DODTMP(2,DFN,.353,"I")),DODSRCE=$G(DODTMP(2,DFN,.353,"E")),DODSRC=HL("Q")
; **926, Story #323009 (ckn): Source of Notification moved from set of codes to pointer which is pointing to new Source Of Notification file (#47.76)
I DODSRCE'="" D
. S DODSRCCD=$P($G(^DG(47.76,DODSRCI,0)),"^",2)
. S DODSRC=DODSRCCD_CS_DODSRCE_CS_"L"
I DODSRCE'="" S DODSRC=DODSRCI_CS_DODSRCE_CS_"L"
S DODLUPD=$G(DODTMP(2,DFN,.354,"I")) S DODLUPD=$S(DODLUPD="":HL("Q"),1:$$HLDATE^HLFNC(DODLUPD))
;If LAST EDITED BY field(#.355) have value, use it to populate sequence 16 of OBX
;If LAST EDITED BY field(#.355) does not have value, use DEATH ENTERED BY field(#.352) to populate sequence 16 of OBX
;If both fields empty, send double quotes in sequence 16 of OBX
S DODLEB=HL("Q") ;Default seq 16
S DODEBE=$G(DODTMP(2,DFN,.352,"E")),DODEBI=$G(DODTMP(2,DFN,.352,"I")) ;DOD Entered by
S DODLEBE=$G(DODTMP(2,DFN,.355,"E")),DODLEBI=$G(DODTMP(2,DFN,.355,"I")) ;DOD Last Edited By
I DODLEBE'="" D
.S DODLEBE=$$HLNAME^HLFNC(DODLEBE,CS),DODLNAM=$S($P(DODLEBE,CS)="":HL("Q"),1:$P(DODLEBE,CS)),DODFNAM=$S($P(DODLEBE,CS,2)="":HL("Q"),1:$P(DODLEBE,CS,2)),DODMNAM=$S($P(DODLEBE,CS,3)="":HL("Q"),1:$P(DODLEBE,CS,3))
.S DODLEB=$S(DODLEBI="":HL("Q"),1:DODLEBI)_CS_DODLNAM_CS_DODFNAM_CS_DODMNAM_CS_CS_CS_CS_CS_"USVHA"_SC_SC_"0363"_CS_"L"_CS_CS_CS_"PN"_CS_"VA FACILITY ID"_SC_$P($$SITE^VASITE(),"^",3)_SC_"L"
I DODLEBE="",(DODEBE'="") D
.S DODEBE=$$HLNAME^HLFNC(DODEBE,CS),DODLNAM=$S($P(DODEBE,CS)="":HL("Q"),1:$P(DODEBE,CS)),DODFNAM=$S($P(DODEBE,CS,2)="":HL("Q"),1:$P(DODEBE,CS,2)),DODMNAM=$S($P(DODEBE,CS,3)="":HL("Q"),1:$P(DODEBE,CS,3))
.S DODLEB=$S(DODEBI="":HL("Q"),1:DODEBI)_CS_DODLNAM_CS_DODFNAM_CS_DODMNAM_CS_CS_CS_CS_CS_"USVHA"_SC_SC_"0363"_CS_"L"_CS_CS_CS_"PN"_CS_"VA FACILITY ID"_SC_$P($$SITE^VASITE(),"^",3)_SC_"L"
S OBX="OBX"_HL("FS")_HL("FS")_"CE"_HL("FS")_"DATE OF DEATH DATA"_HL("FS")_HL("FS")_DODSRC_HL("FS")_HL("FS")_HL("FS")_HL("FS")_HL("FS")_HL("FS")_"R"_HL("FS")_HL("FS")_HL("FS")_DODLUPD_HL("FS")_HL("FS")_$G(DODLEB)
K DA,DR,DIC,DIQ
Q OBX
;
DODD(DFN) ;**926, Story #323009 (ckn): Build OBX for DATE OF DEATH DOCUMENTS
N OBX,DODTMP,DODDI,DODD,DODDE,DODDCD
S CS=$E(HL("ECH"))
S DIC=2,DA=DFN,DR=".357",DIQ="DODTMP",DIQ(0)="I,E,N" D EN^DIQ1
S DODDI=$G(DODTMP(2,DFN,.357,"I")),DODDE=$G(DODTMP(2,DFN,.357,"E")),DODD=HL("Q")
I DODDE'="" D
. S DODDCD=$P($G(^DG(47.75,DODDI,0)),"^",2)
. S DODD=DODDCD_CS_DODDE_CS_"L"
S OBX="OBX"_HL("FS")_HL("FS")_"CE"_HL("FS")_"DATE OF DEATH DOCUMENTS"_HL("FS")_HL("FS")_DODD
K DA,DR,DIC,DIQ
Q OBX
;
DODOPT(DFN) ;**926, Story #323009 (ckn): Build OBX for DATE OF DEATH OPTION
N OBX,DODOPT,DODOPTE,DODOPTI
S CS=$E(HL("ECH"))
S DIC=2,DA=DFN,DR=".358",DIQ="DODTMP",DIQ(0)="I,E,N" D EN^DIQ1
S DODOPTE=$G(DODTMP(2,DFN,.358,"E")),DODOPTI=$G(DODTMP(2,DFN,.358,"I")),DODOPT=HL("Q")
I DODOPTE'="" S DODOPT=DODOPTI_CS_DODOPTE_CS_"L"
S OBX="OBX"_HL("FS")_HL("FS")_"CE"_HL("FS")_"DATE OF DEATH OPTION"_HL("FS")_HL("FS")_DODOPT
K DA,DR,DIC,DIQ
Q OBX
;
DODDISDT(DFN) ;**926, Story #323009 (ckn): Build OBX for DATE OF DEATH DISCHARGE DATE
;Q OBX
;
DODNTPRV(DFN) ;**926, Story #323009 (ckn): Build OBX for DATE OF DEATH NOTIFICATION
N OBX,DODNP,STN
S CS=$E(HL("ECH")),STN=$$SITE^VASITE(),DODNP=""
;Populate notify provider if Date of Death last updated have value
I $$GET1^DIQ(2,DFN_",",.354,"I")'="" S DODNP=$P(STN,"^",3)_CS_$P(STN,"^",2)_CS_"L"
S OBX="OBX"_HL("FS")_HL("FS")_"CE"_HL("FS")_"NOTIFY PROVIDER"_HL("FS")_HL("FS")_DODNP
Q OBX
;
SECLOG(DFN) ;**1059, Story #783361 (ckn): Build OBX for Sensitivity information
N OBX,SECLVL,SECLOG
S CS=$E(HL("ECH")),OBX=""
S DA=$O(^DGSL(38.1,"B",DFN,"")) I DA="" Q OBX
S DIC=38.1,DR="2",DIQ="SECLOG",DIQ(0)="I,E,N" D EN^DIQ1
S SECLVL=$G(SECLOG(38.1,DA,2,"I")) I SECLVL="" Q OBX
S SECLVL=SECLVL_CS_$G(SECLOG(38.1,DA,2,"E"))_CS_"L"
S OBX="OBX"_HL("FS")_HL("FS")_"CE"_HL("FS")_"SECURITY LEVEL"_HL("FS")_HL("FS")_SECLVL_HL("FS")_HL("FS")_HL("FS")_HL("FS")_HL("FS")_HL("FS")_"F"
Q OBX
;
NAMEOBX(DFN) ;**876,MVI_3453 (mko): Build OBX for Patient .01 and Name Components
N FS
S FS=HL("FS")
Q "OBX"_FS_FS_"CE"_FS_"NAME COMPONENTS"_FS_FS_$$NAMECOMP(DFN,$E(HL("ECH")))
;
NAMEERR(DFN) ;**876,MVI_3453 (mko): Build ERR for Patient .01 and Name Components
N CS,SC
S CS=$E(HL("ECH")),SC=$E(HL("ECH"),4)
Q "ERR"_HL("FS")_CS_CS_CS_SC_$$NAMECOMP(DFN,SC)
;
NAMECOMP(DFN,DELIM) ;**876,MVI_3453 (mko): Return Patient .01 and Name Components
N DIHELP,DIMSG,DIERR,MSG,NC,NCIEN,NCIENS,NCPTR,TARG
S NC=$P($G(^DPT(DFN,0)),"^")
S NCPTR=$P($G(^DPT(DFN,"NAME")),"^") Q:'NCPTR NC
S NCIEN=$$FIND1^DIC(20,"","","`"_NCPTR,"","","MSG") Q:'NCIEN NC
S NCIENS=NCIEN_","
D GETS^DIQ(20,NCIENS,"1:5","","TARG","MSG") Q:$G(DIERR) NC
S NC=NC_DELIM_TARG(20,NCIENS,1)_DELIM_TARG(20,NCIENS,2)_DELIM_TARG(20,NCIENS,3)_DELIM_TARG(20,NCIENS,5)_DELIM_TARG(20,NCIENS,4)
Q NC
;
SEXOR(DFN,OBX) ;build obx for sexual orientation multiple ;**1059, VAMPI-11114 (dri)
;**1071 VAMPI-13755 (dri) - include status, date created, date last updated
N IENS,OBXCNT,SEXOR,SOCODE,SOCRDT,SOEDDT,SOEXT,SOIEN,SOOBX,SOSTAT
D GETS^DIQ(2,DFN_",",".025*","IE","SEXOR")
I '$D(SEXOR) Q
S OBXCNT=1,IENS="" F S IENS=$O(SEXOR(2.025,IENS)) Q:IENS="" D
.S SOIEN=+$G(SEXOR(2.025,IENS,.01,"I")) I 'SOIEN Q
.S SOCODE=$$GET1^DIQ(47.77,SOIEN_",",1)
.S SOEXT=$G(SEXOR(2.025,IENS,.01,"E"))
.S SOOBX=SOCODE_COMP_SOEXT_COMP_"L"
.S SOSTAT=$G(SEXOR(2.025,IENS,.02,"I")) ;sexual orientation status
.I SOSTAT="" S SOSTAT="A" ;default to "A"ctive if null
.S SOCRDT=$$HLDATE^HLFNC($G(SEXOR(2.025,IENS,.03,"I"))) ;create date
.S SOEDDT=$$HLDATE^HLFNC($G(SEXOR(2.025,IENS,.04,"I"))) ;update date
.S OBX(OBXCNT)="OBX"_HL("FS")_HL("FS")_"CE"_HL("FS")_"Sexual Orientation"_HL("FS")_HL("FS")_SOOBX_HL("FS")_HL("FS")_HL("FS")_HL("FS")_HL("FS")_HL("FS")_SOSTAT_HL("FS")_SOEDDT_HL("FS")_HL("FS")_SOCRDT S OBXCNT=OBXCNT+1
Q
;
SEXORD(DFN,OBX) ;build obx for sexual orientation description ;**1059, VAMPI-11114 (dri)
N SEXORDES
S SEXORDES=$$GET1^DIQ(2,DFN_",",.0251)
I SEXORDES="" Q
S OBX(1)="OBX"_HL("FS")_HL("FS")_"ST"_HL("FS")_"Sexual Or Description"_HL("FS")_HL("FS")_$E(HL("ECH"),1)_SEXORDES_$E(HL("ECH"),1)_"L"
I $L(OBX(1))>245 D
.S OBX(2)=$E(OBX(1),246,$L(OBX(1)))
.S OBX(1)=$E(OBX(1),1,245)
Q
;
PRON(DFN,OBX) ;build obx for pronoun multiple ;**1059, VAMPI-11118 (dri)
N IENS,OBXCNT,PRON,PRONCODE,PRONIEN,PRONTYP
D GETS^DIQ(2,DFN_",",".2406*","IE","PRON")
I '$D(PRON) Q
S OBXCNT=1,IENS="" F S IENS=$O(PRON(2.2406,IENS)) Q:IENS="" S PRONIEN=+$G(PRON(2.2406,IENS,.01,"I")) I PRONIEN D
.S PRONCODE=$$GET1^DIQ(47.78,PRONIEN_",",1)
.S PRONTYP=$G(PRON(2.2406,IENS,.01,"E"))
.S OBX(OBXCNT)="OBX"_HL("FS")_HL("FS")_"CE"_HL("FS")_"Pronoun"_HL("FS")_HL("FS")_PRONCODE_$E(HL("ECH"),1)_PRONTYP_$E(HL("ECH"),1)_"L" S OBXCNT=OBXCNT+1
Q
;
PROND(DFN,OBX) ;build obx for pronoun description ;**1059, VAMPI-11118 (dri)
N PRONDES
S PRONDES=$$GET1^DIQ(2,DFN_",",.24061)
I PRONDES="" Q
S OBX(1)="OBX"_HL("FS")_HL("FS")_"ST"_HL("FS")_"Pronoun Description"_HL("FS")_HL("FS")_$E(HL("ECH"),1)_PRONDES_$E(HL("ECH"),1)_"L"
I $L(OBX(1))>245 D
.S OBX(2)=$E(OBX(1),246,$L(OBX(1)))
.S OBX(1)=$E(OBX(1),1,245)
Q
;
LABE() ;BUILD OBX FOR LAST LAB TEST DATE
N OBX S OBX=""
I '$$PATCH^XPDUTL("LR*5.2*295") Q OBX
N LAB,LAB2,EN
S LAB="" K ^TMP("DGLAB",$J) D RESULTS^LRPXAPI("DGLAB",DFN,"C")
S EN=$O(^TMP("DGLAB",$J,"")) I EN'="" S LAB=$P($G(^TMP("DGLAB",$J,EN)),"^")
K ^TMP("DGLAB",$J) D RESULTS^LRPXAPI("DGLAB",DFN,"A")
S EN=$O(^TMP("DGLAB",$J,"")) I EN'="" S LAB2=$P($G(^TMP("DGLAB",$J,EN)),"^") I LAB2>LAB S LAB=LAB2
K ^TMP("DGLAB",$J) D RESULTS^LRPXAPI("DGLAB",DFN,"M")
S EN=$O(^TMP("DGLAB",$J,"")) I EN'="" S LAB2=$P($G(^TMP("DGLAB",$J,EN)),"^") I LAB2>LAB S LAB=LAB2
I LAB'="" D
.S $P(OBX,HL("FS"),2)="TS" ;**756 added the data type
.S $P(OBX,HL("FS"),3)="LAST LAB TEST DATE/TIME"
.S $P(OBX,HL("FS"),11)="F"
.S $P(OBX,HL("FS"),14)=$$HLDATE^HLFNC(LAB)
.S OBX="OBX"_HL("FS")_OBX
Q OBX
;
RADE() ;BUILD OBX FOR LAST RADIOLOGY TEST DATE
N RET S RET=""
I '$$PATCH^XPDUTL("RA*5.0*76") Q RET
N RAD,RADE
S RAD="",RADE=$$XAMDT^RAO7UTL1(DFN) I +RADE<1 Q RAD
I +RADE>0 D
.S $P(OBX,HL("FS"),2)="TS" ;**756 added the data type
.S $P(RAD,HL("FS"),3)="LAST RADIOLOGY EXAM DATE/TIME"
.S $P(RAD,HL("FS"),11)="F"
.S $P(RAD,HL("FS"),14)=$$HLDATE^HLFNC(RADE)
.S RAD="OBX"_HL("FS")_RAD
Q RAD
;
PD1() ;BUILD PD1 segment
;PREFERRED FACILITY -- NOT GOING TO BE PASSED PER IMDQ 9/7/06
N TEAM,PD1
S PD1=""
;S TEAM=$$PREF^DGENPTA(DFN)
;I TEAM'="" S PD1="PD1"_HL("FS")_HL("FS")_HL("FS")_$$STA^XUAF4(TEAM)
Q PD1
;
PV1() ;BUILD PV1 SEGMENT
;CURRENTLY ADMITTED?
N PV1,VAINDT
S PV1=""
S VAINDT=DT
D INP^VADPT
I $G(VAIN(1))'="" S $P(PV1,HL("FS"),44)=$$HLDATE^HLFNC($P(VAIN(7),"^")),PV1="PV1"_HL("FS")_PV1
K VAIN
Q PV1
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVAFCSB 11359 printed Sep 23, 2025@20:38:17 Page 2
VAFCSB ;BIR/CMC-CONT ADT PROCESSOR TO RETRIGGER A08 or A04 MESSAGES WITH AL/AL (COMMIT/APPLICATION) ACKNOWLEDGEMENTS ;2/2/22 17:24
+1 ;;5.3;Registration;**707,756,825,876,902,926,967,1059,1071**;Aug 13, 1993;Build 4
+2 ;
+3 ;Reference to $$XAMDT^RAO7UTL1 is supported by IA #4875
+4 ;Reference to RESUTLS^LRPXAPI is supported by IA #4245
+5 ;Reference to PROF^PSO52API is supported by IA #4820
+6 ;
PV2() ;build pv2 segment
+1 NEW PV2,LSTA,APPT,VASD,VAIP,VARP,VAROOT
+2 SET PV2=""
+3 ;get next outpatient appointment
+4 KILL ^UTILITY("VASD",$JOB)
SET VASD("F")=DT
DO SDA^VADPT
+5 SET APPT=$PIECE($GET(^UTILITY("VASD",$JOB,1,"I")),"^")
+6 IF APPT'=""
SET $PIECE(PV2,HL("FS"),9)=$$HLDATE^HLFNC(APPT)
+7 ;GET LAST ADMISSION DATE
+8 KILL VAIP
SET VAIP("D")="LAST"
SET VAIP("M")=0
DO IN5^VADPT
+9 ; **825,CR_1184: for PV2-14, it will be re-set as the 15th piece
+10 ; in PV2 segment a few lines below
+11 ; I VAIP(2)="1^ADMISSION" S $P(PV2,HL("FS"),15)=$$HLDATE^HLFNC($P(VAIP(3),"^"))
+12 IF VAIP(2)="1^ADMISSION"
SET $PIECE(PV2,HL("FS"),14)=$$HLDATE^HLFNC($PIECE(VAIP(3),"^"))
+13 ;get last registration
+14 SET VAROOT="VARP"
+15 DO REG^VADPT
+16 IF $DATA(VARP(1,"I"))
IF $GET(VARP(1,"I"))>0
SET $PIECE(PV2,HL("FS"),46)=$$HLDATE^HLFNC($PIECE(VARP(1,"I"),"^"),"DT")
SET $PIECE(PV2,HL("FS"),24)="CR"
+17 ;**756 ^ ONLY RETURN DATE FOR LAST REGISTRATION AS HL7 STANDARD CAN ONLY HAVE DATE
+18 IF PV2'=""
SET PV2="PV2"_HL("FS")_PV2
+19 QUIT PV2
+20 ;
PHARA() ;build obx to show active prescriptions
+1 NEW RET
SET RET=""
+2 IF '$$PATCH^XPDUTL("PSS*1.0*101")
QUIT RET
+3 NEW PHARM,DGLIST
+4 SET PHARM=""
DO PROF^PSO52API(DFN,"DGLIST")
+5 IF +$GET(^TMP($JOB,"DGLIST",DFN,0))>0
SET PHARM="OBX"_HL("FS")_HL("FS")_"CE"_HL("FS")_"ACTIVE PRESCRIPTIONS"_HL("FS")_HL("FS")_"Y"
+6 ;**756 CE added as the data type
+7 QUIT PHARM
+8 ;
SIG(DFN) ;**876 MVI_3467 (ckn) Build OBX for Self Identified Gender
+1 NEW SIG,SIGE,SIGTMP,OBX
SET OBX=""
+2 ;I '$$PATCH^XPDUTL("DG*5.3*876") Q OBX
+3 SET DIC=2
SET DA=DFN
SET DR=".024"
SET DIQ="SIGTMP"
SET DIQ(0)="I,E,N"
DO EN^DIQ1
+4 IF '$DATA(SIGTMP)
KILL DA,DR,DIQ
QUIT OBX
+5 SET SIG=$GET(SIGTMP(2,DFN,DR,"I"))
SET SIGE=$GET(SIGTMP(2,DFN,DR,"E"))
+6 SET OBX="OBX"_HL("FS")_HL("FS")_"CE"_HL("FS")_"SELF ID GENDER"_HL("FS")_HL("FS")_SIG_$EXTRACT(HL("ECH"),1)_SIGE
+7 KILL DA,DR,DIC,DIQ
+8 QUIT OBX
+9 ;
DODF(DFN) ;**902 MVI_4898 (ckn) Build OBX for DOD fields
+1 NEW DODTMP,DODEB,DODLEB,DODSRC,DODLUPD,DODSRCI,DODSRCE,CS,DODLNAM
+2 NEW DODFNAM,DODMNAM,DODEBE,DODEBI,DODLEBE,DODLEBI,DODSRCCD
+3 SET CS=$EXTRACT(HL("ECH"))
SET SC=$EXTRACT(HL("ECH"),4)
+4 SET DIC=2
SET DA=DFN
SET DR=".352;.353;.354;.355"
SET DIQ="DODTMP"
SET DIQ(0)="I,E,N"
DO EN^DIQ1
+5 SET DODSRCI=$GET(DODTMP(2,DFN,.353,"I"))
SET DODSRCE=$GET(DODTMP(2,DFN,.353,"E"))
SET DODSRC=HL("Q")
+6 ; **926, Story #323009 (ckn): Source of Notification moved from set of codes to pointer which is pointing to new Source Of Notification file (#47.76)
+7 IF DODSRCE'=""
Begin DoDot:1
+8 SET DODSRCCD=$PIECE($GET(^DG(47.76,DODSRCI,0)),"^",2)
+9 SET DODSRC=DODSRCCD_CS_DODSRCE_CS_"L"
End DoDot:1
+10 IF DODSRCE'=""
SET DODSRC=DODSRCI_CS_DODSRCE_CS_"L"
+11 SET DODLUPD=$GET(DODTMP(2,DFN,.354,"I"))
SET DODLUPD=$SELECT(DODLUPD="":HL("Q"),1:$$HLDATE^HLFNC(DODLUPD))
+12 ;If LAST EDITED BY field(#.355) have value, use it to populate sequence 16 of OBX
+13 ;If LAST EDITED BY field(#.355) does not have value, use DEATH ENTERED BY field(#.352) to populate sequence 16 of OBX
+14 ;If both fields empty, send double quotes in sequence 16 of OBX
+15 ;Default seq 16
SET DODLEB=HL("Q")
+16 ;DOD Entered by
SET DODEBE=$GET(DODTMP(2,DFN,.352,"E"))
SET DODEBI=$GET(DODTMP(2,DFN,.352,"I"))
+17 ;DOD Last Edited By
SET DODLEBE=$GET(DODTMP(2,DFN,.355,"E"))
SET DODLEBI=$GET(DODTMP(2,DFN,.355,"I"))
+18 IF DODLEBE'=""
Begin DoDot:1
+19 SET DODLEBE=$$HLNAME^HLFNC(DODLEBE,CS)
SET DODLNAM=$SELECT($PIECE(DODLEBE,CS)="":HL("Q"),1:$PIECE(DODLEBE,CS))
SET DODFNAM=$SELECT($PIECE(DODLEBE,CS,2)="":HL("Q"),1:$PIECE(DODLEBE,CS,2))
SET DODMNAM=$SELECT($PIECE(DODLEBE,CS,3)="":HL("Q"),1:$PIECE(DODLEBE,CS,3))
+20 SET DODLEB=$SELECT(DODLEBI="":HL("Q"),1:DODLEBI)_CS_DODLNAM_CS_DODFNAM_CS_DODMNAM_CS_CS_CS_CS_CS_"USVHA"_SC_SC_"0363"_CS_"L"_CS_CS_CS_"PN"_CS_"VA FACILITY ID"_SC_$PIECE($$SITE^VASITE(),"^",3)_SC_"L"
End DoDot:1
+21 IF DODLEBE=""
IF (DODEBE'="")
Begin DoDot:1
+22 SET DODEBE=$$HLNAME^HLFNC(DODEBE,CS)
SET DODLNAM=$SELECT($PIECE(DODEBE,CS)="":HL("Q"),1:$PIECE(DODEBE,CS))
SET DODFNAM=$SELECT($PIECE(DODEBE,CS,2)="":HL("Q"),1:$PIECE(DODEBE,CS,2))
SET DODMNAM=$SELECT($PIECE(DODEBE,CS,3)="":HL("Q"),1:$PIECE(DODEBE,CS,3))
+23 SET DODLEB=$SELECT(DODEBI="":HL("Q"),1:DODEBI)_CS_DODLNAM_CS_DODFNAM_CS_DODMNAM_CS_CS_CS_CS_CS_"USVHA"_SC_SC_"0363"_CS_"L"_CS_CS_CS_"PN"_CS_"VA FACILITY ID"_SC_$PIECE($$SITE^VASITE(),"^",3)_SC_"L"
End DoDot:1
+24 SET OBX="OBX"_HL("FS")_HL("FS")_"CE"_HL("FS")_"DATE OF DEATH DATA"_HL("FS")_HL("FS")_DODSRC_HL("FS")_HL("FS")_HL("FS")_HL("FS")_HL("FS")_HL("FS")_"R"_HL("FS")_HL("FS")_HL("FS")_DODLUPD_HL("FS")_HL("FS")_$GET(DODLEB)
+25 KILL DA,DR,DIC,DIQ
+26 QUIT OBX
+27 ;
DODD(DFN) ;**926, Story #323009 (ckn): Build OBX for DATE OF DEATH DOCUMENTS
+1 NEW OBX,DODTMP,DODDI,DODD,DODDE,DODDCD
+2 SET CS=$EXTRACT(HL("ECH"))
+3 SET DIC=2
SET DA=DFN
SET DR=".357"
SET DIQ="DODTMP"
SET DIQ(0)="I,E,N"
DO EN^DIQ1
+4 SET DODDI=$GET(DODTMP(2,DFN,.357,"I"))
SET DODDE=$GET(DODTMP(2,DFN,.357,"E"))
SET DODD=HL("Q")
+5 IF DODDE'=""
Begin DoDot:1
+6 SET DODDCD=$PIECE($GET(^DG(47.75,DODDI,0)),"^",2)
+7 SET DODD=DODDCD_CS_DODDE_CS_"L"
End DoDot:1
+8 SET OBX="OBX"_HL("FS")_HL("FS")_"CE"_HL("FS")_"DATE OF DEATH DOCUMENTS"_HL("FS")_HL("FS")_DODD
+9 KILL DA,DR,DIC,DIQ
+10 QUIT OBX
+11 ;
DODOPT(DFN) ;**926, Story #323009 (ckn): Build OBX for DATE OF DEATH OPTION
+1 NEW OBX,DODOPT,DODOPTE,DODOPTI
+2 SET CS=$EXTRACT(HL("ECH"))
+3 SET DIC=2
SET DA=DFN
SET DR=".358"
SET DIQ="DODTMP"
SET DIQ(0)="I,E,N"
DO EN^DIQ1
+4 SET DODOPTE=$GET(DODTMP(2,DFN,.358,"E"))
SET DODOPTI=$GET(DODTMP(2,DFN,.358,"I"))
SET DODOPT=HL("Q")
+5 IF DODOPTE'=""
SET DODOPT=DODOPTI_CS_DODOPTE_CS_"L"
+6 SET OBX="OBX"_HL("FS")_HL("FS")_"CE"_HL("FS")_"DATE OF DEATH OPTION"_HL("FS")_HL("FS")_DODOPT
+7 KILL DA,DR,DIC,DIQ
+8 QUIT OBX
+9 ;
DODDISDT(DFN) ;**926, Story #323009 (ckn): Build OBX for DATE OF DEATH DISCHARGE DATE
+1 ;Q OBX
+2 ;
DODNTPRV(DFN) ;**926, Story #323009 (ckn): Build OBX for DATE OF DEATH NOTIFICATION
+1 NEW OBX,DODNP,STN
+2 SET CS=$EXTRACT(HL("ECH"))
SET STN=$$SITE^VASITE()
SET DODNP=""
+3 ;Populate notify provider if Date of Death last updated have value
+4 IF $$GET1^DIQ(2,DFN_",",.354,"I")'=""
SET DODNP=$PIECE(STN,"^",3)_CS_$PIECE(STN,"^",2)_CS_"L"
+5 SET OBX="OBX"_HL("FS")_HL("FS")_"CE"_HL("FS")_"NOTIFY PROVIDER"_HL("FS")_HL("FS")_DODNP
+6 QUIT OBX
+7 ;
SECLOG(DFN) ;**1059, Story #783361 (ckn): Build OBX for Sensitivity information
+1 NEW OBX,SECLVL,SECLOG
+2 SET CS=$EXTRACT(HL("ECH"))
SET OBX=""
+3 SET DA=$ORDER(^DGSL(38.1,"B",DFN,""))
IF DA=""
QUIT OBX
+4 SET DIC=38.1
SET DR="2"
SET DIQ="SECLOG"
SET DIQ(0)="I,E,N"
DO EN^DIQ1
+5 SET SECLVL=$GET(SECLOG(38.1,DA,2,"I"))
IF SECLVL=""
QUIT OBX
+6 SET SECLVL=SECLVL_CS_$GET(SECLOG(38.1,DA,2,"E"))_CS_"L"
+7 SET OBX="OBX"_HL("FS")_HL("FS")_"CE"_HL("FS")_"SECURITY LEVEL"_HL("FS")_HL("FS")_SECLVL_HL("FS")_HL("FS")_HL("FS")_HL("FS")_HL("FS")_HL("FS")_"F"
+8 QUIT OBX
+9 ;
NAMEOBX(DFN) ;**876,MVI_3453 (mko): Build OBX for Patient .01 and Name Components
+1 NEW FS
+2 SET FS=HL("FS")
+3 QUIT "OBX"_FS_FS_"CE"_FS_"NAME COMPONENTS"_FS_FS_$$NAMECOMP(DFN,$EXTRACT(HL("ECH")))
+4 ;
NAMEERR(DFN) ;**876,MVI_3453 (mko): Build ERR for Patient .01 and Name Components
+1 NEW CS,SC
+2 SET CS=$EXTRACT(HL("ECH"))
SET SC=$EXTRACT(HL("ECH"),4)
+3 QUIT "ERR"_HL("FS")_CS_CS_CS_SC_$$NAMECOMP(DFN,SC)
+4 ;
NAMECOMP(DFN,DELIM) ;**876,MVI_3453 (mko): Return Patient .01 and Name Components
+1 NEW DIHELP,DIMSG,DIERR,MSG,NC,NCIEN,NCIENS,NCPTR,TARG
+2 SET NC=$PIECE($GET(^DPT(DFN,0)),"^")
+3 SET NCPTR=$PIECE($GET(^DPT(DFN,"NAME")),"^")
if 'NCPTR
QUIT NC
+4 SET NCIEN=$$FIND1^DIC(20,"","","`"_NCPTR,"","","MSG")
if 'NCIEN
QUIT NC
+5 SET NCIENS=NCIEN_","
+6 DO GETS^DIQ(20,NCIENS,"1:5","","TARG","MSG")
if $GET(DIERR)
QUIT NC
+7 SET NC=NC_DELIM_TARG(20,NCIENS,1)_DELIM_TARG(20,NCIENS,2)_DELIM_TARG(20,NCIENS,3)_DELIM_TARG(20,NCIENS,5)_DELIM_TARG(20,NCIENS,4)
+8 QUIT NC
+9 ;
SEXOR(DFN,OBX) ;build obx for sexual orientation multiple ;**1059, VAMPI-11114 (dri)
+1 ;**1071 VAMPI-13755 (dri) - include status, date created, date last updated
+2 NEW IENS,OBXCNT,SEXOR,SOCODE,SOCRDT,SOEDDT,SOEXT,SOIEN,SOOBX,SOSTAT
+3 DO GETS^DIQ(2,DFN_",",".025*","IE","SEXOR")
+4 IF '$DATA(SEXOR)
QUIT
+5 SET OBXCNT=1
SET IENS=""
FOR
SET IENS=$ORDER(SEXOR(2.025,IENS))
if IENS=""
QUIT
Begin DoDot:1
+6 SET SOIEN=+$GET(SEXOR(2.025,IENS,.01,"I"))
IF 'SOIEN
QUIT
+7 SET SOCODE=$$GET1^DIQ(47.77,SOIEN_",",1)
+8 SET SOEXT=$GET(SEXOR(2.025,IENS,.01,"E"))
+9 SET SOOBX=SOCODE_COMP_SOEXT_COMP_"L"
+10 ;sexual orientation status
SET SOSTAT=$GET(SEXOR(2.025,IENS,.02,"I"))
+11 ;default to "A"ctive if null
IF SOSTAT=""
SET SOSTAT="A"
+12 ;create date
SET SOCRDT=$$HLDATE^HLFNC($GET(SEXOR(2.025,IENS,.03,"I")))
+13 ;update date
SET SOEDDT=$$HLDATE^HLFNC($GET(SEXOR(2.025,IENS,.04,"I")))
+14 SET OBX(OBXCNT)="OBX"_HL("FS")_HL("FS")_"CE"_HL("FS")_"Sexual Orientation"_HL("FS")_HL("FS")_SOOBX_HL("FS")_HL("FS")_HL("FS")_HL("FS")_HL("FS")_HL("FS")_SOSTAT_HL("FS")_SOEDDT_HL("FS")_HL("FS")_SOCRDT
SET OBXCNT=OBXCNT+1
End DoDot:1
+15 QUIT
+16 ;
SEXORD(DFN,OBX) ;build obx for sexual orientation description ;**1059, VAMPI-11114 (dri)
+1 NEW SEXORDES
+2 SET SEXORDES=$$GET1^DIQ(2,DFN_",",.0251)
+3 IF SEXORDES=""
QUIT
+4 SET OBX(1)="OBX"_HL("FS")_HL("FS")_"ST"_HL("FS")_"Sexual Or Description"_HL("FS")_HL("FS")_$EXTRACT(HL("ECH"),1)_SEXORDES_$EXTRACT(HL("ECH"),1)_"L"
+5 IF $LENGTH(OBX(1))>245
Begin DoDot:1
+6 SET OBX(2)=$EXTRACT(OBX(1),246,$LENGTH(OBX(1)))
+7 SET OBX(1)=$EXTRACT(OBX(1),1,245)
End DoDot:1
+8 QUIT
+9 ;
PRON(DFN,OBX) ;build obx for pronoun multiple ;**1059, VAMPI-11118 (dri)
+1 NEW IENS,OBXCNT,PRON,PRONCODE,PRONIEN,PRONTYP
+2 DO GETS^DIQ(2,DFN_",",".2406*","IE","PRON")
+3 IF '$DATA(PRON)
QUIT
+4 SET OBXCNT=1
SET IENS=""
FOR
SET IENS=$ORDER(PRON(2.2406,IENS))
if IENS=""
QUIT
SET PRONIEN=+$GET(PRON(2.2406,IENS,.01,"I"))
IF PRONIEN
Begin DoDot:1
+5 SET PRONCODE=$$GET1^DIQ(47.78,PRONIEN_",",1)
+6 SET PRONTYP=$GET(PRON(2.2406,IENS,.01,"E"))
+7 SET OBX(OBXCNT)="OBX"_HL("FS")_HL("FS")_"CE"_HL("FS")_"Pronoun"_HL("FS")_HL("FS")_PRONCODE_$EXTRACT(HL("ECH"),1)_PRONTYP_$EXTRACT(HL("ECH"),1)_"L"
SET OBXCNT=OBXCNT+1
End DoDot:1
+8 QUIT
+9 ;
PROND(DFN,OBX) ;build obx for pronoun description ;**1059, VAMPI-11118 (dri)
+1 NEW PRONDES
+2 SET PRONDES=$$GET1^DIQ(2,DFN_",",.24061)
+3 IF PRONDES=""
QUIT
+4 SET OBX(1)="OBX"_HL("FS")_HL("FS")_"ST"_HL("FS")_"Pronoun Description"_HL("FS")_HL("FS")_$EXTRACT(HL("ECH"),1)_PRONDES_$EXTRACT(HL("ECH"),1)_"L"
+5 IF $LENGTH(OBX(1))>245
Begin DoDot:1
+6 SET OBX(2)=$EXTRACT(OBX(1),246,$LENGTH(OBX(1)))
+7 SET OBX(1)=$EXTRACT(OBX(1),1,245)
End DoDot:1
+8 QUIT
+9 ;
LABE() ;BUILD OBX FOR LAST LAB TEST DATE
+1 NEW OBX
SET OBX=""
+2 IF '$$PATCH^XPDUTL("LR*5.2*295")
QUIT OBX
+3 NEW LAB,LAB2,EN
+4 SET LAB=""
KILL ^TMP("DGLAB",$JOB)
DO RESULTS^LRPXAPI("DGLAB",DFN,"C")
+5 SET EN=$ORDER(^TMP("DGLAB",$JOB,""))
IF EN'=""
SET LAB=$PIECE($GET(^TMP("DGLAB",$JOB,EN)),"^")
+6 KILL ^TMP("DGLAB",$JOB)
DO RESULTS^LRPXAPI("DGLAB",DFN,"A")
+7 SET EN=$ORDER(^TMP("DGLAB",$JOB,""))
IF EN'=""
SET LAB2=$PIECE($GET(^TMP("DGLAB",$JOB,EN)),"^")
IF LAB2>LAB
SET LAB=LAB2
+8 KILL ^TMP("DGLAB",$JOB)
DO RESULTS^LRPXAPI("DGLAB",DFN,"M")
+9 SET EN=$ORDER(^TMP("DGLAB",$JOB,""))
IF EN'=""
SET LAB2=$PIECE($GET(^TMP("DGLAB",$JOB,EN)),"^")
IF LAB2>LAB
SET LAB=LAB2
+10 IF LAB'=""
Begin DoDot:1
+11 ;**756 added the data type
SET $PIECE(OBX,HL("FS"),2)="TS"
+12 SET $PIECE(OBX,HL("FS"),3)="LAST LAB TEST DATE/TIME"
+13 SET $PIECE(OBX,HL("FS"),11)="F"
+14 SET $PIECE(OBX,HL("FS"),14)=$$HLDATE^HLFNC(LAB)
+15 SET OBX="OBX"_HL("FS")_OBX
End DoDot:1
+16 QUIT OBX
+17 ;
RADE() ;BUILD OBX FOR LAST RADIOLOGY TEST DATE
+1 NEW RET
SET RET=""
+2 IF '$$PATCH^XPDUTL("RA*5.0*76")
QUIT RET
+3 NEW RAD,RADE
+4 SET RAD=""
SET RADE=$$XAMDT^RAO7UTL1(DFN)
IF +RADE<1
QUIT RAD
+5 IF +RADE>0
Begin DoDot:1
+6 ;**756 added the data type
SET $PIECE(OBX,HL("FS"),2)="TS"
+7 SET $PIECE(RAD,HL("FS"),3)="LAST RADIOLOGY EXAM DATE/TIME"
+8 SET $PIECE(RAD,HL("FS"),11)="F"
+9 SET $PIECE(RAD,HL("FS"),14)=$$HLDATE^HLFNC(RADE)
+10 SET RAD="OBX"_HL("FS")_RAD
End DoDot:1
+11 QUIT RAD
+12 ;
PD1() ;BUILD PD1 segment
+1 ;PREFERRED FACILITY -- NOT GOING TO BE PASSED PER IMDQ 9/7/06
+2 NEW TEAM,PD1
+3 SET PD1=""
+4 ;S TEAM=$$PREF^DGENPTA(DFN)
+5 ;I TEAM'="" S PD1="PD1"_HL("FS")_HL("FS")_HL("FS")_$$STA^XUAF4(TEAM)
+6 QUIT PD1
+7 ;
PV1() ;BUILD PV1 SEGMENT
+1 ;CURRENTLY ADMITTED?
+2 NEW PV1,VAINDT
+3 SET PV1=""
+4 SET VAINDT=DT
+5 DO INP^VADPT
+6 IF $GET(VAIN(1))'=""
SET $PIECE(PV1,HL("FS"),44)=$$HLDATE^HLFNC($PIECE(VAIN(7),"^"))
SET PV1="PV1"_HL("FS")_PV1
+7 KILL VAIN
+8 QUIT PV1
+9 ;
