IVMPREC6 ;ALB/KCL,BRM,CKN,TDM,PWC,LBD,JAM,KUM - PROCESS INCOMING (Z05 EVENT TYPE) HL7 MESSAGES ;09-02-2019 8:06AM
;;2.0;INCOME VERIFICATION MATCH;**3,4,12,17,34,58,79,102,115,140,144,121,151,152,165,167,171,164,188,192,193,204**;21-OCT-94;Build 20
;Per VA Directive 6402, this routine should not be modified.
;
; This routine will process batch ORU demographic (event type Z05) HL7
; messages received from the IVM center. Format of HL7 batch message:
;
; BHS
; {MSH
; PID
; ZPD
; ZTA
; ZAV
; ZGD
; ZCT (1 episode required, multiple possible)
; ZEM (Veteran)
; ZEM (Spouse - Optional)
; RF1 (optional, multiple possible)
; }
; BTS
;
;
EN ; - entry point to process HL7 patient demographic message
;
N DGENUPLD,VAFCA08,DGRUGA08,COMP,DODSEG,GUARSEG,IVMCSDT,IVMCEDT,IVMCAFG,IVMCAVL,IVMPMAST,IVMCMAST
;N MULTDONE,XREP
N XIVMA,IVMALADT,MULTIDONE
N IVMPHDFG S IVMPHDFG=0 ; IVM*2*171 - add new variable IVMPHDFG to check for PHH deletion
S IVMPMAST=""
;
; Setup array to hold all the Allowed Address Types
;F XIVMA="N","P","VAB1","VAB2","VAB3","VAB4" S IVMALADT(XIVMA)=""
; IVM*2.0*164 - Allow Residential and Confidential Addresses
F XIVMA="P","R","CA","VAB1","VAB2","VAB3","VAB4" S IVMALADT(XIVMA)=""
; Define the Confidential Address Categories
; IVM*2.0*164 - Uncomment below five lines to enable all confidential address categories
S IVMALADT("VACAE")="CA^1" ; ELIGIBILITY/ENROLLMENT
S IVMALADT("VACAA")="CA^2" ; APPOINTMENT/SCHEDULING
S IVMALADT("VACAC")="CA^3" ; COPAYMENTS/VETERAN BILLING
S IVMALADT("VACAM")="CA^4" ; MEDICAL RECORDS
S IVMALADT("VACAO")="CA^5" ; ALL OTHERS
; prevent a return Z07 when uploading a Z05 (Patient file triggers)
S DGENUPLD="ENROLLMENT/ELIGIBILITY UPLOAD IN PROGRESS"
;
; prevent MPI A08 message when uploading Z05 (Patient file triggers)
S VAFCA08=1 ;MPI/CIRN A08 suppression flag
;
S IVMFLG=0,IVMADFLG=0
; - get incoming HL7 message from HL7 Transmission (#772) file
F IVMDA=0:0 S IVMDA=$O(^TMP($J,IVMRTN,IVMDA)) Q:'IVMDA S IVMSEG=$G(^(IVMDA,0)) I $E(IVMSEG,1,3)="MSH" D
.K HLERR,ZEMADRUP
.S IVMTSTPT="" ;Initialize Temp Addr County
.;
.; - message control id from MSH segment
.S MSGID=$P(IVMSEG,HLFS,10),HLMID=MSGID
.;
.; - perform demographics message consistency check
.D EN^IVMPRECA Q:$D(HLERR)
.;
.;Set array of Email, Cell, Pager fields
.D EPCFLDS(.EPCFARY,.EPCDEL)
.D AUPBLD(.AUPFARY,.UPDAUPG)
.; - get next msg segment
.D NEXT I $E(IVMSEG,1,3)'="PID" D Q
..S HLERR="Missing PID segment" D ACK^IVMPREC
.;
.F I=1:1 D NEXT Q:$E(IVMSEG,1,4)="ZPD^" ;Go through all PID
.; - patient IEN (DFN) from PID segment
.;Use IVMPID array created in IVMPRECA while performing consistency
.;to process PID segment
.;
.;I '$G(IVMDFN) S HLERR="Invalid DFN" D ACK^IVMPREC Q
.S DFN=$G(IVMDFN)
.;I ('DFN!(DFN'=+DFN)!('$D(^DPT(+DFN,0)))) D Q
.;.S HLERR="Invalid DFN" D ACK^IVMPREC
.;I IVMPID(19)'=$P(^DPT(DFN,0),"^",9) D Q
.;.S HLERR="Couldn't match HEC SSN with DHCP SSN" D ACK^IVMPREC
.;
.; - check for entry in IVM PATIENT file, otherwise create stub entry
.S IVM3015=$O(^IVM(301.5,"B",DFN,0))
.I 'IVM3015 S DGENUPLD="",IVM3015=$$LOG^IVMPLOG(DFN,DT),DGENUPLD="ENROLLMENT/ELIGIBILITY UPLOAD IN PROGRESS" ;IVM*2.0*165
.I 'IVM3015 D Q
..S HLERR="Failed to create entry in IVM PATIENT file"
..D ACK^IVMPREC
.;
.; - compare PID segment fields with DHCP fields
.S IVMSEG="PID" ;Setting IVMSEG to PID before it calls COMPARE
.I 'DODSEG,'GUARSEG D COMPARE(IVMSEG) Q:$D(HLERR)
.;
.; - get next msg segment -decrement the counter so it can pickup ZPD
.S IVMDA=IVMDA-1 D NEXT I $E(IVMSEG,1,3)'="ZPD" D Q
..S HLERR="Missing ZPD segment" D ACK^IVMPREC
.;Convert "" to null in ZPD segment except seq. 8,9, 31 and 32
.S IVMSEG=$$CLEARF^IVMPRECA(IVMSEG,HLFS,",9,10,32,33,")
.;
.; - compare ZPD segment fields with DHCP fields
.D COMPARE(IVMSEG)
.;
.; - get next msg segment
.D NEXT I $E(IVMSEG,1,3)="ZEL" D Q
..S HLERR="ZEL segment should not be sent in Z05 message" D ACK^IVMPREC
.;
.I $E(IVMSEG,1,3)'="ZTA" D Q
..S HLERR="Missing ZTA segment" D ACK^IVMPREC
.;Convert "" to null in ZTA segment seq. 7
.I $P(IVMSEG,HLFS,8)=HLQ S $P(IVMSEG,HLFS,8)=""
.;
.; - compare ZTA segment fields with DHCP fields
.I 'DODSEG,'GUARSEG D COMPARE(IVMSEG)
.;
.; - get next msg segment
.; KUM - ZAV Segment Processing (CASS field)
.D NEXT
.I $E(IVMSEG,1,3)'="ZAV" D Q
..S HLERR="Missing ZAV segment" D ACK^IVMPREC
.S IVMSEG=$$CLEARF^IVMPRECA(IVMSEG,HLFS)
.I 'DODSEG,'GUARSEG D COMPARE(IVMSEG) ;Process 1st ZAV
.S MULTDONE=0 F XREP=1:1 D Q:MULTDONE ;Handle possible mult ZAVs
..D NEXT I $E(IVMSEG,1,3)'="ZAV" S MULTDONE=1 Q
..S IVMSEG=$$CLEARF^IVMPRECA(IVMSEG,HLFS)
..I 'DODSEG,'GUARSEG D COMPARE(IVMSEG)
.;D NEXT
.;
.; - get next msg segment
.I $E(IVMSEG,1,3)'="ZGD" D Q
..S HLERR="Missing ZGD segment" D ACK^IVMPREC
.;
.; - compare ZGD segment fields with DHCP fields
.; convert "" to null for ZGD segment
.S IVMSEG=$$CLEARF^IVMPRECA(IVMSEG,HLFS,",7,") ;ignore seq. 6
.; convert seq. 6 separately
.S $P(IVMSEG,HLFS,7)=$$CLEARF^IVMPRECA($P(IVMSEG,HLFS,7),$E(HLECH))
.D COMPARE(IVMSEG)
.;S IVMFLG=0
.;
.;S MULTDONE=0 F XREP=1:1 D Q:MULTDONE ;Skip ZCT & ZEM -coming later
.;.D NEXT
.;.I ($E(IVMSEG,1,3)'="ZCT")&($E(IVMSEG,1,3)'="ZEM") S MULTDONE=1 Q
.;S IVMDA=IVMDA-1
.;
.; - get next msg segment
.D NEXT
.I $E(IVMSEG,1,3)'="ZCT" D Q
..S HLERR="Missing ZCT segment" D ACK^IVMPREC
.;KUM - Donot convert "" to null in ZCT segment
.;IVM*2.0*188 - Comment below line. Allow double quotes to stay in ZCT segment, otherwise double quotes will be replaced with null
.;S IVMSEG=$$CLEARF^IVMPRECA(IVMSEG,HLFS)
.I 'DODSEG,'GUARSEG D COMPARE(IVMSEG) ;Process 1st ZCT
.S MULTDONE=0 F XREP=1:1 D Q:MULTDONE ;Handle possible mult ZCTs
..D NEXT I $E(IVMSEG,1,3)'="ZCT" S MULTDONE=1 Q
..;KUM - Donot convert "" to null in ZCT segment
..;IVM*2.0*188 - Comment below line. Allow double quotes to stay in ZCT segment, otherwise double quotes will be replaced with null
..;S IVMSEG=$$CLEARF^IVMPRECA(IVMSEG,HLFS)
..I 'DODSEG,'GUARSEG D COMPARE(IVMSEG)
.;
.S IVMDA=IVMDA-1 D NEXT
.I $E(IVMSEG,1,3)'="ZEM" D Q
..S HLERR="Missing ZEM segment" D ACK^IVMPREC
.I 'DODSEG,'GUARSEG D COMPARE(IVMSEG) ;Process 1st ZEM
.S MULTDONE=0 F XREP=1:1 D Q:MULTDONE ;Handle possible mult ZEMs
..D NEXT I $E(IVMSEG,1,3)'="ZEM" S MULTDONE=1 Q
..I 'DODSEG,'GUARSEG D COMPARE(IVMSEG)
.S IVMDA=IVMDA-1
.;
.; - check for RF1 segment and get segment if it exists
.; This process will automatically update patient address data
.; in the Patient (#2) file if the incoming address is more
.; recent than the existing one.
.;Modified code to handle multiple RF1 segment - IVM*2*115
.S (UPDEPC("SAD"),UPDEPC("CPH"),UPDEPC("PNO"),UPDEPC("EAD"),UPDEPC("PHH"))=0
.S QFLG=0 I $$RF1CHK(IVMRTN,IVMDA) F I=1:1 D Q:QFLG
..D NEXT
..S IVMSEG=$$CLEARF^IVMPRECA(IVMSEG,HLFS,",7,") ;ignore seq. 6
..S $P(IVMSEG,HLFS,7)=$$CLEARF^IVMPRECA($P(IVMSEG,HLFS,7),$E(HLECH))
..I $P(IVMSEG,HLFS,4)="" S QFLG=1 Q ;Quit if RF1 is blank
..D COMPARE(IVMSEG)
..I '$$RF1CHK(IVMRTN,IVMDA) S QFLG=1
.; KUM - IVM*2.0*164 - Set Confidential Active flag
.S IVMCSDT="",IVMCEDT="",IVMCAFG=.14105,IVMCAVL="Y"
.S IVMCSDT=$P($P($G(ADDRESS("CA")),"~",12),"&",1)
.S IVMCSDT=$$FMDATE^HLFNC(IVMCSDT)
.S IVMCEDT=$P($P($G(ADDRESS("CA")),"~",12),"&",2)
.S IVMCEDT=$$FMDATE^HLFNC(IVMCEDT)
.I IVMCSDT="" D
..;I $G(UPDAUPG("CA"))'=1 Q
..S IVMCAVL="N"
.D AUTOAUP^IVMPREC9(DFN,.UPDAUP,.UPDAUPG)
.S IVMFLG=0
; - send mail message if necessary
; This bulletin has been disabled. IVM*2*140
;I IVMCNTR D MAIL^IVMUFNC()
; Cleanup variables if no msg necessary
I 'IVMCNTR K IVMTEXT,XMSUB
;
ENQ ; - cleanup variables
K DA,DR,DFN,IVMADDR,IVMADFLG,IVMDA,IVMDHCP,IVMFLAG,IVMFLD,IVMPHDFG,IVMPIECE,IVMSEG,IVMSTART,IVMXREF,DGENUPLD,IVMPID,PIDSTR,ADDRESS,TELECOM,UPDEPC,EPCFARY,IVMDFN,DODSEG,EPCDEL,GUARSEG,UPDAUP,IVMRACE,IVMTSTPT,IVMPMAST
Q
;
;
NEXT ; - get the next HL7 segment in the message from HL7 Transmission (#772) file
;
S IVMDA=$O(^TMP($J,IVMRTN,IVMDA)),IVMSEG=$G(^(+IVMDA,0))
Q
;
;
COMPARE(IVMSEG) ; - compare incoming HL7 segment/fields with DHCP fields
;
; Input: IVMSEG -- as the text of the incoming HL7 message
;
; Output: None
;
; - get 3 letter HL7 segment name
S IVMXREF=$P(IVMSEG,HLFS,1),IVMSTART=IVMXREF
;
; - strip off HL7 segment name
S IVMSEG=$P(IVMSEG,HLFS,2,99)
;
; - roll through "C" x-ref in IVM Demographic Upload Fields (#301.92) file
F S IVMXREF=$O(^IVM(301.92,"C",IVMXREF)) Q:IVMXREF']"" D
.S IVMDEMDA=$O(^IVM(301.92,"C",IVMXREF,"")) Q:IVMDEMDA']""
.I $$INACTIVE(IVMDEMDA) Q
.;
.; - compare incoming HL7 segment fields with DHCP fields
.I IVMXREF["PID",(IVMSTART["PID") D PID^IVMPREC8
.I IVMXREF["ZPD",(IVMSTART["ZPD") D ZPD^IVMPREC8
.I IVMXREF["ZTA",(IVMSTART["ZTA") D ZTA^IVMPREC8
.; KUM IVM*2.0*164 - ZAV Segment Processing
.I IVMXREF["ZAV",(IVMSTART["ZAV") D ZAV^IVMPREC8
.;
.I IVMXREF["ZGD",(IVMSTART["ZGD") D ZGD^IVMPREC8
.; IVM*2.0*192; JAM; Tag ZCT moved to IVMPREC9
.I IVMXREF["ZCT",(IVMSTART["ZCT") D ZCT^IVMPREC9
.I IVMXREF["ZEM",(IVMSTART["ZEM") D ZEM^IVMPREC8
.I IVMXREF["RF1",(IVMSTART["RF1") D RF1^IVMPREC8
Q
;
;
DEMBULL ; - build mail message for transmission to IVM mail group notifying
; them that patients with updated demographic data has been received
; from the IVM Center and may now be uploaded into DHCP.
;
; If record is auto uploaded, don't add veteran to bulletin
I $$CKAUTO Q
;
S IVMPTID=$$PT^IVMUFNC4(DFN)
S XMSUB="IVM - DEMOGRAPHIC UPLOAD for "_$P($P(IVMPTID,"^"),",")_" ("_$P(IVMPTID,"^",3)_")"
S IVMTEXT(1)="Updated demographic information has been received from the"
S IVMTEXT(2)="Health Eligibilty Center. Please select the 'Demographic Upload'"
S IVMTEXT(3)="option from the IVM Upload Menu in order to take action on this"
S IVMTEXT(4)="demographic information. If you have any questions concerning the"
S IVMTEXT(5)="information received, please contact the Health Eligibility Center."
S IVMTEXT(7)=""
S IVMTEXT(8)="The Health Eligibilty Center has identified the following"
S IVMTEXT(9)="patients as having updated demographic information:"
S IVMTEXT(10)=""
S IVMCNTR=IVMCNTR+1
S IVMTEXT(IVMCNTR+10)=$J(IVMCNTR_")",5)_" "_$P(IVMPTID,"^")_" ("_$P(IVMPTID,"^",3)_")"
Q
;
INACTIVE(IVMDEMDA) ;Check if field is inactive in Demographic Upload
; Input -- IVMDEMDA IVM Demographic Upload Fields IEN
; Output -- 1=Yes and 0=No
Q +$P($G(^IVM(301.92,IVMDEMDA,0)),U,9)
;
RF1CHK(IVMRTN,IVMDA) ;does an RF1 segment exist in this message?
N RF1
S RF1=$O(^TMP($J,IVMRTN,IVMDA))
I $E($G(^(+RF1,0)),1,3)'="RF1" Q 0
Q 1
;
CKAUTO() ;
; Chect if message qualifies for an auto upload.
N AUTO,IVMI,DOD
S AUTO=0,IVMI=$O(^IVM(301.92,"C","ZPD09",""))
I IVMI=IVMDEMDA D
.I +IVMFLD'>0 S AUTO=1 Q
.S DOD=$P($G(^DPT(DFN,.35)),U)
.I DOD=IVMFLD S AUTO=1 Q
;
Q AUTO
BLDPID(PIDTMP,IVMPID) ;Build IVMPID subscripted by sequence number
N STR,X1,X2,N,TEXT,C,L
S STR="",X1=1,(N,X2)=0
F S N=$O(PIDTMP(N)) Q:N="" S TEXT=PIDTMP(N) F L=1:1:$L(TEXT) S C=$E(TEXT,L) D
. I C="^" D Q
. . I X2 S X2=X2+1,IVMPID(X1,X2)=STR
. . E S IVMPID(X1)=STR
. . S STR="",X1=X1+1,X2=0
. I C="|" D Q
. . S X2=X2+1,IVMPID(X1,X2)=STR,STR=""
. S STR=STR_C
I $G(C)'="",$G(C)'="^",$G(C)'="|" D
. I X2 S X2=X2+1,IVMPID(X1,X2)=STR Q
. S IVMPID(X1)=STR
Q
ADDRCHNG(DFN) ;Store Address Change Date/time, Source and site if necessary
;Store Residence Number Change Date/Time, Source and Site (IVM*2*152)
N IVMVALUE,IVMFIELD
I '$D(^TMP($J,"CHANGE UPDATE")) Q
S IVMFIELD=0 F S IVMFIELD=$O(^TMP($J,"CHANGE UPDATE",IVMFIELD)) Q:IVMFIELD="" D
. S IVMVALUE=$G(^TMP($J,"CHANGE UPDATE",IVMFIELD))
. S DIE="^DPT(",DA=DFN,DR=IVMFIELD_"////^S X=IVMVALUE"
. D ^DIE K DA,DIE,DR
.; - delete inaccurate Addr Change Site data if Source is not VAMC
. I IVMFIELD=.119,IVMVALUE'="VAMC" S FDA(2,+DFN_",",.12)="@" D UPDATE^DIE("E","FDA")
.; - delete inaccurate Residence Number Change Site data if Source
.; is not VAMC (IVM*2*152)
. I IVMFIELD=.1322,IVMVALUE'="VAMC" S FDA(2,+DFN_",",.1323)="@" D UPDATE^DIE("E","FDA")
K ^TMP($J,"CHANGE UPDATE")
Q
EPCFLDS(EPCFARY,EPCDEL) ;
;EPCFARY - Contains IENs of Pager, email, Cell phone and Home phone records in 301.92 File - Passed by reference
;EPCDEL - Contains field # of Pager, Email, Cell phone and Home phone fields in Patient(#2) file. - Passed by reference
I (DODSEG)!(GUARSEG) Q
S EPCFARY("PNO")=$O(^IVM(301.92,"B","PAGER NUMBER",0))_"^"_$O(^IVM(301.92,"B","PAGER CHANGE DT/TM",0))_"^"_$O(^IVM(301.92,"B","PAGER CHANGE SITE",0))_"^"_$O(^IVM(301.92,"B","PAGER CHANGE SOURCE",0))
S EPCFARY("CPH")=$O(^IVM(301.92,"B","CELLULAR NUMBER",0))_"^"_$O(^IVM(301.92,"B","CELL PHONE CHANGE DT/TM",0))_"^"_$O(^IVM(301.92,"B","CELL PHONE CHANGE SITE",0))_"^"_$O(^IVM(301.92,"B","CELL PHONE CHANGE SOURCE",0))
S EPCFARY("EAD")=$O(^IVM(301.92,"B","EMAIL ADDRESS",0))_"^"_$O(^IVM(301.92,"B","EMAIL CHANGE DT/TM",0))_"^"_$O(^IVM(301.92,"B","EMAIL CHANGE SITE",0))_"^"_$O(^IVM(301.92,"B","EMAIL CHANGE SOURCE",0))
; IVM*2.0*167 - Make Home phone records auto-upload to Patient File
S EPCFARY("PHH")=$O(^IVM(301.92,"B","PHONE NUMBER [RESIDENCE]",0))_"^"_$O(^IVM(301.92,"B","RESIDENCE NUMBER CHANGE DT/TM",0))_"^"_$O(^IVM(301.92,"B","RESIDENCE NUMBER CHANGE SITE",0))_"^"_$O(^IVM(301.92,"B","RESIDENCE NUMBER CHANGE SOURCE",0))
S EPCDEL("PNO")=".135^.1312^.1313^.1314"
S EPCDEL("CPH")=".134^.139^.1311^.13111"
S EPCDEL("EAD")=".133^.136^.137^.138"
; IVM*2.0*167 - Make Home phone records auto-upload to Patient File
; IVM*2.0*171 - Comment out line to fix the home phone deletion issue
;S EPCDEL("PHH")=".131^.1321^.1322^.1323"
Q
;
AUPBLD(AUPFARY,UPDAUPG) ; Set up array containing fields for auto upload.
;AUPFARY - Contains fields in 301.92 File-Passed by reference
;UPDAUPG - Contains all groups initialized to '0'
N AUPSTR,AUPGRP,AUPFLST,AUPPCE,AUPSGSQ,AUPDA
F I=3:1 S AUPSTR=$P($T(AUPLST+I),";;",2,3) Q:$P(AUPSTR,";")="QUIT" D
.S AUPGRP=$P(AUPSTR,";"),AUPFLST=$P(AUPSTR,";",2)
.F AUPPCE=1:1:$L(AUPFLST,"^") D
..S AUPSGSQ=$P(AUPFLST,"^",AUPPCE) Q:AUPSGSQ=""
..S AUPDA=$O(^IVM(301.92,"C",AUPSGSQ,0)) Q:AUPDA=""
..S AUPFARY(AUPDA)=AUPGRP
..S:AUPGRP'="" UPDAUPG(AUPGRP)=0 ; Default group update flags to '0'
Q
;
; IVM*2.0*164 - ZAV01,ZAV02 AND ZAV04 are added for Auto Upload.
; Residential Address (RA) group is added
; Confidential Address (CA) group is uncommented
; IVM*2.0*193; JAM ; Added fields to groups K1,K2,E1,E2 and D for foreign address fields: Province, Postal Code and Country)
; eg ZCT056K1, ZCT054K1F, ZCT055K1F (COUNTRY, PROV, POSTAL CODE for the K1 group)
; IVM*2.0*204 - Add ZCT08K1, ZCT08K2, ZCT08E1, ZCT08E2, ZCT08D1 for Auto Upload.
AUPLST ; P1;P2
; P1 = Group Name (treat all entries as this group if present)
; P2 = .01 field(s) from 301.92 separated by '^'
;;D1;ZCT03D1^ZCT04D1^ZCT051D1^ZCT052D1^ZCT053D1^ZCT054D1^ZCT055D1^ZCT054D1F^ZCT055D1F^ZCT056D1^ZCT06D1^ZCT07D1^ZCT10D1^ZCT11D1
;;E1;ZCT03E1^ZCT04E1^ZCT051E1^ZCT052E1^ZCT053E1^ZCT054E1^ZCT055E1^ZCT054E1F^ZCT055E1F^ZCT056E1^ZCT06E1^ZCT07E1^ZCT10E1^ZCT11E1
;;E2;ZCT03E2^ZCT04E2^ZCT051E2^ZCT052E2^ZCT053E2^ZCT054E2^ZCT055E2^ZCT054E2F^ZCT055E2F^ZCT056E2^ZCT06E2^ZCT07E2^ZCT10E2^ZCT11E2
;;K1;ZCT03K1^ZCT04K1^ZCT051K1^ZCT052K1^ZCT053K1^ZCT054K1^ZCT055K1^ZCT054K1F^ZCT055K1F^ZCT056K1^ZCT06K1^ZCT07K1^ZCT10K1^ZCT11K1
;;K2;ZCT03K2^ZCT04K2^ZCT051K2^ZCT052K2^ZCT053K2^ZCT054K2^ZCT055K2^ZCT054K2F^ZCT055K2F^ZCT056K2^ZCT06K2^ZCT07K2^ZCT10K2^ZCT11K2
;;TA;ZTA02^ZTA03^ZTA04^ZTA051^ZTA052^ZTA053^ZTA054^ZTA055^ZTA056^ZTA058^ZTA059^ZTA07^ZTA08^ZTA09^ZTA054F^ZTA055F^ZAV04
;;CA;PID111C^PID112C^PID113C^PID114C^PID114CF^PID115C^PID115CF^PID116C^PID117C^PID118C^PID119C^PID1110C^PID1112C^PID1113C^PID13CA^RF161CA^RF171CA^ZAV02
;;RA;PID111R^PID112R^PID113R^PID114R^PID114RF^PID115R^PID115RF^PID116R^PID117R^PID118R^PID119R^PID1110R^PID1112R^PID1113R^PID13RA^RF161RA^RF162RA^RF171RA^ZAV01
;;;ZEM03^ZEM04^ZEM05^ZEM061^ZEM062^ZEM063^ZEM064^ZEM065^ZEM068^ZEM07^ZEM09
;;;ZEM03S^ZEM04S^ZEM05S^ZEM061S^ZEM062S^ZEM063S^ZEM064S^ZEM065S^ZEM068S^ZEM07S^ZEM09S
;;;PID06^PID10^PID16^PID17^PID22^ZPD30^ZPD06^ZPD07
;;QUIT
;;
;;The following have been disabled until further notice
;;;PID113N^PID114N^PID24^PID13W
;;CA;PID111C^PID112C^PID113C^PID114C^PID114CF^PID115C^PID115CF^PID116C^PID117C^PID118C^PID119C^PID1112C1^PID1112C2^PID13CA^RF161CA^RF171CA
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIVMPREC6 16916 printed Apr 09, 2024@21:03:56 Page 2
IVMPREC6 ;ALB/KCL,BRM,CKN,TDM,PWC,LBD,JAM,KUM - PROCESS INCOMING (Z05 EVENT TYPE) HL7 MESSAGES ;09-02-2019 8:06AM
+1 ;;2.0;INCOME VERIFICATION MATCH;**3,4,12,17,34,58,79,102,115,140,144,121,151,152,165,167,171,164,188,192,193,204**;21-OCT-94;Build 20
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ; This routine will process batch ORU demographic (event type Z05) HL7
+5 ; messages received from the IVM center. Format of HL7 batch message:
+6 ;
+7 ; BHS
+8 ; {MSH
+9 ; PID
+10 ; ZPD
+11 ; ZTA
+12 ; ZAV
+13 ; ZGD
+14 ; ZCT (1 episode required, multiple possible)
+15 ; ZEM (Veteran)
+16 ; ZEM (Spouse - Optional)
+17 ; RF1 (optional, multiple possible)
+18 ; }
+19 ; BTS
+20 ;
+21 ;
EN ; - entry point to process HL7 patient demographic message
+1 ;
+2 NEW DGENUPLD,VAFCA08,DGRUGA08,COMP,DODSEG,GUARSEG,IVMCSDT,IVMCEDT,IVMCAFG,IVMCAVL,IVMPMAST,IVMCMAST
+3 ;N MULTDONE,XREP
+4 NEW XIVMA,IVMALADT,MULTIDONE
+5 ; IVM*2*171 - add new variable IVMPHDFG to check for PHH deletion
NEW IVMPHDFG
SET IVMPHDFG=0
+6 SET IVMPMAST=""
+7 ;
+8 ; Setup array to hold all the Allowed Address Types
+9 ;F XIVMA="N","P","VAB1","VAB2","VAB3","VAB4" S IVMALADT(XIVMA)=""
+10 ; IVM*2.0*164 - Allow Residential and Confidential Addresses
+11 FOR XIVMA="P","R","CA","VAB1","VAB2","VAB3","VAB4"
SET IVMALADT(XIVMA)=""
+12 ; Define the Confidential Address Categories
+13 ; IVM*2.0*164 - Uncomment below five lines to enable all confidential address categories
+14 ; ELIGIBILITY/ENROLLMENT
SET IVMALADT("VACAE")="CA^1"
+15 ; APPOINTMENT/SCHEDULING
SET IVMALADT("VACAA")="CA^2"
+16 ; COPAYMENTS/VETERAN BILLING
SET IVMALADT("VACAC")="CA^3"
+17 ; MEDICAL RECORDS
SET IVMALADT("VACAM")="CA^4"
+18 ; ALL OTHERS
SET IVMALADT("VACAO")="CA^5"
+19 ; prevent a return Z07 when uploading a Z05 (Patient file triggers)
+20 SET DGENUPLD="ENROLLMENT/ELIGIBILITY UPLOAD IN PROGRESS"
+21 ;
+22 ; prevent MPI A08 message when uploading Z05 (Patient file triggers)
+23 ;MPI/CIRN A08 suppression flag
SET VAFCA08=1
+24 ;
+25 SET IVMFLG=0
SET IVMADFLG=0
+26 ; - get incoming HL7 message from HL7 Transmission (#772) file
+27 FOR IVMDA=0:0
SET IVMDA=$ORDER(^TMP($JOB,IVMRTN,IVMDA))
if 'IVMDA
QUIT
SET IVMSEG=$GET(^(IVMDA,0))
IF $EXTRACT(IVMSEG,1,3)="MSH"
Begin DoDot:1
+28 KILL HLERR,ZEMADRUP
+29 ;Initialize Temp Addr County
SET IVMTSTPT=""
+30 ;
+31 ; - message control id from MSH segment
+32 SET MSGID=$PIECE(IVMSEG,HLFS,10)
SET HLMID=MSGID
+33 ;
+34 ; - perform demographics message consistency check
+35 DO EN^IVMPRECA
if $DATA(HLERR)
QUIT
+36 ;
+37 ;Set array of Email, Cell, Pager fields
+38 DO EPCFLDS(.EPCFARY,.EPCDEL)
+39 DO AUPBLD(.AUPFARY,.UPDAUPG)
+40 ; - get next msg segment
+41 DO NEXT
IF $EXTRACT(IVMSEG,1,3)'="PID"
Begin DoDot:2
+42 SET HLERR="Missing PID segment"
DO ACK^IVMPREC
End DoDot:2
QUIT
+43 ;
+44 ;Go through all PID
FOR I=1:1
DO NEXT
if $EXTRACT(IVMSEG,1,4)="ZPD^"
QUIT
+45 ; - patient IEN (DFN) from PID segment
+46 ;Use IVMPID array created in IVMPRECA while performing consistency
+47 ;to process PID segment
+48 ;
+49 ;I '$G(IVMDFN) S HLERR="Invalid DFN" D ACK^IVMPREC Q
+50 SET DFN=$GET(IVMDFN)
+51 ;I ('DFN!(DFN'=+DFN)!('$D(^DPT(+DFN,0)))) D Q
+52 ;.S HLERR="Invalid DFN" D ACK^IVMPREC
+53 ;I IVMPID(19)'=$P(^DPT(DFN,0),"^",9) D Q
+54 ;.S HLERR="Couldn't match HEC SSN with DHCP SSN" D ACK^IVMPREC
+55 ;
+56 ; - check for entry in IVM PATIENT file, otherwise create stub entry
+57 SET IVM3015=$ORDER(^IVM(301.5,"B",DFN,0))
+58 ;IVM*2.0*165
IF 'IVM3015
SET DGENUPLD=""
SET IVM3015=$$LOG^IVMPLOG(DFN,DT)
SET DGENUPLD="ENROLLMENT/ELIGIBILITY UPLOAD IN PROGRESS"
+59 IF 'IVM3015
Begin DoDot:2
+60 SET HLERR="Failed to create entry in IVM PATIENT file"
+61 DO ACK^IVMPREC
End DoDot:2
QUIT
+62 ;
+63 ; - compare PID segment fields with DHCP fields
+64 ;Setting IVMSEG to PID before it calls COMPARE
SET IVMSEG="PID"
+65 IF 'DODSEG
IF 'GUARSEG
DO COMPARE(IVMSEG)
if $DATA(HLERR)
QUIT
+66 ;
+67 ; - get next msg segment -decrement the counter so it can pickup ZPD
+68 SET IVMDA=IVMDA-1
DO NEXT
IF $EXTRACT(IVMSEG,1,3)'="ZPD"
Begin DoDot:2
+69 SET HLERR="Missing ZPD segment"
DO ACK^IVMPREC
End DoDot:2
QUIT
+70 ;Convert "" to null in ZPD segment except seq. 8,9, 31 and 32
+71 SET IVMSEG=$$CLEARF^IVMPRECA(IVMSEG,HLFS,",9,10,32,33,")
+72 ;
+73 ; - compare ZPD segment fields with DHCP fields
+74 DO COMPARE(IVMSEG)
+75 ;
+76 ; - get next msg segment
+77 DO NEXT
IF $EXTRACT(IVMSEG,1,3)="ZEL"
Begin DoDot:2
+78 SET HLERR="ZEL segment should not be sent in Z05 message"
DO ACK^IVMPREC
End DoDot:2
QUIT
+79 ;
+80 IF $EXTRACT(IVMSEG,1,3)'="ZTA"
Begin DoDot:2
+81 SET HLERR="Missing ZTA segment"
DO ACK^IVMPREC
End DoDot:2
QUIT
+82 ;Convert "" to null in ZTA segment seq. 7
+83 IF $PIECE(IVMSEG,HLFS,8)=HLQ
SET $PIECE(IVMSEG,HLFS,8)=""
+84 ;
+85 ; - compare ZTA segment fields with DHCP fields
+86 IF 'DODSEG
IF 'GUARSEG
DO COMPARE(IVMSEG)
+87 ;
+88 ; - get next msg segment
+89 ; KUM - ZAV Segment Processing (CASS field)
+90 DO NEXT
+91 IF $EXTRACT(IVMSEG,1,3)'="ZAV"
Begin DoDot:2
+92 SET HLERR="Missing ZAV segment"
DO ACK^IVMPREC
End DoDot:2
QUIT
+93 SET IVMSEG=$$CLEARF^IVMPRECA(IVMSEG,HLFS)
+94 ;Process 1st ZAV
IF 'DODSEG
IF 'GUARSEG
DO COMPARE(IVMSEG)
+95 ;Handle possible mult ZAVs
SET MULTDONE=0
FOR XREP=1:1
Begin DoDot:2
+96 DO NEXT
IF $EXTRACT(IVMSEG,1,3)'="ZAV"
SET MULTDONE=1
QUIT
+97 SET IVMSEG=$$CLEARF^IVMPRECA(IVMSEG,HLFS)
+98 IF 'DODSEG
IF 'GUARSEG
DO COMPARE(IVMSEG)
End DoDot:2
if MULTDONE
QUIT
+99 ;D NEXT
+100 ;
+101 ; - get next msg segment
+102 IF $EXTRACT(IVMSEG,1,3)'="ZGD"
Begin DoDot:2
+103 SET HLERR="Missing ZGD segment"
DO ACK^IVMPREC
End DoDot:2
QUIT
+104 ;
+105 ; - compare ZGD segment fields with DHCP fields
+106 ; convert "" to null for ZGD segment
+107 ;ignore seq. 6
SET IVMSEG=$$CLEARF^IVMPRECA(IVMSEG,HLFS,",7,")
+108 ; convert seq. 6 separately
+109 SET $PIECE(IVMSEG,HLFS,7)=$$CLEARF^IVMPRECA($PIECE(IVMSEG,HLFS,7),$EXTRACT(HLECH))
+110 DO COMPARE(IVMSEG)
+111 ;S IVMFLG=0
+112 ;
+113 ;S MULTDONE=0 F XREP=1:1 D Q:MULTDONE ;Skip ZCT & ZEM -coming later
+114 ;.D NEXT
+115 ;.I ($E(IVMSEG,1,3)'="ZCT")&($E(IVMSEG,1,3)'="ZEM") S MULTDONE=1 Q
+116 ;S IVMDA=IVMDA-1
+117 ;
+118 ; - get next msg segment
+119 DO NEXT
+120 IF $EXTRACT(IVMSEG,1,3)'="ZCT"
Begin DoDot:2
+121 SET HLERR="Missing ZCT segment"
DO ACK^IVMPREC
End DoDot:2
QUIT
+122 ;KUM - Donot convert "" to null in ZCT segment
+123 ;IVM*2.0*188 - Comment below line. Allow double quotes to stay in ZCT segment, otherwise double quotes will be replaced with null
+124 ;S IVMSEG=$$CLEARF^IVMPRECA(IVMSEG,HLFS)
+125 ;Process 1st ZCT
IF 'DODSEG
IF 'GUARSEG
DO COMPARE(IVMSEG)
+126 ;Handle possible mult ZCTs
SET MULTDONE=0
FOR XREP=1:1
Begin DoDot:2
+127 DO NEXT
IF $EXTRACT(IVMSEG,1,3)'="ZCT"
SET MULTDONE=1
QUIT
+128 ;KUM - Donot convert "" to null in ZCT segment
+129 ;IVM*2.0*188 - Comment below line. Allow double quotes to stay in ZCT segment, otherwise double quotes will be replaced with null
+130 ;S IVMSEG=$$CLEARF^IVMPRECA(IVMSEG,HLFS)
+131 IF 'DODSEG
IF 'GUARSEG
DO COMPARE(IVMSEG)
End DoDot:2
if MULTDONE
QUIT
+132 ;
+133 SET IVMDA=IVMDA-1
DO NEXT
+134 IF $EXTRACT(IVMSEG,1,3)'="ZEM"
Begin DoDot:2
+135 SET HLERR="Missing ZEM segment"
DO ACK^IVMPREC
End DoDot:2
QUIT
+136 ;Process 1st ZEM
IF 'DODSEG
IF 'GUARSEG
DO COMPARE(IVMSEG)
+137 ;Handle possible mult ZEMs
SET MULTDONE=0
FOR XREP=1:1
Begin DoDot:2
+138 DO NEXT
IF $EXTRACT(IVMSEG,1,3)'="ZEM"
SET MULTDONE=1
QUIT
+139 IF 'DODSEG
IF 'GUARSEG
DO COMPARE(IVMSEG)
End DoDot:2
if MULTDONE
QUIT
+140 SET IVMDA=IVMDA-1
+141 ;
+142 ; - check for RF1 segment and get segment if it exists
+143 ; This process will automatically update patient address data
+144 ; in the Patient (#2) file if the incoming address is more
+145 ; recent than the existing one.
+146 ;Modified code to handle multiple RF1 segment - IVM*2*115
+147 SET (UPDEPC("SAD"),UPDEPC("CPH"),UPDEPC("PNO"),UPDEPC("EAD"),UPDEPC("PHH"))=0
+148 SET QFLG=0
IF $$RF1CHK(IVMRTN,IVMDA)
FOR I=1:1
Begin DoDot:2
+149 DO NEXT
+150 ;ignore seq. 6
SET IVMSEG=$$CLEARF^IVMPRECA(IVMSEG,HLFS,",7,")
+151 SET $PIECE(IVMSEG,HLFS,7)=$$CLEARF^IVMPRECA($PIECE(IVMSEG,HLFS,7),$EXTRACT(HLECH))
+152 ;Quit if RF1 is blank
IF $PIECE(IVMSEG,HLFS,4)=""
SET QFLG=1
QUIT
+153 DO COMPARE(IVMSEG)
+154 IF '$$RF1CHK(IVMRTN,IVMDA)
SET QFLG=1
End DoDot:2
if QFLG
QUIT
+155 ; KUM - IVM*2.0*164 - Set Confidential Active flag
+156 SET IVMCSDT=""
SET IVMCEDT=""
SET IVMCAFG=.14105
SET IVMCAVL="Y"
+157 SET IVMCSDT=$PIECE($PIECE($GET(ADDRESS("CA")),"~",12),"&",1)
+158 SET IVMCSDT=$$FMDATE^HLFNC(IVMCSDT)
+159 SET IVMCEDT=$PIECE($PIECE($GET(ADDRESS("CA")),"~",12),"&",2)
+160 SET IVMCEDT=$$FMDATE^HLFNC(IVMCEDT)
+161 IF IVMCSDT=""
Begin DoDot:2
+162 ;I $G(UPDAUPG("CA"))'=1 Q
+163 SET IVMCAVL="N"
End DoDot:2
+164 DO AUTOAUP^IVMPREC9(DFN,.UPDAUP,.UPDAUPG)
+165 SET IVMFLG=0
End DoDot:1
+166 ; - send mail message if necessary
+167 ; This bulletin has been disabled. IVM*2*140
+168 ;I IVMCNTR D MAIL^IVMUFNC()
+169 ; Cleanup variables if no msg necessary
+170 IF 'IVMCNTR
KILL IVMTEXT,XMSUB
+171 ;
ENQ ; - cleanup variables
+1 KILL DA,DR,DFN,IVMADDR,IVMADFLG,IVMDA,IVMDHCP,IVMFLAG,IVMFLD,IVMPHDFG,IVMPIECE,IVMSEG,IVMSTART,IVMXREF,DGENUPLD,IVMPID,PIDSTR,ADDRESS,TELECOM,UPDEPC,EPCFARY,IVMDFN,DODSEG,EPCDEL,GUARSEG,UPDAUP,IVMRACE,IVMTSTPT,IVMPMAST
+2 QUIT
+3 ;
+4 ;
NEXT ; - get the next HL7 segment in the message from HL7 Transmission (#772) file
+1 ;
+2 SET IVMDA=$ORDER(^TMP($JOB,IVMRTN,IVMDA))
SET IVMSEG=$GET(^(+IVMDA,0))
+3 QUIT
+4 ;
+5 ;
COMPARE(IVMSEG) ; - compare incoming HL7 segment/fields with DHCP fields
+1 ;
+2 ; Input: IVMSEG -- as the text of the incoming HL7 message
+3 ;
+4 ; Output: None
+5 ;
+6 ; - get 3 letter HL7 segment name
+7 SET IVMXREF=$PIECE(IVMSEG,HLFS,1)
SET IVMSTART=IVMXREF
+8 ;
+9 ; - strip off HL7 segment name
+10 SET IVMSEG=$PIECE(IVMSEG,HLFS,2,99)
+11 ;
+12 ; - roll through "C" x-ref in IVM Demographic Upload Fields (#301.92) file
+13 FOR
SET IVMXREF=$ORDER(^IVM(301.92,"C",IVMXREF))
if IVMXREF']""
QUIT
Begin DoDot:1
+14 SET IVMDEMDA=$ORDER(^IVM(301.92,"C",IVMXREF,""))
if IVMDEMDA']""
QUIT
+15 IF $$INACTIVE(IVMDEMDA)
QUIT
+16 ;
+17 ; - compare incoming HL7 segment fields with DHCP fields
+18 IF IVMXREF["PID"
IF (IVMSTART["PID")
DO PID^IVMPREC8
+19 IF IVMXREF["ZPD"
IF (IVMSTART["ZPD")
DO ZPD^IVMPREC8
+20 IF IVMXREF["ZTA"
IF (IVMSTART["ZTA")
DO ZTA^IVMPREC8
+21 ; KUM IVM*2.0*164 - ZAV Segment Processing
+22 IF IVMXREF["ZAV"
IF (IVMSTART["ZAV")
DO ZAV^IVMPREC8
+23 ;
+24 IF IVMXREF["ZGD"
IF (IVMSTART["ZGD")
DO ZGD^IVMPREC8
+25 ; IVM*2.0*192; JAM; Tag ZCT moved to IVMPREC9
+26 IF IVMXREF["ZCT"
IF (IVMSTART["ZCT")
DO ZCT^IVMPREC9
+27 IF IVMXREF["ZEM"
IF (IVMSTART["ZEM")
DO ZEM^IVMPREC8
+28 IF IVMXREF["RF1"
IF (IVMSTART["RF1")
DO RF1^IVMPREC8
End DoDot:1
+29 QUIT
+30 ;
+31 ;
DEMBULL ; - build mail message for transmission to IVM mail group notifying
+1 ; them that patients with updated demographic data has been received
+2 ; from the IVM Center and may now be uploaded into DHCP.
+3 ;
+4 ; If record is auto uploaded, don't add veteran to bulletin
+5 IF $$CKAUTO
QUIT
+6 ;
+7 SET IVMPTID=$$PT^IVMUFNC4(DFN)
+8 SET XMSUB="IVM - DEMOGRAPHIC UPLOAD for "_$PIECE($PIECE(IVMPTID,"^"),",")_" ("_$PIECE(IVMPTID,"^",3)_")"
+9 SET IVMTEXT(1)="Updated demographic information has been received from the"
+10 SET IVMTEXT(2)="Health Eligibilty Center. Please select the 'Demographic Upload'"
+11 SET IVMTEXT(3)="option from the IVM Upload Menu in order to take action on this"
+12 SET IVMTEXT(4)="demographic information. If you have any questions concerning the"
+13 SET IVMTEXT(5)="information received, please contact the Health Eligibility Center."
+14 SET IVMTEXT(7)=""
+15 SET IVMTEXT(8)="The Health Eligibilty Center has identified the following"
+16 SET IVMTEXT(9)="patients as having updated demographic information:"
+17 SET IVMTEXT(10)=""
+18 SET IVMCNTR=IVMCNTR+1
+19 SET IVMTEXT(IVMCNTR+10)=$JUSTIFY(IVMCNTR_")",5)_" "_$PIECE(IVMPTID,"^")_" ("_$PIECE(IVMPTID,"^",3)_")"
+20 QUIT
+21 ;
INACTIVE(IVMDEMDA) ;Check if field is inactive in Demographic Upload
+1 ; Input -- IVMDEMDA IVM Demographic Upload Fields IEN
+2 ; Output -- 1=Yes and 0=No
+3 QUIT +$PIECE($GET(^IVM(301.92,IVMDEMDA,0)),U,9)
+4 ;
RF1CHK(IVMRTN,IVMDA) ;does an RF1 segment exist in this message?
+1 NEW RF1
+2 SET RF1=$ORDER(^TMP($JOB,IVMRTN,IVMDA))
+3 IF $EXTRACT($GET(^(+RF1,0)),1,3)'="RF1"
QUIT 0
+4 QUIT 1
+5 ;
CKAUTO() ;
+1 ; Chect if message qualifies for an auto upload.
+2 NEW AUTO,IVMI,DOD
+3 SET AUTO=0
SET IVMI=$ORDER(^IVM(301.92,"C","ZPD09",""))
+4 IF IVMI=IVMDEMDA
Begin DoDot:1
+5 IF +IVMFLD'>0
SET AUTO=1
QUIT
+6 SET DOD=$PIECE($GET(^DPT(DFN,.35)),U)
+7 IF DOD=IVMFLD
SET AUTO=1
QUIT
End DoDot:1
+8 ;
+9 QUIT AUTO
BLDPID(PIDTMP,IVMPID) ;Build IVMPID subscripted by sequence number
+1 NEW STR,X1,X2,N,TEXT,C,L
+2 SET STR=""
SET X1=1
SET (N,X2)=0
+3 FOR
SET N=$ORDER(PIDTMP(N))
if N=""
QUIT
SET TEXT=PIDTMP(N)
FOR L=1:1:$LENGTH(TEXT)
SET C=$EXTRACT(TEXT,L)
Begin DoDot:1
+4 IF C="^"
Begin DoDot:2
+5 IF X2
SET X2=X2+1
SET IVMPID(X1,X2)=STR
+6 IF '$TEST
SET IVMPID(X1)=STR
+7 SET STR=""
SET X1=X1+1
SET X2=0
End DoDot:2
QUIT
+8 IF C="|"
Begin DoDot:2
+9 SET X2=X2+1
SET IVMPID(X1,X2)=STR
SET STR=""
End DoDot:2
QUIT
+10 SET STR=STR_C
End DoDot:1
+11 IF $GET(C)'=""
IF $GET(C)'="^"
IF $GET(C)'="|"
Begin DoDot:1
+12 IF X2
SET X2=X2+1
SET IVMPID(X1,X2)=STR
QUIT
+13 SET IVMPID(X1)=STR
End DoDot:1
+14 QUIT
ADDRCHNG(DFN) ;Store Address Change Date/time, Source and site if necessary
+1 ;Store Residence Number Change Date/Time, Source and Site (IVM*2*152)
+2 NEW IVMVALUE,IVMFIELD
+3 IF '$DATA(^TMP($JOB,"CHANGE UPDATE"))
QUIT
+4 SET IVMFIELD=0
FOR
SET IVMFIELD=$ORDER(^TMP($JOB,"CHANGE UPDATE",IVMFIELD))
if IVMFIELD=""
QUIT
Begin DoDot:1
+5 SET IVMVALUE=$GET(^TMP($JOB,"CHANGE UPDATE",IVMFIELD))
+6 SET DIE="^DPT("
SET DA=DFN
SET DR=IVMFIELD_"////^S X=IVMVALUE"
+7 DO ^DIE
KILL DA,DIE,DR
+8 ; - delete inaccurate Addr Change Site data if Source is not VAMC
+9 IF IVMFIELD=.119
IF IVMVALUE'="VAMC"
SET FDA(2,+DFN_",",.12)="@"
DO UPDATE^DIE("E","FDA")
+10 ; - delete inaccurate Residence Number Change Site data if Source
+11 ; is not VAMC (IVM*2*152)
+12 IF IVMFIELD=.1322
IF IVMVALUE'="VAMC"
SET FDA(2,+DFN_",",.1323)="@"
DO UPDATE^DIE("E","FDA")
End DoDot:1
+13 KILL ^TMP($JOB,"CHANGE UPDATE")
+14 QUIT
EPCFLDS(EPCFARY,EPCDEL) ;
+1 ;EPCFARY - Contains IENs of Pager, email, Cell phone and Home phone records in 301.92 File - Passed by reference
+2 ;EPCDEL - Contains field # of Pager, Email, Cell phone and Home phone fields in Patient(#2) file. - Passed by reference
+3 IF (DODSEG)!(GUARSEG)
QUIT
+4 SET EPCFARY("PNO")=$ORDER(^IVM(301.92,"B","PAGER NUMBER",0))_"^"_$ORDER(^IVM(301.92,"B","PAGER CHANGE DT/TM",0))_"^"_$ORDER(^IVM(301.92,"B","PAGER CHANGE SITE",0))_"^"_$ORDER(^IVM(301.92,"B","PAGER CHANGE SOURCE",0))
+5 SET EPCFARY("CPH")=$ORDER(^IVM(301.92,"B","CELLULAR NUMBER",0))_"^"_$ORDER(^IVM(301.92,"B","CELL PHONE CHANGE DT/TM",0))_"^"_$ORDER(^IVM(301.92,"B","CELL PHONE CHANGE SITE",0))_"^"_$ORDER(^IVM(301.92,"B","CELL PHONE CHANGE SOURCE",0))
+6 SET EPCFARY("EAD")=$ORDER(^IVM(301.92,"B","EMAIL ADDRESS",0))_"^"_$ORDER(^IVM(301.92,"B","EMAIL CHANGE DT/TM",0))_"^"_$ORDER(^IVM(301.92,"B","EMAIL CHANGE SITE",0))_"^"_$ORDER(^IVM(301.92,"B","EMAIL CHANGE SOURCE",0))
+7 ; IVM*2.0*167 - Make Home phone records auto-upload to Patient File
+8 SET EPCFARY("PHH")=$ORDER(^IVM(301.92,"B","PHONE NUMBER [RESIDENCE]",0))_"^"_$ORDER(^IVM(301.92,"B","RESIDENCE NUMBER CHANGE DT/TM",0))_"^"_...
... $ORDER(^IVM(301.92,"B","RESIDENCE NUMBER CHANGE SITE",0))_"^"_$ORDER(^IVM(301.92,"B","RESIDENCE NUMBER CHANGE SOURCE",0))
+9 SET EPCDEL("PNO")=".135^.1312^.1313^.1314"
+10 SET EPCDEL("CPH")=".134^.139^.1311^.13111"
+11 SET EPCDEL("EAD")=".133^.136^.137^.138"
+12 ; IVM*2.0*167 - Make Home phone records auto-upload to Patient File
+13 ; IVM*2.0*171 - Comment out line to fix the home phone deletion issue
+14 ;S EPCDEL("PHH")=".131^.1321^.1322^.1323"
+15 QUIT
+16 ;
AUPBLD(AUPFARY,UPDAUPG) ; Set up array containing fields for auto upload.
+1 ;AUPFARY - Contains fields in 301.92 File-Passed by reference
+2 ;UPDAUPG - Contains all groups initialized to '0'
+3 NEW AUPSTR,AUPGRP,AUPFLST,AUPPCE,AUPSGSQ,AUPDA
+4 FOR I=3:1
SET AUPSTR=$PIECE($TEXT(AUPLST+I),";;",2,3)
if $PIECE(AUPSTR,";")="QUIT"
QUIT
Begin DoDot:1
+5 SET AUPGRP=$PIECE(AUPSTR,";")
SET AUPFLST=$PIECE(AUPSTR,";",2)
+6 FOR AUPPCE=1:1:$LENGTH(AUPFLST,"^")
Begin DoDot:2
+7 SET AUPSGSQ=$PIECE(AUPFLST,"^",AUPPCE)
if AUPSGSQ=""
QUIT
+8 SET AUPDA=$ORDER(^IVM(301.92,"C",AUPSGSQ,0))
if AUPDA=""
QUIT
+9 SET AUPFARY(AUPDA)=AUPGRP
+10 ; Default group update flags to '0'
if AUPGRP'=""
SET UPDAUPG(AUPGRP)=0
End DoDot:2
End DoDot:1
+11 QUIT
+12 ;
+13 ; IVM*2.0*164 - ZAV01,ZAV02 AND ZAV04 are added for Auto Upload.
+14 ; Residential Address (RA) group is added
+15 ; Confidential Address (CA) group is uncommented
+16 ; IVM*2.0*193; JAM ; Added fields to groups K1,K2,E1,E2 and D for foreign address fields: Province, Postal Code and Country)
+17 ; eg ZCT056K1, ZCT054K1F, ZCT055K1F (COUNTRY, PROV, POSTAL CODE for the K1 group)
+18 ; IVM*2.0*204 - Add ZCT08K1, ZCT08K2, ZCT08E1, ZCT08E2, ZCT08D1 for Auto Upload.
AUPLST ; P1;P2
+1 ; P1 = Group Name (treat all entries as this group if present)
+2 ; P2 = .01 field(s) from 301.92 separated by '^'
+3 ;;D1;ZCT03D1^ZCT04D1^ZCT051D1^ZCT052D1^ZCT053D1^ZCT054D1^ZCT055D1^ZCT054D1F^ZCT055D1F^ZCT056D1^ZCT06D1^ZCT07D1^ZCT10D1^ZCT11D1
+4 ;;E1;ZCT03E1^ZCT04E1^ZCT051E1^ZCT052E1^ZCT053E1^ZCT054E1^ZCT055E1^ZCT054E1F^ZCT055E1F^ZCT056E1^ZCT06E1^ZCT07E1^ZCT10E1^ZCT11E1
+5 ;;E2;ZCT03E2^ZCT04E2^ZCT051E2^ZCT052E2^ZCT053E2^ZCT054E2^ZCT055E2^ZCT054E2F^ZCT055E2F^ZCT056E2^ZCT06E2^ZCT07E2^ZCT10E2^ZCT11E2
+6 ;;K1;ZCT03K1^ZCT04K1^ZCT051K1^ZCT052K1^ZCT053K1^ZCT054K1^ZCT055K1^ZCT054K1F^ZCT055K1F^ZCT056K1^ZCT06K1^ZCT07K1^ZCT10K1^ZCT11K1
+7 ;;K2;ZCT03K2^ZCT04K2^ZCT051K2^ZCT052K2^ZCT053K2^ZCT054K2^ZCT055K2^ZCT054K2F^ZCT055K2F^ZCT056K2^ZCT06K2^ZCT07K2^ZCT10K2^ZCT11K2
+8 ;;TA;ZTA02^ZTA03^ZTA04^ZTA051^ZTA052^ZTA053^ZTA054^ZTA055^ZTA056^ZTA058^ZTA059^ZTA07^ZTA08^ZTA09^ZTA054F^ZTA055F^ZAV04
+9 ;;CA;PID111C^PID112C^PID113C^PID114C^PID114CF^PID115C^PID115CF^PID116C^PID117C^PID118C^PID119C^PID1110C^PID1112C^PID1113C^PID13CA^RF161CA^RF171CA^ZAV02
+10 ;;RA;PID111R^PID112R^PID113R^PID114R^PID114RF^PID115R^PID115RF^PID116R^PID117R^PID118R^PID119R^PID1110R^PID1112R^PID1113R^PID13RA^RF161RA^RF162RA^RF171RA^ZAV01
+11 ;;;ZEM03^ZEM04^ZEM05^ZEM061^ZEM062^ZEM063^ZEM064^ZEM065^ZEM068^ZEM07^ZEM09
+12 ;;;ZEM03S^ZEM04S^ZEM05S^ZEM061S^ZEM062S^ZEM063S^ZEM064S^ZEM065S^ZEM068S^ZEM07S^ZEM09S
+13 ;;;PID06^PID10^PID16^PID17^PID22^ZPD30^ZPD06^ZPD07
+14 ;;QUIT
+15 ;;
+16 ;;The following have been disabled until further notice
+17 ;;;PID113N^PID114N^PID24^PID13W
+18 ;;CA;PID111C^PID112C^PID113C^PID114C^PID114CF^PID115C^PID115CF^PID116C^PID117C^PID118C^PID119C^PID1112C1^PID1112C2^PID13CA^RF161CA^RF171CA
