- 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 Feb 18, 2025@23:37:44 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