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