- IVMPREC9 ;ALB/KCL,BRM,CKN,TDM,KUM,JAM,KUM - PROCESS INCOMING (Z05 EVENT TYPE) HL7 MESSAGES (CON'T) ;09-05-2017 10:03am
- ;;2.0;INCOME VERIFICATION MATCH;**34,58,115,121,151,159,167,192,193,187,210**;21-OCT-94;Build 13
- ;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))
- ..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 15507 printed Feb 18, 2025@23:27:56 Page 2
- 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
- +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 IF ('+IVMNODE)!($PIECE(IVMNODE,"^",2)']"")
- QUIT
- +25 ;Check if fields needs to be updated for particular comm. Type.
- +26 SET CTYP=0
- FOR
- SET CTYP=$ORDER(UPDEPC(CTYP))
- if CTYP=""!UPDT
- QUIT
- Begin DoDot:3
- +27 IF ("^"_$GET(UPDEPC(CTYP))_"^")[("^"_+IVMNODE_"^")
- SET UPDT=1
- End DoDot:3
- +28 SET IVMCFLD=$PIECE($GET(^IVM(301.92,+IVMNODE,0)),"^",5)
- SET IVMCVAL=$PIECE(IVMNODE,"^",2)
- +29 ; - load communications fields rec'd from IVM into DHCP (#2) file
- +30 IF UPDT
- DO UPLOAD^IVMLDEM6(+DFN,IVMCFLD,IVMCVAL)
- SET IVMFLAG=1
- +31 ; delete inaccurate Addr Change Site data if Source is not VAMC
- +32 ; IVM*2.0*167 - Make Home phone records auto-upload to Patient File
- +33 ;I UPDT,((IVMCFLD=.1311)!(IVMCFLD=.1313)!(IVMCFLD=.137)) D
- +34 IF UPDT
- IF ((IVMCFLD=.1311)!(IVMCFLD=.1313)!(IVMCFLD=.137)!(IVMCFLD=.1322))
- Begin DoDot:3
- +35 IF IVMCVAL="VAMC"
- QUIT
- +36 ; IVM*2.0*167 - Make Home phone records auto-upload to Patient File
- +37 ; S SITEFLD=$S(IVMCFLD=.1311:.13111,IVMCFLD=.1313:.1314,IVMCFLD=.137:.138)
- +38 SET SITEFLD=$SELECT(IVMCFLD=.1311:.13111,IVMCFLD=.1313:.1314,IVMCFLD=.137:.138,IVMCFLD=.1322:.1323)
- +39 SET FDA(2,+DFN_",",SITEFLD)="@"
- DO UPDATE^DIE("E","FDA")
- End DoDot:3
- +40 ; - remove entry only for Email, Cell, Home phone and Pager from (#301.511) sub-file
- +41 SET CTYP=0
- FOR
- SET CTYP=$ORDER(EPCFARY(CTYP))
- if CTYP=""!DFLG
- QUIT
- Begin DoDot:3
- +42 IF ("^"_$GET(EPCFARY(CTYP))_"^")[("^"_+IVMNODE_"^")
- SET DFLG=1
- End DoDot:3
- +43 IF DFLG
- DO DELENT^IVMLDEMU(IVMDA2,IVMDA1,IVMJ)
- End DoDot:2
- End DoDot:1
- +44 ;Delete all communication data (Email, Cell phone, Pager, Home phone) if they are not received in Z05.
- +45 IF $DATA(EPCDEL)
- Begin DoDot:1
- +46 NEW CTYPE,DIE,DR,DA,CNTR,VAL
- +47 SET DR=""
- SET CNTR=0
- SET VAL="@"
- +48 SET CTYPE=""
- FOR
- SET CTYPE=$ORDER(EPCDEL(CTYPE))
- if CTYPE=""
- QUIT
- Begin DoDot:2
- +49 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
- +50 SET DIE="^DPT("
- SET DA=DFN
- +51 DO ^DIE
- KILL DIE,DA,DR
- End DoDot:1
- +52 QUIT IVMFLAG
- +53 ;
- 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 ;