XUMVIEU1 ;MVI/CKN - Master Veteran Index Enrich New Person ; 1/22/21 5:05pm
;;8.0;KERNEL;**744**;Jul 10, 1995;Build 1
;Per VA Directive 6402, this routine should not be modified.
;**744,Story VAMPI_3039 (ckn): New routine
;
SETFDA(IEN,XUARR,FDA) ;Set FDA from XUARR for filing into File #200
N IENS,WHO,VAL
S WHO=$G(XUARR("WHO"))
S IENS=+IEN_","
;
;DEGREE
S:$D(XUARR("DEGREE"))#2 FDA(200,IENS,10.6)=$$TRIM^XLFSTR(XUARR("DEGREE"))
;
;Subject Organization and ID
D:$G(XUARR("SubjectOrgan"),"<undef>")=""!($G(XUARR("SubjectOrganID"),"<undef>")="") SUBJDEF^XUMVIENU(.XUARR)
S:$D(XUARR("SubjectOrgan"))#2 FDA(200,IENS,205.2)=XUARR("SubjectOrgan")
S:$D(XUARR("SubjectOrganID"))#2 FDA(200,IENS,205.3)=XUARR("SubjectOrganID")
;
;GENDER
S:$D(XUARR("GENDER"))#2 FDA(200,IENS,4)=XUARR("GENDER")
;
;ADDRESS DATA
D:$D(XUARR("ADDRESS DATA"))#2
. N ADDR,STR1,STR2,STR3,CITY,STATE,ZIP,OPHN,FAX
. S ADDR=XUARR("ADDRESS DATA")
. S STR1=$P(ADDR,"|"),STR2=$P(ADDR,"|",2),STR3=$P(ADDR,"|",3)
. S CITY=$P(ADDR,"|",4),STATE=$P(ADDR,"|",5),ZIP=$P(ADDR,"|",6)
. S OPHN=$P(ADDR,"|",7),FAX=$P(ADDR,"|",8)
. I $L(ZIP)=9,ZIP'["-" S ZIP=$E(ZIP,1,5)_"-"_$E(ZIP,6,9)
. S FDA(200,IENS,.111)=$E(STR1,1,$$MAXLEN^XUMVIENU(200,.111))
. S FDA(200,IENS,.112)=$E(STR2,1,$$MAXLEN^XUMVIENU(200,.112))
. S FDA(200,IENS,.113)=$E(STR3,1,$$MAXLEN^XUMVIENU(200,.113))
. S FDA(200,IENS,.114)=$E(CITY,1,$$MAXLEN^XUMVIENU(200,.114))
. S FDA(200,IENS,.115)=$$STATEIEN^XUMVIENU(STATE)
. S FDA(200,IENS,.116)=ZIP
. S FDA(200,IENS,.132)=OPHN
. S FDA(200,IENS,.136)=FAX
;
;Tax ID
S:$D(XUARR("TaxID"))#2 FDA(200,IENS,53.92)=XUARR("TaxID")
;
;Termination
S:$D(XUARR("Termination"))#2 FDA(200,IENS,9.2)=XUARR("Termination")
;Inactivate
S:$D(XUARR("Inactivate"))#2 FDA(200,IENS,53.4)=XUARR("Inactivate")
;
;Remarks
I $G(XUARR("Remarks"))="",WHO="200PIEV" D
.I $P($G(^VA(200,+IEN,"PS")),U,9)="" S XUARR("Remarks")="NON-VA PROVIDER"
.E K XUARR("Remarks")
S:$D(XUARR("Remarks"))#2 FDA(200,IENS,53.9)=$E(XUARR("Remarks"),1,$$MAXLEN^XUMVIENU(200,53.9))
;
;Title
I $G(XUARR("Title"))="",WHO="200PIEV" D
.I $P($G(^VA(200,+IEN,0)),U,9)="" S XUARR("Title")="NON-VA PROVIDER"
.E K XUARR("Title")
D:$D(XUARR("Title"))#2
. ;Add Title to TITLE file (#3.1) if not already there
. N DIERR,DIHELP,DIMSG,XUMSG
. S XUARR("Title")=$E($$UP^XLFSTR(XUARR("Title")),1,$$MAXLEN^XUMVIENU(200,8))
. D:$$FIND1^DIC(3.1,"","X",XUARR("Title"),"","","XUMSG")'>0
.. N TITLEFDA
.. S TITLEFDA(3.1,"+1,",.01)=XUARR("Title")
.. D UPDATER^XUMVIENU(.TITLEFDA,"E",.XURET)
. S FDA(200,IENS,8)=XUARR("Title")
;
;Authorized to Write Med Orders
D:$D(XUARR("AuthWriteMedOrders"))#2
. S VAL=$$UP^XLFSTR(XUARR("AuthWriteMedOrders")) S:VAL=0!(VAL="N")!(VAL="NO") VAL=""
. S FDA(200,IENS,53.1)=VAL
;
;Provider Class
S:$D(XUARR("ProviderClass"))#2 FDA(200,IENS,53.5)=XUARR("ProviderClass")
;
;Non VA Prescriber
I WHO="200PIEV",$G(XUARR("NonVAPrescriber"))="" S FDA(200,IENS,53.91)=1
E S:$D(XUARR("NonVAPrescriber"))#2 FDA(200,IENS,53.91)=XUARR("NonVAPrescriber")
;
;Provider Type
D:$D(XUARR("ProviderType"))#2
. N PROVTYPE
. S PROVTYPE=$P(XUARR("ProviderType"),"|")
. S:PROVTYPE="" PROVTYPE=$P(XUARR("ProviderType"),"|",2)
. S FDA(200,IENS,53.6)=PROVTYPE
;
;SECID
S:$D(XUARR("SECID"))#2 FDA(200,IENS,205.1)=XUARR("SECID")
;Unique User ID
S:$D(XUARR("UniqueUserID"))#2 FDA(200,IENS,205.4)=XUARR("UniqueUserID")
;ADUPN (Email)
S:$D(XUARR("ADUPN"))#2 FDA(200,IENS,205.5)=XUARR("ADUPN")
;EMAIL ADDRESS
S:$D(XUARR("EMAIL"))#2 FDA(200,IENS,.151)=XUARR("EMAIL")
;Network Username
S:$D(XUARR("NTUSERNAME"))#2 FDA(200,IENS,501.1)=XUARR("NTUSERNAME")
Q
;
CPRSNVA(IEN,XUARR,OLDTDATE) ;**744 - VAMPI-3039 (ckn)
;CPRS TAB
N IENS,ORDIEN,CPRSEXP,NVAIEN,FDA,NEWTDATE
S IENS=+IEN_","
S NEWTDATE=$P($G(^VA(200,IEN,0)),U,11) ;Termination Date
I NEWTDATE]"" Q ;Quit as Terminated record
;
S ORDIEN=$O(^ORD(101.13,"B","NVA","")) Q:ORDIEN=""
;ADD - If CPRS TAB field does not have date for "NVA", add new record in CPRS TAB multiple field
I '$D(^VA(200,+IEN,"ORD","B",ORDIEN)) D Q
.S FDA(200.010113,"+1,"_IENS,.01)="NVA"
.S FDA(200.010113,"+1,"_IENS,.02)=$$DT^XLFDT()
.I $G(XUARR("Inactivate"))'="" S FDA(200.010113,"+1,"_IENS,.03)=$G(XUARR("Inactivate"))
.D UPDATE^DIE("E","FDA")
.K FDA
;
;UPDATE - Existing CPRS TAB field for "NVA" AND Termination date is deleted in this update,
;Update CPRS TAB multiple field and Quit
S NVAIEN=$O(^VA(200,+IEN,"ORD","B",ORDIEN,"")),CPRSEXP=$P($G(^VA(200,+IEN,"ORD",NVAIEN,0)),"^",3)
I OLDTDATE]"",NEWTDATE="" D Q
.S FDA(200.010113,NVAIEN_","_IENS,.02)=$$DT^XLFDT()
.S FDA(200.010113,NVAIEN_","_IENS,.03)=$S($G(XUARR("Inactivate"))'="":$G(XUARR("Inactivate")),1:"@")
.D FILE^DIE("E","FDA")
.K FDA
;
;UPDATE - Existing CPRS TAB field for "NVA" and No Termination Date
;Update only Expiration Date if Inactivation is sent AND it is different than existing
I $G(XUARR("Inactivate"))'="" D
.I CPRSEXP'="",(XUARR("Inactivate")=$$FMTHL7^XLFDT(CPRSEXP)) Q
.S FDA(200.010113,NVAIEN_","_IENS,.03)=$G(XUARR("Inactivate"))
.D FILE^DIE("E","FDA")
.K FDA
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXUMVIEU1 5214 printed Sep 23, 2025@19:47:31 Page 2
XUMVIEU1 ;MVI/CKN - Master Veteran Index Enrich New Person ; 1/22/21 5:05pm
+1 ;;8.0;KERNEL;**744**;Jul 10, 1995;Build 1
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 ;**744,Story VAMPI_3039 (ckn): New routine
+4 ;
SETFDA(IEN,XUARR,FDA) ;Set FDA from XUARR for filing into File #200
+1 NEW IENS,WHO,VAL
+2 SET WHO=$GET(XUARR("WHO"))
+3 SET IENS=+IEN_","
+4 ;
+5 ;DEGREE
+6 if $DATA(XUARR("DEGREE"))#2
SET FDA(200,IENS,10.6)=$$TRIM^XLFSTR(XUARR("DEGREE"))
+7 ;
+8 ;Subject Organization and ID
+9 if $GET(XUARR("SubjectOrgan"),"<undef>")=""!($GET(XUARR("SubjectOrganID"),"<undef>")="")
DO SUBJDEF^XUMVIENU(.XUARR)
+10 if $DATA(XUARR("SubjectOrgan"))#2
SET FDA(200,IENS,205.2)=XUARR("SubjectOrgan")
+11 if $DATA(XUARR("SubjectOrganID"))#2
SET FDA(200,IENS,205.3)=XUARR("SubjectOrganID")
+12 ;
+13 ;GENDER
+14 if $DATA(XUARR("GENDER"))#2
SET FDA(200,IENS,4)=XUARR("GENDER")
+15 ;
+16 ;ADDRESS DATA
+17 if $DATA(XUARR("ADDRESS DATA"))#2
Begin DoDot:1
+18 NEW ADDR,STR1,STR2,STR3,CITY,STATE,ZIP,OPHN,FAX
+19 SET ADDR=XUARR("ADDRESS DATA")
+20 SET STR1=$PIECE(ADDR,"|")
SET STR2=$PIECE(ADDR,"|",2)
SET STR3=$PIECE(ADDR,"|",3)
+21 SET CITY=$PIECE(ADDR,"|",4)
SET STATE=$PIECE(ADDR,"|",5)
SET ZIP=$PIECE(ADDR,"|",6)
+22 SET OPHN=$PIECE(ADDR,"|",7)
SET FAX=$PIECE(ADDR,"|",8)
+23 IF $LENGTH(ZIP)=9
IF ZIP'["-"
SET ZIP=$EXTRACT(ZIP,1,5)_"-"_$EXTRACT(ZIP,6,9)
+24 SET FDA(200,IENS,.111)=$EXTRACT(STR1,1,$$MAXLEN^XUMVIENU(200,.111))
+25 SET FDA(200,IENS,.112)=$EXTRACT(STR2,1,$$MAXLEN^XUMVIENU(200,.112))
+26 SET FDA(200,IENS,.113)=$EXTRACT(STR3,1,$$MAXLEN^XUMVIENU(200,.113))
+27 SET FDA(200,IENS,.114)=$EXTRACT(CITY,1,$$MAXLEN^XUMVIENU(200,.114))
+28 SET FDA(200,IENS,.115)=$$STATEIEN^XUMVIENU(STATE)
+29 SET FDA(200,IENS,.116)=ZIP
+30 SET FDA(200,IENS,.132)=OPHN
+31 SET FDA(200,IENS,.136)=FAX
End DoDot:1
+32 ;
+33 ;Tax ID
+34 if $DATA(XUARR("TaxID"))#2
SET FDA(200,IENS,53.92)=XUARR("TaxID")
+35 ;
+36 ;Termination
+37 if $DATA(XUARR("Termination"))#2
SET FDA(200,IENS,9.2)=XUARR("Termination")
+38 ;Inactivate
+39 if $DATA(XUARR("Inactivate"))#2
SET FDA(200,IENS,53.4)=XUARR("Inactivate")
+40 ;
+41 ;Remarks
+42 IF $GET(XUARR("Remarks"))=""
IF WHO="200PIEV"
Begin DoDot:1
+43 IF $PIECE($GET(^VA(200,+IEN,"PS")),U,9)=""
SET XUARR("Remarks")="NON-VA PROVIDER"
+44 IF '$TEST
KILL XUARR("Remarks")
End DoDot:1
+45 if $DATA(XUARR("Remarks"))#2
SET FDA(200,IENS,53.9)=$EXTRACT(XUARR("Remarks"),1,$$MAXLEN^XUMVIENU(200,53.9))
+46 ;
+47 ;Title
+48 IF $GET(XUARR("Title"))=""
IF WHO="200PIEV"
Begin DoDot:1
+49 IF $PIECE($GET(^VA(200,+IEN,0)),U,9)=""
SET XUARR("Title")="NON-VA PROVIDER"
+50 IF '$TEST
KILL XUARR("Title")
End DoDot:1
+51 if $DATA(XUARR("Title"))#2
Begin DoDot:1
+52 ;Add Title to TITLE file (#3.1) if not already there
+53 NEW DIERR,DIHELP,DIMSG,XUMSG
+54 SET XUARR("Title")=$EXTRACT($$UP^XLFSTR(XUARR("Title")),1,$$MAXLEN^XUMVIENU(200,8))
+55 if $$FIND1^DIC(3.1,"","X",XUARR("Title"),"","","XUMSG")'>0
Begin DoDot:2
+56 NEW TITLEFDA
+57 SET TITLEFDA(3.1,"+1,",.01)=XUARR("Title")
+58 DO UPDATER^XUMVIENU(.TITLEFDA,"E",.XURET)
End DoDot:2
+59 SET FDA(200,IENS,8)=XUARR("Title")
End DoDot:1
+60 ;
+61 ;Authorized to Write Med Orders
+62 if $DATA(XUARR("AuthWriteMedOrders"))#2
Begin DoDot:1
+63 SET VAL=$$UP^XLFSTR(XUARR("AuthWriteMedOrders"))
if VAL=0!(VAL="N")!(VAL="NO")
SET VAL=""
+64 SET FDA(200,IENS,53.1)=VAL
End DoDot:1
+65 ;
+66 ;Provider Class
+67 if $DATA(XUARR("ProviderClass"))#2
SET FDA(200,IENS,53.5)=XUARR("ProviderClass")
+68 ;
+69 ;Non VA Prescriber
+70 IF WHO="200PIEV"
IF $GET(XUARR("NonVAPrescriber"))=""
SET FDA(200,IENS,53.91)=1
+71 IF '$TEST
if $DATA(XUARR("NonVAPrescriber"))#2
SET FDA(200,IENS,53.91)=XUARR("NonVAPrescriber")
+72 ;
+73 ;Provider Type
+74 if $DATA(XUARR("ProviderType"))#2
Begin DoDot:1
+75 NEW PROVTYPE
+76 SET PROVTYPE=$PIECE(XUARR("ProviderType"),"|")
+77 if PROVTYPE=""
SET PROVTYPE=$PIECE(XUARR("ProviderType"),"|",2)
+78 SET FDA(200,IENS,53.6)=PROVTYPE
End DoDot:1
+79 ;
+80 ;SECID
+81 if $DATA(XUARR("SECID"))#2
SET FDA(200,IENS,205.1)=XUARR("SECID")
+82 ;Unique User ID
+83 if $DATA(XUARR("UniqueUserID"))#2
SET FDA(200,IENS,205.4)=XUARR("UniqueUserID")
+84 ;ADUPN (Email)
+85 if $DATA(XUARR("ADUPN"))#2
SET FDA(200,IENS,205.5)=XUARR("ADUPN")
+86 ;EMAIL ADDRESS
+87 if $DATA(XUARR("EMAIL"))#2
SET FDA(200,IENS,.151)=XUARR("EMAIL")
+88 ;Network Username
+89 if $DATA(XUARR("NTUSERNAME"))#2
SET FDA(200,IENS,501.1)=XUARR("NTUSERNAME")
+90 QUIT
+91 ;
CPRSNVA(IEN,XUARR,OLDTDATE) ;**744 - VAMPI-3039 (ckn)
+1 ;CPRS TAB
+2 NEW IENS,ORDIEN,CPRSEXP,NVAIEN,FDA,NEWTDATE
+3 SET IENS=+IEN_","
+4 ;Termination Date
SET NEWTDATE=$PIECE($GET(^VA(200,IEN,0)),U,11)
+5 ;Quit as Terminated record
IF NEWTDATE]""
QUIT
+6 ;
+7 SET ORDIEN=$ORDER(^ORD(101.13,"B","NVA",""))
if ORDIEN=""
QUIT
+8 ;ADD - If CPRS TAB field does not have date for "NVA", add new record in CPRS TAB multiple field
+9 IF '$DATA(^VA(200,+IEN,"ORD","B",ORDIEN))
Begin DoDot:1
+10 SET FDA(200.010113,"+1,"_IENS,.01)="NVA"
+11 SET FDA(200.010113,"+1,"_IENS,.02)=$$DT^XLFDT()
+12 IF $GET(XUARR("Inactivate"))'=""
SET FDA(200.010113,"+1,"_IENS,.03)=$GET(XUARR("Inactivate"))
+13 DO UPDATE^DIE("E","FDA")
+14 KILL FDA
End DoDot:1
QUIT
+15 ;
+16 ;UPDATE - Existing CPRS TAB field for "NVA" AND Termination date is deleted in this update,
+17 ;Update CPRS TAB multiple field and Quit
+18 SET NVAIEN=$ORDER(^VA(200,+IEN,"ORD","B",ORDIEN,""))
SET CPRSEXP=$PIECE($GET(^VA(200,+IEN,"ORD",NVAIEN,0)),"^",3)
+19 IF OLDTDATE]""
IF NEWTDATE=""
Begin DoDot:1
+20 SET FDA(200.010113,NVAIEN_","_IENS,.02)=$$DT^XLFDT()
+21 SET FDA(200.010113,NVAIEN_","_IENS,.03)=$SELECT($GET(XUARR("Inactivate"))'="":$GET(XUARR("Inactivate")),1:"@")
+22 DO FILE^DIE("E","FDA")
+23 KILL FDA
End DoDot:1
QUIT
+24 ;
+25 ;UPDATE - Existing CPRS TAB field for "NVA" and No Termination Date
+26 ;Update only Expiration Date if Inactivation is sent AND it is different than existing
+27 IF $GET(XUARR("Inactivate"))'=""
Begin DoDot:1
+28 IF CPRSEXP'=""
IF (XUARR("Inactivate")=$$FMTHL7^XLFDT(CPRSEXP))
QUIT
+29 SET FDA(200.010113,NVAIEN_","_IENS,.03)=$GET(XUARR("Inactivate"))
+30 DO FILE^DIE("E","FDA")
+31 KILL FDA
End DoDot:1
+32 QUIT
