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

XUMVIEU1.m

Go to the documentation of this file.
  1. XUMVIEU1 ;MVI/CKN - Master Veteran Index Enrich New Person ; 1/22/21 5:05pm
  1. ;;8.0;KERNEL;**744**;Jul 10, 1995;Build 1
  1. ;Per VA Directive 6402, this routine should not be modified.
  1. ;**744,Story VAMPI_3039 (ckn): New routine
  1. ;
  1. SETFDA(IEN,XUARR,FDA) ;Set FDA from XUARR for filing into File #200
  1. N IENS,WHO,VAL
  1. S WHO=$G(XUARR("WHO"))
  1. S IENS=+IEN_","
  1. ;
  1. ;DEGREE
  1. S:$D(XUARR("DEGREE"))#2 FDA(200,IENS,10.6)=$$TRIM^XLFSTR(XUARR("DEGREE"))
  1. ;
  1. ;Subject Organization and ID
  1. D:$G(XUARR("SubjectOrgan"),"<undef>")=""!($G(XUARR("SubjectOrganID"),"<undef>")="") SUBJDEF^XUMVIENU(.XUARR)
  1. S:$D(XUARR("SubjectOrgan"))#2 FDA(200,IENS,205.2)=XUARR("SubjectOrgan")
  1. S:$D(XUARR("SubjectOrganID"))#2 FDA(200,IENS,205.3)=XUARR("SubjectOrganID")
  1. ;
  1. ;GENDER
  1. S:$D(XUARR("GENDER"))#2 FDA(200,IENS,4)=XUARR("GENDER")
  1. ;
  1. ;ADDRESS DATA
  1. D:$D(XUARR("ADDRESS DATA"))#2
  1. . N ADDR,STR1,STR2,STR3,CITY,STATE,ZIP,OPHN,FAX
  1. . S ADDR=XUARR("ADDRESS DATA")
  1. . S STR1=$P(ADDR,"|"),STR2=$P(ADDR,"|",2),STR3=$P(ADDR,"|",3)
  1. . S CITY=$P(ADDR,"|",4),STATE=$P(ADDR,"|",5),ZIP=$P(ADDR,"|",6)
  1. . S OPHN=$P(ADDR,"|",7),FAX=$P(ADDR,"|",8)
  1. . I $L(ZIP)=9,ZIP'["-" S ZIP=$E(ZIP,1,5)_"-"_$E(ZIP,6,9)
  1. . S FDA(200,IENS,.111)=$E(STR1,1,$$MAXLEN^XUMVIENU(200,.111))
  1. . S FDA(200,IENS,.112)=$E(STR2,1,$$MAXLEN^XUMVIENU(200,.112))
  1. . S FDA(200,IENS,.113)=$E(STR3,1,$$MAXLEN^XUMVIENU(200,.113))
  1. . S FDA(200,IENS,.114)=$E(CITY,1,$$MAXLEN^XUMVIENU(200,.114))
  1. . S FDA(200,IENS,.115)=$$STATEIEN^XUMVIENU(STATE)
  1. . S FDA(200,IENS,.116)=ZIP
  1. . S FDA(200,IENS,.132)=OPHN
  1. . S FDA(200,IENS,.136)=FAX
  1. ;
  1. ;Tax ID
  1. S:$D(XUARR("TaxID"))#2 FDA(200,IENS,53.92)=XUARR("TaxID")
  1. ;
  1. ;Termination
  1. S:$D(XUARR("Termination"))#2 FDA(200,IENS,9.2)=XUARR("Termination")
  1. ;Inactivate
  1. S:$D(XUARR("Inactivate"))#2 FDA(200,IENS,53.4)=XUARR("Inactivate")
  1. ;
  1. ;Remarks
  1. I $G(XUARR("Remarks"))="",WHO="200PIEV" D
  1. .I $P($G(^VA(200,+IEN,"PS")),U,9)="" S XUARR("Remarks")="NON-VA PROVIDER"
  1. .E K XUARR("Remarks")
  1. S:$D(XUARR("Remarks"))#2 FDA(200,IENS,53.9)=$E(XUARR("Remarks"),1,$$MAXLEN^XUMVIENU(200,53.9))
  1. ;
  1. ;Title
  1. I $G(XUARR("Title"))="",WHO="200PIEV" D
  1. .I $P($G(^VA(200,+IEN,0)),U,9)="" S XUARR("Title")="NON-VA PROVIDER"
  1. .E K XUARR("Title")
  1. D:$D(XUARR("Title"))#2
  1. . ;Add Title to TITLE file (#3.1) if not already there
  1. . N DIERR,DIHELP,DIMSG,XUMSG
  1. . S XUARR("Title")=$E($$UP^XLFSTR(XUARR("Title")),1,$$MAXLEN^XUMVIENU(200,8))
  1. . D:$$FIND1^DIC(3.1,"","X",XUARR("Title"),"","","XUMSG")'>0
  1. .. N TITLEFDA
  1. .. S TITLEFDA(3.1,"+1,",.01)=XUARR("Title")
  1. .. D UPDATER^XUMVIENU(.TITLEFDA,"E",.XURET)
  1. . S FDA(200,IENS,8)=XUARR("Title")
  1. ;
  1. ;Authorized to Write Med Orders
  1. D:$D(XUARR("AuthWriteMedOrders"))#2
  1. . S VAL=$$UP^XLFSTR(XUARR("AuthWriteMedOrders")) S:VAL=0!(VAL="N")!(VAL="NO") VAL=""
  1. . S FDA(200,IENS,53.1)=VAL
  1. ;
  1. ;Provider Class
  1. S:$D(XUARR("ProviderClass"))#2 FDA(200,IENS,53.5)=XUARR("ProviderClass")
  1. ;
  1. ;Non VA Prescriber
  1. I WHO="200PIEV",$G(XUARR("NonVAPrescriber"))="" S FDA(200,IENS,53.91)=1
  1. E S:$D(XUARR("NonVAPrescriber"))#2 FDA(200,IENS,53.91)=XUARR("NonVAPrescriber")
  1. ;
  1. ;Provider Type
  1. D:$D(XUARR("ProviderType"))#2
  1. . N PROVTYPE
  1. . S PROVTYPE=$P(XUARR("ProviderType"),"|")
  1. . S:PROVTYPE="" PROVTYPE=$P(XUARR("ProviderType"),"|",2)
  1. . S FDA(200,IENS,53.6)=PROVTYPE
  1. ;
  1. ;SECID
  1. S:$D(XUARR("SECID"))#2 FDA(200,IENS,205.1)=XUARR("SECID")
  1. ;Unique User ID
  1. S:$D(XUARR("UniqueUserID"))#2 FDA(200,IENS,205.4)=XUARR("UniqueUserID")
  1. ;ADUPN (Email)
  1. S:$D(XUARR("ADUPN"))#2 FDA(200,IENS,205.5)=XUARR("ADUPN")
  1. ;EMAIL ADDRESS
  1. S:$D(XUARR("EMAIL"))#2 FDA(200,IENS,.151)=XUARR("EMAIL")
  1. ;Network Username
  1. S:$D(XUARR("NTUSERNAME"))#2 FDA(200,IENS,501.1)=XUARR("NTUSERNAME")
  1. Q
  1. ;
  1. CPRSNVA(IEN,XUARR,OLDTDATE) ;**744 - VAMPI-3039 (ckn)
  1. ;CPRS TAB
  1. N IENS,ORDIEN,CPRSEXP,NVAIEN,FDA,NEWTDATE
  1. S IENS=+IEN_","
  1. S NEWTDATE=$P($G(^VA(200,IEN,0)),U,11) ;Termination Date
  1. I NEWTDATE]"" Q ;Quit as Terminated record
  1. ;
  1. S ORDIEN=$O(^ORD(101.13,"B","NVA","")) Q:ORDIEN=""
  1. ;ADD - If CPRS TAB field does not have date for "NVA", add new record in CPRS TAB multiple field
  1. I '$D(^VA(200,+IEN,"ORD","B",ORDIEN)) D Q
  1. .S FDA(200.010113,"+1,"_IENS,.01)="NVA"
  1. .S FDA(200.010113,"+1,"_IENS,.02)=$$DT^XLFDT()
  1. .I $G(XUARR("Inactivate"))'="" S FDA(200.010113,"+1,"_IENS,.03)=$G(XUARR("Inactivate"))
  1. .D UPDATE^DIE("E","FDA")
  1. .K FDA
  1. ;
  1. ;UPDATE - Existing CPRS TAB field for "NVA" AND Termination date is deleted in this update,
  1. ;Update CPRS TAB multiple field and Quit
  1. S NVAIEN=$O(^VA(200,+IEN,"ORD","B",ORDIEN,"")),CPRSEXP=$P($G(^VA(200,+IEN,"ORD",NVAIEN,0)),"^",3)
  1. I OLDTDATE]"",NEWTDATE="" D Q
  1. .S FDA(200.010113,NVAIEN_","_IENS,.02)=$$DT^XLFDT()
  1. .S FDA(200.010113,NVAIEN_","_IENS,.03)=$S($G(XUARR("Inactivate"))'="":$G(XUARR("Inactivate")),1:"@")
  1. .D FILE^DIE("E","FDA")
  1. .K FDA
  1. ;
  1. ;UPDATE - Existing CPRS TAB field for "NVA" and No Termination Date
  1. ;Update only Expiration Date if Inactivation is sent AND it is different than existing
  1. I $G(XUARR("Inactivate"))'="" D
  1. .I CPRSEXP'="",(XUARR("Inactivate")=$$FMTHL7^XLFDT(CPRSEXP)) Q
  1. .S FDA(200.010113,NVAIEN_","_IENS,.03)=$G(XUARR("Inactivate"))
  1. .D FILE^DIE("E","FDA")
  1. .K FDA
  1. Q