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

IVMPREC6.m

Go to the documentation of this file.
  1. IVMPREC6 ;ALB/KCL,BRM,CKN,TDM,PWC,LBD,JAM,KUM - PROCESS INCOMING (Z05 EVENT TYPE) HL7 MESSAGES ;7/22/24 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,214,215**;21-OCT-94;Build 14
  1. ;Per VA Directive 6402, this routine should not be modified.
  1. ;
  1. ; This routine will process batch ORU demographic (event type Z05) HL7
  1. ; messages received from the IVM center. Format of HL7 batch message:
  1. ;
  1. ; BHS
  1. ; {MSH
  1. ; PID
  1. ; ZPD
  1. ; ZTA
  1. ; ZAV
  1. ; ZGD
  1. ; ZCT (1 episode required, multiple possible)
  1. ; ZEM (Veteran)
  1. ; ZEM (Spouse - Optional)
  1. ; RF1 (optional, multiple possible)
  1. ; }
  1. ; BTS
  1. ;
  1. ;
  1. EN ; - entry point to process HL7 patient demographic message
  1. ;
  1. N DGENUPLD,VAFCA08,DGRUGA08,COMP,DODSEG,GUARSEG,IVMCSDT,IVMCEDT,IVMCAFG,IVMCAVL,IVMPMAST,IVMCMAST
  1. ;N MULTDONE,XREP
  1. N XIVMA,IVMALADT,MULTIDONE
  1. N IVMPHDFG S IVMPHDFG=0 ; IVM*2*171 - add new variable IVMPHDFG to check for PHH deletion
  1. S IVMPMAST=""
  1. ;
  1. ; Setup array to hold all the Allowed Address Types
  1. ;F XIVMA="N","P","VAB1","VAB2","VAB3","VAB4" S IVMALADT(XIVMA)=""
  1. ; IVM*2.0*164 - Allow Residential and Confidential Addresses
  1. F XIVMA="P","R","CA","VAB1","VAB2","VAB3","VAB4" S IVMALADT(XIVMA)=""
  1. ; Define the Confidential Address Categories
  1. ; IVM*2.0*164 - Uncomment below five lines to enable all confidential address categories
  1. S IVMALADT("VACAE")="CA^1" ; ELIGIBILITY/ENROLLMENT
  1. S IVMALADT("VACAA")="CA^2" ; APPOINTMENT/SCHEDULING
  1. S IVMALADT("VACAC")="CA^3" ; COPAYMENTS/VETERAN BILLING
  1. S IVMALADT("VACAM")="CA^4" ; MEDICAL RECORDS
  1. S IVMALADT("VACAO")="CA^5" ; ALL OTHERS
  1. ; prevent a return Z07 when uploading a Z05 (Patient file triggers)
  1. S DGENUPLD="ENROLLMENT/ELIGIBILITY UPLOAD IN PROGRESS"
  1. ;
  1. ; prevent MPI A08 message when uploading Z05 (Patient file triggers)
  1. S VAFCA08=1 ;MPI/CIRN A08 suppression flag
  1. ;
  1. S IVMFLG=0,IVMADFLG=0
  1. ; - get incoming HL7 message from HL7 Transmission (#772) file
  1. 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
  1. .K HLERR,ZEMADRUP
  1. .S IVMTSTPT="" ;Initialize Temp Addr County
  1. .;
  1. .; - message control id from MSH segment
  1. .S MSGID=$P(IVMSEG,HLFS,10),HLMID=MSGID
  1. .;
  1. .; - perform demographics message consistency check
  1. .D EN^IVMPRECA Q:$D(HLERR)
  1. .;
  1. .;Set array of Email, Cell, Pager fields
  1. .D EPCFLDS(.EPCFARY,.EPCDEL)
  1. .D AUPBLD(.AUPFARY,.UPDAUPG)
  1. .; - get next msg segment
  1. .D NEXT I $E(IVMSEG,1,3)'="PID" D Q
  1. ..S HLERR="Missing PID segment" D ACK^IVMPREC
  1. .;
  1. .F I=1:1 D NEXT Q:$E(IVMSEG,1,4)="ZPD^" ;Go through all PID
  1. .; - patient IEN (DFN) from PID segment
  1. .;Use IVMPID array created in IVMPRECA while performing consistency
  1. .;to process PID segment
  1. .;
  1. .;I '$G(IVMDFN) S HLERR="Invalid DFN" D ACK^IVMPREC Q
  1. .S DFN=$G(IVMDFN)
  1. .;I ('DFN!(DFN'=+DFN)!('$D(^DPT(+DFN,0)))) D Q
  1. .;.S HLERR="Invalid DFN" D ACK^IVMPREC
  1. .;I IVMPID(19)'=$P(^DPT(DFN,0),"^",9) D Q
  1. .;.S HLERR="Couldn't match HEC SSN with DHCP SSN" D ACK^IVMPREC
  1. .;
  1. .; - check for entry in IVM PATIENT file, otherwise create stub entry
  1. .S IVM3015=$O(^IVM(301.5,"B",DFN,0))
  1. .I 'IVM3015 S DGENUPLD="",IVM3015=$$LOG^IVMPLOG(DFN,DT),DGENUPLD="ENROLLMENT/ELIGIBILITY UPLOAD IN PROGRESS" ;IVM*2.0*165
  1. .I 'IVM3015 D Q
  1. ..S HLERR="Failed to create entry in IVM PATIENT file"
  1. ..D ACK^IVMPREC
  1. .;
  1. .; - compare PID segment fields with DHCP fields
  1. .S IVMSEG="PID" ;Setting IVMSEG to PID before it calls COMPARE
  1. .I 'DODSEG,'GUARSEG D COMPARE(IVMSEG) Q:$D(HLERR)
  1. .;
  1. .; - get next msg segment -decrement the counter so it can pickup ZPD
  1. .S IVMDA=IVMDA-1 D NEXT I $E(IVMSEG,1,3)'="ZPD" D Q
  1. ..S HLERR="Missing ZPD segment" D ACK^IVMPREC
  1. .;Convert "" to null in ZPD segment except seq. 8,9, 31 and 32
  1. .S IVMSEG=$$CLEARF^IVMPRECA(IVMSEG,HLFS,",9,10,32,33,")
  1. .;
  1. .; - compare ZPD segment fields with DHCP fields
  1. .D COMPARE(IVMSEG)
  1. .;
  1. .; - get next msg segment
  1. .D NEXT I $E(IVMSEG,1,3)="ZEL" D Q
  1. ..S HLERR="ZEL segment should not be sent in Z05 message" D ACK^IVMPREC
  1. .;
  1. .I $E(IVMSEG,1,3)'="ZTA" D Q
  1. ..S HLERR="Missing ZTA segment" D ACK^IVMPREC
  1. .;Convert "" to null in ZTA segment seq. 7
  1. .I $P(IVMSEG,HLFS,8)=HLQ S $P(IVMSEG,HLFS,8)=""
  1. .;
  1. .; - compare ZTA segment fields with DHCP fields
  1. .I 'DODSEG,'GUARSEG D COMPARE(IVMSEG)
  1. .;
  1. .; - get next msg segment
  1. .; KUM - ZAV Segment Processing (CASS field)
  1. .D NEXT
  1. .I $E(IVMSEG,1,3)'="ZAV" D Q
  1. ..S HLERR="Missing ZAV segment" D ACK^IVMPREC
  1. .S IVMSEG=$$CLEARF^IVMPRECA(IVMSEG,HLFS)
  1. .I 'DODSEG,'GUARSEG D COMPARE(IVMSEG) ;Process 1st ZAV
  1. .S MULTDONE=0 F XREP=1:1 D Q:MULTDONE ;Handle possible mult ZAVs
  1. ..D NEXT I $E(IVMSEG,1,3)'="ZAV" S MULTDONE=1 Q
  1. ..S IVMSEG=$$CLEARF^IVMPRECA(IVMSEG,HLFS)
  1. ..I 'DODSEG,'GUARSEG D COMPARE(IVMSEG)
  1. .;D NEXT
  1. .;
  1. .; - get next msg segment
  1. .I $E(IVMSEG,1,3)'="ZGD" D Q
  1. ..S HLERR="Missing ZGD segment" D ACK^IVMPREC
  1. .;
  1. .; - compare ZGD segment fields with DHCP fields
  1. .; convert "" to null for ZGD segment
  1. .S IVMSEG=$$CLEARF^IVMPRECA(IVMSEG,HLFS,",7,") ;ignore seq. 6
  1. .; convert seq. 6 separately
  1. .S $P(IVMSEG,HLFS,7)=$$CLEARF^IVMPRECA($P(IVMSEG,HLFS,7),$E(HLECH))
  1. .D COMPARE(IVMSEG)
  1. .;S IVMFLG=0
  1. .;
  1. .;S MULTDONE=0 F XREP=1:1 D Q:MULTDONE ;Skip ZCT & ZEM -coming later
  1. .;.D NEXT
  1. .;.I ($E(IVMSEG,1,3)'="ZCT")&($E(IVMSEG,1,3)'="ZEM") S MULTDONE=1 Q
  1. .;S IVMDA=IVMDA-1
  1. .;
  1. .; - get next msg segment
  1. .D NEXT
  1. .I $E(IVMSEG,1,3)'="ZCT" D Q
  1. ..S HLERR="Missing ZCT segment" D ACK^IVMPREC
  1. .;KUM - Donot convert "" to null in ZCT segment
  1. .;IVM*2.0*188 - Comment below line. Allow double quotes to stay in ZCT segment, otherwise double quotes will be replaced with null
  1. .;S IVMSEG=$$CLEARF^IVMPRECA(IVMSEG,HLFS)
  1. .I 'DODSEG,'GUARSEG D COMPARE(IVMSEG) ;Process 1st ZCT
  1. .S MULTDONE=0 F XREP=1:1 D Q:MULTDONE ;Handle possible mult ZCTs
  1. ..D NEXT I $E(IVMSEG,1,3)'="ZCT" S MULTDONE=1 Q
  1. ..;KUM - Donot convert "" to null in ZCT segment
  1. ..;IVM*2.0*188 - Comment below line. Allow double quotes to stay in ZCT segment, otherwise double quotes will be replaced with null
  1. ..;S IVMSEG=$$CLEARF^IVMPRECA(IVMSEG,HLFS)
  1. ..I 'DODSEG,'GUARSEG D COMPARE(IVMSEG)
  1. .;
  1. .S IVMDA=IVMDA-1 D NEXT
  1. .I $E(IVMSEG,1,3)'="ZEM" D Q
  1. ..S HLERR="Missing ZEM segment" D ACK^IVMPREC
  1. .I 'DODSEG,'GUARSEG D COMPARE(IVMSEG) ;Process 1st ZEM
  1. .S MULTDONE=0 F XREP=1:1 D Q:MULTDONE ;Handle possible mult ZEMs
  1. ..D NEXT I $E(IVMSEG,1,3)'="ZEM" S MULTDONE=1 Q
  1. ..I 'DODSEG,'GUARSEG D COMPARE(IVMSEG)
  1. .S IVMDA=IVMDA-1
  1. .;
  1. .; - check for RF1 segment and get segment if it exists
  1. .; This process will automatically update patient address data
  1. .; in the Patient (#2) file if the incoming address is more
  1. .; recent than the existing one.
  1. .;Modified code to handle multiple RF1 segment - IVM*2*115
  1. .;IVM*2.0*214 - Added PHW to UPDEPC to automate PHONE NUMBER[WORK] update to Patient (#2) File.
  1. .;S (UPDEPC("SAD"),UPDEPC("CPH"),UPDEPC("PNO"),UPDEPC("EAD"),UPDEPC("PHH"))=0
  1. .S (UPDEPC("SAD"),UPDEPC("CPH"),UPDEPC("PNO"),UPDEPC("EAD"),UPDEPC("PHH"),UPDEPC("PHW"))=0
  1. .S QFLG=0 I $$RF1CHK(IVMRTN,IVMDA) F I=1:1 D Q:QFLG
  1. ..D NEXT
  1. ..S IVMSEG=$$CLEARF^IVMPRECA(IVMSEG,HLFS,",7,") ;ignore seq. 6
  1. ..S $P(IVMSEG,HLFS,7)=$$CLEARF^IVMPRECA($P(IVMSEG,HLFS,7),$E(HLECH))
  1. ..I $P(IVMSEG,HLFS,4)="" S QFLG=1 Q ;Quit if RF1 is blank
  1. ..D COMPARE(IVMSEG)
  1. ..I '$$RF1CHK(IVMRTN,IVMDA) S QFLG=1
  1. .; KUM - IVM*2.0*164 - Set Confidential Active flag
  1. .S IVMCSDT="",IVMCEDT="",IVMCAFG=.14105,IVMCAVL="Y"
  1. .S IVMCSDT=$P($P($G(ADDRESS("CA")),"~",12),"&",1)
  1. .S IVMCSDT=$$FMDATE^HLFNC(IVMCSDT)
  1. .S IVMCEDT=$P($P($G(ADDRESS("CA")),"~",12),"&",2)
  1. .S IVMCEDT=$$FMDATE^HLFNC(IVMCEDT)
  1. .I IVMCSDT="" D
  1. ..;I $G(UPDAUPG("CA"))'=1 Q
  1. ..S IVMCAVL="N"
  1. .D AUTOAUP^IVMPREC9(DFN,.UPDAUP,.UPDAUPG)
  1. .S IVMFLG=0
  1. ; - send mail message if necessary
  1. ; This bulletin has been disabled. IVM*2*140
  1. ;I IVMCNTR D MAIL^IVMUFNC()
  1. ; Cleanup variables if no msg necessary
  1. I 'IVMCNTR K IVMTEXT,XMSUB
  1. ;
  1. ENQ ; - cleanup variables
  1. 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
  1. Q
  1. ;
  1. ;
  1. NEXT ; - get the next HL7 segment in the message from HL7 Transmission (#772) file
  1. ;
  1. S IVMDA=$O(^TMP($J,IVMRTN,IVMDA)),IVMSEG=$G(^(+IVMDA,0))
  1. Q
  1. ;
  1. ;
  1. COMPARE(IVMSEG) ; - compare incoming HL7 segment/fields with DHCP fields
  1. ;
  1. ; Input: IVMSEG -- as the text of the incoming HL7 message
  1. ;
  1. ; Output: None
  1. ;
  1. ; - get 3 letter HL7 segment name
  1. S IVMXREF=$P(IVMSEG,HLFS,1),IVMSTART=IVMXREF
  1. ;
  1. ; - strip off HL7 segment name
  1. S IVMSEG=$P(IVMSEG,HLFS,2,99)
  1. ;
  1. ; - roll through "C" x-ref in IVM Demographic Upload Fields (#301.92) file
  1. F S IVMXREF=$O(^IVM(301.92,"C",IVMXREF)) Q:IVMXREF']"" D
  1. .S IVMDEMDA=$O(^IVM(301.92,"C",IVMXREF,"")) Q:IVMDEMDA']""
  1. .I $$INACTIVE(IVMDEMDA) Q
  1. .;
  1. .; - compare incoming HL7 segment fields with DHCP fields
  1. .I IVMXREF["PID",(IVMSTART["PID") D PID^IVMPREC8
  1. .I IVMXREF["ZPD",(IVMSTART["ZPD") D ZPD^IVMPREC8
  1. .I IVMXREF["ZTA",(IVMSTART["ZTA") D ZTA^IVMPREC8
  1. .; KUM IVM*2.0*164 - ZAV Segment Processing
  1. .I IVMXREF["ZAV",(IVMSTART["ZAV") D ZAV^IVMPREC8
  1. .;
  1. .I IVMXREF["ZGD",(IVMSTART["ZGD") D ZGD^IVMPREC8
  1. .; IVM*2.0*192; JAM; Tag ZCT moved to IVMPREC9
  1. .I IVMXREF["ZCT",(IVMSTART["ZCT") D ZCT^IVMPREC9
  1. .I IVMXREF["ZEM",(IVMSTART["ZEM") D ZEM^IVMPREC8
  1. .I IVMXREF["RF1",(IVMSTART["RF1") D RF1^IVMPREC8
  1. Q
  1. ;
  1. ;
  1. DEMBULL ; - build mail message for transmission to IVM mail group notifying
  1. ; them that patients with updated demographic data has been received
  1. ; from the IVM Center and may now be uploaded into DHCP.
  1. ;
  1. ; If record is auto uploaded, don't add veteran to bulletin
  1. I $$CKAUTO Q
  1. ;
  1. S IVMPTID=$$PT^IVMUFNC4(DFN)
  1. S XMSUB="IVM - DEMOGRAPHIC UPLOAD for "_$P($P(IVMPTID,"^"),",")_" ("_$P(IVMPTID,"^",3)_")"
  1. S IVMTEXT(1)="Updated demographic information has been received from the"
  1. S IVMTEXT(2)="Health Eligibilty Center. Please select the 'Demographic Upload'"
  1. S IVMTEXT(3)="option from the IVM Upload Menu in order to take action on this"
  1. S IVMTEXT(4)="demographic information. If you have any questions concerning the"
  1. S IVMTEXT(5)="information received, please contact the Health Eligibility Center."
  1. S IVMTEXT(7)=""
  1. S IVMTEXT(8)="The Health Eligibilty Center has identified the following"
  1. S IVMTEXT(9)="patients as having updated demographic information:"
  1. S IVMTEXT(10)=""
  1. S IVMCNTR=IVMCNTR+1
  1. S IVMTEXT(IVMCNTR+10)=$J(IVMCNTR_")",5)_" "_$P(IVMPTID,"^")_" ("_$P(IVMPTID,"^",3)_")"
  1. Q
  1. ;
  1. INACTIVE(IVMDEMDA) ;Check if field is inactive in Demographic Upload
  1. ; Input -- IVMDEMDA IVM Demographic Upload Fields IEN
  1. ; Output -- 1=Yes and 0=No
  1. Q +$P($G(^IVM(301.92,IVMDEMDA,0)),U,9)
  1. ;
  1. RF1CHK(IVMRTN,IVMDA) ;does an RF1 segment exist in this message?
  1. N RF1
  1. S RF1=$O(^TMP($J,IVMRTN,IVMDA))
  1. I $E($G(^(+RF1,0)),1,3)'="RF1" Q 0
  1. Q 1
  1. ;
  1. CKAUTO() ;
  1. ; Chect if message qualifies for an auto upload.
  1. N AUTO,IVMI,DOD
  1. S AUTO=0,IVMI=$O(^IVM(301.92,"C","ZPD09",""))
  1. I IVMI=IVMDEMDA D
  1. .I +IVMFLD'>0 S AUTO=1 Q
  1. .S DOD=$P($G(^DPT(DFN,.35)),U)
  1. .I DOD=IVMFLD S AUTO=1 Q
  1. ;
  1. Q AUTO
  1. BLDPID(PIDTMP,IVMPID) ;Build IVMPID subscripted by sequence number
  1. N STR,X1,X2,N,TEXT,C,L
  1. S STR="",X1=1,(N,X2)=0
  1. F S N=$O(PIDTMP(N)) Q:N="" S TEXT=PIDTMP(N) F L=1:1:$L(TEXT) S C=$E(TEXT,L) D
  1. . I C="^" D Q
  1. . . I X2 S X2=X2+1,IVMPID(X1,X2)=STR
  1. . . E S IVMPID(X1)=STR
  1. . . S STR="",X1=X1+1,X2=0
  1. . I C="|" D Q
  1. . . S X2=X2+1,IVMPID(X1,X2)=STR,STR=""
  1. . S STR=STR_C
  1. I $G(C)'="",$G(C)'="^",$G(C)'="|" D
  1. . I X2 S X2=X2+1,IVMPID(X1,X2)=STR Q
  1. . S IVMPID(X1)=STR
  1. Q
  1. 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)
  1. N IVMVALUE,IVMFIELD
  1. I '$D(^TMP($J,"CHANGE UPDATE")) Q
  1. S IVMFIELD=0 F S IVMFIELD=$O(^TMP($J,"CHANGE UPDATE",IVMFIELD)) Q:IVMFIELD="" D
  1. . S IVMVALUE=$G(^TMP($J,"CHANGE UPDATE",IVMFIELD))
  1. . S DIE="^DPT(",DA=DFN,DR=IVMFIELD_"////^S X=IVMVALUE"
  1. . D ^DIE K DA,DIE,DR
  1. .; - delete inaccurate Addr Change Site data if Source is not VAMC
  1. . I IVMFIELD=.119,IVMVALUE'="VAMC" S FDA(2,+DFN_",",.12)="@" D UPDATE^DIE("E","FDA")
  1. .; - delete inaccurate Residence Number Change Site data if Source
  1. .; is not VAMC (IVM*2*152)
  1. . I IVMFIELD=.1322,IVMVALUE'="VAMC" S FDA(2,+DFN_",",.1323)="@" D UPDATE^DIE("E","FDA")
  1. K ^TMP($J,"CHANGE UPDATE")
  1. Q
  1. EPCFLDS(EPCFARY,EPCDEL) ;
  1. ;EPCFARY - Contains IENs of Pager, email, Cell phone and Home phone records in 301.92 File - Passed by reference
  1. ;EPCDEL - Contains field # of Pager, Email, Cell phone and Home phone fields in Patient(#2) file. - Passed by reference
  1. I (DODSEG)!(GUARSEG) Q
  1. 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))
  1. 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))
  1. 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))
  1. ; IVM*2.0*167 - Make Home phone records auto-upload to Patient File
  1. 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))
  1. ; IVM*2.0*214 - Populate IENs of PHONE NUMBER [WORK], WORK NUMBER CHANGE DT/TM records in IVM PATIENT (#301.5) file
  1. S EPCFARY("PHW")=$O(^IVM(301.92,"B","PHONE NUMBER [WORK]",0))_"^"_$O(^IVM(301.92,"B","WORK NUMBER CHANGE DT/TM",0))
  1. S EPCDEL("PNO")=".135^.1312^.1313^.1314"
  1. S EPCDEL("CPH")=".134^.139^.1311^.13111"
  1. S EPCDEL("EAD")=".133^.136^.137^.138"
  1. ; IVM*2.0*167 - Make Home phone records auto-upload to Patient File
  1. ; IVM*2.0*171 - Comment out line to fix the home phone deletion issue
  1. ;S EPCDEL("PHH")=".131^.1321^.1322^.1323"
  1. ; IVM*2.0*214 - Make Work phone records auto-upload to Patient File
  1. S EPCDEL("PHW")=".132^.1326"
  1. Q
  1. ;
  1. AUPBLD(AUPFARY,UPDAUPG) ; Set up array containing fields for auto upload.
  1. ;AUPFARY - Contains fields in 301.92 File-Passed by reference
  1. ;UPDAUPG - Contains all groups initialized to '0'
  1. N AUPSTR,AUPGRP,AUPFLST,AUPPCE,AUPSGSQ,AUPDA
  1. F I=3:1 S AUPSTR=$P($T(AUPLST+I),";;",2,3) Q:$P(AUPSTR,";")="QUIT" D
  1. .S AUPGRP=$P(AUPSTR,";"),AUPFLST=$P(AUPSTR,";",2)
  1. .F AUPPCE=1:1:$L(AUPFLST,"^") D
  1. ..S AUPSGSQ=$P(AUPFLST,"^",AUPPCE) Q:AUPSGSQ=""
  1. ..S AUPDA=$O(^IVM(301.92,"C",AUPSGSQ,0)) Q:AUPDA=""
  1. ..S AUPFARY(AUPDA)=AUPGRP
  1. ..S:AUPGRP'="" UPDAUPG(AUPGRP)=0 ; Default group update flags to '0'
  1. Q
  1. ;
  1. ; IVM*2.0*164 - ZAV01,ZAV02 AND ZAV04 are added for Auto Upload.
  1. ; Residential Address (RA) group is added
  1. ; Confidential Address (CA) group is uncommented
  1. ; IVM*2.0*193; JAM ; Added fields to groups K1,K2,E1,E2 and D for foreign address fields: Province, Postal Code and Country)
  1. ; eg ZCT056K1, ZCT054K1F, ZCT055K1F (COUNTRY, PROV, POSTAL CODE for the K1 group)
  1. ; IVM*2.0*204 - Add ZCT08K1, ZCT08K2, ZCT08E1, ZCT08E2, ZCT08D1 for Auto Upload.
  1. ; IVM*2.0*215 - Add ZTA101, ZTA102, ZTA104 and remove ZTA07
  1. AUPLST ; P1;P2
  1. ; P1 = Group Name (treat all entries as this group if present)
  1. ; P2 = .01 field(s) from 301.92 separated by '^'
  1. ;;D1;ZCT03D1^ZCT04D1^ZCT051D1^ZCT052D1^ZCT053D1^ZCT054D1^ZCT055D1^ZCT054D1F^ZCT055D1F^ZCT056D1^ZCT06D1^ZCT07D1^ZCT10D1^ZCT11D1
  1. ;;E1;ZCT03E1^ZCT04E1^ZCT051E1^ZCT052E1^ZCT053E1^ZCT054E1^ZCT055E1^ZCT054E1F^ZCT055E1F^ZCT056E1^ZCT06E1^ZCT07E1^ZCT10E1^ZCT11E1
  1. ;;E2;ZCT03E2^ZCT04E2^ZCT051E2^ZCT052E2^ZCT053E2^ZCT054E2^ZCT055E2^ZCT054E2F^ZCT055E2F^ZCT056E2^ZCT06E2^ZCT07E2^ZCT10E2^ZCT11E2
  1. ;;K1;ZCT03K1^ZCT04K1^ZCT051K1^ZCT052K1^ZCT053K1^ZCT054K1^ZCT055K1^ZCT054K1F^ZCT055K1F^ZCT056K1^ZCT06K1^ZCT07K1^ZCT10K1^ZCT11K1
  1. ;;K2;ZCT03K2^ZCT04K2^ZCT051K2^ZCT052K2^ZCT053K2^ZCT054K2^ZCT055K2^ZCT054K2F^ZCT055K2F^ZCT056K2^ZCT06K2^ZCT07K2^ZCT10K2^ZCT11K2
  1. ;;TA;ZTA02^ZTA03^ZTA04^ZTA051^ZTA052^ZTA053^ZTA054^ZTA055^ZTA056^ZTA058^ZTA059^ZTA08^ZTA09^ZTA101^ZTA102^ZTA104^ZTA054F^ZTA055F^ZAV04
  1. ;;CA;PID111C^PID112C^PID113C^PID114C^PID114CF^PID115C^PID115CF^PID116C^PID117C^PID118C^PID119C^PID1110C^PID1112C^PID1113C^PID13CA^RF161CA^RF171CA^ZAV02
  1. ;;RA;PID111R^PID112R^PID113R^PID114R^PID114RF^PID115R^PID115RF^PID116R^PID117R^PID118R^PID119R^PID1110R^PID1112R^PID1113R^PID13RA^RF161RA^RF162RA^RF171RA^ZAV01
  1. ;;;ZEM03^ZEM04^ZEM05^ZEM061^ZEM062^ZEM063^ZEM064^ZEM065^ZEM068^ZEM07^ZEM09
  1. ;;;ZEM03S^ZEM04S^ZEM05S^ZEM061S^ZEM062S^ZEM063S^ZEM064S^ZEM065S^ZEM068S^ZEM07S^ZEM09S
  1. ;;;PID06^PID10^PID16^PID17^PID22^ZPD30^ZPD06^ZPD07
  1. ;;QUIT
  1. ;;
  1. ;;The following have been disabled until further notice
  1. ;;;PID113N^PID114N^PID24^PID13W
  1. ;;CA;PID111C^PID112C^PID113C^PID114C^PID114CF^PID115C^PID115CF^PID116C^PID117C^PID118C^PID119C^PID1112C1^PID1112C2^PID13CA^RF161CA^RF171CA