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