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

XUMVIENU.m

Go to the documentation of this file.
  1. 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
  1. ;Per VA Directive 6402, this routine should not be modified.
  1. ;**711,Story 977838 (mko/ckn): New routine
  1. ;Entry point: UPDATE^XUMVIENU(XURET,.XUARR,XUFLAG)
  1. ; called from rpc: XUS MVI ENRICH NEW PERSON
  1. ;
  1. ; Input:
  1. ; XUARR(subscript)=value to update
  1. ; XUFLAG = "A" : if RPC is being called to add a record to the New Person file
  1. ; "U" : if RPC is being called to edit an existing New Person file record.
  1. ;
  1. ; Return Parameter:
  1. ; On success:
  1. ; DUZ of New Person File entry edited or added
  1. ; Returned if there were no issues adding or editing the entry.
  1. ;
  1. ; DUZ^-1^errorMessage
  1. ; Returned if entry was edited, but some data was not valid and could
  1. ; not be filed.
  1. ; On failure:
  1. ; -1^errorMessage
  1. ; Returned for example if required data was not passed, entry could
  1. ; not be added when FLAG="A", or entry could not be found based on
  1. ; the NPI when FLAG="U".
  1. ;
  1. UPDATE(XURET,XUARR,XUFLAG) ;RPC to enrich New Pperson file entry
  1. N XUDBSEQ
  1. S XUDBSEQ=$$RECORD(.XUARR,$G(XUFLAG))
  1. D PROC(.XURET,.XUARR,.XUFLAG)
  1. D RETURN(XUDBSEQ,XURET)
  1. Q
  1. ;
  1. PROC(XURET,XUARR,XUFLAG) ;Main code for RPC
  1. N FDA,OLDTDATE,XUDUZ,XURSET
  1. K XURET S XURSET=0
  1. ;
  1. ;Check inputs
  1. S XURET=$$CHKINPUT(.XUARR,.XUFLAG)
  1. Q:XURET<0
  1. ;
  1. ;Add or get New Person IEN in XUDUZ
  1. S XURET=""
  1. I $G(XUFLAG)="A" D
  1. . ;Call entry point to add the record
  1. . D:$G(XUARR("SubjectOrgan"))=""!($G(XUARR("SubjectOrganID"))="") SUBJDEF(.XUARR)
  1. . S XUDUZ=$$ADDUSER^XUMVINPA(.XUARR)
  1. . I $P(XUDUZ,"^",3)'=1 S XUFLAG="U",XURSET=1 ;**767 found exists already so process as update
  1. . I XUDUZ<0 S XURET=XUDUZ ;If error, we'll return -1^errorMessage
  1. . E I $P(XUDUZ,U,3)=1 S XUDUZ=+XUDUZ ;If record was added, set XUDUZ to new IEN
  1. . E S XURET=+XUDUZ ;If record was found, not added, we'll just return DUZ -- no edit will take place
  1. E D
  1. . ;Lookup user based on NPI
  1. . ;S XATTRIB(8)=XUARR("NPI") ; NPI
  1. . ;S XUDUZ=$$FINDUSER^XUESSO2(.XATTRIB) ; find user based on NPI ; returns -1^Not authorized if DUZ("LOA")<2
  1. . S XUDUZ=$O(^VA(200,"ANPI",XUARR("NPI"),0))
  1. . S:XUDUZ'>0 XURET="-1^User with NPI "_XUARR("NPI")_" not found."
  1. ;
  1. ;If add or lookup above set XURET, we're done
  1. I XURET]""&(XUFLAG="A") Q
  1. ;
  1. ;**744 - VAMPI-8213 (ckn)
  1. ;If update is from PPMS/PIE and if New Person have Primary Menu,
  1. ;then no update as this is a Dual Provider.
  1. 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)
  1. ;If update is from PPMS/PIE and if CPRS TAB multiple field have any other
  1. ;values than "NVA", then no update as this is a Dual Provider.
  1. N QCPFLG,TABIEN S QCPFLG=0
  1. I $G(XUFLAG)="U",($G(XUARR("WHO"))="200PIEV") D
  1. .N ORDIEN S ORDIEN=$O(^ORD(101.13,"B","NVA",""))
  1. .I $D(^VA(200,+XUDUZ,"ORD")) D
  1. ..S TABIEN=0 F S TABIEN=$O(^VA(200,+XUDUZ,"ORD","B",TABIEN)) Q:+TABIEN=0!(QCPFLG) D
  1. ...I TABIEN'=ORDIEN S QCPFLG=1
  1. I QCPFLG S XURET="-1^Provider has Non-NVA values in CPRS TAB" Q
  1. ;
  1. ;Update the NAME first. (Within a FILE^DIE call, triggers on the .01 that in turn call FILE^DIE
  1. ;may cause the Filer flag to change from "E", to "".)
  1. I $G(XUFLAG)'="A",$D(XUARR("NAME"))#2 D
  1. . N NAME
  1. . S NAME=$P($G(XUARR("NAME")),"|",5)
  1. . S:NAME="" NAME=$$FMNAME^HLFNC($G(XUARR("NAME")),"|")
  1. . I NAME]"" S FDA(200,+XUDUZ_",",.01)=NAME D FILER(.FDA,"E",.XURET)
  1. ;
  1. ;Set up FDA
  1. D SETFDA(XUDUZ,.XUARR,.FDA)
  1. ;
  1. ;Remove Termination Date from FDA if it's in the future
  1. D TERMDATE(.FDA,.XURES)
  1. ;
  1. ;Save the original Termination Date
  1. S OLDTDATE=$P($G(^VA(200,XUDUZ,0)),U,11)
  1. ;
  1. ;Call the Filer
  1. D FILER(.FDA,"E",.XURET)
  1. ;
  1. ;**744 - VAMPI-3039 (ckn) - Update CPRS tab
  1. I $G(XUARR("WHO"))="200PIEV" D CPRSNVA^XUMVIEU1(XUDUZ,.XUARR,OLDTDATE)
  1. ;
  1. ;If Termination Date was added or deleted, remove or add Security keys PROVIDER and XUORES
  1. D SECKEYS(XUDUZ,OLDTDATE,.XURET,XURSET) ;**767 OR if ADD is now UPDATE XURSET=1
  1. ;
  1. ;File the Person Class data
  1. D PERSCLAS(XUDUZ,.XUARR,.XURET)
  1. ;
  1. ;File the DEA data
  1. I $$PATCH^XPDUTL("XU*8.0*688"),$$VFIELD^DILFD(200,53.21),$$VFILE^DILFD(8991.9) D
  1. . ;File NEW DEA #'S in multiple and add/edit entries in File #8991.9
  1. . D NEWDEA(XUDUZ,.XUARR,.XURET)
  1. . ;File first NEW DEA data into single-valued fields of NP file
  1. . D NPDEA(XUDUZ,.XUARR,.XURET)
  1. E D
  1. . ;File first valid DEA # into file (NEW DEA#'s multiple doesn't exist)
  1. . D FIRSTDEA(XUDUZ,.XUARR,.XURET)
  1. ;
  1. ;Return DUZ in first piece. If errors, also return -1^errMsg in 2nd and 3rd pieces.
  1. S XURET=XUDUZ_$S(XURET<0:U_XURET,1:"")
  1. Q
  1. ;
  1. CHKINPUT(XUARR,XUFLAG) ;Check inputs
  1. ;Returns: "-1^errorMsg" if problem; otherwise return 0
  1. Q:'$D(XUARR) "-1^No data passed"
  1. Q:$G(XUARR("NPI"))="" "-1^Missing NPI"
  1. Q:'$$CHKDGT^XUSNPI($G(XUARR("NPI"))) "-1^NPI is not valid"
  1. Q:$G(XUARR("WHO"))="" "-1^Missing requesting Station number"
  1. ;
  1. S:$G(XUFLAG)="" XUFLAG="U"
  1. Q:"^A^U^"'[(U_$G(XUFLAG)_U) "-1^Invalid flag "_XUFLAG_" was passed."
  1. Q 0
  1. ;
  1. 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
  1. D SETFDA^XUMVIEU1(IEN,.XUARR,.FDA)
  1. Q
  1. ;
  1. SUBJDEF(XUARR) ;Set default Subject Organization and ID
  1. S XUARR("SubjectOrgan")="Department Of Veterans Affairs"
  1. S XUARR("SubjectOrganID")="urn:oid:2.16.840.1.113883.4.349"
  1. Q
  1. ;
  1. 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
  1. N IENS,TDATE
  1. S IENS=$O(FDA(200,"")) Q:IENS=""
  1. Q:"@"[$G(FDA(200,IENS,9.2))
  1. ;
  1. ;Get internal form
  1. S TDATE=$$GETINT(200,9.2,FDA(200,IENS,9.2)) Q:TDATE=U
  1. ;
  1. I $P($G(^VA(200,+IENS,201)),U)]"" D Q
  1. . D ADDERR(.XURET,"User has a PRIMARY MENU and cannot be terminated.")
  1. . K FDA(200,IENS,9.2)
  1. ;
  1. ;Remove from FDA if it's a future date, and add an error message
  1. D:TDATE>DT
  1. . D ADDERR(.XURET,"TERMINATION DATE '"_FDA(200,IENS,9.2)_"' is in the future.")
  1. . K FDA(200,IENS,9.2)
  1. Q
  1. ;
  1. SECKEYS(XUDUZ,OLDTDATE,XURET,XURSET) ;Add or remove Security Keys PROVIDER and XUORES
  1. ;based on whether Termination Date is deleted or created
  1. ;**767 OR if ADD is now UPDATE XURSET=1
  1. N KEY,KEYIEN,NEWTDATE
  1. S XUDUZ=+$G(XUDUZ),OLDTDATE=$G(OLDTDATE)
  1. S NEWTDATE=$P($G(^VA(200,XUDUZ,0)),U,11)
  1. Q:$G(OLDTDATE)=NEWTDATE&(XURSET=0)
  1. ;
  1. F KEY="PROVIDER","XUORES" D
  1. . S KEYIEN=$O(^DIC(19.1,"B",KEY,0)) Q:KEYIEN'>0
  1. . I OLDTDATE="",NEWTDATE]"" D
  1. .. ;Delete the key
  1. .. N DA,DIK
  1. .. S DA=$O(^VA(200,XUDUZ,51,"B",KEYIEN,0)) Q:DA'>0
  1. .. S DA(1)=XUDUZ,DIK="^VA(200,"_XUDUZ_",51,"
  1. .. D ^DIK
  1. .I OLDTDATE]"",NEWTDATE="" D ADDKEY(XUDUZ,KEYIEN)
  1. .I XURSET=1 D ADDKEY(XUDUZ,KEYIEN)
  1. Q
  1. ADDKEY(XUDUZ,KEYIEN) ;Add the key
  1. ;**724,Story 1209890 (mko): The #.01 of the KEYS multiple is DINUM'd, so pass IEN(1)
  1. ; Also, GIVEN BY (#1) and DATE GIVEN (#2) are triggered by the #.01.
  1. N IENS,FDA,IEN
  1. Q:$O(^VA(200,XUDUZ,51,"B",KEYIEN,0))
  1. S IENS="+1,"_XUDUZ_","
  1. S (FDA(200.051,IENS,.01),IEN(1))=KEYIEN
  1. D UPDATER(.FDA,"",.XURET,.IEN)
  1. Q
  1. ;
  1. PERSCLAS(XUDUZ,XUARR,XURET) ;Update PERSON CLASS multiple
  1. N CNT,CURVAL,D0,FDA,IEN,IENS,NEWVAL,PCIEN,VACODE,X12CODE
  1. S CNT=0 F S CNT=$O(XUARR("PersonClass",CNT)) Q:'CNT D
  1. . S X12CODE=$G(XUARR("PersonClass",CNT,"PersonClass")) Q:X12CODE=""
  1. . ;
  1. . ;Lookup the Person Class entry in the multiple
  1. . S PCIEN=0
  1. . 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
  1. . I 'PCIEN S PCIEN=$O(^USC(8932.1,"G",X12CODE,0))
  1. . S IEN=$O(^VA(200,+XUDUZ,"USC1","B",+PCIEN,0))
  1. . ;
  1. . ;If not found, add it
  1. . I IEN'>0 D Q:IEN'>0
  1. .. S FDA(200.05,"+1,"_+XUDUZ_",",.01)=PCIEN ;now passing internal value of X12CODE
  1. .. S IEN=$$UPDATER(.FDA,"",.XURET)
  1. . ;
  1. . ;Update the other values in the Person Class multiple
  1. . S IENS=+IEN_","_+XUDUZ_","
  1. . S CURVAL=$P($G(^VA(200,+XUDUZ,"USC1",+IEN,0)),U,2)
  1. . S NEWVAL=$G(XUARR("PersonClass",CNT,"PersonClassActive"))
  1. . I NEWVAL="",'$$ISPCACTV(XUDUZ,IEN) S FDA(200.05,IENS,2)="TODAY",FDA(200.05,IENS,3)="@"
  1. . E I NEWVAL]"" S FDA(200.05,IENS,2)=NEWVAL
  1. . S:$D(XUARR("PersonClass",CNT,"PersonClassExpire"))#2 FDA(200.05,IENS,3)=XUARR("PersonClass",CNT,"PersonClassExpire")
  1. . S D0=+XUDUZ ;Needed by input transform of Effective Date (200.05,2)
  1. . D FILER(.FDA,"E",.XURET)
  1. Q
  1. ;
  1. ISPCACTV(XUDUZ,SUBIEN) ;Is the Person Class active?
  1. N EFFDT,EXPDT,ND
  1. S ND=$G(^VA(200,+$G(XUDUZ),"USC1",+$G(SUBIEN),0)) Q:ND="" 0
  1. S EFFDT=$P(ND,U,2),EXPDT=$P(ND,U,3)
  1. I EFFDT,DT'<EFFDT,DT'>EXPDT Q 1
  1. Q 0
  1. ;
  1. NEWDEA(XUDUZ,XUARR,XURET) ;Update DEA NUMBERS File #8991.9
  1. ;and the NEW PERSON File NEW DEA #'s multiple
  1. N CNT,DEA,DIERR,DIHELP,DIMSG,FDA,IEN,IENS,NDEAIEN,XUERR
  1. N STR1,STR2,STR3,CITY,STATE,ZIP,ADDR
  1. ;
  1. ;Get address parts
  1. D:$D(XUARR("ADDRESS DATA"))#2
  1. . S ADDR=XUARR("ADDRESS DATA")
  1. . S STR1=$E($P(ADDR,"|"),1,$$MAXLEN(8991.9,1.2))
  1. . S STR2=$E($P(ADDR,"|",2),1,$$MAXLEN(8991.9,1.3))
  1. . S STR3=$E($P(ADDR,"|",3),1,$$MAXLEN(8991.9,1.4))
  1. . S CITY=$E($P(ADDR,"|",4),1,$$MAXLEN(8991.9,1.5))
  1. . S STATE=$P(ADDR,"|",5)
  1. . S ZIP=$TR($P(ADDR,"|",6),"-")
  1. ;
  1. S CNT=0 F S CNT=$O(XUARR("DEA",CNT)) Q:'CNT D
  1. . S DEA=$G(XUARR("DEA",CNT,"DEA"))
  1. . Q:DEA=""
  1. . ;
  1. . ;Lookup or add a record to File #8991.9 with the passed DEA #
  1. . S NDEAIEN=$O(^XTV(8991.9,"B",DEA,0))
  1. . I NDEAIEN'>0 D Q:NDEAIEN'>0
  1. .. K FDA
  1. .. S IENS="+1,"
  1. .. S FDA(8991.9,IENS,.01)=DEA
  1. .. S FDA(8991.9,IENS,10.2)="NOW"
  1. .. S NDEAIEN=$$UPDATER(.FDA,"E",.XURET)
  1. . ;
  1. . ;Update Expiration Date, Address, and Schedule fields for this File #8991.9 entry
  1. . K FDA
  1. . S IENS=NDEAIEN_","
  1. . D:$D(XUARR("ADDRESS DATA"))#2
  1. .. S FDA(8991.9,IENS,1.2)=STR1
  1. .. S FDA(8991.9,IENS,1.3)=STR2
  1. .. S FDA(8991.9,IENS,1.4)=STR3
  1. .. S FDA(8991.9,IENS,1.5)=CITY
  1. .. S FDA(8991.9,IENS,1.6)=$$STATEIEN(STATE)
  1. .. S FDA(8991.9,IENS,1.7)=ZIP
  1. . S:$D(XUARR("DEA",CNT,"Detox"))#2 FDA(8991.9,IENS,.03)=XUARR("DEA",CNT,"Detox")
  1. . S:$D(XUARR("DEA",CNT,"DEAExpire"))#2 FDA(8991.9,IENS,.04)=XUARR("DEA",CNT,"DEAExpire")
  1. . S:$D(XUARR("DEA",CNT,"SchedIINarc"))#2 FDA(8991.9,IENS,2.1)=XUARR("DEA",CNT,"SchedIINarc")
  1. . S:$D(XUARR("DEA",CNT,"SchedIINonNarc"))#2 FDA(8991.9,IENS,2.2)=XUARR("DEA",CNT,"SchedIINonNarc")
  1. . S:$D(XUARR("DEA",CNT,"SchedIIINarc"))#2 FDA(8991.9,IENS,2.3)=XUARR("DEA",CNT,"SchedIIINarc")
  1. . S:$D(XUARR("DEA",CNT,"SchedIIINonNarc"))#2 FDA(8991.9,IENS,2.4)=XUARR("DEA",CNT,"SchedIIINonNarc")
  1. . S:$D(XUARR("DEA",CNT,"SchedIV"))#2 FDA(8991.9,IENS,2.5)=XUARR("DEA",CNT,"SchedIV")
  1. . S:$D(XUARR("DEA",CNT,"SchedV"))#2 FDA(8991.9,IENS,2.6)=XUARR("DEA",CNT,"SchedV")
  1. . S:$D(FDA) FDA(8991.9,IENS,10.1)=$S($G(DUZ):"`"_DUZ,1:""),FDA(8991.9,IENS,10.2)="NOW"
  1. . D FILER(.FDA,"E",.XURET)
  1. . ;
  1. . ;Lookup or add corresponding entry in New Person NEW DEA #'S multiple
  1. . S IEN=$O(^VA(200,+XUDUZ,"PS4","B",DEA,0))
  1. . I IEN'>0 D Q:IEN'>0
  1. .. K FDA
  1. .. S FDA(200.5321,"+1,"_+XUDUZ_",",.01)=DEA
  1. .. S IEN=$$UPDATER(.FDA,"E",.XURET)
  1. . ;
  1. . ;Update the DEA POINTER value in the NEW DEA #'s multiple
  1. . K FDA
  1. . S FDA(200.5321,+IEN_","_+XUDUZ_",",.03)=NDEAIEN
  1. . D FILER(.FDA,"",.XURET)
  1. Q
  1. ;
  1. 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
  1. ; the NEW DEA#'s multiple; Also default Auth to Write Med Orders to 1 if not already set,
  1. ; WHO is 200PIEV, and there's a DEA#
  1. N DEAIEN,FDA,IENS,ND0,ND2,NDEAIEN
  1. S DEAIEN=$O(^VA(200,XUDUZ,"PS4",0)) Q:'DEAIEN
  1. S NDEAIEN=$P(^VA(200,XUDUZ,"PS4",DEAIEN,0),U,3) Q:NDEAIEN'>0
  1. ;
  1. ;Set up FDA with data from DEA NUMBERS entry
  1. S IENS=+XUDUZ_","
  1. S ND0=$G(^XTV(8991.9,+NDEAIEN,0)),ND2=$G(^(2)) Q:$P(ND0,U)=""
  1. S FDA(200,IENS,53.2)=$P(ND0,U) ;DEA#
  1. S FDA(200,IENS,53.11)=$P(ND0,U,3) ;DETOX NUMBER
  1. S FDA(200,IENS,747.44)=$P(ND0,U,4) ;DEA EXPIRATION DATE
  1. S FDA(200,IENS,55.1)=$P(ND2,U) ;SCHEDULE II NARCOTIC
  1. S FDA(200,IENS,55.2)=$P(ND2,U,2) ;SCHEDULE II NON-NARCOTIC
  1. S FDA(200,IENS,55.3)=$P(ND2,U,3) ;SCHEDULE III NARCOTIC
  1. S FDA(200,IENS,55.4)=$P(ND2,U,4) ;SCHEDULE III NON-NARCOTIC
  1. S FDA(200,IENS,55.5)=$P(ND2,U,5) ;SCHEDULE IV
  1. S FDA(200,IENS,55.6)=$P(ND2,U,6) ;SCHEDULE V
  1. I $G(XUARR("WHO"))="200PIEV",$G(XUARR("AuthWriteMedOrders"))="" S FDA(200,IENS,53.1)=1
  1. D FILER(.FDA,"",.XURET)
  1. Q
  1. ;
  1. 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
  1. N CNT,DEA,FDA,FIRST,IENS
  1. ;
  1. ;Find the first valid DEA number in the input array
  1. S FIRST="",CNT=0 F S CNT=$O(XUARR("DEA",CNT)) Q:'CNT D Q:FIRST
  1. . S DEA=$G(XUARR("DEA",CNT,"DEA")) Q:DEA=""
  1. . S DEA=$$GETINT(200,53.2,DEA)
  1. . S:DEA'=U FIRST=CNT
  1. Q:'FIRST
  1. ;
  1. ;Set up FDA with data from DEA NUMBERS entry
  1. S IENS=XUDUZ_","
  1. S FDA(200,IENS,53.2)=DEA
  1. S:$D(XUARR("DEA",FIRST,"Detox"))#2 FDA(200,IENS,53.11)=XUARR("DEA",FIRST,"Detox")
  1. S:$D(XUARR("DEA",FIRST,"DEAExpire"))#2 FDA(200,IENS,747.44)=XUARR("DEA",FIRST,"DEAExpire")
  1. S:$D(XUARR("DEA",FIRST,"SchedIINarc"))#2 FDA(200,IENS,55.1)=XUARR("DEA",FIRST,"SchedIINarc")
  1. S:$D(XUARR("DEA",FIRST,"SchedIINonNarc"))#2 FDA(200,IENS,55.2)=XUARR("DEA",FIRST,"SchedIINonNarc")
  1. S:$D(XUARR("DEA",FIRST,"SchedIIINarc"))#2 FDA(200,IENS,55.3)=XUARR("DEA",FIRST,"SchedIIINarc")
  1. S:$D(XUARR("DEA",FIRST,"SchedIIINonNarc"))#2 FDA(200,IENS,55.4)=XUARR("DEA",FIRST,"SchedIIINonNarc")
  1. S:$D(XUARR("DEA",FIRST,"SchedIV"))#2 FDA(200,IENS,55.5)=XUARR("DEA",FIRST,"SchedIV")
  1. S:$D(XUARR("DEA",FIRST,"SchedV"))#2 FDA(200,IENS,55.6)=XUARR("DEA",FIRST,"SchedV")
  1. I $G(XUARR("WHO"))="200PIEV",$G(XUARR("AuthWriteMedOrders"))="" S FDA(200,IENS,53.1)=1
  1. D FILER(.FDA,"E",.XURET)
  1. Q
  1. ;
  1. FILER(XUMVIFDA,FLAG,XURET) ;Call the Filer
  1. N DIERR,DIHELP,DIMSG,IENS,FILE,ROOT,XUMVIERR
  1. Q:'$D(XUMVIFDA)
  1. S FILE=$O(XUMVIFDA(0)),IENS=$O(XUMVIFDA(+FILE,"")),ROOT=$$ROOT^DILFD(FILE,IENS)_+IENS_")"
  1. I $G(ROOT)="" D ADDERR(.XURET,"Unable to determine global root of File #"_FILE_", IENS '"_IENS_".") Q
  1. L +@ROOT:10 E D ADDERR(.XURET,"Unable to lock global "_ROOT_".") Q
  1. D FILE^DIE($G(FLAG),"XUMVIFDA","XUMVIERR")
  1. L -@ROOT
  1. D:$G(DIERR) ADDERR(.XURET,$$BLDERR("XUMVIERR"))
  1. Q
  1. ;
  1. 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
  1. N DIERR,DIHELP,DIMSG,XUMVIERR
  1. D UPDATE^DIE(FLAG,"XUMVIFDA","XUMVIIEN","XUMVIERR")
  1. I $G(DIERR) D ADDERR(.XURET,$$BLDERR("XUMVIERR")) Q 0
  1. Q +$G(XUMVIIEN(1))
  1. ;
  1. ADDERR(XURET,MSG) ;Add error MSG to XURET
  1. Q:$G(MSG)=""
  1. S XURET=$S(XURET]"":XURET_" ",1:"-1^")_MSG
  1. Q
  1. ;
  1. STATEIEN(STATE) ;Return "`"_IEN if valid abbreviation, VA code, or name
  1. N IEN
  1. Q:$G(STATE)="" ""
  1. 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)))
  1. S:'IEN IEN=$O(^DIC(5,"B",STATE,""))
  1. Q $S(IEN>0:"`"_IEN,1:STATE)
  1. ;
  1. GETINT(FILE,FLD,VAL) ;Get the internal form of the data; returns "^" if not valid
  1. N DIERR,DIHELP,DIMSG,XUMSG,XURES
  1. Q:VAL="" ""
  1. D CHK^DIE(FILE,FLD,"",VAL,.XURES,"XUMSG")
  1. Q XURES
  1. ;
  1. BLDERR(INROOT) ;Build a string containing error messages returned by FileMan
  1. N ERRSTR,I,XUERMSGS
  1. D MSG^DIALOG("AE",.XUERMSGS,"","",$G(INROOT))
  1. S ERRSTR=""
  1. S I=0 F S I=$O(XUERMSGS(I)) Q:'I S:XUERMSGS(I)]"" ERRSTR=ERRSTR_$E(" ",ERRSTR]"")_XUERMSGS(I)
  1. Q ERRSTR
  1. ;
  1. MAXLEN(FILE,FLD) ;Return the maximum length of field FLD in file FILE
  1. N MAX
  1. S MAX=$$GET1^DID(+FILE,+FLD,"","FIELD LENGTH") S:MAX'>0 MAX=999
  1. Q MAX
  1. ;
  1. ;=================================================
  1. ; Code for storing debugging information in ^XTMP
  1. ;=================================================
  1. RECORD(PARAM,FLAG,RPCNAME) ;Record RPC inputs for debugging
  1. ;Return seq# in ^XTMP
  1. N NODE,NOW,SEQ,TODAY
  1. Q:'$$ISDEBUG 0
  1. S:$G(RPCNAME)="" RPCNAME="XUS MVI ENRICH NEW PERSON"
  1. S NOW=$$NOW^XLFDT,TODAY=$P(NOW,".")
  1. S NODE=$$NODE
  1. ;
  1. L +^XTMP(NODE):2
  1. D SETXTMP0(NODE)
  1. S SEQ=$O(^XTMP(NODE," "),-1)+1
  1. M ^XTMP(NODE,SEQ,"PARAM")=PARAM
  1. S ^XTMP(NODE,SEQ,"FLAG")=$G(FLAG)
  1. S ^XTMP(NODE,SEQ,"DT")=NOW
  1. S ^XTMP(NODE,SEQ,"DUZ")=$G(DUZ)
  1. S ^XTMP(NODE,SEQ,"RPC")=RPCNAME
  1. L -^XTMP(NODE)
  1. Q SEQ
  1. ;
  1. RETURN(SEQ,RETURN) ;Record the return value
  1. Q:'SEQ Q:'$$ISDEBUG
  1. M ^XTMP($$NODE,SEQ,"RETURN")=RETURN
  1. Q
  1. ;
  1. DBON ;Set DEBUG on
  1. N NODE
  1. S NODE=$$NODE
  1. D SETXTMP0
  1. S ^XTMP(NODE,"DEBUG")=1
  1. W !,$NA(^XTMP(NODE,"DEBUG"))_" set to 1.",!
  1. Q
  1. ;
  1. DBOFF ;Set DEBUG off
  1. N NODE
  1. S NODE=$$NODE
  1. K ^XTMP(NODE,"DEBUG")
  1. K:'$O(^XTMP(NODE,0)) ^XTMP(NODE)
  1. W !,$NA(^XTMP(NODE,"DEBUG"))_" killed.",!
  1. Q
  1. ;
  1. ISDEBUG() ;Return 1 if DEBUG mode flag is set
  1. Q $G(^XTMP($$NODE,"DEBUG"))
  1. ;
  1. PURGE ;Purge the debugging data stored in ^XTMP
  1. N ISDEBUG
  1. S ISDEBUG=$$ISDEBUG
  1. K ^XTMP($$NODE)
  1. W !,$NA(^XTMP($$NODE))_" killed.",!
  1. D:ISDEBUG DBON
  1. Q
  1. ;
  1. SETXTMP0(NODE,DESC,LIFE) ;Set 0 node of ^XTMP(node)
  1. N CREATEDT
  1. S:$G(NODE)="" NODE=$$NODE
  1. S CREATEDT=$S($D(^XTMP(NODE,0))#2:$P(^(0),U,2),1:DT)
  1. S:'$G(LIFE) LIFE=30
  1. S:$G(DESC)="" DESC="New Person RPC Inputs and Outputs"
  1. S ^XTMP(NODE,0)=$$FMADD^XLFDT(DT,LIFE)_U_CREATEDT_U_DESC
  1. Q
  1. ;
  1. NODE() ;Return ^XTMP Debug subscript
  1. Q "XU_RPC_DEBUG_NP"