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

IVMLDEM6.m

Go to the documentation of this file.
  1. IVMLDEM6 ;ALB/KCL,BRM,PHH,CKN,LBD,SJD - IVM DEMOGRAPHIC UPLOAD FILE ADDRESS ;09/02/19 8:24pm
  1. ;;2.0;INCOME VERIFICATION MATCH;**10,58,73,79,108,106,105,124,115,152,164,177,188,212**;21-OCT-94;Build 1
  1. ;;Per VHA Directive 10-93-142, this routine should not be modified.
  1. ;
  1. ;
  1. ADDR(DFN,IVMDA2,IVMDA1,IVMDA,IVMPPICK) ; - function to check if uploadable field
  1. ; is an address field and return a flag
  1. ;
  1. ; Input: DFN - as patient IEN
  1. ; IVMDA2 - pointer to case record in (#301.5) file
  1. ; IVMDA1 - pointer to PID msg in (#301.501) sub-file
  1. ; IVMDA - pointer to record in (#301.511) sub-file
  1. ; IVMPPICK - residence phone number and/or another address
  1. ; field selected
  1. ; 0 - phone or an address field not selected
  1. ; 1 - address field(s) selected
  1. ; 2 - phone selected
  1. ; 3 - both address field(s) and phone selected
  1. ;
  1. ; Output: IVMFLAG - 1 if address field
  1. ; 0 if not an address field
  1. ;
  1. ;
  1. N IVMFLAG,IVMI,IVMJ,IVMNODE,IVMPTR,Y,IVMAFLD,IVMAVAL,IVMFNAM
  1. ;
  1. ; - initialize flags
  1. S IVMFLAG=0
  1. ;
  1. ; - check for required parameters
  1. I '$G(DFN)!('$G(IVMDA))!('$G(IVMDA1))!'($G(IVMDA2)) G ADDRQ
  1. ;
  1. ; - get pointer to (#301.92) file from (#301.511) sub-file
  1. S IVMPTR=+$G(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM",IVMDA,0)) G ADDRQ:'IVMPTR
  1. ;
  1. ASK I '$D(^IVM(301.92,"AD",+IVMPTR)) G ADDRQ
  1. I IVMPPICK=2 G ASK1
  1. W ! S DIR("A")="Do you wish to proceed with this action"
  1. S DIR("A",1)="You have selected to update an address field."
  1. S DIR("A",2)="You will be required to upload the entire address."
  1. S DIR("?")="Enter 'YES' to continue or 'NO' to abort."
  1. S DIR(0)="Y",DIR("B")="NO"
  1. D ^DIR K DIR
  1. S IVMFLAG=1
  1. I 'Y,IVMPPICK=1 G ADDRQ ;only address selected so quit
  1. I 'Y S IVMPPICK=2 G ASK1 ;check if phone should be updated
  1. W ! S DIR("A")="Are you sure that you want to update the complete address"
  1. S:$$PHARM(+$G(DFN)) DIR("A",1)="*** WARNING: This patient has ACTIVE PRESCRIPTIONS on file."
  1. S DIR("A",2)=""
  1. I $$ADRDTCK^IVMLDEM9(+$G(DFN),IVMDA2,IVMDA1) S DIR("A",2)="*** WARNING: The address that you are attempting to file is OLDER than",DIR("A",3)=" the address on file.",DIR("A",4)=""
  1. S DIR("?",1)="Enter 'YES' to update the complete address that was received from"
  1. S DIR("?")="HEC. Enter 'NO' to quit."
  1. S DIR(0)="Y",DIR("B")="NO"
  1. D ^DIR K DIR
  1. S IVMFLAG=1
  1. I 'Y,IVMPPICK=1 G ADDRQ ;only address selected so quit
  1. I 'Y S IVMPPICK=2 G ASK1 ;check if phone should be updated
  1. ;
  1. ; determine correct address change date/time to use
  1. D ADDRDT(DFN,IVMDA2,IVMDA1)
  1. ;
  1. I IVMPPICK=3 G ASK1 ;phone number also selected
  1. ;
  1. G LOOP ;only address selected, proceed to filing
  1. ;
  1. ASK1 ; - phone selected to be uploaded
  1. W !! S DIR("A")="OK to update"
  1. S DIR("A",1)="You have selected to update the PHONE NUMBER [RESIDENCE] field."
  1. I $$PHNDTCK^IVMLDEM9(+$G(DFN),IVMDA2,IVMDA1) D
  1. .S DIR("A",2)="*** WARNING: The phone number that you are attempting to file is OLDER than"
  1. .S DIR("A",3)=" the phone number on file."
  1. .S DIR("A",4)=""
  1. S DIR("?",1)="Enter 'YES' to update the patient's Phone Number [Residence] that was"
  1. S DIR("?",2)="received from HEC. Enter 'NO' to quit."
  1. S DIR(0)="Y",DIR("B")="YES"
  1. D ^DIR K DIR
  1. S IVMFLAG=1
  1. I 'Y,IVMPPICK=2 G ADDRQ ;no phone or address updates, just quit
  1. I 'Y S IVMPPICK=1 G LOOP ;address still needs to be filed
  1. ;
  1. ; determine correct phone # change date/time to use
  1. D PHONDT(DFN,IVMDA2,IVMDA1)
  1. ;
  1. W !,"Filing PHONE NUMBER [RESIDENCE] field... "
  1. ;
  1. LOOP ;
  1. N DGPRIOR D GETPRIOR^DGADDUTL(DFN,.DGPRIOR)
  1. ;
  1. I IVMPPICK'=2 D
  1. .W !,"Filing address fields... "
  1. .D EN^DGCLEAR(DFN,"PERM") ;Deleting existing address before updating
  1. ; - loop thru fields in ^IVM(301.92,"AD" x-ref
  1. S IVMI=0 F S IVMI=$O(^IVM(301.92,"AD",IVMI)) Q:IVMI']"" D
  1. .S IVMJ=0 F S IVMJ=$O(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM","B",IVMI,IVMJ)) Q:IVMJ']"" D
  1. ..;
  1. ..; - check for data node in (#301.511) sub-file
  1. ..S IVMNODE=$G(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM",IVMJ,0)) Q:IVMNODE']""
  1. ..Q:'(+IVMNODE)!($P(IVMNODE,"^",2)']"")
  1. ..;
  1. ..S IVMFNAM=$P($G(^IVM(301.92,+IVMNODE,0)),U) Q:IVMFNAM=""
  1. ..; - check if residence phone number and not selected to upload
  1. ..I IVMPPICK=1&(IVMFNAM="PHONE NUMBER [RESIDENCE]"!(IVMFNAM["RESIDENCE NUMBER CHANGE")) Q
  1. ..; - check if not residence phone number and only phone selected to upload
  1. ..I IVMPPICK=2&(IVMFNAM'="PHONE NUMBER [RESIDENCE]"&(IVMFNAM'["RESIDENCE NUMBER CHANGE")) Q
  1. ..;
  1. ..;Store Address change Date/time, source and site in ^TMP to file at the end of process.
  1. ..S IVMAFLD=$P($G(^IVM(301.92,+IVMNODE,0)),"^",5),IVMAVAL=$P(IVMNODE,"^",2)
  1. ..I ((IVMAFLD=.118)!(IVMAFLD=.119)!(IVMAFLD=.12)) S ^TMP($J,"CHANGE UPDATE",IVMAFLD)=IVMAVAL
  1. ..;Store Residence Number change Date/time, source and site in ^TMP to file at the end of process.
  1. ..I ((IVMAFLD=.1321)!(IVMAFLD=.1322)!(IVMAFLD=.1323)) S ^TMP($J,"CHANGE UPDATE",IVMAFLD)=IVMAVAL
  1. ..; - perform any necessary address field manipulation and
  1. ..; load addr field rec'd from IVM into DHCP (#2) file
  1. ..D UPLOAD(+DFN,$P($G(^IVM(301.92,+IVMNODE,0)),"^",5),$P(IVMNODE,"^",2)) S IVMFLAG=1
  1. ..;
  1. ..; - remove entry from (#301.511) sub-file
  1. ..D DELENT^IVMLDEMU(IVMDA2,IVMDA1,IVMJ)
  1. ;
  1. D ADDRCHNG^IVMPREC6(DFN) ;Update Address change date/time,source,site if necessary
  1. I IVMFLAG W "completed.",! D
  1. .N DGCURR
  1. .D GETUPDTS^DGADDUTL(DFN,.DGCURR)
  1. .D UPDADDLG^DGADDUTL(DFN,.DGPRIOR,.DGCURR)
  1. ;
  1. ; - if addr is uploaded and phone # is not - ask user delete phone
  1. ;I IVMFLAG,$P($G(^DPT(+DFN,.13)),"^")]"",(2>IVMPPICK) D PHONE
  1. S VALMBCK="R"
  1. ;
  1. ;
  1. ADDRQ ; - return --> 1 if uploadable field is an address field
  1. ; --> 0 if uploadable field is not an address field
  1. ;
  1. I IVMFLAG D RESET^IVMLDEMU
  1. Q IVMFLAG
  1. ;
  1. ;
  1. UPLOAD(DFN,IVMFIELD,IVMVALUE) ; - file address fields received from IVM
  1. ;
  1. ; Input: DFN - as patient IEN
  1. ; IVMFIELD - as the field number to be updated
  1. ; IVMVALUE - as the value of the field
  1. ;
  1. ; Output: None
  1. ;
  1. ;
  1. ; - update specified address field in the Patient (#2) file
  1. N DIE,DA,DR,IENS,FDA,IVMZCT
  1. ; KUM - IVM*2.0*164
  1. ; To bypass DELETE TEST node test in DD for TEMP ADDRESS LINE2 AND TEMP ADDRESS LINE3
  1. ; In Some production accounts, DELETE TEST node is set for .1212 and .1213
  1. I ((IVMFIELD=.1212)!(IVMFIELD=.1213)),(IVMVALUE="@") D Q
  1. .S IENS=DFN_","
  1. .S FDA(2,IENS,IVMFIELD)="@"
  1. .D FILE^DIE("","FDA")
  1. ; IVM*2.0*164 - Allow updating null values in Confidential start and end dates
  1. I ((IVMFIELD=.1417)!(IVMFIELD=.1418)) D
  1. .S IENS=DFN_","
  1. .S FDA(2,IENS,IVMCAFG)="Y"
  1. .D FILE^DIE("","FDA")
  1. I ((IVMFIELD=.1417)!(IVMFIELD=.1418)),(IVMVALUE="@") D Q
  1. .S IENS=DFN_","
  1. .S FDA(2,IENS,IVMFIELD)="@"
  1. .D FILE^DIE("","FDA")
  1. I IVMFIELD=.14112 D Q
  1. .S IENS=DFN_","
  1. .S FDA(2,IENS,IVMCAFG)=IVMCAVL
  1. .D FILE^DIE("","FDA")
  1. .S IENS=DFN_","
  1. .S FDA(2,IENS,IVMFIELD)=IVMVALUE
  1. .D FILE^DIE("","FDA")
  1. .;
  1. .;KUM - Use API to delete if field from ZCT and double quotes are sent. Double quotes are converted to @
  1. .;IVM*2.0*188
  1. .S IVMZCT="N"
  1. .;NAME Fields
  1. .I ((IVMFIELD=.211)!(IVMFIELD=.2191)!(IVMFIELD=.331)!(IVMFIELD=.3311)!(IVMFIELD=.341)) S IVMZCT="Y"
  1. .;RELATIONSHIP TO PATIENT Fields
  1. .I ((IVMFIELD=.212)!(IVMFIELD=.2192)!(IVMFIELD=.332)!(IVMFIELD=.3312)!(IVMFIELD=.342)) S IVMZCT="Y"
  1. .;STREET ADDRESS LINE1 Fields
  1. .I ((IVMFIELD=.213)!(IVMFIELD=.2193)!(IVMFIELD=.333)!(IVMFIELD=.3313)!(IVMFIELD=.343)) S IVMZCT="Y"
  1. .;STREET ADDRESS LINE2 Fields
  1. .I ((IVMFIELD=.214)!(IVMFIELD=.2194)!(IVMFIELD=.334)!(IVMFIELD=.3314)!(IVMFIELD=.344)) S IVMZCT="Y"
  1. .;STREET ADDRESS LINE3 Fields
  1. .I ((IVMFIELD=.215)!(IVMFIELD=.2195)!(IVMFIELD=.335)!(IVMFIELD=.3315)!(IVMFIELD=.345)) S IVMZCT="Y"
  1. .;CITY Fields
  1. .I ((IVMFIELD=.216)!(IVMFIELD=.2196)!(IVMFIELD=.336)!(IVMFIELD=.3316)!(IVMFIELD=.346)) S IVMZCT="Y"
  1. .;STATE Fields
  1. .I ((IVMFIELD=.217)!(IVMFIELD=.2197)!(IVMFIELD=.337)!(IVMFIELD=.3317)!(IVMFIELD=.347)) S IVMZCT="Y"
  1. .;ZIPCODE Fields
  1. .I ((IVMFIELD=.218)!(IVMFIELD=.2198)!(IVMFIELD=.338)!(IVMFIELD=.3318)!(IVMFIELD=.348)) S IVMZCT="Y"
  1. .;ZIP+4 Fields
  1. .I ((IVMFIELD=.2201)!(IVMFIELD=.2203)!(IVMFIELD=.2207)!(IVMFIELD=.2204)!(IVMFIELD=.2202)) S IVMZCT="Y"
  1. .;PHONE NUMBER Fields
  1. .I ((IVMFIELD=.219)!(IVMFIELD=.2199)!(IVMFIELD=.339)!(IVMFIELD=.3319)!(IVMFIELD=.349)) S IVMZCT="Y"
  1. .;WORK PHONE NUMBER Fields
  1. .I ((IVMFIELD=.21011)!(IVMFIELD=.211011)!(IVMFIELD=.33011)!(IVMFIELD=.331011)!(IVMFIELD=.34011)) S IVMZCT="Y"
  1. .;ADDRESS SAME AS PATIENT Fields
  1. .I ((IVMFIELD=.2125)!(IVMFIELD=.21925)) S IVMZCT="Y"
  1. .;CONTACT TYPE SAME AS NOK Fields
  1. .I ((IVMFIELD=.3305)!(IVMFIELD=.3405)) S IVMZCT="Y"
  1. .I (IVMVALUE="@"),(IVMZCT="Y") D
  1. ..S IENS=DFN_","
  1. ..S FDA(2,IENS,IVMFIELD)="@"
  1. ..D FILE^DIE("","FDA")
  1. ;KUM - END
  1. ;SJD - IVM*2.0*212 - Use ZIP complement fields when ZIPs are processed only when ZIP > 5.
  1. ; Compliment zip fields Example: .218 = .2207. Flip ZIP to ZIP+4 and allow ZIP+4 field X-ref
  1. ; trigger to set ZIP field. The ZIP+4 X-ref does a $Extract of 1,5 and sets complement ZIP.
  1. I (IVMFIELD=.218),($L(IVMVALUE)>5) S IVMFIELD=.2207
  1. I (IVMFIELD=.338),($L(IVMVALUE)>5) S IVMFIELD=.2201
  1. I (IVMFIELD=.348),($L(IVMVALUE)>5) S IVMFIELD=.2202
  1. I (IVMFIELD=.2198),($L(IVMVALUE)>5) S IVMFIELD=.2203
  1. I (IVMFIELD=.3318),($L(IVMVALUE)>5) S IVMFIELD=.2204
  1. ;SJD - IVM*2.0*212 - END
  1. S DIE="^DPT(",DA=DFN,DR=IVMFIELD_"////^S X=IVMVALUE"
  1. D ^DIE K DA,DIE,DR
  1. ;
  1. ; - delete inaccurate Addr Change Site data if Source is not VAMC
  1. ; (trigger x-ref does not fire with 4 slash stuff)
  1. I IVMFIELD=.119,IVMVALUE'="VAMC" S FDA(2,+DFN_",",.12)="@" D UPDATE^DIE("E","FDA")
  1. ; KUM - IVM*2.0*164
  1. ; If Source is not VAMC, delete the Site
  1. I IVMFIELD=.11582,IVMVALUE'="VAMC" S FDA(2,+DFN_",",.11581)="@" D UPDATE^DIE("E","FDA")
  1. Q
  1. ;
  1. ;
  1. PHONE ; - ask user to delete phone # [Residence] from Patient (#2) file
  1. D PHONE^IVMPREC9 ;Moved this tag to IVMPREC9 due to routine size limit.
  1. Q
  1. ;
  1. AUTOADDR(DFN,IVMPPICK,NOUPDT,NOPHUP) ;
  1. ; this functionality is copied from above and modified to allow
  1. ; an automated upload of patient address information as stipulated
  1. ; in the business requirements for Address Indexing to support GMT
  1. ;
  1. ; Input: DFN - as patient IEN
  1. ; IVMPPICK - residence phone number and/or another address
  1. ; field selected
  1. ; 1 - address field(s) selected
  1. ; 3 - both address field(s) and phone selected
  1. ; NOUPDT - (optional) this flag is set when the incoming
  1. ; address data is older than the existing
  1. ; address in the Patient (#2) file
  1. ; NOPHUP - (optional) this flag is set when the incoming
  1. ; home phone number is older than the existing
  1. ; home phone number in the Patient (#2) file
  1. ; Output: IVMFLAG - 1 if address fields updated
  1. ; 0 if address fields not updated
  1. ;
  1. ;
  1. ;
  1. N IVMFLAG,IVMI,IVMJ,IVMNODE,IVMPTR,Y,IVMAFLD,IVMAVAL,DELFLG
  1. ;
  1. ; - initialize flags
  1. S IVMFLAG=0,DELFLG=1
  1. S:'$G(NOUPDT) NOUPDT=0
  1. S:'$G(NOPHUP) NOPHUP=0 ;Added for IVM*2*152
  1. ;
  1. ; - check for required parameters
  1. Q:'$G(DFN) IVMFLAG
  1. ;
  1. N DGPRIOR D GETPRIOR^DGADDUTL(DFN,.DGPRIOR)
  1. ; Set the flag to don't auto-update if there is an active Prescription record and the Bad Address Indicator is null
  1. ; IVM*2.0*177; jam; - Auto upload even if patient has active prescription and bad address indicator is null
  1. ;I ('NOUPDT),$$PHARM(+DFN),'$$BADADR^DGUTL3(+DFN) S DELFLG=0
  1. I 'NOUPDT,DELFLG D EN^DGCLEAR(DFN,"PERM") ;Deleting existing address before updating
  1. ;
  1. S IVMDA2=$G(IVM3015)
  1. Q:'$G(IVMDA2) IVMFLAG
  1. S IVMDA1=$O(^HL(771.3,"B","PID",""))
  1. S IVMDA1=$O(^IVM(301.5,IVMDA2,"IN","B",IVMDA1,""),-1)
  1. Q:'IVMDA1 IVMFLAG
  1. ;
  1. S IVMI=0 F S IVMI=$O(^IVM(301.92,"AD",IVMI)) Q:IVMI']"" D
  1. .S IVMJ=0 F S IVMJ=$O(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM","B",IVMI,IVMJ)) Q:IVMJ']"" D
  1. ..;
  1. ..; - check for data node in (#301.511) sub-file
  1. ..S IVMNODE=$G(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM",IVMJ,0))
  1. ..I ('+IVMNODE)!($P(IVMNODE,"^",2)']"") Q
  1. ..;
  1. ..; - check if residence phone number -> do not auto-upload
  1. ..; If NOPHUP=1 delete entry from #301.511 sub-file, otherwise quit
  1. ..; (IVM*2*152)
  1. ..I $P($G(^IVM(301.92,+IVMNODE,0)),U)="PHONE NUMBER [RESIDENCE]"!($P($G(^IVM(301.92,+IVMNODE,0)),U)["RESIDENCE NUMBER CHANGE") D Q
  1. ...I NOPHUP D DELENT^IVMLDEMU(IVMDA2,IVMDA1,IVMJ)
  1. ..;
  1. ..; don't auto-update if there is an active Prescription record and
  1. ..; the Bad Address Indicator is null
  1. ..I 'DELFLG D DEMBULL^IVMPREC6 Q
  1. ..;Store Address change Date/time, source and site in ^TMP to file at the end of process.
  1. ..S IVMAFLD=$P($G(^IVM(301.92,+IVMNODE,0)),"^",5),IVMAVAL=$P(IVMNODE,"^",2)
  1. ..I 'NOUPDT,((IVMAFLD=.118)!(IVMAFLD=.119)!(IVMAFLD=.12)) S ^TMP($J,"CHANGE UPDATE",IVMAFLD)=IVMAVAL
  1. ..;
  1. ..; - load addr field rec'd from IVM into DHCP (#2) file
  1. ..I 'NOUPDT D UPLOAD(+DFN,IVMAFLD,IVMAVAL) S IVMFLAG=1
  1. ..;
  1. ..; - remove entry from (#301.511) sub-file
  1. ..D DELENT^IVMLDEMU(IVMDA2,IVMDA1,IVMJ)
  1. ..; - if no display or uploadable fields left, then delete the PID
  1. ..; segment
  1. ..I '$$DEMO^IVMLDEM5(IVMDA2,IVMDA1,0),'$$DEMO^IVMLDEM5(IVMDA2,IVMDA1,1) D
  1. ...D DELETE^IVMLDEM5(IVMDA2,IVMDA1," ") ; Dummy up name parameter
  1. D ADDRCHNG^IVMPREC6(DFN) ;Update Address change date/time,source,site if necessary
  1. I IVMFLAG D
  1. .N DGCURR
  1. .D GETUPDTS^DGADDUTL(DFN,.DGCURR)
  1. .D UPDADDLG^DGADDUTL(DFN,.DGPRIOR,.DGCURR)
  1. Q IVMFLAG
  1. ;
  1. ADDRDT(DFN,IVMDA2,IVMDA1) ;
  1. ; - validate Address Change Dt/Tm before filing
  1. ; if incoming address is accepted and the change date is older
  1. ; than what's on file, then use today's date for Addr Chg Dt/Tm
  1. ;
  1. Q:'$$ADRDTCK^IVMLDEM9(DFN,IVMDA2,IVMDA1)
  1. N FDA,IEN92,IVMDA,IENS,ERR
  1. S IEN92=$O(^IVM(301.92,"C","RF171","")) Q:'IEN92
  1. Q:'$D(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM","B",IEN92))
  1. S IVMDA=$O(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM","B",IEN92,"")) Q:'IVMDA
  1. S IENS=IVMDA_","_IVMDA1_","_IVMDA2_","
  1. S FDA(301.511,IENS,.02)=$$NOW^XLFDT
  1. D FILE^DIE("","FDA","ERR")
  1. Q
  1. ;
  1. PHONDT(DFN,IVMDA2,IVMDA1) ;
  1. ; - validate Residence Number Change Dt/Tm before filing
  1. ; if incoming phone number is accepted and the change date is
  1. ; older than what's on file, then use today's date for
  1. ; Residence Number Change Dt/Tm (IVM*2*152)
  1. ;
  1. Q:'$$PHNDTCK^IVMLDEM9(DFN,IVMDA2,IVMDA1)
  1. N FDA,IEN92,IVMDA,IENS,ERR
  1. S IEN92=$O(^IVM(301.92,"C","RF171P","")) Q:'IEN92
  1. Q:'$D(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM","B",IEN92))
  1. S IVMDA=$O(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM","B",IEN92,"")) Q:'IVMDA
  1. S IENS=IVMDA_","_IVMDA1_","_IVMDA2_","
  1. S FDA(301.511,IENS,.02)=$$NOW^XLFDT
  1. D FILE^DIE("","FDA","ERR")
  1. Q
  1. ;
  1. PHARM(DFN) ;does this patient have active pharmacy prescriptions?
  1. ;
  1. ;External reference to $$EN^PSSRXACT supported by IA #4237
  1. ;
  1. Q $S('$G(DFN):0,1:$$EN^PSSRXACT(DFN))