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

IVMPREC9.m

Go to the documentation of this file.
  1. IVMPREC9 ;ALB/KCL,BRM,CKN,TDM,KUM,JAM,KUM - PROCESS INCOMING (Z05 EVENT TYPE) HL7 MESSAGES (CON'T) ;09-05-2017 10:03am
  1. ;;2.0;INCOME VERIFICATION MATCH;**34,58,115,121,151,159,167,192,193,187,210**;21-OCT-94;Build 13
  1. ;Per VA Directive 6402, this routine should not be modified.
  1. ;
  1. ;
  1. ;ICRs
  1. ; Reference to ^HL(771.3 in ICR #941
  1. ; Reference to ^DI(.85 in ICR #6062
  1. ;
  1. ZCT ; - compare ZCT with DHCP ; IVM*2.0*192;JAM ; Tag ZCT moved from IVMPREC8
  1. N ZCTTYP,IVMFORAD,IVMFOR,IVMCNTRY,IVMDHCP,IVMFLD,IVMPIECE,IVMADDR,IVMADFLG
  1. S IVMADFLG=0
  1. S IVMPIECE=$E(IVMXREF,4,8)
  1. ; PATCH IVM*2.0*193; jam; Capture if IVMXREF is for a foreign address
  1. ; IVMXREF may have a 9th char - Foreign address eg ZCT054K1F
  1. S IVMFOR=$E(IVMXREF,9)
  1. ;IVM*2.0*188-COMMENT BELOW TO ALLOW QUOTES
  1. ;S IVMSEG=$$CLEARF^IVMPRECA(IVMSEG,HLFS)
  1. S ZCTTYP=$E(IVMPIECE,$L(IVMPIECE)-1,$L(IVMPIECE))
  1. Q:$P(IVMSEG,HLFS,2)'=$S(ZCTTYP="K1":1,ZCTTYP="K2":2,ZCTTYP="E1":3,ZCTTYP="E2":4,ZCTTYP="D1":5,1:"")
  1. ;
  1. ; IVM*2.0*192 - Get country field - if it has a value and if not "USA", quit entire ZCT processing
  1. ; IVM*2.0*193; patch 192 code removed - process foreign addresses
  1. ; S ADDR=$P(IVMSEG,"^",5),COUNTRY=$P(ADDR,"~",6) I COUNTRY'=""&(COUNTRY'="USA") QUIT
  1. ;
  1. I $P(IVMSEG,HLFS,$E(IVMPIECE,1,2))]"" D
  1. .;
  1. .; -set var IVMFLD to incoming HL7 field
  1. .I 'IVMADFLG S IVMFLD=$P(IVMSEG,HLFS,$E(IVMPIECE,1,2))
  1. .;IVM*2.0*188-convert "" to @
  1. .I IVMFLD="""""" S IVMFLD="@"
  1. .;
  1. .; - if HL7 name format convert to FM
  1. .I IVMXREF["ZCT03" S IVMFLD=$$FMNAME^HLFNC(IVMFLD)
  1. .;
  1. .I IVMFLD="@," S IVMFLD="@" ;IVM*2.0*188
  1. .; - ZCT05 as the ZCT address field is 6 pieces separated by HLECH (~)
  1. .I IVMXREF["ZCT05" D
  1. ..; IVM*2.0*193; jam; Concatenate IVMFOR to piece
  1. ..S IVMADDR=$P(IVMSEG,HLFS,$E(IVMPIECE,1,2)),IVMPIECE=$E(IVMPIECE,3)_IVMFOR
  1. ..S IVMFLD=$P(IVMADDR,$E(HLECH),IVMPIECE),IVMADFLG=1
  1. ..; IVM*2.0*193; jam; 6th piece added - Country - default to USA
  1. ..S IVMCNTRY=$S($P(IVMADDR,$E(HLECH),6)'="":$P(IVMADDR,$E(HLECH),6),1:"USA")
  1. ..; IVM*2.0*193; jam; Set flag if this is a foreign country
  1. ..S IVMFORAD=$S(IVMCNTRY="USA":0,1:1)
  1. ..;IVM*2.0*188-convert "" to @
  1. ..I IVMFLD="""""" S IVMFLD="@" Q
  1. ..; IVM*2.0*193; jam; foreign address added
  1. ..I (IVMPIECE=4)!(IVMPIECE=5) S IVMFLD=$S('IVMFORAD:IVMFLD,1:"") Q:IVMFLD=""
  1. ..I IVMPIECE=4 S IVMFLD=$O(^DIC(5,"C",IVMFLD,0))
  1. ..I IVMPIECE=5 S X=IVMFLD D ZIPIN^VAFADDR S IVMFLD=$G(X)
  1. ..I IVMPIECE="4F" S IVMFLD=$S(IVMFORAD:IVMFLD,1:"") ;PROVINCE
  1. ..I IVMPIECE="5F" S IVMFLD=$S(IVMFORAD:IVMFLD,1:"") ;POSTAL CODE
  1. ..I IVMPIECE=6 S IVMFLD=$$CNTRCONV^IVMPREC8(IVMCNTRY) ;COUNTRY
  1. .I IVMADFLG D STORE Q
  1. .; - if HL7 date convert to FM date
  1. .I IVMXREF["ZCT10" S IVMFLD=$$FMDATE^HLFNC(IVMFLD)
  1. .;
  1. .; - execute code on the 1 node and get DHCP field
  1. .S IVMDHCP="" X:$D(^IVM(301.92,+IVMDEMDA,1)) ^(1) S IVMDHCP=Y
  1. .;
  1. .;IVM*2.0*188-convert "" to @
  1. .I IVMFLD="""""" S IVMFLD="@"
  1. .;
  1. .; if field from IVM does not equal DHCP-store for upload
  1. .I IVMFLD]"",(IVMFLD'=IVMDHCP) D STORE
  1. .;
  1. .I IVMXREF["ZCT10" D
  1. ..I IVMFLD]"",(IVMFLD>IVMDHCP) S UPDAUPG(ZCTTYP)=1
  1. Q
  1. ;
  1. STORE ; - store HL7 fields that have a different value than DHCP fields in
  1. ; the IVM Patient (#301.5) file (#301.511) multiple for uploading
  1. ;
  1. S:$D(AUPFARY(IVMDEMDA)) UPDAUP(IVMDEMDA)=""
  1. G:IVMFLG STORE2
  1. S X=$$IEN^IVMUFNC4("PID")
  1. ;
  1. K DIC("DR")
  1. S DA(1)=IVM3015
  1. I $G(^IVM(301.5,DA(1),"IN",0))']"" S ^(0)="^301.501PA^^"
  1. S DIC="^IVM(301.5,"_DA(1)_",""IN"",",DIC(0)="L",DLAYGO=301.501
  1. K DD,DO D FILE^DICN
  1. K DIC,DLAYGO,X,Y
  1. ;
  1. ; - build mail message if SUPRESS DEMOGRAPHIC NOTIFICATION field is
  1. ; not set in the IVM Site Parameter (#301.9) file
  1. ;
  1. I '$P($G(^IVM(301.9,1,0)),"^",5),'IVMADFLG D DEMBULL^IVMPREC6
  1. ;
  1. ; - set flag in order to not repeat STORE tag for one msg
  1. S IVMFLG=1
  1. ;
  1. S DA(2)=DA(1)
  1. S DA(1)=$P(^IVM(301.5,DA(1),"IN",0),"^",3)
  1. ;
  1. STORE2 ;
  1. ; - X as the record in the IVM Demo Upload Fields (#301.92) file
  1. S X=+IVMDEMDA
  1. I $G(^IVM(301.5,DA(2),"IN",DA(1),"DEM",0))']"" S ^(0)="^301.511PA^^"
  1. S DIC="^IVM(301.5,"_DA(2)_",""IN"",DA(1),""DEM"",",DIC(0)="L"
  1. S DIC("DR")=".02////^S X=IVMFLD",DLAYGO=301.511
  1. K DD,DO D FILE^DICN
  1. K DIC,DLAYGO,X,Y
  1. ;
  1. Q
  1. ;
  1. ;
  1. LOOK ; Find the current DHCP field value.
  1. ; Input: DR -- Field number of the field in file #2
  1. ; DFN -- Pointer to the patient in file #2
  1. ; Output: Y -- Internal value of field
  1. ;
  1. N IVMOUTTY,I
  1. ;S DIC="^DPT(",DA=DFN,DIQ="IVM",DIQ(0)="I" D EN^DIQ1
  1. S DIQ(0)=$S($G(DIQ(0))="":"I",$G(DIQ(0))="E":"E",1:"I")
  1. S IVMOUTTY=DIQ(0)
  1. S DIC="^DPT(",DA=DFN,DIQ="IVM" D EN^DIQ1
  1. ;S Y=$G(IVM(2,DFN,DR,"I"))
  1. S Y=$G(IVM(2,DFN,DR,IVMOUTTY))
  1. K DIC,DIQ,DR,IVM
  1. Q
  1. AUTOEPC(DFN,UPDEPC) ;
  1. ; this functionality is copied from IVMLDEM6 and modified to allow
  1. ; an automated upload of patient communications information
  1. ; Input: DFN - as patient IEN
  1. ; UPDEPC - array contains flag for update/noupdate for all
  1. ; communication types.
  1. ; Output: IVMFLAG - 1 if communications fields updated
  1. ; 0 if communications fields not updated
  1. ;
  1. N IVMFLAG,IVMI,IVMJ,IVMNODE,IVMPTR,Y,UPDT,IVMCVAL,IVMCFLD,SITEFLD,DFLG,CTYP,UPDT
  1. S IVMFLAG=0 ;initialize flags
  1. ; - check for required parameters
  1. Q:'$G(DFN) IVMFLAG
  1. S IVMDA2=$G(IVM3015)
  1. Q:'$G(IVMDA2) IVMFLAG
  1. S IVMDA1=$O(^HL(771.3,"B","PID",""))
  1. S IVMDA1=$O(^IVM(301.5,IVMDA2,"IN","B",IVMDA1,""),-1)
  1. Q:'IVMDA1 IVMFLAG
  1. ;
  1. S IVMI=0 F S IVMI=$O(^IVM(301.92,"AD",IVMI)) Q:IVMI']"" D
  1. .S IVMJ=0 F S IVMJ=$O(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM","B",IVMI,IVMJ)) Q:IVMJ']"" D
  1. ..S (UPDT,DFLG)=0
  1. ..; - check for data node in (#301.511) sub-file
  1. ..S IVMNODE=$G(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM",IVMJ,0))
  1. ..I ('+IVMNODE)!($P(IVMNODE,"^",2)']"") Q
  1. ..;Check if fields needs to be updated for particular comm. Type.
  1. ..S CTYP=0 F S CTYP=$O(UPDEPC(CTYP)) Q:CTYP=""!UPDT D
  1. ...I ("^"_$G(UPDEPC(CTYP))_"^")[("^"_+IVMNODE_"^") S UPDT=1
  1. ..S IVMCFLD=$P($G(^IVM(301.92,+IVMNODE,0)),"^",5),IVMCVAL=$P(IVMNODE,"^",2)
  1. ..; - load communications fields rec'd from IVM into DHCP (#2) file
  1. ..I UPDT D UPLOAD^IVMLDEM6(+DFN,IVMCFLD,IVMCVAL) S IVMFLAG=1
  1. ..; delete inaccurate Addr Change Site data if Source is not VAMC
  1. ..; IVM*2.0*167 - Make Home phone records auto-upload to Patient File
  1. ..;I UPDT,((IVMCFLD=.1311)!(IVMCFLD=.1313)!(IVMCFLD=.137)) D
  1. ..I UPDT,((IVMCFLD=.1311)!(IVMCFLD=.1313)!(IVMCFLD=.137)!(IVMCFLD=.1322)) D
  1. ...I IVMCVAL="VAMC" Q
  1. ...; IVM*2.0*167 - Make Home phone records auto-upload to Patient File
  1. ...; S SITEFLD=$S(IVMCFLD=.1311:.13111,IVMCFLD=.1313:.1314,IVMCFLD=.137:.138)
  1. ...S SITEFLD=$S(IVMCFLD=.1311:.13111,IVMCFLD=.1313:.1314,IVMCFLD=.137:.138,IVMCFLD=.1322:.1323)
  1. ...S FDA(2,+DFN_",",SITEFLD)="@" D UPDATE^DIE("E","FDA")
  1. ..; - remove entry only for Email, Cell, Home phone and Pager from (#301.511) sub-file
  1. ..S CTYP=0 F S CTYP=$O(EPCFARY(CTYP)) Q:CTYP=""!DFLG D
  1. ...I ("^"_$G(EPCFARY(CTYP))_"^")[("^"_+IVMNODE_"^") S DFLG=1
  1. ..I DFLG D DELENT^IVMLDEMU(IVMDA2,IVMDA1,IVMJ)
  1. ;Delete all communication data (Email, Cell phone, Pager, Home phone) if they are not received in Z05.
  1. I $D(EPCDEL) D
  1. . N CTYPE,DIE,DR,DA,CNTR,VAL
  1. . S DR="",CNTR=0,VAL="@"
  1. . S CTYPE="" F S CTYPE=$O(EPCDEL(CTYPE)) Q:CTYPE="" D
  1. . . F I=1:1:$L(EPCDEL(CTYPE),"^") S CNTR=CNTR+1,$P(DR,";",CNTR)=$P(EPCDEL(CTYPE),"^",I)_"////^S X=VAL"
  1. . S DIE="^DPT(",DA=DFN
  1. . D ^DIE K DIE,DA,DR
  1. Q IVMFLAG
  1. ;
  1. AUTORINC(DFN) ;
  1. ; application to automatically upload Rated Incompetent data
  1. ; Input: DFN - Patient IEN
  1. N IVMI,IVMJ,IVMDA1,IVMDA2,IVMNODE,IVMFLAG,IVMRIVAL,IVMRIFLD
  1. S IVMFLAG=0
  1. S IVMDA2=$G(IVM3015)
  1. I 'IVMDA2 Q IVMFLAG
  1. S IVMDA1=$O(^HL(771.3,"B","PID",""))
  1. S IVMDA1=$O(^IVM(301.5,IVMDA2,"IN","B",IVMDA1,""),-1)
  1. S IVMI=$O(^IVM(301.92,"C","ZPD08","")) I IVMI="" Q IVMFLAG
  1. S IVMJ=$O(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM","B",IVMI,""))
  1. I IVMJ']"" Q IVMFLAG
  1. ; - check for data node in (#301.511) sub-file
  1. S IVMNODE=$G(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM",IVMJ,0))
  1. I '(+IVMNODE)!($P(IVMNODE,"^",2)']"") Q IVMFLAG
  1. S IVMRIFLD=$P($G(^IVM(301.92,+IVMNODE,0)),"^",5),IVMRIVAL=$P(IVMNODE,"^",2)
  1. I IVMRIVAL="""""" S IVMRIVAL="@"
  1. D UPLOAD^IVMLDEM6(DFN,IVMRIFLD,IVMRIVAL) S IVMFLAG=1
  1. ; - remove entry from (#301.511) sub-file
  1. D DELENT^IVMLDEMU(IVMDA2,IVMDA1,IVMJ)
  1. Q IVMFLAG
  1. PHONE ; - ask user to delete phone # [Residence] from Patient (#2) file
  1. ; This tag is moved here from IVMLDEM6 due to routine size limit
  1. D FULL^VALM1
  1. W ! S DIR("A")="Is it okay to delete the patient's Phone Number [Residence]"
  1. W ! S DIR("A",1)="The patient's address has been updated and the phonenumber"
  1. S DIR("A",2)="remains on file."
  1. S DIR("A",3)=" "
  1. S DIR("A",4)="Patient Name: "_$P($$PT^IVMUFNC4(+DFN),"^")_" ("_$P($$PT^IVMUFNC4(+DFN),"^",3)_")"
  1. S DIR("A",5)="Phone Number [Residence]: "_$P($G(^DPT(+DFN,.13)),"^")
  1. S DIR("A",6)=" "
  1. S DIR("?",1)="Enter 'YES' to delete the patient's Phone Number [Residence] that is"
  1. S DIR("?",2)="currently on file. Enter 'NO' to quit without deleting the patient's"
  1. S DIR("?")="Phone Number [Residence]."
  1. S DIR(0)="Y",DIR("B")="NO"
  1. D ^DIR K DIR
  1. S:Y $P(^DPT(DFN,.13),"^")="" W !!,"Patient's Phone Number [Residence] has ",$S(Y:"",1:"not "),"been deleted."
  1. Q
  1. ;
  1. AUTOAUP(DFN,UPDAUP,UPDAUPG) ;
  1. ; automated upload of misc information
  1. ; Input: DFN - patient IEN
  1. ; UPDAUP - array contains fields for auto-upload
  1. ; UPDAUPG - array contains field group flag for auto-upload
  1. ;
  1. N IVMDA2,IVMDA1,IVMI,MULTFLG,IVMXREF,UFLG,IVMJ,IVMNODE,IVMCFLD,IVMCVAL,Y,IVM30192,MULFIL
  1. Q:'$G(DFN)
  1. S IVMDA2=$G(IVM3015) Q:'IVMDA2
  1. S IVMDA1=$O(^HL(771.3,"B","PID",""))
  1. S IVMDA1=$O(^IVM(301.5,IVMDA2,"IN","B",IVMDA1,""),-1) Q:'IVMDA1
  1. ;
  1. S IVMI="" F S IVMI=$O(UPDAUP(IVMI)) Q:IVMI="" D
  1. .;
  1. .;If DHCP field is a multiple set multiple flag for special filing
  1. .S MULTFLG=0
  1. .S IVM30192=$G(^IVM(301.92,IVMI,0)),IVMXREF=$P(IVM30192,"^",2)
  1. .I IVMXREF="PID10" S MULTFLG=1 ;Race
  1. .I IVMXREF="PID117C" S MULTFLG=1 ;Conf Addr Category
  1. .I IVMXREF="PID22" S MULTFLG=1 ;Ethnicity
  1. .;
  1. .;Don't file if part of a group & group update flag not set
  1. .S UFLG=1 I AUPFARY(IVMI)'="",'UPDAUPG(AUPFARY(IVMI)) S UFLG=0
  1. .;
  1. .S IVMJ=0 F S IVMJ=$O(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM","B",IVMI,IVMJ)) Q:IVMJ']"" D
  1. ..S IVMNODE=$G(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM",IVMJ,0))
  1. ..I $G(AUPFARY(+$P(IVMNODE,"^")))'="",(($P(IVMNODE,"^",2)="")!($P(IVMNODE,"^",2)="""""")) S $P(IVMNODE,"^",2)="@"
  1. ..I +$G(ZEMADRUP(IVMXREF)),$P(IVMNODE,"^",2)="" S $P(IVMNODE,"^",2)="@"
  1. ..I ('+IVMNODE)!($P(IVMNODE,"^",2)']"") Q
  1. ..S IVMCFLD=$P($G(^IVM(301.92,+IVMNODE,0)),"^",5)
  1. ..S IVMCVAL=$P(IVMNODE,"^",2)
  1. ..;
  1. ..I UFLG D
  1. ...I MULTFLG D AUTOAUPM(+DFN,IVM30192,IVMCVAL) ;file mult fld
  1. ...I 'MULTFLG D UPLOAD^IVMLDEM6(+DFN,IVMCFLD,IVMCVAL) ;file non-mult
  1. ..D DELENT^IVMLDEMU(IVMDA2,IVMDA1,IVMJ) ;remove from 301.511
  1. ..; - if no display or uploadable fields left, delete the PID segment
  1. ..I '$$DEMO^IVMLDEM5(IVMDA2,IVMDA1,0),'$$DEMO^IVMLDEM5(IVMDA2,IVMDA1,1) D
  1. ...D DELETE^IVMLDEM5(IVMDA2,IVMDA1," ") ; Dummy up name parameter
  1. Q
  1. ;
  1. AUTOAUPM(DFN,IVM30192,IVMVALUE) ;
  1. ; Input: DFN - as patient IEN
  1. ; IVM30192 - as '0' node of the 301.92 entry
  1. ; IVMVALUE - as the value of the field
  1. ;
  1. ; Output: None
  1. ;
  1. N MFIL,MFLD,DDINFO,DDMNOD,DDMFLD,DA,DIK,DGENDA,MULFIL,DATA,SUB
  1. S MFIL=$P(IVM30192,"^",4),MFLD=$P(IVM30192,"^",5)
  1. S DDINFO=$G(^DD(MFIL,MFLD,0))
  1. S DDMNOD=$P($P(DDINFO,"^",4),";"),DDMFLD=+$P(DDINFO,"^",2)
  1. ;
  1. ; - delete values currently in the multiple field
  1. S DA(1)=DFN,DIK="^DPT("_DFN_","""_DDMNOD_""","
  1. S DA=0 F S DA=$O(^DPT(DFN,DDMNOD,DA)) Q:'DA D ^DIK
  1. ;
  1. ; - add new values to multiple field
  1. S DGENDA(1)=DFN
  1. ;
  1. I DDMFLD=2.02 D
  1. .S DATA(.02)=$$FIND1^DIC(10.3,,,"SELF IDENTIFICATION")
  1. .S SUB="" F S SUB=$O(IVMRACE(2,SUB)) Q:SUB="" D
  1. ..S DATA(.01)=SUB
  1. ..; Changed FileMan call for processing of DINUM recs IVM*2.0*159
  1. ..;I $$ADD^DGENDBS(DDMFLD,.DGENDA,.DATA)
  1. ..S (X,DINUM)=DATA(.01),DIC="^DPT(DFN,.02,",DA(1)=DFN,DIC(0)="L"
  1. ..K DO D FILE^DICN K DIC,X,DINUM,DA
  1. ;
  1. I DDMFLD=2.06 D
  1. .S DATA(.01)=IVMVALUE
  1. .S DATA(.02)=$$FIND1^DIC(10.3,,,"SELF IDENTIFICATION")
  1. .;Changed Fileman call for processing of Dinum recs IVM*2.0*159-BG
  1. .;I $$ADD^DGENDBS(DDMFLD,.DGENDA,.DATA)
  1. .S (X,DINUM)=DATA(.01),DIC="^DPT(DFN,.06,",DA(1)=DFN,DIC(0)="L"
  1. .K DO D FILE^DICN K DIC,X,DINUM,DA
  1. ;
  1. I DDMFLD=2.141 D
  1. .S DATA(1)="Y"
  1. .S SUB="" F S SUB=$O(CONFADCT(SUB)) Q:SUB="" D
  1. ..S DATA(.01)=SUB
  1. ..I $$ADD^DGENDBS(DDMFLD,.DGENDA,.DATA)
  1. Q
  1. PID12 ;IVM*2.0*187 Called from IVMPREC8 to reset FORADDR
  1. I $G(AUPFARY(IVMDEMDA))="CA" S IVMADDR=$G(ADDRESS("CA")) ;Conf Addr
  1. I $G(AUPFARY(IVMDEMDA))'="CA" D
  1. .S IVMADDR=$S($D(ADDRESS("P")):ADDRESS("P"),$D(ADDRESS("VAB1")):ADDRESS("VAB1"),$D(ADDRESS("VAB2")):ADDRESS("VAB2"),$D(ADDRESS("VAB3")):ADDRESS("VAB3"),$D(ADDRESS("VAB4")):ADDRESS("VAB4"),1:"")
  1. .I $G(AUPFARY(IVMDEMDA))="RA" S IVMADDR=$G(ADDRESS("R"))
  1. I IVMADDR="" Q
  1. S COUNTRY=$P(IVMADDR,$E(HLECH),6)
  1. S FORADDR=$S(COUNTRY="USA":0,1:1)
  1. Q
  1. AUTOLANG(DFN) ;IVM*2.0*210
  1. ; application to automatically upload Language data
  1. ; Input: DFN - Patient IEN
  1. ; Output 0 - Not Uploaded; 1 - Uploaded
  1. Q:'$$LANGCK^IVMPREC9(DFN)
  1. N IVMI,IVMJ,IVMDA1,IVMDA2,IVMNODE,IVMFLAG,IVMRIVAL,IVMRIFLD,IVMJLDT,IVMENDA
  1. S IVMENDA(1)=DFN
  1. S IVMFLAG=0
  1. S IVMDA2=$G(IVM3015)
  1. I 'IVMDA2 Q IVMFLAG
  1. S IVMDA1=$O(^HL(771.3,"B","PID",""))
  1. S IVMDA1=$O(^IVM(301.5,IVMDA2,"IN","B",IVMDA1,""),-1)
  1. ; Retrieve Language Date/Time
  1. S IVMI=$O(^IVM(301.92,"C","ZPD47","")) I IVMI="" Q IVMFLAG
  1. S IVMJ=$O(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM","B",IVMI,""))
  1. I IVMJ']"" Q IVMFLAG
  1. S IVMNODE=$G(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM",IVMJ,0))
  1. I '(+IVMNODE)!($P(IVMNODE,"^",2)']"") Q IVMFLAG
  1. S IVMRIVAL=$P(IVMNODE,"^",2)
  1. S IVMJLDT=IVMJ
  1. S DATA(.01)=IVMRIVAL
  1. ; Retrieve Language
  1. S IVMI=$O(^IVM(301.92,"C","ZPD46","")) I IVMI="" Q IVMFLAG
  1. S IVMJ=$O(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM","B",IVMI,""))
  1. S IVMNODE=$G(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM",IVMJ,0))
  1. I '(+IVMNODE) Q IVMFLAG
  1. S DATA(.02)=""
  1. S IVMRIVAL=$P(IVMNODE,"^",2)
  1. I IVMRIVAL="""""" S IVMRIVAL=""
  1. I IVMRIVAL]"" D
  1. .S IVMRIVAL=$TR(IVMRIVAL,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
  1. .I +IVMRIVAL=888 S DATA(.02)="DECLINED TO ANSWER" Q
  1. .I +IVMRIVAL=999 S DATA(.02)="NO PREFERENCE" Q
  1. .S IVMRIVAL=$$FIND1^DIC(.85,,"MX",IVMRIVAL)
  1. .I IVMRIVAL]"" S DATA(.02)=$$GET1^DIQ(.85,IVMRIVAL,.01) ; Language
  1. I $$ADD^DGENDBS(2.07,.IVMENDA,.DATA) S IVMFLAG=1
  1. ; - remove entries from (#301.511) sub-file
  1. D DELENT^IVMLDEMU(IVMDA2,IVMDA1,IVMJLDT)
  1. D DELENT^IVMLDEMU(IVMDA2,IVMDA1,IVMJ)
  1. Q IVMFLAG
  1. LANGCK(DFN) ;IVM*2.0*210 - Check if Language Date and Time needs to be uploaded or not.
  1. ;
  1. ; Input: DFN
  1. ; Output: 0 - Don't Upload; 1 - Upload
  1. ;
  1. N IVMDATE,IVMDA,IVMLANGDT
  1. ;
  1. S IVMLANGDT="",IVMDA=""
  1. ;
  1. I $P(IVMSEG,"^",47)=""""""!($P(IVMSEG,"^",47)="") Q 0
  1. ; Retrieve Preferred Language and Preferred Language Date/Time
  1. S IVMDATE="",IVMDATE=$O(^DPT(DFN,.207,"B",IVMDATE),-1)
  1. I IVMDATE'="" S IVMDA=$O(^DPT(DFN,.207,"B",IVMDATE,0))
  1. I IVMDA'="" S IVMLANGDT=$$GET1^DIQ(2.07,IVMDA_","_DFN_",",.01,"I")
  1. I IVMLANGDT="" Q 1
  1. I $$FMDATE^HLFNC($P(IVMSEG,"^",47))<=IVMLANGDT Q 0
  1. ;
  1. Q 1 ;
  1. ;