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