XUREMAP1 ;VISS/CEP - Remote Application Registration ; JAN 15, 2025
;;8.0;KERNEL;**759**;Jul 10, 1995;Build 40
;Per VA Directive 6402, this routine should not be modified.
Q
GETCNTXT(OUTCTXT,XUCONTXT,OUTINDEX) ; get Context Option (file #19) details for each entry
;
;INPUT:
; XUCONTXT: Name (#.01 ) from option File (#19) of B-Type Option
; OUTINDEX: [optional] positive integer to use as first subscript in return array.
;
;RETURN:
; OUTCTXT--OUTPUT ARRAY BY REFERENCE. SEE DOCUMENTATION FROM RAQ2 FOR CONTEXT OPTION FORMAT
;
N IENS,IEN19,ERRS
I '$G(OUTINDEX)!(OUTINDEX=0) S OUTINDEX=1
S OUTCTXT="OUTCTXT("_OUTINDEX_")"
;
S IEN19=$$FINDOPT^XUREMAP1(XUCONTXT)
I +IEN19'>0 S OUTCTXT(0)="0^Option "_XUCONTXT_" not found."_U_$P($$SITE^VASITE(),U,3) Q
; return array is linked to entry with RAIEN
S IENS=IEN19_","
D GETS^DIQ(19,IENS,"**","N",OUTCTXT,"ERRS")
S OUTCTXT(0)=1_"^Option "_XUCONTXT_" found (IEN: "_IEN19_")."_U_$P($$SITE^VASITE(),U,3)
Q
;
GETFLNUM(XUARR) ; Function returns filenumber from input ^ file name ^ location in array
;
N ARR,FOUND,FILENUM,FLDNUM,IDATA
S ARR="XUARR"
S FOUND=0
F S ARR=$Q(@ARR) Q:ARR="" S FILENUM=+$P($P(@ARR,U),";"),FLDNUM=+$P($P(@ARR,U),";",2),IDATA=$P(@ARR,U,3) D Q:FOUND
. I FLDNUM=".01" S FOUND=FILENUM
Q FOUND_U_$G(IDATA)_U_$S(+FOUND:$QS(ARR,1),1:"")
;
INSPLIT(INARR,ARRM,SUB) ;
; split INARR into an array with top level data (INARR) and
; multiple data (ARRM)
; SUB = subfile number to split into ARRM
;
N INC,FNO
I $G(SUB)'>0 S SUB=8994.51
S INC=0
F S INC=$O(INARR(INC)) Q:INC'>0 D
. S FNO=$P($G(INARR(INC)),";")
. I FNO=SUB D
.. S ARRM(INC)=$G(INARR(INC)) ;Add to ARRM array
.. K INARR(INC) ;Kill from original array
Q
FORMAT(RETURN,TOPLEVEL,MULTIPLE,CNTXTM) ;
; Take top level of entries, multiple entries and Context option
; arrays and return formatted array for IAM specification
;
;
N INDEX,RACNT,TOPIEN
S (INDEX,RACNT)=0
F S RACNT=$O(TOPLEVEL("DILIST",2,RACNT)) Q:RACNT'>0 D
. D TOPLEVEL(.RETURN,.TOPLEVEL,.MULTIPLE,.RACNT,.INDEX,.TOPIEN)
. D CONTEXT(.RETURN,.CNTXTM,.INDEX,.TOPIEN)
Q
;
TOPLEVEL(RETURN,TOPLEVEL,MULTIPLE,RACNT,INDEX,TOPIEN) ;
;
;
;
N FLDNUM,EVALUE,FLDN,CBCNT
S FLDNUM=0
F S FLDNUM=$O(TOPLEVEL("DILIST","ID",RACNT,FLDNUM)) Q:FLDNUM'>0 D
. S TOPIEN=$G(TOPLEVEL("DILIST",2,RACNT))
. S EVALUE=$G(TOPLEVEL("DILIST","ID",RACNT,FLDNUM))
. D ADDELEM(.RETURN,8994.5,FLDNUM,EVALUE,.INDEX)
. ; LOOP TO BUILD MULTIPLE RETURN
S CBCNT=0
F S CBCNT=$O(MULTIPLE(TOPIEN,"DILIST","ID",CBCNT)) Q:CBCNT'>0 D
. S FLDN=0
. F S FLDN=$O(MULTIPLE(TOPIEN,"DILIST","ID",CBCNT,FLDN)) Q:FLDN'>0 D
.. S EVALUE=$G(MULTIPLE(TOPIEN,"DILIST","ID",CBCNT,FLDN))
.. D ADDELEM(.RETURN,8994.51,FLDN,EVALUE,.INDEX)
Q
CONTEXT(RETURN,CNTXTM,INDEX,TOPIEN) ;
; ADD context option (file #19) top level...
N I,ENTRY,FLDN,EVALUE,WPNODE
;
S ENTRY=$O(CNTXTM(TOPIEN,19,""))
Q:ENTRY'>0
S FLDN=0
F S FLDN=$O(CNTXTM(TOPIEN,19,ENTRY,FLDN)) Q:FLDN'>0 D
. S EVALUE=$G(CNTXTM(TOPIEN,19,ENTRY,FLDN))
. S WPNODE=$NA(CNTXTM(TOPIEN,19,ENTRY,FLDN))
. I $P(EVALUE,"(",2)=$P(WPNODE,"(",2) D
.. S I=0 F S I=$O(CNTXTM(TOPIEN,19,ENTRY,FLDN,I)) Q:I'>0 D
... S EVALUE=$G(CNTXTM(TOPIEN,19,ENTRY,FLDN,I))
... D ADDELEM(.RETURN,19,FLDN,EVALUE,.INDEX)
. E D
.. D ADDELEM(.RETURN,19,FLDN,EVALUE,.INDEX)
;
; Add the rpc multiple of the context options (ONLY .01 field)
S ENTRY=0
F S ENTRY=$O(CNTXTM(TOPIEN,19.05,ENTRY)) Q:ENTRY'>0 D
. S FLDN=0
. F S FLDN=$O(CNTXTM(TOPIEN,19.05,ENTRY,FLDN)) Q:FLDN'>0 D
.. S EVALUE=$G(CNTXTM(TOPIEN,19.05,ENTRY,FLDN))
.. D ADDELEM(.RETURN,19.05,FLDN,EVALUE,.INDEX)
;
Q
;
ADDELEM(ARRAY,FILE,FLDNUM,EVALUE,INDEX) ;
; Set a line in the return array
; ADD a line (ELEMent) to the return array
N LABEL
D FIELD^DID(FILE,FLDNUM,"","LABEL","LABEL")
S INDEX=INDEX+1
S ARRAY(INDEX)=FILE_";"_FLDNUM_U_$G(LABEL("LABEL"))_U_EVALUE
;
Q
FAUXFL(XUTEST,NAME,XUARR,XUARRM) ; test filing a Remote Application Entry under false name
;
; INPUT:
; XUARR = top level of input array (see ADDRA^XUREMAP)
; XUARRM = multiple array from INSPLIT call
; OUTPUT:
; XUTEST = result of ADDRA^XUREMAP1 call
; NAME = name of remote application name parsed from input XUARR
;
N INDEX,FILENUM,FAUXARR,FAUXNM,INPUTFN,XUREMOVE
;
S XUTEST(0)=0 ; no matching entry found
;
;
; grab filenumber, name, index position from input array (fn^.01name^index)
S INPUTFN=$$GETFLNUM(.XUARR)
S FILENUM=+INPUTFN
S NAME=$P(INPUTFN,U,2)
I $G(NAME)="" D Q
. S XUARR="-1^Remote Application name cannot be empty."
S INDEX=$P(INPUTFN,U,3)
; Attempt filing under faux name
M FAUXARR=XUARR
S FAUXNM=$$FAUXNM(NAME) ; return name prepended with XUFAUX (
S FAUXARR(INDEX)=FILENUM_";.01^NAME^"_FAUXNM
I FILENUM=8994.5 D ADDRA^XUREMAP1(.XUTEST,.FAUXARR,.XUARRM,-1)
I FILENUM=19 D ADDEP(.XUTEST,.FAUXARR,"")
I $G(XUTEST(0))>0 D REMOVE(.XUREMOVE,.FAUXNM,FILENUM)
Q
;
FAUXNM(NAME) ; Return a name to test filing that is unique.
Q $$TRIM^XLFSTR($E("XUFAUX"_NAME,1,30))
;
REMOVE(XURET,XUNAME,FILENUM) ; remove the Remote Application test entry
N RAIEN,ERR,MSG,FDA
S RAIEN=""
S XURET=0
S RAIEN=$$FIND1^DIC(FILENUM,"","MX",XUNAME,"","","ERR")
I +RAIEN D
. S FDA(FILENUM,RAIEN_",",.01)="@"
. D FILE^DIE("","FDA","MSG")
. M XURET=MSG
E D
. S XURET="-1"_U_XUNAME_" not found. Deletion not performed."
Q
;
ADDRA(XURET,XUARR,XUARRM,XURAIEN) ; implementation of ADDRA^XUREMAP
;
;INPUT:
; XUARR: top level file array with data to file
; XUARRM: multiple array with data to file
; XURAIEN: [optional]
; -1 : don't check for duplicate Authorization codes
; +N : internal entry of 8994.5 entry to overwrite
;
N APPFDA,APPIEN,STATUS,XUERR,RAIEN
I '$D(XUARR) S XURET(0)="-1^No data passed" Q
;
; build top level RA entry FDA array or set error in
; STATUS if input array context option is not found
; in local file 19.
;
S STATUS=$$FDARA(.XUARR,.APPFDA,$G(XURAIEN))
I +STATUS<1 S XURET(0)=STATUS Q
;
; FDA for the callback multiple
I $D(XUARRM) D FDACBM(.XUARRM,.APPFDA)
I $G(XURAIEN)>0 S APPIEN(1)=XURAIEN
D UPDATE^DIE("E","APPFDA","APPIEN","XUERR")
I $D(XUERR("DIERR")) D Q
. S XURET(0)="-1^"_$G(XUERR("DIERR",1,"TEXT",1))
S RAIEN=+$G(APPIEN($O(APPIEN(0))))
S XURET(0)=1_U_RAIEN_U_$P($$SITE^VASITE(),U,3)
Q
;
FDARA(XUARR,FDA,REPLACE) ; convert XUARR to FDA for REMOTE APP
; pass by reference
;
; If this is a rip and replace then XURAIEN should be defined as
; the IEN of the entry being ripped. The replacement needs to be
; stored under the original IEN
;
N ARR,ERROR,IDATA,FILENUM,FLDNAM,FLDNUM,OPT,APPC,COPT
S ARR="XUARR"
S (APPC,ERROR,COPT)=0
F S ARR=$Q(@ARR) Q:ARR="" S FILENUM=+$P($P(@ARR,U,1),";",1),FLDNUM=+$P($P(@ARR,U,1),";",2),FLDNAM=$P(@ARR,U,2),IDATA=$P(@ARR,U,3) D I $G(ERROR) Q
. I FLDNAM="NAME" D
.. I $G(IDATA)="" S ERROR="-1^Remote application name cannot be empty." Q
. I FLDNAM="CONTEXTOPTION" D Q
.. S COPT=1
.. I $G(IDATA)="" S ERROR="-1^Input missing context option." Q
.. S OPT=$$FINDOPT($G(IDATA))
.. I OPT'>0 S ERROR="-1^Input context option does not exist." Q
.. S FDA(FILENUM,"?+1,",FLDNUM)=IDATA
. I FLDNAM="APPLICATIONCODE" D Q
.. S APPC=1
.. I IDATA="" S ERROR="-1^Input missing Application Code." Q
.. S IDATA=$$SHAHASH^XUSHSH(256,IDATA,"B")
.. ; (faux filing)&(application code already in use)
.. I (REPLACE'=-1)&($O(^XWB(8994.5,"ACODE",IDATA,0))>0) S ERROR="-1^Application Code already in use." Q
.. S FDA(FILENUM,"?+1,",FLDNUM)=IDATA
.;
. S FDA(FILENUM,"?+1,",FLDNUM)=IDATA
;
I ERROR Q ERROR
I 'COPT S ERROR="-1^Input missing context option node." Q ERROR
I 'APPC S ERROR="-1^Input missing application code node." Q ERROR
Q 1
;
FDACBM(XUARRM,FDA) ; Add CALLBACKTYPE to known Remote app entry
;
; Count number of multiple entries.
; Each entry may have 4 lines for fields .01, .02, .03, and .04
;
N CBMCNT,ADDCNT,IEN,INC,IENS,ARR,IDATA,FILENUM,FLDNAM,FLDNUM
S IEN="?+1,"
S CBMCNT=0
S ADDCNT=1
S INC=2
S IENS="?+"_INC_","
;
S ARR="XUARRM"
F S ARR=$Q(@ARR) Q:ARR="" S FILENUM=+$P($P(@ARR,"^",1),";",1),FLDNUM=+$P($P(@ARR,"^",1),";",2),FLDNAM=$P(@ARR,"^",2),IDATA=$P(@ARR,"^",3) D
. I FLDNUM=.01 D
.. S CBMCNT=CBMCNT+1
.. I ADDCNT'=CBMCNT D
... S IENS="?+"_(INC*CBMCNT)_","
... S ADDCNT=CBMCNT
. S FDA(FILENUM,IENS_IEN,FLDNUM)=IDATA
Q
;
FINDOPT(OPT) ; find option OPT
Q $$FIND1^DIC(19,"","X",$G(OPT),"B")
;
ADDEP(XURET,XUARR,FDAIEN) ; implementation of ADDEP^XUREMAP
;
I '$D(XUARR) S XURET(0)="-1^No data passed" Q
D FDAEP(.XURET,.XUARR,FDAIEN)
Q
;
FDAEP(XURET,XUARR,FDAIEN) ; convert XUARR to FDA for ENDPOINT
; pass by reference
;
N ARR,FILENUM,FLDNAM,FLDNUM,IDATA,RPCNT,RPCIEN,WPLINE,WPARRAY,FDA
S RPCNT=1
S WPLINE=8
S ARR="XUARR"
F S ARR=$Q(@ARR) Q:ARR="" S FILENUM=+$P($P(@ARR,"^",1),";",1),FLDNUM=+$P($P(@ARR,"^",1),";",2),FLDNAM=$P(@ARR,"^",2),IDATA=$P(@ARR,"^",3) D
. I FILENUM=19 D
.. ; for top level fields use standard FDA setup (but handle WP special cases)
.. I $$ISFLDWP(FILENUM,FLDNUM) D
... S WPLINE=WPLINE+1
... S WPARRAY(FLDNUM,WPLINE,0)=$P(@ARR,U,3)
... S FDA(19,"?+1,",FLDNUM)="WPARRAY("_FLDNUM_")"
.. E D
... S FDA(FILENUM,"?+1,",FLDNUM)=IDATA
. I FILENUM=19.05 D
.. I FLDNUM=.01 D
... S RPCIEN=$$FINDRPC(IDATA)
... I +$G(RPCIEN) D
.... S RPCNT=RPCNT+1
.... S FDA(FILENUM,"+"_RPCNT_",?+1,",FLDNUM)=RPCIEN
... E D
.... D LOGNORPC(.XURET,IDATA,19.05)
.. E D
... I +$G(RPCIEN) S FDA(FILENUM,"+"_RPCNT_",?+1,",FLDNUM)=IDATA
;
D SETOPT(.XURET,.FDA,FDAIEN)
Q
;
LOGNORPC(RET,RPCNM,FILENO) ;
;RET( ) = SUCCESS/FAIL AT CONTEXT
;RET(19.05,"WARNINGS",0)=19.05 COUNT
;RET(19.05,"WARNINGS",1..n)=<WARNING TEXT>
;
;S RET(FILENO,"WARNINGS",0)=+$G(RET(FILENO,"WARNINGS",0))+1
;S RET(FILENO,"WARNINGS",$G(RET(FILENO,"WARNINGS",0)))="RPC does not exist - not filed: "_RPCNM
N NLN S NLN=$O(RET(99999999),-1)+1
S RET(+NLN)="WARNING"_U_"RPC does not exist - not filed: "_RPCNM
Q
FINDRPC(RPNM) ;
;Find RPC by Name
Q $$FIND1^DIC(8994,"","X",$G(RPNM),"B")
;
SETOPT(XURET,FDA,FDAIEN) ; find or add option entry
; pass by reference
;
N OPTIEN,XUERR,CTXTIEN
I +$G(FDAIEN)>0 S OPTIEN(1)=+FDAIEN
D UPDATE^DIE("","FDA","OPTIEN","XUERR")
I $D(XUERR("DIERR")) D
. S XURET(0)="-1^"_$G(XUERR("DIERR",1,"TEXT",1))_U_$P($$SITE^VASITE(),U,3)
E D
. S CTXTIEN=+$G(OPTIEN($O(OPTIEN(0))))
. S XURET(0)=1_U_CTXTIEN_U_$P($$SITE^VASITE(),U,3)
Q
;
ADDRA2(XURET,XUARR) ; implementation of ADDRA^XUREMAP
N APPFDA,APPIEN,STATUS,XUERR,RAIEN
;
I '$D(XUARR) S XURET(0)="-1^No data passed" Q
S STATUS=$$FDARA(.XUARR,.APPFDA)
I +STATUS<1 S XURET(0)=STATUS Q
; FDA for the callback multiple
S STATUS=$$FDACBM2(.XUARR,.APPFDA)
I +STATUS<1 S XURET(0)=STATUS Q
D UPDATE^DIE("E","APPFDA","APPIEN","XUERR")
I $D(XUERR("DIERR")) D Q
. S XURET(0)="-1^"_$G(XUERR("DIERR",1,"TEXT",1))
S RAIEN=+$G(APPIEN($O(APPIEN(0))))
S XURET(0)=1_U_RAIEN
Q
;
FDACBM2(XUARRM,FDA) ; Add CALLBACKTYPE to known Remote app entry
;
; Callbacktype multiple subentries must be in order (.01, .02, .03 )
; Each multiple entry can have 4 lines of data, one line each for .01,
; .02, .03, and .04 fields.
;
N ADDCNT,ARR,ERROR,IDATA,FILENUM,FLDNAM,FLDNUM,OPT,IENS
S ADDCNT=0
;
S ARR="XUARRM"
F S ARR=$Q(@ARR) Q:ARR="" S FILENUM=+$P($P(@ARR,"^",1),";",1),FLDNUM=+$P($P(@ARR,"^",1),";",2),FLDNAM=$P(@ARR,"^",2),IDATA=$P(@ARR,"^",3) D I $G(ERROR) Q
. I FLDNUM=.01 S ADDCNT=ADDCNT+2,IENS="?+"_ADDCNT_"," ; increment multiple count
. S FDA(FILENUM,IENS_"?+1,",FLDNUM)=IDATA ; URLSTRING
I $G(ERROR) K FDA Q ERROR
Q 1
;
ISFLDWP(FILENO,FIELDNO) ;
; function return true if input field is a word processing multiple?
;
; INPUT:
; FILENO = [required] file number
; FIELDNO = [required] field number in file specified by FILENO
;
N RET
D FIELD^DID(FILENO,FIELDNO,,"TYPE","RET")
Q $G(RET("TYPE"))="WORD-PROCESSING"
CHKAEPIN(XURET,XUARR) ;
;CHECK THE INPUT ARRAY
N ARR,FILENUM,FLDNUM,FLDNAM,IDATA,TIS
S ARR="XUARR"
S TIS=0 ;TYPE IS SET
F S ARR=$Q(@ARR) Q:ARR="" S FILENUM=+$P($P(@ARR,"^",1),";",1),FLDNUM=+$P($P(@ARR,"^",1),";",2),FLDNAM=$P(@ARR,"^",2),IDATA=$P(@ARR,"^",3) D
. I FILENUM=19,FLDNUM=4 D
. . I (IDATA'="B")&(IDATA'="Broker (Client/Server)") S XURET(0)="-1^Only B-type (BROKER) options are allowed."
. . E S TIS=1
. I FILENUM=19.05,FLDNUM=1 D
. . I $$FIND1^DIC(19.1,,"X",IDATA,"B")'>0 S XURET(0)="-1^Invalid security key: Security key "_IDATA_" does not exist."
I 'TIS S XURET(0)="-1^Only B-type (BROKER) options are allowed."
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXUREMAP1 12998 printed May 25, 2026@12:46:48 Page 2
XUREMAP1 ;VISS/CEP - Remote Application Registration ; JAN 15, 2025
+1 ;;8.0;KERNEL;**759**;Jul 10, 1995;Build 40
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 QUIT
GETCNTXT(OUTCTXT,XUCONTXT,OUTINDEX) ; get Context Option (file #19) details for each entry
+1 ;
+2 ;INPUT:
+3 ; XUCONTXT: Name (#.01 ) from option File (#19) of B-Type Option
+4 ; OUTINDEX: [optional] positive integer to use as first subscript in return array.
+5 ;
+6 ;RETURN:
+7 ; OUTCTXT--OUTPUT ARRAY BY REFERENCE. SEE DOCUMENTATION FROM RAQ2 FOR CONTEXT OPTION FORMAT
+8 ;
+9 NEW IENS,IEN19,ERRS
+10 IF '$GET(OUTINDEX)!(OUTINDEX=0)
SET OUTINDEX=1
+11 SET OUTCTXT="OUTCTXT("_OUTINDEX_")"
+12 ;
+13 SET IEN19=$$FINDOPT^XUREMAP1(XUCONTXT)
+14 IF +IEN19'>0
SET OUTCTXT(0)="0^Option "_XUCONTXT_" not found."_U_$PIECE($$SITE^VASITE(),U,3)
QUIT
+15 ; return array is linked to entry with RAIEN
+16 SET IENS=IEN19_","
+17 DO GETS^DIQ(19,IENS,"**","N",OUTCTXT,"ERRS")
+18 SET OUTCTXT(0)=1_"^Option "_XUCONTXT_" found (IEN: "_IEN19_")."_U_$PIECE($$SITE^VASITE(),U,3)
+19 QUIT
+20 ;
GETFLNUM(XUARR) ; Function returns filenumber from input ^ file name ^ location in array
+1 ;
+2 NEW ARR,FOUND,FILENUM,FLDNUM,IDATA
+3 SET ARR="XUARR"
+4 SET FOUND=0
+5 FOR
SET ARR=$QUERY(@ARR)
if ARR=""
QUIT
SET FILENUM=+$PIECE($PIECE(@ARR,U),";")
SET FLDNUM=+$PIECE($PIECE(@ARR,U),";",2)
SET IDATA=$PIECE(@ARR,U,3)
Begin DoDot:1
+6 IF FLDNUM=".01"
SET FOUND=FILENUM
End DoDot:1
if FOUND
QUIT
+7 QUIT FOUND_U_$GET(IDATA)_U_$SELECT(+FOUND:$QSUBSCRIPT(ARR,1),1:"")
+8 ;
INSPLIT(INARR,ARRM,SUB) ;
+1 ; split INARR into an array with top level data (INARR) and
+2 ; multiple data (ARRM)
+3 ; SUB = subfile number to split into ARRM
+4 ;
+5 NEW INC,FNO
+6 IF $GET(SUB)'>0
SET SUB=8994.51
+7 SET INC=0
+8 FOR
SET INC=$ORDER(INARR(INC))
if INC'>0
QUIT
Begin DoDot:1
+9 SET FNO=$PIECE($GET(INARR(INC)),";")
+10 IF FNO=SUB
Begin DoDot:2
+11 ;Add to ARRM array
SET ARRM(INC)=$GET(INARR(INC))
+12 ;Kill from original array
KILL INARR(INC)
End DoDot:2
End DoDot:1
+13 QUIT
FORMAT(RETURN,TOPLEVEL,MULTIPLE,CNTXTM) ;
+1 ; Take top level of entries, multiple entries and Context option
+2 ; arrays and return formatted array for IAM specification
+3 ;
+4 ;
+5 NEW INDEX,RACNT,TOPIEN
+6 SET (INDEX,RACNT)=0
+7 FOR
SET RACNT=$ORDER(TOPLEVEL("DILIST",2,RACNT))
if RACNT'>0
QUIT
Begin DoDot:1
+8 DO TOPLEVEL(.RETURN,.TOPLEVEL,.MULTIPLE,.RACNT,.INDEX,.TOPIEN)
+9 DO CONTEXT(.RETURN,.CNTXTM,.INDEX,.TOPIEN)
End DoDot:1
+10 QUIT
+11 ;
TOPLEVEL(RETURN,TOPLEVEL,MULTIPLE,RACNT,INDEX,TOPIEN) ;
+1 ;
+2 ;
+3 ;
+4 NEW FLDNUM,EVALUE,FLDN,CBCNT
+5 SET FLDNUM=0
+6 FOR
SET FLDNUM=$ORDER(TOPLEVEL("DILIST","ID",RACNT,FLDNUM))
if FLDNUM'>0
QUIT
Begin DoDot:1
+7 SET TOPIEN=$GET(TOPLEVEL("DILIST",2,RACNT))
+8 SET EVALUE=$GET(TOPLEVEL("DILIST","ID",RACNT,FLDNUM))
+9 DO ADDELEM(.RETURN,8994.5,FLDNUM,EVALUE,.INDEX)
+10 ; LOOP TO BUILD MULTIPLE RETURN
End DoDot:1
+11 SET CBCNT=0
+12 FOR
SET CBCNT=$ORDER(MULTIPLE(TOPIEN,"DILIST","ID",CBCNT))
if CBCNT'>0
QUIT
Begin DoDot:1
+13 SET FLDN=0
+14 FOR
SET FLDN=$ORDER(MULTIPLE(TOPIEN,"DILIST","ID",CBCNT,FLDN))
if FLDN'>0
QUIT
Begin DoDot:2
+15 SET EVALUE=$GET(MULTIPLE(TOPIEN,"DILIST","ID",CBCNT,FLDN))
+16 DO ADDELEM(.RETURN,8994.51,FLDN,EVALUE,.INDEX)
End DoDot:2
End DoDot:1
+17 QUIT
CONTEXT(RETURN,CNTXTM,INDEX,TOPIEN) ;
+1 ; ADD context option (file #19) top level...
+2 NEW I,ENTRY,FLDN,EVALUE,WPNODE
+3 ;
+4 SET ENTRY=$ORDER(CNTXTM(TOPIEN,19,""))
+5 if ENTRY'>0
QUIT
+6 SET FLDN=0
+7 FOR
SET FLDN=$ORDER(CNTXTM(TOPIEN,19,ENTRY,FLDN))
if FLDN'>0
QUIT
Begin DoDot:1
+8 SET EVALUE=$GET(CNTXTM(TOPIEN,19,ENTRY,FLDN))
+9 SET WPNODE=$NAME(CNTXTM(TOPIEN,19,ENTRY,FLDN))
+10 IF $PIECE(EVALUE,"(",2)=$PIECE(WPNODE,"(",2)
Begin DoDot:2
+11 SET I=0
FOR
SET I=$ORDER(CNTXTM(TOPIEN,19,ENTRY,FLDN,I))
if I'>0
QUIT
Begin DoDot:3
+12 SET EVALUE=$GET(CNTXTM(TOPIEN,19,ENTRY,FLDN,I))
+13 DO ADDELEM(.RETURN,19,FLDN,EVALUE,.INDEX)
End DoDot:3
End DoDot:2
+14 IF '$TEST
Begin DoDot:2
+15 DO ADDELEM(.RETURN,19,FLDN,EVALUE,.INDEX)
End DoDot:2
End DoDot:1
+16 ;
+17 ; Add the rpc multiple of the context options (ONLY .01 field)
+18 SET ENTRY=0
+19 FOR
SET ENTRY=$ORDER(CNTXTM(TOPIEN,19.05,ENTRY))
if ENTRY'>0
QUIT
Begin DoDot:1
+20 SET FLDN=0
+21 FOR
SET FLDN=$ORDER(CNTXTM(TOPIEN,19.05,ENTRY,FLDN))
if FLDN'>0
QUIT
Begin DoDot:2
+22 SET EVALUE=$GET(CNTXTM(TOPIEN,19.05,ENTRY,FLDN))
+23 DO ADDELEM(.RETURN,19.05,FLDN,EVALUE,.INDEX)
End DoDot:2
End DoDot:1
+24 ;
+25 QUIT
+26 ;
ADDELEM(ARRAY,FILE,FLDNUM,EVALUE,INDEX) ;
+1 ; Set a line in the return array
+2 ; ADD a line (ELEMent) to the return array
+3 NEW LABEL
+4 DO FIELD^DID(FILE,FLDNUM,"","LABEL","LABEL")
+5 SET INDEX=INDEX+1
+6 SET ARRAY(INDEX)=FILE_";"_FLDNUM_U_$GET(LABEL("LABEL"))_U_EVALUE
+7 ;
+8 QUIT
FAUXFL(XUTEST,NAME,XUARR,XUARRM) ; test filing a Remote Application Entry under false name
+1 ;
+2 ; INPUT:
+3 ; XUARR = top level of input array (see ADDRA^XUREMAP)
+4 ; XUARRM = multiple array from INSPLIT call
+5 ; OUTPUT:
+6 ; XUTEST = result of ADDRA^XUREMAP1 call
+7 ; NAME = name of remote application name parsed from input XUARR
+8 ;
+9 NEW INDEX,FILENUM,FAUXARR,FAUXNM,INPUTFN,XUREMOVE
+10 ;
+11 ; no matching entry found
SET XUTEST(0)=0
+12 ;
+13 ;
+14 ; grab filenumber, name, index position from input array (fn^.01name^index)
+15 SET INPUTFN=$$GETFLNUM(.XUARR)
+16 SET FILENUM=+INPUTFN
+17 SET NAME=$PIECE(INPUTFN,U,2)
+18 IF $GET(NAME)=""
Begin DoDot:1
+19 SET XUARR="-1^Remote Application name cannot be empty."
End DoDot:1
QUIT
+20 SET INDEX=$PIECE(INPUTFN,U,3)
+21 ; Attempt filing under faux name
+22 MERGE FAUXARR=XUARR
+23 ; return name prepended with XUFAUX (
SET FAUXNM=$$FAUXNM(NAME)
+24 SET FAUXARR(INDEX)=FILENUM_";.01^NAME^"_FAUXNM
+25 IF FILENUM=8994.5
DO ADDRA^XUREMAP1(.XUTEST,.FAUXARR,.XUARRM,-1)
+26 IF FILENUM=19
DO ADDEP(.XUTEST,.FAUXARR,"")
+27 IF $GET(XUTEST(0))>0
DO REMOVE(.XUREMOVE,.FAUXNM,FILENUM)
+28 QUIT
+29 ;
FAUXNM(NAME) ; Return a name to test filing that is unique.
+1 QUIT $$TRIM^XLFSTR($EXTRACT("XUFAUX"_NAME,1,30))
+2 ;
REMOVE(XURET,XUNAME,FILENUM) ; remove the Remote Application test entry
+1 NEW RAIEN,ERR,MSG,FDA
+2 SET RAIEN=""
+3 SET XURET=0
+4 SET RAIEN=$$FIND1^DIC(FILENUM,"","MX",XUNAME,"","","ERR")
+5 IF +RAIEN
Begin DoDot:1
+6 SET FDA(FILENUM,RAIEN_",",.01)="@"
+7 DO FILE^DIE("","FDA","MSG")
+8 MERGE XURET=MSG
End DoDot:1
+9 IF '$TEST
Begin DoDot:1
+10 SET XURET="-1"_U_XUNAME_" not found. Deletion not performed."
End DoDot:1
+11 QUIT
+12 ;
ADDRA(XURET,XUARR,XUARRM,XURAIEN) ; implementation of ADDRA^XUREMAP
+1 ;
+2 ;INPUT:
+3 ; XUARR: top level file array with data to file
+4 ; XUARRM: multiple array with data to file
+5 ; XURAIEN: [optional]
+6 ; -1 : don't check for duplicate Authorization codes
+7 ; +N : internal entry of 8994.5 entry to overwrite
+8 ;
+9 NEW APPFDA,APPIEN,STATUS,XUERR,RAIEN
+10 IF '$DATA(XUARR)
SET XURET(0)="-1^No data passed"
QUIT
+11 ;
+12 ; build top level RA entry FDA array or set error in
+13 ; STATUS if input array context option is not found
+14 ; in local file 19.
+15 ;
+16 SET STATUS=$$FDARA(.XUARR,.APPFDA,$GET(XURAIEN))
+17 IF +STATUS<1
SET XURET(0)=STATUS
QUIT
+18 ;
+19 ; FDA for the callback multiple
+20 IF $DATA(XUARRM)
DO FDACBM(.XUARRM,.APPFDA)
+21 IF $GET(XURAIEN)>0
SET APPIEN(1)=XURAIEN
+22 DO UPDATE^DIE("E","APPFDA","APPIEN","XUERR")
+23 IF $DATA(XUERR("DIERR"))
Begin DoDot:1
+24 SET XURET(0)="-1^"_$GET(XUERR("DIERR",1,"TEXT",1))
End DoDot:1
QUIT
+25 SET RAIEN=+$GET(APPIEN($ORDER(APPIEN(0))))
+26 SET XURET(0)=1_U_RAIEN_U_$PIECE($$SITE^VASITE(),U,3)
+27 QUIT
+28 ;
FDARA(XUARR,FDA,REPLACE) ; convert XUARR to FDA for REMOTE APP
+1 ; pass by reference
+2 ;
+3 ; If this is a rip and replace then XURAIEN should be defined as
+4 ; the IEN of the entry being ripped. The replacement needs to be
+5 ; stored under the original IEN
+6 ;
+7 NEW ARR,ERROR,IDATA,FILENUM,FLDNAM,FLDNUM,OPT,APPC,COPT
+8 SET ARR="XUARR"
+9 SET (APPC,ERROR,COPT)=0
+10 FOR
SET ARR=$QUERY(@ARR)
if ARR=""
QUIT
SET FILENUM=+$PIECE($PIECE(@ARR,U,1),";",1)
SET FLDNUM=+$PIECE($PIECE(@ARR,U,1),";",2)
SET FLDNAM=$PIECE(@ARR,U,2)
SET IDATA=$PIECE(@ARR,U,3)
Begin DoDot:1
+11 IF FLDNAM="NAME"
Begin DoDot:2
+12 IF $GET(IDATA)=""
SET ERROR="-1^Remote application name cannot be empty."
QUIT
End DoDot:2
+13 IF FLDNAM="CONTEXTOPTION"
Begin DoDot:2
+14 SET COPT=1
+15 IF $GET(IDATA)=""
SET ERROR="-1^Input missing context option."
QUIT
+16 SET OPT=$$FINDOPT($GET(IDATA))
+17 IF OPT'>0
SET ERROR="-1^Input context option does not exist."
QUIT
+18 SET FDA(FILENUM,"?+1,",FLDNUM)=IDATA
End DoDot:2
QUIT
+19 IF FLDNAM="APPLICATIONCODE"
Begin DoDot:2
+20 SET APPC=1
+21 IF IDATA=""
SET ERROR="-1^Input missing Application Code."
QUIT
+22 SET IDATA=$$SHAHASH^XUSHSH(256,IDATA,"B")
+23 ; (faux filing)&(application code already in use)
+24 IF (REPLACE'=-1)&($ORDER(^XWB(8994.5,"ACODE",IDATA,0))>0)
SET ERROR="-1^Application Code already in use."
QUIT
+25 SET FDA(FILENUM,"?+1,",FLDNUM)=IDATA
End DoDot:2
QUIT
+26 ;
+27 SET FDA(FILENUM,"?+1,",FLDNUM)=IDATA
End DoDot:1
IF $GET(ERROR)
QUIT
+28 ;
+29 IF ERROR
QUIT ERROR
+30 IF 'COPT
SET ERROR="-1^Input missing context option node."
QUIT ERROR
+31 IF 'APPC
SET ERROR="-1^Input missing application code node."
QUIT ERROR
+32 QUIT 1
+33 ;
FDACBM(XUARRM,FDA) ; Add CALLBACKTYPE to known Remote app entry
+1 ;
+2 ; Count number of multiple entries.
+3 ; Each entry may have 4 lines for fields .01, .02, .03, and .04
+4 ;
+5 NEW CBMCNT,ADDCNT,IEN,INC,IENS,ARR,IDATA,FILENUM,FLDNAM,FLDNUM
+6 SET IEN="?+1,"
+7 SET CBMCNT=0
+8 SET ADDCNT=1
+9 SET INC=2
+10 SET IENS="?+"_INC_","
+11 ;
+12 SET ARR="XUARRM"
+13 FOR
SET ARR=$QUERY(@ARR)
if ARR=""
QUIT
SET FILENUM=+$PIECE($PIECE(@ARR,"^",1),";",1)
SET FLDNUM=+$PIECE($PIECE(@ARR,"^",1),";",2)
SET FLDNAM=$PIECE(@ARR,"^",2)
SET IDATA=$PIECE(@ARR,"^",3)
Begin DoDot:1
+14 IF FLDNUM=.01
Begin DoDot:2
+15 SET CBMCNT=CBMCNT+1
+16 IF ADDCNT'=CBMCNT
Begin DoDot:3
+17 SET IENS="?+"_(INC*CBMCNT)_","
+18 SET ADDCNT=CBMCNT
End DoDot:3
End DoDot:2
+19 SET FDA(FILENUM,IENS_IEN,FLDNUM)=IDATA
End DoDot:1
+20 QUIT
+21 ;
FINDOPT(OPT) ; find option OPT
+1 QUIT $$FIND1^DIC(19,"","X",$GET(OPT),"B")
+2 ;
ADDEP(XURET,XUARR,FDAIEN) ; implementation of ADDEP^XUREMAP
+1 ;
+2 IF '$DATA(XUARR)
SET XURET(0)="-1^No data passed"
QUIT
+3 DO FDAEP(.XURET,.XUARR,FDAIEN)
+4 QUIT
+5 ;
FDAEP(XURET,XUARR,FDAIEN) ; convert XUARR to FDA for ENDPOINT
+1 ; pass by reference
+2 ;
+3 NEW ARR,FILENUM,FLDNAM,FLDNUM,IDATA,RPCNT,RPCIEN,WPLINE,WPARRAY,FDA
+4 SET RPCNT=1
+5 SET WPLINE=8
+6 SET ARR="XUARR"
+7 FOR
SET ARR=$QUERY(@ARR)
if ARR=""
QUIT
SET FILENUM=+$PIECE($PIECE(@ARR,"^",1),";",1)
SET FLDNUM=+$PIECE($PIECE(@ARR,"^",1),";",2)
SET FLDNAM=$PIECE(@ARR,"^",2)
SET IDATA=$PIECE(@ARR,"^",3)
Begin DoDot:1
+8 IF FILENUM=19
Begin DoDot:2
+9 ; for top level fields use standard FDA setup (but handle WP special cases)
+10 IF $$ISFLDWP(FILENUM,FLDNUM)
Begin DoDot:3
+11 SET WPLINE=WPLINE+1
+12 SET WPARRAY(FLDNUM,WPLINE,0)=$PIECE(@ARR,U,3)
+13 SET FDA(19,"?+1,",FLDNUM)="WPARRAY("_FLDNUM_")"
End DoDot:3
+14 IF '$TEST
Begin DoDot:3
+15 SET FDA(FILENUM,"?+1,",FLDNUM)=IDATA
End DoDot:3
End DoDot:2
+16 IF FILENUM=19.05
Begin DoDot:2
+17 IF FLDNUM=.01
Begin DoDot:3
+18 SET RPCIEN=$$FINDRPC(IDATA)
+19 IF +$GET(RPCIEN)
Begin DoDot:4
+20 SET RPCNT=RPCNT+1
+21 SET FDA(FILENUM,"+"_RPCNT_",?+1,",FLDNUM)=RPCIEN
End DoDot:4
+22 IF '$TEST
Begin DoDot:4
+23 DO LOGNORPC(.XURET,IDATA,19.05)
End DoDot:4
End DoDot:3
+24 IF '$TEST
Begin DoDot:3
+25 IF +$GET(RPCIEN)
SET FDA(FILENUM,"+"_RPCNT_",?+1,",FLDNUM)=IDATA
End DoDot:3
End DoDot:2
End DoDot:1
+26 ;
+27 DO SETOPT(.XURET,.FDA,FDAIEN)
+28 QUIT
+29 ;
LOGNORPC(RET,RPCNM,FILENO) ;
+1 ;RET( ) = SUCCESS/FAIL AT CONTEXT
+2 ;RET(19.05,"WARNINGS",0)=19.05 COUNT
+3 ;RET(19.05,"WARNINGS",1..n)=<WARNING TEXT>
+4 ;
+5 ;S RET(FILENO,"WARNINGS",0)=+$G(RET(FILENO,"WARNINGS",0))+1
+6 ;S RET(FILENO,"WARNINGS",$G(RET(FILENO,"WARNINGS",0)))="RPC does not exist - not filed: "_RPCNM
+7 NEW NLN
SET NLN=$ORDER(RET(99999999),-1)+1
+8 SET RET(+NLN)="WARNING"_U_"RPC does not exist - not filed: "_RPCNM
+9 QUIT
FINDRPC(RPNM) ;
+1 ;Find RPC by Name
+2 QUIT $$FIND1^DIC(8994,"","X",$GET(RPNM),"B")
+3 ;
SETOPT(XURET,FDA,FDAIEN) ; find or add option entry
+1 ; pass by reference
+2 ;
+3 NEW OPTIEN,XUERR,CTXTIEN
+4 IF +$GET(FDAIEN)>0
SET OPTIEN(1)=+FDAIEN
+5 DO UPDATE^DIE("","FDA","OPTIEN","XUERR")
+6 IF $DATA(XUERR("DIERR"))
Begin DoDot:1
+7 SET XURET(0)="-1^"_$GET(XUERR("DIERR",1,"TEXT",1))_U_$PIECE($$SITE^VASITE(),U,3)
End DoDot:1
+8 IF '$TEST
Begin DoDot:1
+9 SET CTXTIEN=+$GET(OPTIEN($ORDER(OPTIEN(0))))
+10 SET XURET(0)=1_U_CTXTIEN_U_$PIECE($$SITE^VASITE(),U,3)
End DoDot:1
+11 QUIT
+12 ;
ADDRA2(XURET,XUARR) ; implementation of ADDRA^XUREMAP
+1 NEW APPFDA,APPIEN,STATUS,XUERR,RAIEN
+2 ;
+3 IF '$DATA(XUARR)
SET XURET(0)="-1^No data passed"
QUIT
+4 SET STATUS=$$FDARA(.XUARR,.APPFDA)
+5 IF +STATUS<1
SET XURET(0)=STATUS
QUIT
+6 ; FDA for the callback multiple
+7 SET STATUS=$$FDACBM2(.XUARR,.APPFDA)
+8 IF +STATUS<1
SET XURET(0)=STATUS
QUIT
+9 DO UPDATE^DIE("E","APPFDA","APPIEN","XUERR")
+10 IF $DATA(XUERR("DIERR"))
Begin DoDot:1
+11 SET XURET(0)="-1^"_$GET(XUERR("DIERR",1,"TEXT",1))
End DoDot:1
QUIT
+12 SET RAIEN=+$GET(APPIEN($ORDER(APPIEN(0))))
+13 SET XURET(0)=1_U_RAIEN
+14 QUIT
+15 ;
FDACBM2(XUARRM,FDA) ; Add CALLBACKTYPE to known Remote app entry
+1 ;
+2 ; Callbacktype multiple subentries must be in order (.01, .02, .03 )
+3 ; Each multiple entry can have 4 lines of data, one line each for .01,
+4 ; .02, .03, and .04 fields.
+5 ;
+6 NEW ADDCNT,ARR,ERROR,IDATA,FILENUM,FLDNAM,FLDNUM,OPT,IENS
+7 SET ADDCNT=0
+8 ;
+9 SET ARR="XUARRM"
+10 FOR
SET ARR=$QUERY(@ARR)
if ARR=""
QUIT
SET FILENUM=+$PIECE($PIECE(@ARR,"^",1),";",1)
SET FLDNUM=+$PIECE($PIECE(@ARR,"^",1),";",2)
SET FLDNAM=$PIECE(@ARR,"^",2)
SET IDATA=$PIECE(@ARR,"^",3)
Begin DoDot:1
+11 ; increment multiple count
IF FLDNUM=.01
SET ADDCNT=ADDCNT+2
SET IENS="?+"_ADDCNT_","
+12 ; URLSTRING
SET FDA(FILENUM,IENS_"?+1,",FLDNUM)=IDATA
End DoDot:1
IF $GET(ERROR)
QUIT
+13 IF $GET(ERROR)
KILL FDA
QUIT ERROR
+14 QUIT 1
+15 ;
ISFLDWP(FILENO,FIELDNO) ;
+1 ; function return true if input field is a word processing multiple?
+2 ;
+3 ; INPUT:
+4 ; FILENO = [required] file number
+5 ; FIELDNO = [required] field number in file specified by FILENO
+6 ;
+7 NEW RET
+8 DO FIELD^DID(FILENO,FIELDNO,,"TYPE","RET")
+9 QUIT $GET(RET("TYPE"))="WORD-PROCESSING"
CHKAEPIN(XURET,XUARR) ;
+1 ;CHECK THE INPUT ARRAY
+2 NEW ARR,FILENUM,FLDNUM,FLDNAM,IDATA,TIS
+3 SET ARR="XUARR"
+4 ;TYPE IS SET
SET TIS=0
+5 FOR
SET ARR=$QUERY(@ARR)
if ARR=""
QUIT
SET FILENUM=+$PIECE($PIECE(@ARR,"^",1),";",1)
SET FLDNUM=+$PIECE($PIECE(@ARR,"^",1),";",2)
SET FLDNAM=$PIECE(@ARR,"^",2)
SET IDATA=$PIECE(@ARR,"^",3)
Begin DoDot:1
+6 IF FILENUM=19
IF FLDNUM=4
Begin DoDot:2
+7 IF (IDATA'="B")&(IDATA'="Broker (Client/Server)")
SET XURET(0)="-1^Only B-type (BROKER) options are allowed."
+8 IF '$TEST
SET TIS=1
End DoDot:2
+9 IF FILENUM=19.05
IF FLDNUM=1
Begin DoDot:2
+10 IF $$FIND1^DIC(19.1,,"X",IDATA,"B")'>0
SET XURET(0)="-1^Invalid security key: Security key "_IDATA_" does not exist."
End DoDot:2
End DoDot:1
+11 IF 'TIS
SET XURET(0)="-1^Only B-type (BROKER) options are allowed."
+12 QUIT
