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

VAFCSB.m

Go to the documentation of this file.
  1. 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
  1. ;
  1. ;Reference to $$XAMDT^RAO7UTL1 is supported by IA #4875
  1. ;Reference to RESUTLS^LRPXAPI is supported by IA #4245
  1. ;Reference to PROF^PSO52API is supported by IA #4820
  1. ;
  1. PV2() ;build pv2 segment
  1. N PV2,LSTA,APPT,VASD,VAIP,VARP,VAROOT
  1. S PV2=""
  1. ;get next outpatient appointment
  1. K ^UTILITY("VASD",$J) S VASD("F")=DT D SDA^VADPT
  1. S APPT=$P($G(^UTILITY("VASD",$J,1,"I")),"^")
  1. I APPT'="" S $P(PV2,HL("FS"),9)=$$HLDATE^HLFNC(APPT)
  1. ;GET LAST ADMISSION DATE
  1. K VAIP S VAIP("D")="LAST",VAIP("M")=0 D IN5^VADPT
  1. ; **825,CR_1184: for PV2-14, it will be re-set as the 15th piece
  1. ; in PV2 segment a few lines below
  1. ; I VAIP(2)="1^ADMISSION" S $P(PV2,HL("FS"),15)=$$HLDATE^HLFNC($P(VAIP(3),"^"))
  1. I VAIP(2)="1^ADMISSION" S $P(PV2,HL("FS"),14)=$$HLDATE^HLFNC($P(VAIP(3),"^"))
  1. ;get last registration
  1. S VAROOT="VARP"
  1. D REG^VADPT
  1. 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"
  1. ;**756 ^ ONLY RETURN DATE FOR LAST REGISTRATION AS HL7 STANDARD CAN ONLY HAVE DATE
  1. I PV2'="" S PV2="PV2"_HL("FS")_PV2
  1. Q PV2
  1. ;
  1. PHARA() ;build obx to show active prescriptions
  1. N RET S RET=""
  1. I '$$PATCH^XPDUTL("PSS*1.0*101") Q RET
  1. N PHARM,DGLIST
  1. S PHARM="" D PROF^PSO52API(DFN,"DGLIST")
  1. 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"
  1. ;**756 CE added as the data type
  1. Q PHARM
  1. ;
  1. SIG(DFN) ;**876 MVI_3467 (ckn) Build OBX for Self Identified Gender
  1. N SIG,SIGE,SIGTMP,OBX S OBX=""
  1. ;I '$$PATCH^XPDUTL("DG*5.3*876") Q OBX
  1. S DIC=2,DA=DFN,DR=".024",DIQ="SIGTMP",DIQ(0)="I,E,N" D EN^DIQ1
  1. I '$D(SIGTMP) K DA,DR,DIQ Q OBX
  1. S SIG=$G(SIGTMP(2,DFN,DR,"I")),SIGE=$G(SIGTMP(2,DFN,DR,"E"))
  1. S OBX="OBX"_HL("FS")_HL("FS")_"CE"_HL("FS")_"SELF ID GENDER"_HL("FS")_HL("FS")_SIG_$E(HL("ECH"),1)_SIGE
  1. K DA,DR,DIC,DIQ
  1. Q OBX
  1. ;
  1. DODF(DFN) ;**902 MVI_4898 (ckn) Build OBX for DOD fields
  1. N DODTMP,DODEB,DODLEB,DODSRC,DODLUPD,DODSRCI,DODSRCE,CS,DODLNAM
  1. N DODFNAM,DODMNAM,DODEBE,DODEBI,DODLEBE,DODLEBI,DODSRCCD
  1. S CS=$E(HL("ECH")),SC=$E(HL("ECH"),4)
  1. S DIC=2,DA=DFN,DR=".352;.353;.354;.355",DIQ="DODTMP",DIQ(0)="I,E,N" D EN^DIQ1
  1. S DODSRCI=$G(DODTMP(2,DFN,.353,"I")),DODSRCE=$G(DODTMP(2,DFN,.353,"E")),DODSRC=HL("Q")
  1. ; **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)
  1. I DODSRCE'="" D
  1. . S DODSRCCD=$P($G(^DG(47.76,DODSRCI,0)),"^",2)
  1. . S DODSRC=DODSRCCD_CS_DODSRCE_CS_"L"
  1. I DODSRCE'="" S DODSRC=DODSRCI_CS_DODSRCE_CS_"L"
  1. S DODLUPD=$G(DODTMP(2,DFN,.354,"I")) S DODLUPD=$S(DODLUPD="":HL("Q"),1:$$HLDATE^HLFNC(DODLUPD))
  1. ;If LAST EDITED BY field(#.355) have value, use it to populate sequence 16 of OBX
  1. ;If LAST EDITED BY field(#.355) does not have value, use DEATH ENTERED BY field(#.352) to populate sequence 16 of OBX
  1. ;If both fields empty, send double quotes in sequence 16 of OBX
  1. S DODLEB=HL("Q") ;Default seq 16
  1. S DODEBE=$G(DODTMP(2,DFN,.352,"E")),DODEBI=$G(DODTMP(2,DFN,.352,"I")) ;DOD Entered by
  1. S DODLEBE=$G(DODTMP(2,DFN,.355,"E")),DODLEBI=$G(DODTMP(2,DFN,.355,"I")) ;DOD Last Edited By
  1. I DODLEBE'="" D
  1. .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))
  1. .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"
  1. I DODLEBE="",(DODEBE'="") D
  1. .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))
  1. .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"
  1. 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)
  1. K DA,DR,DIC,DIQ
  1. Q OBX
  1. ;
  1. DODD(DFN) ;**926, Story #323009 (ckn): Build OBX for DATE OF DEATH DOCUMENTS
  1. N OBX,DODTMP,DODDI,DODD,DODDE,DODDCD
  1. S CS=$E(HL("ECH"))
  1. S DIC=2,DA=DFN,DR=".357",DIQ="DODTMP",DIQ(0)="I,E,N" D EN^DIQ1
  1. S DODDI=$G(DODTMP(2,DFN,.357,"I")),DODDE=$G(DODTMP(2,DFN,.357,"E")),DODD=HL("Q")
  1. I DODDE'="" D
  1. . S DODDCD=$P($G(^DG(47.75,DODDI,0)),"^",2)
  1. . S DODD=DODDCD_CS_DODDE_CS_"L"
  1. S OBX="OBX"_HL("FS")_HL("FS")_"CE"_HL("FS")_"DATE OF DEATH DOCUMENTS"_HL("FS")_HL("FS")_DODD
  1. K DA,DR,DIC,DIQ
  1. Q OBX
  1. ;
  1. DODOPT(DFN) ;**926, Story #323009 (ckn): Build OBX for DATE OF DEATH OPTION
  1. N OBX,DODOPT,DODOPTE,DODOPTI
  1. S CS=$E(HL("ECH"))
  1. S DIC=2,DA=DFN,DR=".358",DIQ="DODTMP",DIQ(0)="I,E,N" D EN^DIQ1
  1. S DODOPTE=$G(DODTMP(2,DFN,.358,"E")),DODOPTI=$G(DODTMP(2,DFN,.358,"I")),DODOPT=HL("Q")
  1. I DODOPTE'="" S DODOPT=DODOPTI_CS_DODOPTE_CS_"L"
  1. S OBX="OBX"_HL("FS")_HL("FS")_"CE"_HL("FS")_"DATE OF DEATH OPTION"_HL("FS")_HL("FS")_DODOPT
  1. K DA,DR,DIC,DIQ
  1. Q OBX
  1. ;
  1. DODDISDT(DFN) ;**926, Story #323009 (ckn): Build OBX for DATE OF DEATH DISCHARGE DATE
  1. ;Q OBX
  1. ;
  1. DODNTPRV(DFN) ;**926, Story #323009 (ckn): Build OBX for DATE OF DEATH NOTIFICATION
  1. N OBX,DODNP,STN
  1. S CS=$E(HL("ECH")),STN=$$SITE^VASITE(),DODNP=""
  1. ;Populate notify provider if Date of Death last updated have value
  1. I $$GET1^DIQ(2,DFN_",",.354,"I")'="" S DODNP=$P(STN,"^",3)_CS_$P(STN,"^",2)_CS_"L"
  1. S OBX="OBX"_HL("FS")_HL("FS")_"CE"_HL("FS")_"NOTIFY PROVIDER"_HL("FS")_HL("FS")_DODNP
  1. Q OBX
  1. ;
  1. SECLOG(DFN) ;**1059, Story #783361 (ckn): Build OBX for Sensitivity information
  1. N OBX,SECLVL,SECLOG
  1. S CS=$E(HL("ECH")),OBX=""
  1. S DA=$O(^DGSL(38.1,"B",DFN,"")) I DA="" Q OBX
  1. S DIC=38.1,DR="2",DIQ="SECLOG",DIQ(0)="I,E,N" D EN^DIQ1
  1. S SECLVL=$G(SECLOG(38.1,DA,2,"I")) I SECLVL="" Q OBX
  1. S SECLVL=SECLVL_CS_$G(SECLOG(38.1,DA,2,"E"))_CS_"L"
  1. 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"
  1. Q OBX
  1. ;
  1. NAMEOBX(DFN) ;**876,MVI_3453 (mko): Build OBX for Patient .01 and Name Components
  1. N FS
  1. S FS=HL("FS")
  1. Q "OBX"_FS_FS_"CE"_FS_"NAME COMPONENTS"_FS_FS_$$NAMECOMP(DFN,$E(HL("ECH")))
  1. ;
  1. NAMEERR(DFN) ;**876,MVI_3453 (mko): Build ERR for Patient .01 and Name Components
  1. N CS,SC
  1. S CS=$E(HL("ECH")),SC=$E(HL("ECH"),4)
  1. Q "ERR"_HL("FS")_CS_CS_CS_SC_$$NAMECOMP(DFN,SC)
  1. ;
  1. NAMECOMP(DFN,DELIM) ;**876,MVI_3453 (mko): Return Patient .01 and Name Components
  1. N DIHELP,DIMSG,DIERR,MSG,NC,NCIEN,NCIENS,NCPTR,TARG
  1. S NC=$P($G(^DPT(DFN,0)),"^")
  1. S NCPTR=$P($G(^DPT(DFN,"NAME")),"^") Q:'NCPTR NC
  1. S NCIEN=$$FIND1^DIC(20,"","","`"_NCPTR,"","","MSG") Q:'NCIEN NC
  1. S NCIENS=NCIEN_","
  1. D GETS^DIQ(20,NCIENS,"1:5","","TARG","MSG") Q:$G(DIERR) NC
  1. 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)
  1. Q NC
  1. ;
  1. 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
  1. N IENS,OBXCNT,SEXOR,SOCODE,SOCRDT,SOEDDT,SOEXT,SOIEN,SOOBX,SOSTAT
  1. D GETS^DIQ(2,DFN_",",".025*","IE","SEXOR")
  1. I '$D(SEXOR) Q
  1. S OBXCNT=1,IENS="" F S IENS=$O(SEXOR(2.025,IENS)) Q:IENS="" D
  1. .S SOIEN=+$G(SEXOR(2.025,IENS,.01,"I")) I 'SOIEN Q
  1. .S SOCODE=$$GET1^DIQ(47.77,SOIEN_",",1)
  1. .S SOEXT=$G(SEXOR(2.025,IENS,.01,"E"))
  1. .S SOOBX=SOCODE_COMP_SOEXT_COMP_"L"
  1. .S SOSTAT=$G(SEXOR(2.025,IENS,.02,"I")) ;sexual orientation status
  1. .I SOSTAT="" S SOSTAT="A" ;default to "A"ctive if null
  1. .S SOCRDT=$$HLDATE^HLFNC($G(SEXOR(2.025,IENS,.03,"I"))) ;create date
  1. .S SOEDDT=$$HLDATE^HLFNC($G(SEXOR(2.025,IENS,.04,"I"))) ;update date
  1. .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
  1. Q
  1. ;
  1. SEXORD(DFN,OBX) ;build obx for sexual orientation description ;**1059, VAMPI-11114 (dri)
  1. N SEXORDES
  1. S SEXORDES=$$GET1^DIQ(2,DFN_",",.0251)
  1. I SEXORDES="" Q
  1. 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"
  1. I $L(OBX(1))>245 D
  1. .S OBX(2)=$E(OBX(1),246,$L(OBX(1)))
  1. .S OBX(1)=$E(OBX(1),1,245)
  1. Q
  1. ;
  1. PRON(DFN,OBX) ;build obx for pronoun multiple ;**1059, VAMPI-11118 (dri)
  1. N IENS,OBXCNT,PRON,PRONCODE,PRONIEN,PRONTYP
  1. D GETS^DIQ(2,DFN_",",".2406*","IE","PRON")
  1. I '$D(PRON) Q
  1. 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
  1. .S PRONCODE=$$GET1^DIQ(47.78,PRONIEN_",",1)
  1. .S PRONTYP=$G(PRON(2.2406,IENS,.01,"E"))
  1. .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
  1. Q
  1. ;
  1. PROND(DFN,OBX) ;build obx for pronoun description ;**1059, VAMPI-11118 (dri)
  1. N PRONDES
  1. S PRONDES=$$GET1^DIQ(2,DFN_",",.24061)
  1. I PRONDES="" Q
  1. 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"
  1. I $L(OBX(1))>245 D
  1. .S OBX(2)=$E(OBX(1),246,$L(OBX(1)))
  1. .S OBX(1)=$E(OBX(1),1,245)
  1. Q
  1. ;
  1. LABE() ;BUILD OBX FOR LAST LAB TEST DATE
  1. N OBX S OBX=""
  1. I '$$PATCH^XPDUTL("LR*5.2*295") Q OBX
  1. N LAB,LAB2,EN
  1. S LAB="" K ^TMP("DGLAB",$J) D RESULTS^LRPXAPI("DGLAB",DFN,"C")
  1. S EN=$O(^TMP("DGLAB",$J,"")) I EN'="" S LAB=$P($G(^TMP("DGLAB",$J,EN)),"^")
  1. K ^TMP("DGLAB",$J) D RESULTS^LRPXAPI("DGLAB",DFN,"A")
  1. S EN=$O(^TMP("DGLAB",$J,"")) I EN'="" S LAB2=$P($G(^TMP("DGLAB",$J,EN)),"^") I LAB2>LAB S LAB=LAB2
  1. K ^TMP("DGLAB",$J) D RESULTS^LRPXAPI("DGLAB",DFN,"M")
  1. S EN=$O(^TMP("DGLAB",$J,"")) I EN'="" S LAB2=$P($G(^TMP("DGLAB",$J,EN)),"^") I LAB2>LAB S LAB=LAB2
  1. I LAB'="" D
  1. .S $P(OBX,HL("FS"),2)="TS" ;**756 added the data type
  1. .S $P(OBX,HL("FS"),3)="LAST LAB TEST DATE/TIME"
  1. .S $P(OBX,HL("FS"),11)="F"
  1. .S $P(OBX,HL("FS"),14)=$$HLDATE^HLFNC(LAB)
  1. .S OBX="OBX"_HL("FS")_OBX
  1. Q OBX
  1. ;
  1. RADE() ;BUILD OBX FOR LAST RADIOLOGY TEST DATE
  1. N RET S RET=""
  1. I '$$PATCH^XPDUTL("RA*5.0*76") Q RET
  1. N RAD,RADE
  1. S RAD="",RADE=$$XAMDT^RAO7UTL1(DFN) I +RADE<1 Q RAD
  1. I +RADE>0 D
  1. .S $P(OBX,HL("FS"),2)="TS" ;**756 added the data type
  1. .S $P(RAD,HL("FS"),3)="LAST RADIOLOGY EXAM DATE/TIME"
  1. .S $P(RAD,HL("FS"),11)="F"
  1. .S $P(RAD,HL("FS"),14)=$$HLDATE^HLFNC(RADE)
  1. .S RAD="OBX"_HL("FS")_RAD
  1. Q RAD
  1. ;
  1. PD1() ;BUILD PD1 segment
  1. ;PREFERRED FACILITY -- NOT GOING TO BE PASSED PER IMDQ 9/7/06
  1. N TEAM,PD1
  1. S PD1=""
  1. ;S TEAM=$$PREF^DGENPTA(DFN)
  1. ;I TEAM'="" S PD1="PD1"_HL("FS")_HL("FS")_HL("FS")_$$STA^XUAF4(TEAM)
  1. Q PD1
  1. ;
  1. PV1() ;BUILD PV1 SEGMENT
  1. ;CURRENTLY ADMITTED?
  1. N PV1,VAINDT
  1. S PV1=""
  1. S VAINDT=DT
  1. D INP^VADPT
  1. I $G(VAIN(1))'="" S $P(PV1,HL("FS"),44)=$$HLDATE^HLFNC($P(VAIN(7),"^")),PV1="PV1"_HL("FS")_PV1
  1. K VAIN
  1. Q PV1
  1. ;