XUMVIENU ;MVI/CKN,MKO - Master Veteran Index Enrich New Person ; 1/26/21 3:10pm
;;8.0;KERNEL;**711,724,744,767**;Jul 10, 1995;Build 1
;Per VA Directive 6402, this routine should not be modified.
;**711,Story 977838 (mko/ckn): New routine
;Entry point: UPDATE^XUMVIENU(XURET,.XUARR,XUFLAG)
; called from rpc: XUS MVI ENRICH NEW PERSON
;
; Input:
; XUARR(subscript)=value to update
; XUFLAG = "A" : if RPC is being called to add a record to the New Person file
; "U" : if RPC is being called to edit an existing New Person file record.
;
; Return Parameter:
; On success:
; DUZ of New Person File entry edited or added
; Returned if there were no issues adding or editing the entry.
;
; DUZ^-1^errorMessage
; Returned if entry was edited, but some data was not valid and could
; not be filed.
; On failure:
; -1^errorMessage
; Returned for example if required data was not passed, entry could
; not be added when FLAG="A", or entry could not be found based on
; the NPI when FLAG="U".
;
UPDATE(XURET,XUARR,XUFLAG) ;RPC to enrich New Pperson file entry
N XUDBSEQ
S XUDBSEQ=$$RECORD(.XUARR,$G(XUFLAG))
D PROC(.XURET,.XUARR,.XUFLAG)
D RETURN(XUDBSEQ,XURET)
Q
;
PROC(XURET,XUARR,XUFLAG) ;Main code for RPC
N FDA,OLDTDATE,XUDUZ,XURSET
K XURET S XURSET=0
;
;Check inputs
S XURET=$$CHKINPUT(.XUARR,.XUFLAG)
Q:XURET<0
;
;Add or get New Person IEN in XUDUZ
S XURET=""
I $G(XUFLAG)="A" D
. ;Call entry point to add the record
. D:$G(XUARR("SubjectOrgan"))=""!($G(XUARR("SubjectOrganID"))="") SUBJDEF(.XUARR)
. S XUDUZ=$$ADDUSER^XUMVINPA(.XUARR)
. I $P(XUDUZ,"^",3)'=1 S XUFLAG="U",XURSET=1 ;**767 found exists already so process as update
. I XUDUZ<0 S XURET=XUDUZ ;If error, we'll return -1^errorMessage
. E I $P(XUDUZ,U,3)=1 S XUDUZ=+XUDUZ ;If record was added, set XUDUZ to new IEN
. E S XURET=+XUDUZ ;If record was found, not added, we'll just return DUZ -- no edit will take place
E D
. ;Lookup user based on NPI
. ;S XATTRIB(8)=XUARR("NPI") ; NPI
. ;S XUDUZ=$$FINDUSER^XUESSO2(.XATTRIB) ; find user based on NPI ; returns -1^Not authorized if DUZ("LOA")<2
. S XUDUZ=$O(^VA(200,"ANPI",XUARR("NPI"),0))
. S:XUDUZ'>0 XURET="-1^User with NPI "_XUARR("NPI")_" not found."
;
;If add or lookup above set XURET, we're done
I XURET]""&(XUFLAG="A") Q
;
;**744 - VAMPI-8213 (ckn)
;If update is from PPMS/PIE and if New Person have Primary Menu,
;then no update as this is a Dual Provider.
I $G(XUFLAG)="U",($G(XUARR("WHO"))="200PIEV"),($P($G(^VA(200,+XUDUZ,201)),"^")'="") S XURET="-1^Provider has a Primary Menu, no update." Q ;**744 - VAMPI-8213 (ckn)
;If update is from PPMS/PIE and if CPRS TAB multiple field have any other
;values than "NVA", then no update as this is a Dual Provider.
N QCPFLG,TABIEN S QCPFLG=0
I $G(XUFLAG)="U",($G(XUARR("WHO"))="200PIEV") D
.N ORDIEN S ORDIEN=$O(^ORD(101.13,"B","NVA",""))
.I $D(^VA(200,+XUDUZ,"ORD")) D
..S TABIEN=0 F S TABIEN=$O(^VA(200,+XUDUZ,"ORD","B",TABIEN)) Q:+TABIEN=0!(QCPFLG) D
...I TABIEN'=ORDIEN S QCPFLG=1
I QCPFLG S XURET="-1^Provider has Non-NVA values in CPRS TAB" Q
;
;Update the NAME first. (Within a FILE^DIE call, triggers on the .01 that in turn call FILE^DIE
;may cause the Filer flag to change from "E", to "".)
I $G(XUFLAG)'="A",$D(XUARR("NAME"))#2 D
. N NAME
. S NAME=$P($G(XUARR("NAME")),"|",5)
. S:NAME="" NAME=$$FMNAME^HLFNC($G(XUARR("NAME")),"|")
. I NAME]"" S FDA(200,+XUDUZ_",",.01)=NAME D FILER(.FDA,"E",.XURET)
;
;Set up FDA
D SETFDA(XUDUZ,.XUARR,.FDA)
;
;Remove Termination Date from FDA if it's in the future
D TERMDATE(.FDA,.XURES)
;
;Save the original Termination Date
S OLDTDATE=$P($G(^VA(200,XUDUZ,0)),U,11)
;
;Call the Filer
D FILER(.FDA,"E",.XURET)
;
;**744 - VAMPI-3039 (ckn) - Update CPRS tab
I $G(XUARR("WHO"))="200PIEV" D CPRSNVA^XUMVIEU1(XUDUZ,.XUARR,OLDTDATE)
;
;If Termination Date was added or deleted, remove or add Security keys PROVIDER and XUORES
D SECKEYS(XUDUZ,OLDTDATE,.XURET,XURSET) ;**767 OR if ADD is now UPDATE XURSET=1
;
;File the Person Class data
D PERSCLAS(XUDUZ,.XUARR,.XURET)
;
;File the DEA data
I $$PATCH^XPDUTL("XU*8.0*688"),$$VFIELD^DILFD(200,53.21),$$VFILE^DILFD(8991.9) D
. ;File NEW DEA #'S in multiple and add/edit entries in File #8991.9
. D NEWDEA(XUDUZ,.XUARR,.XURET)
. ;File first NEW DEA data into single-valued fields of NP file
. D NPDEA(XUDUZ,.XUARR,.XURET)
E D
. ;File first valid DEA # into file (NEW DEA#'s multiple doesn't exist)
. D FIRSTDEA(XUDUZ,.XUARR,.XURET)
;
;Return DUZ in first piece. If errors, also return -1^errMsg in 2nd and 3rd pieces.
S XURET=XUDUZ_$S(XURET<0:U_XURET,1:"")
Q
;
CHKINPUT(XUARR,XUFLAG) ;Check inputs
;Returns: "-1^errorMsg" if problem; otherwise return 0
Q:'$D(XUARR) "-1^No data passed"
Q:$G(XUARR("NPI"))="" "-1^Missing NPI"
Q:'$$CHKDGT^XUSNPI($G(XUARR("NPI"))) "-1^NPI is not valid"
Q:$G(XUARR("WHO"))="" "-1^Missing requesting Station number"
;
S:$G(XUFLAG)="" XUFLAG="U"
Q:"^A^U^"'[(U_$G(XUFLAG)_U) "-1^Invalid flag "_XUFLAG_" was passed."
Q 0
;
SETFDA(IEN,XUARR,FDA) ;Set FDA from XUARR for filing into File #200
;**744 VAMPI-3039 (ckn) - Moving this tag to new routine XUMVIEU1
D SETFDA^XUMVIEU1(IEN,.XUARR,.FDA)
Q
;
SUBJDEF(XUARR) ;Set default Subject Organization and ID
S XUARR("SubjectOrgan")="Department Of Veterans Affairs"
S XUARR("SubjectOrganID")="urn:oid:2.16.840.1.113883.4.349"
Q
;
TERMDATE(FDA,XURES) ;Remove Termination Date from FDA if it's in the future,
;or if Termination Date is passed but user has a Primary Menu, and return an error message
N IENS,TDATE
S IENS=$O(FDA(200,"")) Q:IENS=""
Q:"@"[$G(FDA(200,IENS,9.2))
;
;Get internal form
S TDATE=$$GETINT(200,9.2,FDA(200,IENS,9.2)) Q:TDATE=U
;
I $P($G(^VA(200,+IENS,201)),U)]"" D Q
. D ADDERR(.XURET,"User has a PRIMARY MENU and cannot be terminated.")
. K FDA(200,IENS,9.2)
;
;Remove from FDA if it's a future date, and add an error message
D:TDATE>DT
. D ADDERR(.XURET,"TERMINATION DATE '"_FDA(200,IENS,9.2)_"' is in the future.")
. K FDA(200,IENS,9.2)
Q
;
SECKEYS(XUDUZ,OLDTDATE,XURET,XURSET) ;Add or remove Security Keys PROVIDER and XUORES
;based on whether Termination Date is deleted or created
;**767 OR if ADD is now UPDATE XURSET=1
N KEY,KEYIEN,NEWTDATE
S XUDUZ=+$G(XUDUZ),OLDTDATE=$G(OLDTDATE)
S NEWTDATE=$P($G(^VA(200,XUDUZ,0)),U,11)
Q:$G(OLDTDATE)=NEWTDATE&(XURSET=0)
;
F KEY="PROVIDER","XUORES" D
. S KEYIEN=$O(^DIC(19.1,"B",KEY,0)) Q:KEYIEN'>0
. I OLDTDATE="",NEWTDATE]"" D
.. ;Delete the key
.. N DA,DIK
.. S DA=$O(^VA(200,XUDUZ,51,"B",KEYIEN,0)) Q:DA'>0
.. S DA(1)=XUDUZ,DIK="^VA(200,"_XUDUZ_",51,"
.. D ^DIK
.I OLDTDATE]"",NEWTDATE="" D ADDKEY(XUDUZ,KEYIEN)
.I XURSET=1 D ADDKEY(XUDUZ,KEYIEN)
Q
ADDKEY(XUDUZ,KEYIEN) ;Add the key
;**724,Story 1209890 (mko): The #.01 of the KEYS multiple is DINUM'd, so pass IEN(1)
; Also, GIVEN BY (#1) and DATE GIVEN (#2) are triggered by the #.01.
N IENS,FDA,IEN
Q:$O(^VA(200,XUDUZ,51,"B",KEYIEN,0))
S IENS="+1,"_XUDUZ_","
S (FDA(200.051,IENS,.01),IEN(1))=KEYIEN
D UPDATER(.FDA,"",.XURET,.IEN)
Q
;
PERSCLAS(XUDUZ,XUARR,XURET) ;Update PERSON CLASS multiple
N CNT,CURVAL,D0,FDA,IEN,IENS,NEWVAL,PCIEN,VACODE,X12CODE
S CNT=0 F S CNT=$O(XUARR("PersonClass",CNT)) Q:'CNT D
. S X12CODE=$G(XUARR("PersonClass",CNT,"PersonClass")) Q:X12CODE=""
. ;
. ;Lookup the Person Class entry in the multiple
. S PCIEN=0
. S VACODE=$S(X12CODE="207LP3000X":"V110403",X12CODE="2084B0040X":"V182914",X12CODE="390200000X":"V115500",1:"") I VACODE'="" S PCIEN=$O(^USC(8932.1,"F",VACODE,0)) ;to resolve duplicate x12 codes
. I 'PCIEN S PCIEN=$O(^USC(8932.1,"G",X12CODE,0))
. S IEN=$O(^VA(200,+XUDUZ,"USC1","B",+PCIEN,0))
. ;
. ;If not found, add it
. I IEN'>0 D Q:IEN'>0
.. S FDA(200.05,"+1,"_+XUDUZ_",",.01)=PCIEN ;now passing internal value of X12CODE
.. S IEN=$$UPDATER(.FDA,"",.XURET)
. ;
. ;Update the other values in the Person Class multiple
. S IENS=+IEN_","_+XUDUZ_","
. S CURVAL=$P($G(^VA(200,+XUDUZ,"USC1",+IEN,0)),U,2)
. S NEWVAL=$G(XUARR("PersonClass",CNT,"PersonClassActive"))
. I NEWVAL="",'$$ISPCACTV(XUDUZ,IEN) S FDA(200.05,IENS,2)="TODAY",FDA(200.05,IENS,3)="@"
. E I NEWVAL]"" S FDA(200.05,IENS,2)=NEWVAL
. S:$D(XUARR("PersonClass",CNT,"PersonClassExpire"))#2 FDA(200.05,IENS,3)=XUARR("PersonClass",CNT,"PersonClassExpire")
. S D0=+XUDUZ ;Needed by input transform of Effective Date (200.05,2)
. D FILER(.FDA,"E",.XURET)
Q
;
ISPCACTV(XUDUZ,SUBIEN) ;Is the Person Class active?
N EFFDT,EXPDT,ND
S ND=$G(^VA(200,+$G(XUDUZ),"USC1",+$G(SUBIEN),0)) Q:ND="" 0
S EFFDT=$P(ND,U,2),EXPDT=$P(ND,U,3)
I EFFDT,DT'<EFFDT,DT'>EXPDT Q 1
Q 0
;
NEWDEA(XUDUZ,XUARR,XURET) ;Update DEA NUMBERS File #8991.9
;and the NEW PERSON File NEW DEA #'s multiple
N CNT,DEA,DIERR,DIHELP,DIMSG,FDA,IEN,IENS,NDEAIEN,XUERR
N STR1,STR2,STR3,CITY,STATE,ZIP,ADDR
;
;Get address parts
D:$D(XUARR("ADDRESS DATA"))#2
. S ADDR=XUARR("ADDRESS DATA")
. S STR1=$E($P(ADDR,"|"),1,$$MAXLEN(8991.9,1.2))
. S STR2=$E($P(ADDR,"|",2),1,$$MAXLEN(8991.9,1.3))
. S STR3=$E($P(ADDR,"|",3),1,$$MAXLEN(8991.9,1.4))
. S CITY=$E($P(ADDR,"|",4),1,$$MAXLEN(8991.9,1.5))
. S STATE=$P(ADDR,"|",5)
. S ZIP=$TR($P(ADDR,"|",6),"-")
;
S CNT=0 F S CNT=$O(XUARR("DEA",CNT)) Q:'CNT D
. S DEA=$G(XUARR("DEA",CNT,"DEA"))
. Q:DEA=""
. ;
. ;Lookup or add a record to File #8991.9 with the passed DEA #
. S NDEAIEN=$O(^XTV(8991.9,"B",DEA,0))
. I NDEAIEN'>0 D Q:NDEAIEN'>0
.. K FDA
.. S IENS="+1,"
.. S FDA(8991.9,IENS,.01)=DEA
.. S FDA(8991.9,IENS,10.2)="NOW"
.. S NDEAIEN=$$UPDATER(.FDA,"E",.XURET)
. ;
. ;Update Expiration Date, Address, and Schedule fields for this File #8991.9 entry
. K FDA
. S IENS=NDEAIEN_","
. D:$D(XUARR("ADDRESS DATA"))#2
.. S FDA(8991.9,IENS,1.2)=STR1
.. S FDA(8991.9,IENS,1.3)=STR2
.. S FDA(8991.9,IENS,1.4)=STR3
.. S FDA(8991.9,IENS,1.5)=CITY
.. S FDA(8991.9,IENS,1.6)=$$STATEIEN(STATE)
.. S FDA(8991.9,IENS,1.7)=ZIP
. S:$D(XUARR("DEA",CNT,"Detox"))#2 FDA(8991.9,IENS,.03)=XUARR("DEA",CNT,"Detox")
. S:$D(XUARR("DEA",CNT,"DEAExpire"))#2 FDA(8991.9,IENS,.04)=XUARR("DEA",CNT,"DEAExpire")
. S:$D(XUARR("DEA",CNT,"SchedIINarc"))#2 FDA(8991.9,IENS,2.1)=XUARR("DEA",CNT,"SchedIINarc")
. S:$D(XUARR("DEA",CNT,"SchedIINonNarc"))#2 FDA(8991.9,IENS,2.2)=XUARR("DEA",CNT,"SchedIINonNarc")
. S:$D(XUARR("DEA",CNT,"SchedIIINarc"))#2 FDA(8991.9,IENS,2.3)=XUARR("DEA",CNT,"SchedIIINarc")
. S:$D(XUARR("DEA",CNT,"SchedIIINonNarc"))#2 FDA(8991.9,IENS,2.4)=XUARR("DEA",CNT,"SchedIIINonNarc")
. S:$D(XUARR("DEA",CNT,"SchedIV"))#2 FDA(8991.9,IENS,2.5)=XUARR("DEA",CNT,"SchedIV")
. S:$D(XUARR("DEA",CNT,"SchedV"))#2 FDA(8991.9,IENS,2.6)=XUARR("DEA",CNT,"SchedV")
. S:$D(FDA) FDA(8991.9,IENS,10.1)=$S($G(DUZ):"`"_DUZ,1:""),FDA(8991.9,IENS,10.2)="NOW"
. D FILER(.FDA,"E",.XURET)
. ;
. ;Lookup or add corresponding entry in New Person NEW DEA #'S multiple
. S IEN=$O(^VA(200,+XUDUZ,"PS4","B",DEA,0))
. I IEN'>0 D Q:IEN'>0
.. K FDA
.. S FDA(200.5321,"+1,"_+XUDUZ_",",.01)=DEA
.. S IEN=$$UPDATER(.FDA,"E",.XURET)
. ;
. ;Update the DEA POINTER value in the NEW DEA #'s multiple
. K FDA
. S FDA(200.5321,+IEN_","_+XUDUZ_",",.03)=NDEAIEN
. D FILER(.FDA,"",.XURET)
Q
;
NPDEA(XUDUZ,XUARR,XURET) ;Set the single-valued fields in the New Person file for
; DEA#, Detox #, DEA Expiration Date, and the Schedule fields from the first entry in
; the NEW DEA#'s multiple; Also default Auth to Write Med Orders to 1 if not already set,
; WHO is 200PIEV, and there's a DEA#
N DEAIEN,FDA,IENS,ND0,ND2,NDEAIEN
S DEAIEN=$O(^VA(200,XUDUZ,"PS4",0)) Q:'DEAIEN
S NDEAIEN=$P(^VA(200,XUDUZ,"PS4",DEAIEN,0),U,3) Q:NDEAIEN'>0
;
;Set up FDA with data from DEA NUMBERS entry
S IENS=+XUDUZ_","
S ND0=$G(^XTV(8991.9,+NDEAIEN,0)),ND2=$G(^(2)) Q:$P(ND0,U)=""
S FDA(200,IENS,53.2)=$P(ND0,U) ;DEA#
S FDA(200,IENS,53.11)=$P(ND0,U,3) ;DETOX NUMBER
S FDA(200,IENS,747.44)=$P(ND0,U,4) ;DEA EXPIRATION DATE
S FDA(200,IENS,55.1)=$P(ND2,U) ;SCHEDULE II NARCOTIC
S FDA(200,IENS,55.2)=$P(ND2,U,2) ;SCHEDULE II NON-NARCOTIC
S FDA(200,IENS,55.3)=$P(ND2,U,3) ;SCHEDULE III NARCOTIC
S FDA(200,IENS,55.4)=$P(ND2,U,4) ;SCHEDULE III NON-NARCOTIC
S FDA(200,IENS,55.5)=$P(ND2,U,5) ;SCHEDULE IV
S FDA(200,IENS,55.6)=$P(ND2,U,6) ;SCHEDULE V
I $G(XUARR("WHO"))="200PIEV",$G(XUARR("AuthWriteMedOrders"))="" S FDA(200,IENS,53.1)=1
D FILER(.FDA,"",.XURET)
Q
;
FIRSTDEA(XUDUZ,XUARR,XURET) ;File the first valid DEA in the XUARR input array
;into the single-value DEA fields of the NP file
N CNT,DEA,FDA,FIRST,IENS
;
;Find the first valid DEA number in the input array
S FIRST="",CNT=0 F S CNT=$O(XUARR("DEA",CNT)) Q:'CNT D Q:FIRST
. S DEA=$G(XUARR("DEA",CNT,"DEA")) Q:DEA=""
. S DEA=$$GETINT(200,53.2,DEA)
. S:DEA'=U FIRST=CNT
Q:'FIRST
;
;Set up FDA with data from DEA NUMBERS entry
S IENS=XUDUZ_","
S FDA(200,IENS,53.2)=DEA
S:$D(XUARR("DEA",FIRST,"Detox"))#2 FDA(200,IENS,53.11)=XUARR("DEA",FIRST,"Detox")
S:$D(XUARR("DEA",FIRST,"DEAExpire"))#2 FDA(200,IENS,747.44)=XUARR("DEA",FIRST,"DEAExpire")
S:$D(XUARR("DEA",FIRST,"SchedIINarc"))#2 FDA(200,IENS,55.1)=XUARR("DEA",FIRST,"SchedIINarc")
S:$D(XUARR("DEA",FIRST,"SchedIINonNarc"))#2 FDA(200,IENS,55.2)=XUARR("DEA",FIRST,"SchedIINonNarc")
S:$D(XUARR("DEA",FIRST,"SchedIIINarc"))#2 FDA(200,IENS,55.3)=XUARR("DEA",FIRST,"SchedIIINarc")
S:$D(XUARR("DEA",FIRST,"SchedIIINonNarc"))#2 FDA(200,IENS,55.4)=XUARR("DEA",FIRST,"SchedIIINonNarc")
S:$D(XUARR("DEA",FIRST,"SchedIV"))#2 FDA(200,IENS,55.5)=XUARR("DEA",FIRST,"SchedIV")
S:$D(XUARR("DEA",FIRST,"SchedV"))#2 FDA(200,IENS,55.6)=XUARR("DEA",FIRST,"SchedV")
I $G(XUARR("WHO"))="200PIEV",$G(XUARR("AuthWriteMedOrders"))="" S FDA(200,IENS,53.1)=1
D FILER(.FDA,"E",.XURET)
Q
;
FILER(XUMVIFDA,FLAG,XURET) ;Call the Filer
N DIERR,DIHELP,DIMSG,IENS,FILE,ROOT,XUMVIERR
Q:'$D(XUMVIFDA)
S FILE=$O(XUMVIFDA(0)),IENS=$O(XUMVIFDA(+FILE,"")),ROOT=$$ROOT^DILFD(FILE,IENS)_+IENS_")"
I $G(ROOT)="" D ADDERR(.XURET,"Unable to determine global root of File #"_FILE_", IENS '"_IENS_".") Q
L +@ROOT:10 E D ADDERR(.XURET,"Unable to lock global "_ROOT_".") Q
D FILE^DIE($G(FLAG),"XUMVIFDA","XUMVIERR")
L -@ROOT
D:$G(DIERR) ADDERR(.XURET,$$BLDERR("XUMVIERR"))
Q
;
UPDATER(XUMVIFDA,FLAG,XURET,XUMVIIEN) ;Call the Updater
;**724,Story 1209890 (mko): Add XUMVIIEN as an input paramater to allow controlling IEN of new record
N DIERR,DIHELP,DIMSG,XUMVIERR
D UPDATE^DIE(FLAG,"XUMVIFDA","XUMVIIEN","XUMVIERR")
I $G(DIERR) D ADDERR(.XURET,$$BLDERR("XUMVIERR")) Q 0
Q +$G(XUMVIIEN(1))
;
ADDERR(XURET,MSG) ;Add error MSG to XURET
Q:$G(MSG)=""
S XURET=$S(XURET]"":XURET_" ",1:"-1^")_MSG
Q
;
STATEIEN(STATE) ;Return "`"_IEN if valid abbreviation, VA code, or name
N IEN
Q:$G(STATE)="" ""
S IEN=$S(STATE="FG":$O(^DIC(5,"B","FOREIGN COUNTRY",0)),STATE="OT":$O(^DIC(5,"B","OTHER",0)),STATE="EU":$O(^DIC(5,"B","EUROPE",0)),1:$O(^DIC(5,"C",STATE,0)))
S:'IEN IEN=$O(^DIC(5,"B",STATE,""))
Q $S(IEN>0:"`"_IEN,1:STATE)
;
GETINT(FILE,FLD,VAL) ;Get the internal form of the data; returns "^" if not valid
N DIERR,DIHELP,DIMSG,XUMSG,XURES
Q:VAL="" ""
D CHK^DIE(FILE,FLD,"",VAL,.XURES,"XUMSG")
Q XURES
;
BLDERR(INROOT) ;Build a string containing error messages returned by FileMan
N ERRSTR,I,XUERMSGS
D MSG^DIALOG("AE",.XUERMSGS,"","",$G(INROOT))
S ERRSTR=""
S I=0 F S I=$O(XUERMSGS(I)) Q:'I S:XUERMSGS(I)]"" ERRSTR=ERRSTR_$E(" ",ERRSTR]"")_XUERMSGS(I)
Q ERRSTR
;
MAXLEN(FILE,FLD) ;Return the maximum length of field FLD in file FILE
N MAX
S MAX=$$GET1^DID(+FILE,+FLD,"","FIELD LENGTH") S:MAX'>0 MAX=999
Q MAX
;
;=================================================
; Code for storing debugging information in ^XTMP
;=================================================
RECORD(PARAM,FLAG,RPCNAME) ;Record RPC inputs for debugging
;Return seq# in ^XTMP
N NODE,NOW,SEQ,TODAY
Q:'$$ISDEBUG 0
S:$G(RPCNAME)="" RPCNAME="XUS MVI ENRICH NEW PERSON"
S NOW=$$NOW^XLFDT,TODAY=$P(NOW,".")
S NODE=$$NODE
;
L +^XTMP(NODE):2
D SETXTMP0(NODE)
S SEQ=$O(^XTMP(NODE," "),-1)+1
M ^XTMP(NODE,SEQ,"PARAM")=PARAM
S ^XTMP(NODE,SEQ,"FLAG")=$G(FLAG)
S ^XTMP(NODE,SEQ,"DT")=NOW
S ^XTMP(NODE,SEQ,"DUZ")=$G(DUZ)
S ^XTMP(NODE,SEQ,"RPC")=RPCNAME
L -^XTMP(NODE)
Q SEQ
;
RETURN(SEQ,RETURN) ;Record the return value
Q:'SEQ Q:'$$ISDEBUG
M ^XTMP($$NODE,SEQ,"RETURN")=RETURN
Q
;
DBON ;Set DEBUG on
N NODE
S NODE=$$NODE
D SETXTMP0
S ^XTMP(NODE,"DEBUG")=1
W !,$NA(^XTMP(NODE,"DEBUG"))_" set to 1.",!
Q
;
DBOFF ;Set DEBUG off
N NODE
S NODE=$$NODE
K ^XTMP(NODE,"DEBUG")
K:'$O(^XTMP(NODE,0)) ^XTMP(NODE)
W !,$NA(^XTMP(NODE,"DEBUG"))_" killed.",!
Q
;
ISDEBUG() ;Return 1 if DEBUG mode flag is set
Q $G(^XTMP($$NODE,"DEBUG"))
;
PURGE ;Purge the debugging data stored in ^XTMP
N ISDEBUG
S ISDEBUG=$$ISDEBUG
K ^XTMP($$NODE)
W !,$NA(^XTMP($$NODE))_" killed.",!
D:ISDEBUG DBON
Q
;
SETXTMP0(NODE,DESC,LIFE) ;Set 0 node of ^XTMP(node)
N CREATEDT
S:$G(NODE)="" NODE=$$NODE
S CREATEDT=$S($D(^XTMP(NODE,0))#2:$P(^(0),U,2),1:DT)
S:'$G(LIFE) LIFE=30
S:$G(DESC)="" DESC="New Person RPC Inputs and Outputs"
S ^XTMP(NODE,0)=$$FMADD^XLFDT(DT,LIFE)_U_CREATEDT_U_DESC
Q
;
NODE() ;Return ^XTMP Debug subscript
Q "XU_RPC_DEBUG_NP"
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXUMVIENU 17592 printed Sep 23, 2025@19:47:30 Page 2
XUMVIENU ;MVI/CKN,MKO - Master Veteran Index Enrich New Person ; 1/26/21 3:10pm
+1 ;;8.0;KERNEL;**711,724,744,767**;Jul 10, 1995;Build 1
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 ;**711,Story 977838 (mko/ckn): New routine
+4 ;Entry point: UPDATE^XUMVIENU(XURET,.XUARR,XUFLAG)
+5 ; called from rpc: XUS MVI ENRICH NEW PERSON
+6 ;
+7 ; Input:
+8 ; XUARR(subscript)=value to update
+9 ; XUFLAG = "A" : if RPC is being called to add a record to the New Person file
+10 ; "U" : if RPC is being called to edit an existing New Person file record.
+11 ;
+12 ; Return Parameter:
+13 ; On success:
+14 ; DUZ of New Person File entry edited or added
+15 ; Returned if there were no issues adding or editing the entry.
+16 ;
+17 ; DUZ^-1^errorMessage
+18 ; Returned if entry was edited, but some data was not valid and could
+19 ; not be filed.
+20 ; On failure:
+21 ; -1^errorMessage
+22 ; Returned for example if required data was not passed, entry could
+23 ; not be added when FLAG="A", or entry could not be found based on
+24 ; the NPI when FLAG="U".
+25 ;
UPDATE(XURET,XUARR,XUFLAG) ;RPC to enrich New Pperson file entry
+1 NEW XUDBSEQ
+2 SET XUDBSEQ=$$RECORD(.XUARR,$GET(XUFLAG))
+3 DO PROC(.XURET,.XUARR,.XUFLAG)
+4 DO RETURN(XUDBSEQ,XURET)
+5 QUIT
+6 ;
PROC(XURET,XUARR,XUFLAG) ;Main code for RPC
+1 NEW FDA,OLDTDATE,XUDUZ,XURSET
+2 KILL XURET
SET XURSET=0
+3 ;
+4 ;Check inputs
+5 SET XURET=$$CHKINPUT(.XUARR,.XUFLAG)
+6 if XURET<0
QUIT
+7 ;
+8 ;Add or get New Person IEN in XUDUZ
+9 SET XURET=""
+10 IF $GET(XUFLAG)="A"
Begin DoDot:1
+11 ;Call entry point to add the record
+12 if $GET(XUARR("SubjectOrgan"))=""!($GET(XUARR("SubjectOrganID"))="")
DO SUBJDEF(.XUARR)
+13 SET XUDUZ=$$ADDUSER^XUMVINPA(.XUARR)
+14 ;**767 found exists already so process as update
IF $PIECE(XUDUZ,"^",3)'=1
SET XUFLAG="U"
SET XURSET=1
+15 ;If error, we'll return -1^errorMessage
IF XUDUZ<0
SET XURET=XUDUZ
+16 ;If record was added, set XUDUZ to new IEN
IF '$TEST
IF $PIECE(XUDUZ,U,3)=1
SET XUDUZ=+XUDUZ
+17 ;If record was found, not added, we'll just return DUZ -- no edit will take place
IF '$TEST
SET XURET=+XUDUZ
End DoDot:1
+18 IF '$TEST
Begin DoDot:1
+19 ;Lookup user based on NPI
+20 ;S XATTRIB(8)=XUARR("NPI") ; NPI
+21 ;S XUDUZ=$$FINDUSER^XUESSO2(.XATTRIB) ; find user based on NPI ; returns -1^Not authorized if DUZ("LOA")<2
+22 SET XUDUZ=$ORDER(^VA(200,"ANPI",XUARR("NPI"),0))
+23 if XUDUZ'>0
SET XURET="-1^User with NPI "_XUARR("NPI")_" not found."
End DoDot:1
+24 ;
+25 ;If add or lookup above set XURET, we're done
+26 IF XURET]""&(XUFLAG="A")
QUIT
+27 ;
+28 ;**744 - VAMPI-8213 (ckn)
+29 ;If update is from PPMS/PIE and if New Person have Primary Menu,
+30 ;then no update as this is a Dual Provider.
+31 ;**744 - VAMPI-8213 (ckn)
IF $GET(XUFLAG)="U"
IF ($GET(XUARR("WHO"))="200PIEV")
IF ($PIECE($GET(^VA(200,+XUDUZ,201)),"^")'="")
SET XURET="-1^Provider has a Primary Menu, no update."
QUIT
+32 ;If update is from PPMS/PIE and if CPRS TAB multiple field have any other
+33 ;values than "NVA", then no update as this is a Dual Provider.
+34 NEW QCPFLG,TABIEN
SET QCPFLG=0
+35 IF $GET(XUFLAG)="U"
IF ($GET(XUARR("WHO"))="200PIEV")
Begin DoDot:1
+36 NEW ORDIEN
SET ORDIEN=$ORDER(^ORD(101.13,"B","NVA",""))
+37 IF $DATA(^VA(200,+XUDUZ,"ORD"))
Begin DoDot:2
+38 SET TABIEN=0
FOR
SET TABIEN=$ORDER(^VA(200,+XUDUZ,"ORD","B",TABIEN))
if +TABIEN=0!(QCPFLG)
QUIT
Begin DoDot:3
+39 IF TABIEN'=ORDIEN
SET QCPFLG=1
End DoDot:3
End DoDot:2
End DoDot:1
+40 IF QCPFLG
SET XURET="-1^Provider has Non-NVA values in CPRS TAB"
QUIT
+41 ;
+42 ;Update the NAME first. (Within a FILE^DIE call, triggers on the .01 that in turn call FILE^DIE
+43 ;may cause the Filer flag to change from "E", to "".)
+44 IF $GET(XUFLAG)'="A"
IF $DATA(XUARR("NAME"))#2
Begin DoDot:1
+45 NEW NAME
+46 SET NAME=$PIECE($GET(XUARR("NAME")),"|",5)
+47 if NAME=""
SET NAME=$$FMNAME^HLFNC($GET(XUARR("NAME")),"|")
+48 IF NAME]""
SET FDA(200,+XUDUZ_",",.01)=NAME
DO FILER(.FDA,"E",.XURET)
End DoDot:1
+49 ;
+50 ;Set up FDA
+51 DO SETFDA(XUDUZ,.XUARR,.FDA)
+52 ;
+53 ;Remove Termination Date from FDA if it's in the future
+54 DO TERMDATE(.FDA,.XURES)
+55 ;
+56 ;Save the original Termination Date
+57 SET OLDTDATE=$PIECE($GET(^VA(200,XUDUZ,0)),U,11)
+58 ;
+59 ;Call the Filer
+60 DO FILER(.FDA,"E",.XURET)
+61 ;
+62 ;**744 - VAMPI-3039 (ckn) - Update CPRS tab
+63 IF $GET(XUARR("WHO"))="200PIEV"
DO CPRSNVA^XUMVIEU1(XUDUZ,.XUARR,OLDTDATE)
+64 ;
+65 ;If Termination Date was added or deleted, remove or add Security keys PROVIDER and XUORES
+66 ;**767 OR if ADD is now UPDATE XURSET=1
DO SECKEYS(XUDUZ,OLDTDATE,.XURET,XURSET)
+67 ;
+68 ;File the Person Class data
+69 DO PERSCLAS(XUDUZ,.XUARR,.XURET)
+70 ;
+71 ;File the DEA data
+72 IF $$PATCH^XPDUTL("XU*8.0*688")
IF $$VFIELD^DILFD(200,53.21)
IF $$VFILE^DILFD(8991.9)
Begin DoDot:1
+73 ;File NEW DEA #'S in multiple and add/edit entries in File #8991.9
+74 DO NEWDEA(XUDUZ,.XUARR,.XURET)
+75 ;File first NEW DEA data into single-valued fields of NP file
+76 DO NPDEA(XUDUZ,.XUARR,.XURET)
End DoDot:1
+77 IF '$TEST
Begin DoDot:1
+78 ;File first valid DEA # into file (NEW DEA#'s multiple doesn't exist)
+79 DO FIRSTDEA(XUDUZ,.XUARR,.XURET)
End DoDot:1
+80 ;
+81 ;Return DUZ in first piece. If errors, also return -1^errMsg in 2nd and 3rd pieces.
+82 SET XURET=XUDUZ_$SELECT(XURET<0:U_XURET,1:"")
+83 QUIT
+84 ;
CHKINPUT(XUARR,XUFLAG) ;Check inputs
+1 ;Returns: "-1^errorMsg" if problem; otherwise return 0
+2 if '$DATA(XUARR)
QUIT "-1^No data passed"
+3 if $GET(XUARR("NPI"))=""
QUIT "-1^Missing NPI"
+4 if '$$CHKDGT^XUSNPI($GET(XUARR("NPI")))
QUIT "-1^NPI is not valid"
+5 if $GET(XUARR("WHO"))=""
QUIT "-1^Missing requesting Station number"
+6 ;
+7 if $GET(XUFLAG)=""
SET XUFLAG="U"
+8 if "^A^U^"'[(U_$GET(XUFLAG)_U)
QUIT "-1^Invalid flag "_XUFLAG_" was passed."
+9 QUIT 0
+10 ;
SETFDA(IEN,XUARR,FDA) ;Set FDA from XUARR for filing into File #200
+1 ;**744 VAMPI-3039 (ckn) - Moving this tag to new routine XUMVIEU1
+2 DO SETFDA^XUMVIEU1(IEN,.XUARR,.FDA)
+3 QUIT
+4 ;
SUBJDEF(XUARR) ;Set default Subject Organization and ID
+1 SET XUARR("SubjectOrgan")="Department Of Veterans Affairs"
+2 SET XUARR("SubjectOrganID")="urn:oid:2.16.840.1.113883.4.349"
+3 QUIT
+4 ;
TERMDATE(FDA,XURES) ;Remove Termination Date from FDA if it's in the future,
+1 ;or if Termination Date is passed but user has a Primary Menu, and return an error message
+2 NEW IENS,TDATE
+3 SET IENS=$ORDER(FDA(200,""))
if IENS=""
QUIT
+4 if "@"[$GET(FDA(200,IENS,9.2))
QUIT
+5 ;
+6 ;Get internal form
+7 SET TDATE=$$GETINT(200,9.2,FDA(200,IENS,9.2))
if TDATE=U
QUIT
+8 ;
+9 IF $PIECE($GET(^VA(200,+IENS,201)),U)]""
Begin DoDot:1
+10 DO ADDERR(.XURET,"User has a PRIMARY MENU and cannot be terminated.")
+11 KILL FDA(200,IENS,9.2)
End DoDot:1
QUIT
+12 ;
+13 ;Remove from FDA if it's a future date, and add an error message
+14 if TDATE>DT
Begin DoDot:1
+15 DO ADDERR(.XURET,"TERMINATION DATE '"_FDA(200,IENS,9.2)_"' is in the future.")
+16 KILL FDA(200,IENS,9.2)
End DoDot:1
+17 QUIT
+18 ;
SECKEYS(XUDUZ,OLDTDATE,XURET,XURSET) ;Add or remove Security Keys PROVIDER and XUORES
+1 ;based on whether Termination Date is deleted or created
+2 ;**767 OR if ADD is now UPDATE XURSET=1
+3 NEW KEY,KEYIEN,NEWTDATE
+4 SET XUDUZ=+$GET(XUDUZ)
SET OLDTDATE=$GET(OLDTDATE)
+5 SET NEWTDATE=$PIECE($GET(^VA(200,XUDUZ,0)),U,11)
+6 if $GET(OLDTDATE)=NEWTDATE&(XURSET=0)
QUIT
+7 ;
+8 FOR KEY="PROVIDER","XUORES"
Begin DoDot:1
+9 SET KEYIEN=$ORDER(^DIC(19.1,"B",KEY,0))
if KEYIEN'>0
QUIT
+10 IF OLDTDATE=""
IF NEWTDATE]""
Begin DoDot:2
+11 ;Delete the key
+12 NEW DA,DIK
+13 SET DA=$ORDER(^VA(200,XUDUZ,51,"B",KEYIEN,0))
if DA'>0
QUIT
+14 SET DA(1)=XUDUZ
SET DIK="^VA(200,"_XUDUZ_",51,"
+15 DO ^DIK
End DoDot:2
+16 IF OLDTDATE]""
IF NEWTDATE=""
DO ADDKEY(XUDUZ,KEYIEN)
+17 IF XURSET=1
DO ADDKEY(XUDUZ,KEYIEN)
End DoDot:1
+18 QUIT
ADDKEY(XUDUZ,KEYIEN) ;Add the key
+1 ;**724,Story 1209890 (mko): The #.01 of the KEYS multiple is DINUM'd, so pass IEN(1)
+2 ; Also, GIVEN BY (#1) and DATE GIVEN (#2) are triggered by the #.01.
+3 NEW IENS,FDA,IEN
+4 if $ORDER(^VA(200,XUDUZ,51,"B",KEYIEN,0))
QUIT
+5 SET IENS="+1,"_XUDUZ_","
+6 SET (FDA(200.051,IENS,.01),IEN(1))=KEYIEN
+7 DO UPDATER(.FDA,"",.XURET,.IEN)
+8 QUIT
+9 ;
PERSCLAS(XUDUZ,XUARR,XURET) ;Update PERSON CLASS multiple
+1 NEW CNT,CURVAL,D0,FDA,IEN,IENS,NEWVAL,PCIEN,VACODE,X12CODE
+2 SET CNT=0
FOR
SET CNT=$ORDER(XUARR("PersonClass",CNT))
if 'CNT
QUIT
Begin DoDot:1
+3 SET X12CODE=$GET(XUARR("PersonClass",CNT,"PersonClass"))
if X12CODE=""
QUIT
+4 ;
+5 ;Lookup the Person Class entry in the multiple
+6 SET PCIEN=0
+7 ;to resolve duplicate x12 codes
SET VACODE=$SELECT(X12CODE="207LP3000X":"V110403",X12CODE="2084B0040X":"V182914",X12CODE="390200000X":"V115500",1:"")
IF VACODE'=""
SET PCIEN=$ORDER(^USC(8932.1,"F",VACODE,0))
+8 IF 'PCIEN
SET PCIEN=$ORDER(^USC(8932.1,"G",X12CODE,0))
+9 SET IEN=$ORDER(^VA(200,+XUDUZ,"USC1","B",+PCIEN,0))
+10 ;
+11 ;If not found, add it
+12 IF IEN'>0
Begin DoDot:2
+13 ;now passing internal value of X12CODE
SET FDA(200.05,"+1,"_+XUDUZ_",",.01)=PCIEN
+14 SET IEN=$$UPDATER(.FDA,"",.XURET)
End DoDot:2
if IEN'>0
QUIT
+15 ;
+16 ;Update the other values in the Person Class multiple
+17 SET IENS=+IEN_","_+XUDUZ_","
+18 SET CURVAL=$PIECE($GET(^VA(200,+XUDUZ,"USC1",+IEN,0)),U,2)
+19 SET NEWVAL=$GET(XUARR("PersonClass",CNT,"PersonClassActive"))
+20 IF NEWVAL=""
IF '$$ISPCACTV(XUDUZ,IEN)
SET FDA(200.05,IENS,2)="TODAY"
SET FDA(200.05,IENS,3)="@"
+21 IF '$TEST
IF NEWVAL]""
SET FDA(200.05,IENS,2)=NEWVAL
+22 if $DATA(XUARR("PersonClass",CNT,"PersonClassExpire"))#2
SET FDA(200.05,IENS,3)=XUARR("PersonClass",CNT,"PersonClassExpire")
+23 ;Needed by input transform of Effective Date (200.05,2)
SET D0=+XUDUZ
+24 DO FILER(.FDA,"E",.XURET)
End DoDot:1
+25 QUIT
+26 ;
ISPCACTV(XUDUZ,SUBIEN) ;Is the Person Class active?
+1 NEW EFFDT,EXPDT,ND
+2 SET ND=$GET(^VA(200,+$GET(XUDUZ),"USC1",+$GET(SUBIEN),0))
if ND=""
QUIT 0
+3 SET EFFDT=$PIECE(ND,U,2)
SET EXPDT=$PIECE(ND,U,3)
+4 IF EFFDT
IF DT'<EFFDT
IF DT'>EXPDT
QUIT 1
+5 QUIT 0
+6 ;
NEWDEA(XUDUZ,XUARR,XURET) ;Update DEA NUMBERS File #8991.9
+1 ;and the NEW PERSON File NEW DEA #'s multiple
+2 NEW CNT,DEA,DIERR,DIHELP,DIMSG,FDA,IEN,IENS,NDEAIEN,XUERR
+3 NEW STR1,STR2,STR3,CITY,STATE,ZIP,ADDR
+4 ;
+5 ;Get address parts
+6 if $DATA(XUARR("ADDRESS DATA"))#2
Begin DoDot:1
+7 SET ADDR=XUARR("ADDRESS DATA")
+8 SET STR1=$EXTRACT($PIECE(ADDR,"|"),1,$$MAXLEN(8991.9,1.2))
+9 SET STR2=$EXTRACT($PIECE(ADDR,"|",2),1,$$MAXLEN(8991.9,1.3))
+10 SET STR3=$EXTRACT($PIECE(ADDR,"|",3),1,$$MAXLEN(8991.9,1.4))
+11 SET CITY=$EXTRACT($PIECE(ADDR,"|",4),1,$$MAXLEN(8991.9,1.5))
+12 SET STATE=$PIECE(ADDR,"|",5)
+13 SET ZIP=$TRANSLATE($PIECE(ADDR,"|",6),"-")
End DoDot:1
+14 ;
+15 SET CNT=0
FOR
SET CNT=$ORDER(XUARR("DEA",CNT))
if 'CNT
QUIT
Begin DoDot:1
+16 SET DEA=$GET(XUARR("DEA",CNT,"DEA"))
+17 if DEA=""
QUIT
+18 ;
+19 ;Lookup or add a record to File #8991.9 with the passed DEA #
+20 SET NDEAIEN=$ORDER(^XTV(8991.9,"B",DEA,0))
+21 IF NDEAIEN'>0
Begin DoDot:2
+22 KILL FDA
+23 SET IENS="+1,"
+24 SET FDA(8991.9,IENS,.01)=DEA
+25 SET FDA(8991.9,IENS,10.2)="NOW"
+26 SET NDEAIEN=$$UPDATER(.FDA,"E",.XURET)
End DoDot:2
if NDEAIEN'>0
QUIT
+27 ;
+28 ;Update Expiration Date, Address, and Schedule fields for this File #8991.9 entry
+29 KILL FDA
+30 SET IENS=NDEAIEN_","
+31 if $DATA(XUARR("ADDRESS DATA"))#2
Begin DoDot:2
+32 SET FDA(8991.9,IENS,1.2)=STR1
+33 SET FDA(8991.9,IENS,1.3)=STR2
+34 SET FDA(8991.9,IENS,1.4)=STR3
+35 SET FDA(8991.9,IENS,1.5)=CITY
+36 SET FDA(8991.9,IENS,1.6)=$$STATEIEN(STATE)
+37 SET FDA(8991.9,IENS,1.7)=ZIP
End DoDot:2
+38 if $DATA(XUARR("DEA",CNT,"Detox"))#2
SET FDA(8991.9,IENS,.03)=XUARR("DEA",CNT,"Detox")
+39 if $DATA(XUARR("DEA",CNT,"DEAExpire"))#2
SET FDA(8991.9,IENS,.04)=XUARR("DEA",CNT,"DEAExpire")
+40 if $DATA(XUARR("DEA",CNT,"SchedIINarc"))#2
SET FDA(8991.9,IENS,2.1)=XUARR("DEA",CNT,"SchedIINarc")
+41 if $DATA(XUARR("DEA",CNT,"SchedIINonNarc"))#2
SET FDA(8991.9,IENS,2.2)=XUARR("DEA",CNT,"SchedIINonNarc")
+42 if $DATA(XUARR("DEA",CNT,"SchedIIINarc"))#2
SET FDA(8991.9,IENS,2.3)=XUARR("DEA",CNT,"SchedIIINarc")
+43 if $DATA(XUARR("DEA",CNT,"SchedIIINonNarc"))#2
SET FDA(8991.9,IENS,2.4)=XUARR("DEA",CNT,"SchedIIINonNarc")
+44 if $DATA(XUARR("DEA",CNT,"SchedIV"))#2
SET FDA(8991.9,IENS,2.5)=XUARR("DEA",CNT,"SchedIV")
+45 if $DATA(XUARR("DEA",CNT,"SchedV"))#2
SET FDA(8991.9,IENS,2.6)=XUARR("DEA",CNT,"SchedV")
+46 if $DATA(FDA)
SET FDA(8991.9,IENS,10.1)=$SELECT($GET(DUZ):"`"_DUZ,1:"")
SET FDA(8991.9,IENS,10.2)="NOW"
+47 DO FILER(.FDA,"E",.XURET)
+48 ;
+49 ;Lookup or add corresponding entry in New Person NEW DEA #'S multiple
+50 SET IEN=$ORDER(^VA(200,+XUDUZ,"PS4","B",DEA,0))
+51 IF IEN'>0
Begin DoDot:2
+52 KILL FDA
+53 SET FDA(200.5321,"+1,"_+XUDUZ_",",.01)=DEA
+54 SET IEN=$$UPDATER(.FDA,"E",.XURET)
End DoDot:2
if IEN'>0
QUIT
+55 ;
+56 ;Update the DEA POINTER value in the NEW DEA #'s multiple
+57 KILL FDA
+58 SET FDA(200.5321,+IEN_","_+XUDUZ_",",.03)=NDEAIEN
+59 DO FILER(.FDA,"",.XURET)
End DoDot:1
+60 QUIT
+61 ;
NPDEA(XUDUZ,XUARR,XURET) ;Set the single-valued fields in the New Person file for
+1 ; DEA#, Detox #, DEA Expiration Date, and the Schedule fields from the first entry in
+2 ; the NEW DEA#'s multiple; Also default Auth to Write Med Orders to 1 if not already set,
+3 ; WHO is 200PIEV, and there's a DEA#
+4 NEW DEAIEN,FDA,IENS,ND0,ND2,NDEAIEN
+5 SET DEAIEN=$ORDER(^VA(200,XUDUZ,"PS4",0))
if 'DEAIEN
QUIT
+6 SET NDEAIEN=$PIECE(^VA(200,XUDUZ,"PS4",DEAIEN,0),U,3)
if NDEAIEN'>0
QUIT
+7 ;
+8 ;Set up FDA with data from DEA NUMBERS entry
+9 SET IENS=+XUDUZ_","
+10 SET ND0=$GET(^XTV(8991.9,+NDEAIEN,0))
SET ND2=$GET(^(2))
if $PIECE(ND0,U)=""
QUIT
+11 ;DEA#
SET FDA(200,IENS,53.2)=$PIECE(ND0,U)
+12 ;DETOX NUMBER
SET FDA(200,IENS,53.11)=$PIECE(ND0,U,3)
+13 ;DEA EXPIRATION DATE
SET FDA(200,IENS,747.44)=$PIECE(ND0,U,4)
+14 ;SCHEDULE II NARCOTIC
SET FDA(200,IENS,55.1)=$PIECE(ND2,U)
+15 ;SCHEDULE II NON-NARCOTIC
SET FDA(200,IENS,55.2)=$PIECE(ND2,U,2)
+16 ;SCHEDULE III NARCOTIC
SET FDA(200,IENS,55.3)=$PIECE(ND2,U,3)
+17 ;SCHEDULE III NON-NARCOTIC
SET FDA(200,IENS,55.4)=$PIECE(ND2,U,4)
+18 ;SCHEDULE IV
SET FDA(200,IENS,55.5)=$PIECE(ND2,U,5)
+19 ;SCHEDULE V
SET FDA(200,IENS,55.6)=$PIECE(ND2,U,6)
+20 IF $GET(XUARR("WHO"))="200PIEV"
IF $GET(XUARR("AuthWriteMedOrders"))=""
SET FDA(200,IENS,53.1)=1
+21 DO FILER(.FDA,"",.XURET)
+22 QUIT
+23 ;
FIRSTDEA(XUDUZ,XUARR,XURET) ;File the first valid DEA in the XUARR input array
+1 ;into the single-value DEA fields of the NP file
+2 NEW CNT,DEA,FDA,FIRST,IENS
+3 ;
+4 ;Find the first valid DEA number in the input array
+5 SET FIRST=""
SET CNT=0
FOR
SET CNT=$ORDER(XUARR("DEA",CNT))
if 'CNT
QUIT
Begin DoDot:1
+6 SET DEA=$GET(XUARR("DEA",CNT,"DEA"))
if DEA=""
QUIT
+7 SET DEA=$$GETINT(200,53.2,DEA)
+8 if DEA'=U
SET FIRST=CNT
End DoDot:1
if FIRST
QUIT
+9 if 'FIRST
QUIT
+10 ;
+11 ;Set up FDA with data from DEA NUMBERS entry
+12 SET IENS=XUDUZ_","
+13 SET FDA(200,IENS,53.2)=DEA
+14 if $DATA(XUARR("DEA",FIRST,"Detox"))#2
SET FDA(200,IENS,53.11)=XUARR("DEA",FIRST,"Detox")
+15 if $DATA(XUARR("DEA",FIRST,"DEAExpire"))#2
SET FDA(200,IENS,747.44)=XUARR("DEA",FIRST,"DEAExpire")
+16 if $DATA(XUARR("DEA",FIRST,"SchedIINarc"))#2
SET FDA(200,IENS,55.1)=XUARR("DEA",FIRST,"SchedIINarc")
+17 if $DATA(XUARR("DEA",FIRST,"SchedIINonNarc"))#2
SET FDA(200,IENS,55.2)=XUARR("DEA",FIRST,"SchedIINonNarc")
+18 if $DATA(XUARR("DEA",FIRST,"SchedIIINarc"))#2
SET FDA(200,IENS,55.3)=XUARR("DEA",FIRST,"SchedIIINarc")
+19 if $DATA(XUARR("DEA",FIRST,"SchedIIINonNarc"))#2
SET FDA(200,IENS,55.4)=XUARR("DEA",FIRST,"SchedIIINonNarc")
+20 if $DATA(XUARR("DEA",FIRST,"SchedIV"))#2
SET FDA(200,IENS,55.5)=XUARR("DEA",FIRST,"SchedIV")
+21 if $DATA(XUARR("DEA",FIRST,"SchedV"))#2
SET FDA(200,IENS,55.6)=XUARR("DEA",FIRST,"SchedV")
+22 IF $GET(XUARR("WHO"))="200PIEV"
IF $GET(XUARR("AuthWriteMedOrders"))=""
SET FDA(200,IENS,53.1)=1
+23 DO FILER(.FDA,"E",.XURET)
+24 QUIT
+25 ;
FILER(XUMVIFDA,FLAG,XURET) ;Call the Filer
+1 NEW DIERR,DIHELP,DIMSG,IENS,FILE,ROOT,XUMVIERR
+2 if '$DATA(XUMVIFDA)
QUIT
+3 SET FILE=$ORDER(XUMVIFDA(0))
SET IENS=$ORDER(XUMVIFDA(+FILE,""))
SET ROOT=$$ROOT^DILFD(FILE,IENS)_+IENS_")"
+4 IF $GET(ROOT)=""
DO ADDERR(.XURET,"Unable to determine global root of File #"_FILE_", IENS '"_IENS_".")
QUIT
+5 LOCK +@ROOT:10
IF '$TEST
DO ADDERR(.XURET,"Unable to lock global "_ROOT_".")
QUIT
+6 DO FILE^DIE($GET(FLAG),"XUMVIFDA","XUMVIERR")
+7 LOCK -@ROOT
+8 if $GET(DIERR)
DO ADDERR(.XURET,$$BLDERR("XUMVIERR"))
+9 QUIT
+10 ;
UPDATER(XUMVIFDA,FLAG,XURET,XUMVIIEN) ;Call the Updater
+1 ;**724,Story 1209890 (mko): Add XUMVIIEN as an input paramater to allow controlling IEN of new record
+2 NEW DIERR,DIHELP,DIMSG,XUMVIERR
+3 DO UPDATE^DIE(FLAG,"XUMVIFDA","XUMVIIEN","XUMVIERR")
+4 IF $GET(DIERR)
DO ADDERR(.XURET,$$BLDERR("XUMVIERR"))
QUIT 0
+5 QUIT +$GET(XUMVIIEN(1))
+6 ;
ADDERR(XURET,MSG) ;Add error MSG to XURET
+1 if $GET(MSG)=""
QUIT
+2 SET XURET=$SELECT(XURET]"":XURET_" ",1:"-1^")_MSG
+3 QUIT
+4 ;
STATEIEN(STATE) ;Return "`"_IEN if valid abbreviation, VA code, or name
+1 NEW IEN
+2 if $GET(STATE)=""
QUIT ""
+3 SET IEN=$SELECT(STATE="FG":$ORDER(^DIC(5,"B","FOREIGN COUNTRY",0)),STATE="OT":$ORDER(^DIC(5,"B","OTHER",0)),STATE="EU":$ORDER(^DIC(5,"B","EUROPE",0)),1:$ORDER(^DIC(5,"C",STATE,0)))
+4 if 'IEN
SET IEN=$ORDER(^DIC(5,"B",STATE,""))
+5 QUIT $SELECT(IEN>0:"`"_IEN,1:STATE)
+6 ;
GETINT(FILE,FLD,VAL) ;Get the internal form of the data; returns "^" if not valid
+1 NEW DIERR,DIHELP,DIMSG,XUMSG,XURES
+2 if VAL=""
QUIT ""
+3 DO CHK^DIE(FILE,FLD,"",VAL,.XURES,"XUMSG")
+4 QUIT XURES
+5 ;
BLDERR(INROOT) ;Build a string containing error messages returned by FileMan
+1 NEW ERRSTR,I,XUERMSGS
+2 DO MSG^DIALOG("AE",.XUERMSGS,"","",$GET(INROOT))
+3 SET ERRSTR=""
+4 SET I=0
FOR
SET I=$ORDER(XUERMSGS(I))
if 'I
QUIT
if XUERMSGS(I)]""
SET ERRSTR=ERRSTR_$EXTRACT(" ",ERRSTR]"")_XUERMSGS(I)
+5 QUIT ERRSTR
+6 ;
MAXLEN(FILE,FLD) ;Return the maximum length of field FLD in file FILE
+1 NEW MAX
+2 SET MAX=$$GET1^DID(+FILE,+FLD,"","FIELD LENGTH")
if MAX'>0
SET MAX=999
+3 QUIT MAX
+4 ;
+5 ;=================================================
+6 ; Code for storing debugging information in ^XTMP
+7 ;=================================================
RECORD(PARAM,FLAG,RPCNAME) ;Record RPC inputs for debugging
+1 ;Return seq# in ^XTMP
+2 NEW NODE,NOW,SEQ,TODAY
+3 if '$$ISDEBUG
QUIT 0
+4 if $GET(RPCNAME)=""
SET RPCNAME="XUS MVI ENRICH NEW PERSON"
+5 SET NOW=$$NOW^XLFDT
SET TODAY=$PIECE(NOW,".")
+6 SET NODE=$$NODE
+7 ;
+8 LOCK +^XTMP(NODE):2
+9 DO SETXTMP0(NODE)
+10 SET SEQ=$ORDER(^XTMP(NODE," "),-1)+1
+11 MERGE ^XTMP(NODE,SEQ,"PARAM")=PARAM
+12 SET ^XTMP(NODE,SEQ,"FLAG")=$GET(FLAG)
+13 SET ^XTMP(NODE,SEQ,"DT")=NOW
+14 SET ^XTMP(NODE,SEQ,"DUZ")=$GET(DUZ)
+15 SET ^XTMP(NODE,SEQ,"RPC")=RPCNAME
+16 LOCK -^XTMP(NODE)
+17 QUIT SEQ
+18 ;
RETURN(SEQ,RETURN) ;Record the return value
+1 if 'SEQ
QUIT
if '$$ISDEBUG
QUIT
+2 MERGE ^XTMP($$NODE,SEQ,"RETURN")=RETURN
+3 QUIT
+4 ;
DBON ;Set DEBUG on
+1 NEW NODE
+2 SET NODE=$$NODE
+3 DO SETXTMP0
+4 SET ^XTMP(NODE,"DEBUG")=1
+5 WRITE !,$NAME(^XTMP(NODE,"DEBUG"))_" set to 1.",!
+6 QUIT
+7 ;
DBOFF ;Set DEBUG off
+1 NEW NODE
+2 SET NODE=$$NODE
+3 KILL ^XTMP(NODE,"DEBUG")
+4 if '$ORDER(^XTMP(NODE,0))
KILL ^XTMP(NODE)
+5 WRITE !,$NAME(^XTMP(NODE,"DEBUG"))_" killed.",!
+6 QUIT
+7 ;
ISDEBUG() ;Return 1 if DEBUG mode flag is set
+1 QUIT $GET(^XTMP($$NODE,"DEBUG"))
+2 ;
PURGE ;Purge the debugging data stored in ^XTMP
+1 NEW ISDEBUG
+2 SET ISDEBUG=$$ISDEBUG
+3 KILL ^XTMP($$NODE)
+4 WRITE !,$NAME(^XTMP($$NODE))_" killed.",!
+5 if ISDEBUG
DO DBON
+6 QUIT
+7 ;
SETXTMP0(NODE,DESC,LIFE) ;Set 0 node of ^XTMP(node)
+1 NEW CREATEDT
+2 if $GET(NODE)=""
SET NODE=$$NODE
+3 SET CREATEDT=$SELECT($DATA(^XTMP(NODE,0))#2:$PIECE(^(0),U,2),1:DT)
+4 if '$GET(LIFE)
SET LIFE=30
+5 if $GET(DESC)=""
SET DESC="New Person RPC Inputs and Outputs"
+6 SET ^XTMP(NODE,0)=$$FMADD^XLFDT(DT,LIFE)_U_CREATEDT_U_DESC
+7 QUIT
+8 ;
NODE() ;Return ^XTMP Debug subscript
+1 QUIT "XU_RPC_DEBUG_NP"
