BUSAUTIL ;GDIT/HS/BEE-IHS USER SECURITY AUDIT Utility Program ; 31 Jan 2013 9:53 AM
;;1.0;IHS USER SECURITY AUDIT;;Nov 05, 2013;Build 65
;
Q
;
SINPUT(PARM) ;PEP - Return Single Input Parameter Value
;
;Required Application Variables
;BUSARPC - The name of the called RPC
;BUSABKR - The broker making the call
;
;Input variable
;PARM - The RPC input parameter piece to pull
;
NEW OUT
;
I +$G(PARM)<1 Q ""
I $G(BUSABKR)="" Q ""
I $G(BUSARPC)="" Q ""
;
;Retrieve information
D VAL("I",PARM,BUSABKR,BUSARPC,.OUT)
;
;Return first record
Q $G(OUT)
;
SOUTPUT(PARM) ;PEP - Return Single Output Parameter Value
;
;Required Application Variables
;BUSARPC - The name of the called RPC
;BUSABKR - The broker making call
;
;Input variable
;PARM - The RPC input parameter piece to pull
;
NEW OUT
;
I +$G(PARM)<1 Q ""
I $G(BUSABKR)="" Q ""
I $G(BUSARPC)="" Q ""
;
;Retrieve information
D VAL("R",PARM,BUSABKR,BUSARPC,.OUT)
;
;Return first record
Q $G(OUT)
;
VAL(TYPE,LOCATION,BROKER,RPC,RVAL) ;PEP - Return information located in specified location
;
;Input:
; TYPE - The area to look (I:Input Parameter, R:Results)
; LOCATION - The input parameter number, the return piece or column name
; BROKER - The broker making the call (B:BMXNet,C:CIA,W:XWB)
; RPC - The RPC name
; RVAL - The return value array
;
S TYPE=$G(TYPE),LOCATION=$G(LOCATION),BROKER=$G(BROKER),RPC=$G(RPC)
;
I TYPE'="I",TYPE'="R" Q "0^Invalid Type"
I LOCATION="" Q "0^Missing Location"
I BROKER'="B",BROKER'="C",BROKER'="W" Q "0^Invalid Broker"
I RPC="" Q "0^Missing RPC Call"
;
;Process data in input parameters
I TYPE="I" D G XVAL
. I BROKER="B" D BINP(LOCATION,.RVAL) ;BMXNet
. I BROKER="C" D CINP(LOCATION,.RVAL) ;CIA
. I BROKER="W" D WINP(LOCATION,.RVAL) ;XWB
;
;Process data in results
I TYPE="R" D G XVAL
. I BROKER="B" D BRES(LOCATION,RPC,.RVAL) ;BMXNet
. I BROKER="C" D CRES(LOCATION,RPC,.RVAL) ;CIA
. I BROKER="W" D WRES(LOCATION,RPC,.RVAL) ;XWB
XVAL Q 1
;
BINP(LOC,RVAL) ;EP - Return BMXNet input parameter value
S RVAL=$G(BUSAP(3,"P",LOC-1))
Q
;
WINP(LOC,RVAL) ;EP - Return XWB input parameter value
S RVAL=$G(BUSAP(3,"P",LOC-1))
Q
;
CINP(LOC,RVAL) ;EP - Return CIA input parameter value
S RVAL=$G(@("P"_LOC))
Q
;
BRES(LOC,RPC,RVAL) ;EP - Return BMXNet result value
;
NEW RPCIEN,RTVAL
S RPCIEN=$O(^XWB(8994,"B",RPC,0))
;
;Retrieve global return value
S RTVAL=$$GET1^DIQ(8994,RPCIEN_",",.04,"I")
;
;Global Array
I RTVAL=4 D BGARES(LOC,.RVAL)
;
Q
;
WRES(LOC,RPC,RVAL) ;EP - Return BMXNet result value
;
NEW RPCIEN,RTVAL
S RPCIEN=$O(^XWB(8994,"B",RPC,0))
;
;Retrieve global return value
S RTVAL=$$GET1^DIQ(8994,RPCIEN_",",.04,"I")
;
;Global Array
I RTVAL=4 D WGARES(LOC,.RVAL)
;
Q
;
CRES(LOC,RPC,RVAL) ;EP - Return CIA result value
;
;Handle single value returns
I XWBPTYPE=1 D Q
. S RVAL(1)=$P($G(CIAD),U,LOC)
;
I XWBPTYPE=5 D Q
. S RVAL(1)=$P($G(@CIAD),U,LOC)
;
;Handle Array, Word Processing, Global Array
I XWBPTYPE=2 D CROUT("CIAD",LOC,.RVAL) Q
I XWBPTYPE=3 D CROUT("CIAD",LOC,.RVAL) Q
I XWBPTYPE=4 D CROUT(CIAD,LOC,.RVAL) Q
Q
;
;Return result information
CROUT(ARY,LOC,RVAL) ;
N X,L,K,II
S K=$E(ARY)'="~"
S:'K ARY=$E(ARY,2,999)
Q:'$L(ARY)
S ARY=$NA(@ARY)
S X=ARY,L=$QL(ARY)
F S X=$Q(@X) Q:'$L(X) Q:$NA(@X,L)'=ARY S II=$G(II)+1,RVAL(II)=$P($G(@X),U,LOC)
Q
;
BGARES(LOC,RVAL) ;EP - Return BMXNet Global Array Value
;
NEW BMXIEN,FCOL,COL,FHDR,BMXHDR
;
;Pull header row and locate column
S BMXHDR=@BMXY@(0)
S FCOL="" F COL=1:1:$L(BMXHDR,U) S FHDR=$TR($E($P(BMXHDR,U,COL),7,99),$C(30)) I FHDR=LOC S FCOL=COL
;
;Find the field
I FCOL]"" S BMXIEN=0 F S BMXIEN=$O(@BMXY@(BMXIEN)) Q:BMXIEN="" D
. ;
. NEW VAL
. ;
. ;Quit on last record
. I $TR(@BMXY@(BMXIEN),$C(31))="" Q
. ;
. ;Pull the column value if populated
. S VAL=$P($G(@BMXY@(BMXIEN)),U,FCOL)
. I VAL]"" S RVAL(BMXIEN)=$TR(VAL,$C(30))
Q
;
WGARES(LOC,RVAL) ;EP - Return XWB Global Array Value
;
NEW XWBIEN,FCOL,COL,FHDR,XWBHDR
;
;Pull header row and locate column
S XWBHDR=@XWBY@(0)
S FCOL="" F COL=1:1:$L(XWBHDR,U) S FHDR=$TR($E($P(XWBHDR,U,COL),7,99),$C(30)) I FHDR=LOC S FCOL=COL
;
;Find the field
I FCOL]"" S XWBIEN=0 F S XWBIEN=$O(@XWBY@(XWBIEN)) Q:XWBIEN="" D
. ;
. NEW VAL
. ;
. ;Quit on last record
. I $TR(@XWBY@(XWBIEN),$C(31))="" Q
. ;
. ;Pull the column value if populated
. S VAL=$P($G(@XWBY@(XWBIEN)),U,FCOL)
. I VAL]"" S RVAL(XWBIEN)=$TR(VAL,$C(30))
Q
;
BFILE(BUSAOVAL,BUSADVAL,PIECE,EXE,MULT,MINP) ;EP - BMX: Format and file data detail array
;
;Result output filing
I $G(MULT)=1 D Q
. NEW BMXIEN
. S BMXIEN=0 F S BMXIEN=$O(@BMXY@(BMXIEN)) Q:BMXIEN="" D
.. NEW X,DFN,VIEN
.. ;
.. ;Pull DFN/VIEN so they can be used (if populated)
.. S DFN=$P($G(BUSADVAL(BMXIEN)),U) I PIECE>2,DFN="" Q
.. S VIEN=$P($G(BUSADVAL(BMXIEN)),U,2)
.. ;
.. ;Process desired piece
.. S X=$G(BUSAOVAL) ;Look in variable first
.. S:X="" X=$G(BUSAOVAL(BMXIEN)) ;Look in array second
.. I $G(EXE)]"" X EXE
.. I $G(X)]"" S $P(BUSADVAL(BMXIEN),U,PIECE)=X
.. ;
.. ;If VIEN piece - check if DFN needs filled in
.. I PIECE'=2 Q
.. ;
.. ;Quit if already populated
.. I DFN]"" Q
.. ;
.. ;Plug in DFN
.. S DFN=$$GET1^DIQ(9000010,X_",",".05","I")
.. I DFN]"" S $P(BUSADVAL(BMXIEN),U)=DFN
;
;Multiple input filing
I $G(MINP)=1 D Q
. ;
. ;DFN/VIEN pieces already processed
. I (PIECE=1)!(PIECE=2) Q
. ;
. NEW BMXIEN
. ;
. S BMXIEN=0 F S BMXIEN=$O(BUSADVAL(BMXIEN)) Q:BMXIEN="" D
.. ;
.. NEW X,DFN,VIEN
.. ;
.. ;Pull populated values
.. S DFN=$P(BUSADVAL(BMXIEN),U) I PIECE>2,DFN="" Q
.. S VIEN=$P(BUSADVAL(BMXIEN),U,2)
.. ;
.. ;Pull field value
.. S X=$P(BUSADVAL(BMXIEN),U,PIECE)
.. ;
.. ;Call executable
.. I $G(EXE)]"" X EXE
.. ;
.. ;Save value
.. I $G(X)]"" S $P(BUSADVAL(BMXIEN),U,PIECE)=X
;
;Single record output
;
NEW X,DFN,VIEN
;
;Pull DFN/VIEN so they can be used (if populated)
S DFN=$P($G(BUSADVAL(1)),U) I PIECE>2,DFN="" Q
S VIEN=$P($G(BUSADVAL(1)),U,2)
;
;Now populate correct piece
S X=$G(BUSAOVAL) S:X="" X=$G(BUSAOVAL(1))
I $G(EXE)]"" X EXE
I $G(X)]"" S $P(BUSADVAL(1),U,PIECE)=X
;
;If VIEN piece - check if DFN needs filled in
I PIECE'=2 Q
;
;Quit if already populated
I DFN]"" Q
;
;Plug in DFN
S DFN=$$GET1^DIQ(9000010,X_",",".05","I")
I DFN]"" S $P(BUSADVAL(1),U)=DFN
;
Q
;
WFILE(BUSAOVAL,BUSADVAL,PIECE,EXE,MULT,MINP) ;EP - XWB: Format and file data detail array
;
;Result output filing
I $G(MULT)=1 D Q
. NEW XWBIEN
. S XWBIEN=0 F S XWBIEN=$O(@BXWB@(XWBIEN)) Q:XWBIEN="" D
.. NEW X,DFN,VIEN
.. ;
.. ;Pull DFN/VIEN so they can be used (if populated)
.. S DFN=$P($G(BUSADVAL(XWBIEN)),U) I PIECE>2,DFN="" Q
.. S VIEN=$P($G(BUSADVAL(XWBIEN)),U,2)
.. ;
.. ;Process desired piece
.. S X=$G(BUSAOVAL) ;Look in variable first
.. S:X="" X=$G(BUSAOVAL(XWBIEN)) ;Look in array second
.. I $G(EXE)]"" X EXE
.. I $G(X)]"" S $P(BUSADVAL(XWBIEN),U,PIECE)=X
.. ;
.. ;If VIEN piece - check if DFN needs filled in
.. I PIECE'=2 Q
.. ;
.. ;Quit if already populated
.. I DFN]"" Q
.. ;
.. ;Plug in DFN
.. S DFN=$$GET1^DIQ(9000010,X_",",".05","I")
.. I DFN]"" S $P(BUSADVAL(XWBIEN),U)=DFN
;
;Multiple input filing
I $G(MINP)=1 D Q
. ;
. ;DFN/VIEN pieces already processed
. I (PIECE=1)!(PIECE=2) Q
. ;
. NEW XWBIEN
. ;
. S XWBIEN=0 F S XWBIEN=$O(BUSADVAL(XWBIEN)) Q:XWBIEN="" D
.. ;
.. NEW X,DFN,VIEN
.. ;
.. ;Pull populated values
.. S DFN=$P(BUSADVAL(XWBIEN),U) I PIECE>2,DFN="" Q
.. S VIEN=$P(BUSADVAL(XWBIEN),U,2)
.. ;
.. ;Pull field value
.. S X=$P(BUSADVAL(XWBIEN),U,PIECE)
.. ;
.. ;Call executable
.. I $G(EXE)]"" X EXE
.. ;
.. ;Save value
.. I $G(X)]"" S $P(BUSADVAL(XWBIEN),U,PIECE)=X
;
;Single record output
;
NEW X,DFN,VIEN
;
;Pull DFN/VIEN so they can be used (if populated)
S DFN=$P($G(BUSADVAL(1)),U) I PIECE>2,DFN="" Q
S VIEN=$P($G(BUSADVAL(1)),U,2)
;
;Now populate correct piece
S X=$G(BUSAOVAL) S:X="" X=$G(BUSAOVAL(1))
I $G(EXE)]"" X EXE
I $G(X)]"" S $P(BUSADVAL(1),U,PIECE)=X
;
;If VIEN piece - check if DFN needs filled in
I PIECE'=2 Q
;
;Quit if already populated
I DFN]"" Q
;
;Plug in DFN
S DFN=$$GET1^DIQ(9000010,X_",",".05","I")
I DFN]"" S $P(BUSADVAL(1),U)=DFN
;
Q
;
CFILE(BUSAOVAL,BUSADVAL,PIECE,EXE,MULT,MINP) ;EP - Format and file CIA data detail array
;
;Multiple input filing
I $G(MINP)=1 D Q
. ;
. ;DFN/VIEN pieces already processed
. I (PIECE=1)!(PIECE=2) Q
. ;
. NEW BMXIEN
. ;
. S BMXIEN=0 F S BMXIEN=$O(BUSADVAL(BMXIEN)) Q:BMXIEN="" D
.. ;
.. NEW X,DFN,VIEN
.. ;
.. ;Pull populated values
.. S DFN=$P(BUSADVAL(BMXIEN),U) I PIECE>2,DFN="" Q
.. S VIEN=$P(BUSADVAL(BMXIEN),U,2)
.. ;
.. ;Pull field value
.. S X=$P(BUSADVAL(BMXIEN),U,PIECE)
.. ;
.. ;Call executable
.. I $G(EXE)]"" X EXE
.. ;
.. ;Save value
.. I $G(X)]"" S $P(BUSADVAL(BMXIEN),U,PIECE)=X
;
;Single return value
;
I (XWBPTYPE=1)!(XWBPTYPE=5)!'MULT D Q
. ;
. NEW X,DFN,VIEN
. ;
. ;Pull DFN/VIEN so they can be used (if populated)
. S DFN=$P($G(BUSADVAL(1)),U) I PIECE>2,DFN="" Q
. S VIEN=$P($G(BUSADVAL(1)),U,2)
. ;
. ;Now populate correct piece
. S X=$G(BUSAOVAL) S:X="" X=$G(BUSAOVAL(1))
. I $G(EXE)]"" X EXE
. I $G(X)]"" S $P(BUSADVAL(1),U,PIECE)=X
. ;
. ;If VIEN piece - check if DFN needs filled in
. I PIECE'=2 Q
. ;
. ;Quite if already populated
. I DFN]"" Q
. ;
. ;Plug in DFN
. S DFN=$$GET1^DIQ(9000010,X_",",".05","I")
. I DFN]"" S $P(BUSADVAL(1),U)=DFN
;
;Multiple return values
;Handle Array, Word Processing, Global Array Types
I XWBPTYPE=2 D CLOOP("CIAD",.BUSAOVAL,.BUSADVAL)
I XWBPTYPE=3 D CLOOP("CIAD",.BUSAOVAL,.BUSADVAL)
I XWBPTYPE=4 D CLOOP(CIAD,.BUSAOVAL,.BUSADVAL)
Q
;
;Loop through output and fill in piece
CLOOP(ARY,BUSAOVAL,BUSADVAL) ;
NEW CL,L,K,II
S K=$E(ARY)'="~"
S:'K ARY=$E(ARY,2,999)
Q:'$L(ARY)
S ARY=$NA(@ARY)
S CL=ARY,L=$QL(ARY)
F S CL=$Q(@CL) Q:'$L(CL) Q:$NA(@CL,L)'=ARY D
. ;
. NEW X,DFN,VIEN
. S II=$G(II)+1
. ;
. ;Pull DFN/VIEN so they can be used (if populated)
. S DFN=$P($G(BUSADVAL(II)),U) I PIECE>2,DFN="" Q
. S VIEN=$P($G(BUSADVAL(II)),U,2)
. ;
. ;Pull field value
. S X=$S($G(BUSAOVAL)]"":BUSAOVAL,1:$G(BUSAOVAL(II)))
. ;
. ;Call executable
. I $G(EXE)]"" X EXE
. ;
. ;Save value
. I $G(X)]"" S $P(BUSADVAL(II),U,PIECE)=X
. ;
. ;If VIEN piece - check if DFN needs filled in
. I PIECE'=2 Q
. ;
. ;Quit if already populated
. I DFN]"" Q
. ;
. ;Plug in DFN
. S DFN=$$GET1^DIQ(9000010,X_",",".05","I")
. I DFN]"" S $P(BUSADVAL(II),U)=DFN
;
Q
;
PNLNAME(USER,PIEN) ;EP - Return the iCare panel name
;
NEW DA,IENS
;
S USER=$G(USER),PIEN=$G(PIEN)
;
I USER=""!(PIEN="") Q ""
;
S DA(1)=USER,DA=PIEN,IENS=$$IENS^DILF(.DA)
Q $$GET1^DIQ(90505.01,IENS,".01","I")
;
VFETCH(X,DESC) ;EP - Return the visit information
;
;Fetch existing visit
S X=$P(X,";",4) Q:X]"" X
;
;Visit stub
S X=$$SOUTPUT^BUSAUTIL(6)
I X="" S DESC="EHR: Created new visit stub" Q ""
;
;New visit
S DESC="EHR: Created new visit"
Q X
;
WRAP(OUT,TEXT,RM,IND) ;EP - Wrap the text and insert in array
;
NEW SP
;
I $G(TEXT)="" S OUT(1)="" Q
I $G(RM)="" Q
I $G(IND)="" S IND=0
S $P(SP," ",80)=" "
;
;Strip out $c(10)
S TEXT=$TR(TEXT,$C(10))
;
F I $L(TEXT)>0 D Q:$L(TEXT)=0
. NEW PIECE,SPACE,LINE
. S PIECE=$E(TEXT,1,RM)
. ;
. ;Check if line is less than right margin
. I $L(PIECE)<RM S OUT=$G(OUT)+1,OUT(OUT)=PIECE,TEXT="" Q
. ;
. ;Locate last space in line and handle if no space
. F SPACE=$L(PIECE):-1:(IND+1) I $E(PIECE,SPACE)=" " Q
. I (SPACE=(IND+1)) D S:TEXT]"" TEXT=$E(SP,1,IND)_TEXT Q
.. S LINE=PIECE,OUT=$G(OUT)+1,OUT(OUT)=LINE,TEXT=$$STZ($E(TEXT,RM+1,999999999))
. ;
. ;Handle line with space
. S LINE=$E(PIECE,1,SPACE-1),OUT=$G(OUT)+1,OUT(OUT)=LINE,TEXT=$$STZ($E(TEXT,SPACE+1,999999999))
. S:TEXT]"" TEXT=$E(SP,1,IND)_TEXT
;
Q
;
STZ(TEXT) ;EP - Strip Leading Spaces
NEW START
F START=1:1:$L(TEXT) I $E(TEXT,START)'=" " Q
Q $E(TEXT,START,9999999999)
;
SEND(BUSAIEN,BUSAXPDA) ;EP - Determine whether to include RPC in KIDS build
;
;This function is call by code placed in the 'Screen to Select Data' field
;in the KIDS File List/Data Export Option
;
;Check for needed values
I '$G(BUSAIEN) Q 0
I '$G(BUSAXPDA) Q 0
;
NEW TIEN,BIEN
;
;First look for RPC in BUSA RPC TRANSPORT LIST
S TIEN=$O(^BUSATR("B",BUSAIEN,"")) Q:TIEN="" 0
;
;Now see if in build
S BIEN=$O(^BUSATR(TIEN,1,"B",BUSAXPDA,"")) Q:BIEN="" 0
;
;Send in build
Q 1
;
MINP(BUSALIST,BUSADLM,BUSATYPE,BUSAEXE,BUSADVAL) ;EP - Process Multiple input DFN/VIEN
;
;Updates the detail BUSADVAL array
;
;Input variables:
;BUSALIST - Variable containing list of DFNs/VIENs
;BUSADLM - The list delimiter, in quotes, ex. "^",";","$C(28)",use "U" for "^"
;BUSATYPE - "D" for DFN list, "V" for VIEN list
;BUSAEXE - Field executable code
;BUSADVAL - Array to update
;
;Input validation
I $G(BUSALIST)="" Q
I $G(BUSADLM)="" Q
I $G(BUSATYPE)="" Q
;
NEW PIECE,DETPC,DTCNT,DLM,X
;
;Format delimiter
S DLM=$S(BUSADLM="U":"^",BUSADLM["$C(":$C($P($P(BUSADLM,"(",2),")")),1:BUSADLM)
;
;Determine piece to save
S DETPC=$S(BUSATYPE="D":1,BUSATYPE="V":2,1:"") Q:DETPC=""
;
;Loop through list and save entry for each
S DTCNT=0 F PIECE=1:1:$L(BUSALIST,DLM) S X=$P(BUSALIST,DLM,PIECE) D
. NEW DFN
. ;
. ;Run executable code
. I $G(BUSAEXE)]"" X BUSAEXE
. ;
. ;Quit if no value
. I X="" Q
. ;
. ;Value defined - save entry
. S DTCNT=DTCNT+1
. S $P(BUSADVAL(DTCNT),U,DETPC)=X
. ;
. ;On type VIEN, check if DFN needed
. Q:BUSATYPE="D"
. ;
. ;Quit if populated
. I $P(BUSADVAL(DTCNT),U)]"" Q
. ;
. ;Plug in DFN
. S DFN=$$GET1^DIQ(9000010,X_",",".05","I")
. S $P(BUSADVAL(DTCNT),U)=DFN
;
Q
;
CHECKAV(BUSAAV) ;EP - Authenticate AC/VC and Return DUZ
;
; Input: BUSAAV - ACCESS CODE_";"_VERIFY CODE
; Output: DUZ value
;
N BUSADUZ,XUF
;
S:$G(U)="" U="^"
S:$G(DT)="" DT=$$DT^XLFDT
;
S XUF=0
S BUSADUZ=$$CHECKAV^XUS(BUSAAV)
I BUSADUZ=0 Q 0
;
;Return DUZ if user inactive
I (+$P($G(^VA(200,BUSADUZ,0)),U,11)'>0)!(+$P($G(^VA(200,BUSADUZ,0)),U,11)'<DT) Q BUSADUZ
Q 0
;
AUTH(BUSADUZ) ;EP - Authenticate User for BUSA REPORT Access
;
; Input: BUSADUZ - User's DUZ value
; Output: 0 - No Authorized/1 - Authorized
;
N BUSAKEY
;
S:$G(U)="" U="^"
;
I $G(BUSADUZ)<1 Q 0
S BUSAKEY=$O(^DIC(19.1,"B","BUSAZRPT","")) I BUSAKEY="" Q 0
I '$D(^VA(200,"AB",BUSAKEY,BUSADUZ,BUSAKEY)) Q 0
Q 1
BUSAUTIL ;GDIT/HS/BEE-IHS USER SECURITY AUDIT Utility Program ; 31 Jan 2013 9:53 AM
+1 ;;1.0;IHS USER SECURITY AUDIT;;Nov 05, 2013;Build 65
+2 ;
+3 QUIT
+4 ;
SINPUT(PARM) ;PEP - Return Single Input Parameter Value
+1 ;
+2 ;Required Application Variables
+3 ;BUSARPC - The name of the called RPC
+4 ;BUSABKR - The broker making the call
+5 ;
+6 ;Input variable
+7 ;PARM - The RPC input parameter piece to pull
+8 ;
+9 NEW OUT
+10 ;
+11 IF +$GET(PARM)<1
QUIT ""
+12 IF $GET(BUSABKR)=""
QUIT ""
+13 IF $GET(BUSARPC)=""
QUIT ""
+14 ;
+15 ;Retrieve information
+16 DO VAL("I",PARM,BUSABKR,BUSARPC,.OUT)
+17 ;
+18 ;Return first record
+19 QUIT $GET(OUT)
+20 ;
SOUTPUT(PARM) ;PEP - Return Single Output Parameter Value
+1 ;
+2 ;Required Application Variables
+3 ;BUSARPC - The name of the called RPC
+4 ;BUSABKR - The broker making call
+5 ;
+6 ;Input variable
+7 ;PARM - The RPC input parameter piece to pull
+8 ;
+9 NEW OUT
+10 ;
+11 IF +$GET(PARM)<1
QUIT ""
+12 IF $GET(BUSABKR)=""
QUIT ""
+13 IF $GET(BUSARPC)=""
QUIT ""
+14 ;
+15 ;Retrieve information
+16 DO VAL("R",PARM,BUSABKR,BUSARPC,.OUT)
+17 ;
+18 ;Return first record
+19 QUIT $GET(OUT)
+20 ;
VAL(TYPE,LOCATION,BROKER,RPC,RVAL) ;PEP - Return information located in specified location
+1 ;
+2 ;Input:
+3 ; TYPE - The area to look (I:Input Parameter, R:Results)
+4 ; LOCATION - The input parameter number, the return piece or column name
+5 ; BROKER - The broker making the call (B:BMXNet,C:CIA,W:XWB)
+6 ; RPC - The RPC name
+7 ; RVAL - The return value array
+8 ;
+9 SET TYPE=$GET(TYPE)
SET LOCATION=$GET(LOCATION)
SET BROKER=$GET(BROKER)
SET RPC=$GET(RPC)
+10 ;
+11 IF TYPE'="I"
IF TYPE'="R"
QUIT "0^Invalid Type"
+12 IF LOCATION=""
QUIT "0^Missing Location"
+13 IF BROKER'="B"
IF BROKER'="C"
IF BROKER'="W"
QUIT "0^Invalid Broker"
+14 IF RPC=""
QUIT "0^Missing RPC Call"
+15 ;
+16 ;Process data in input parameters
+17 IF TYPE="I"
Begin DoDot:1
+18 ;BMXNet
IF BROKER="B"
DO BINP(LOCATION,.RVAL)
+19 ;CIA
IF BROKER="C"
DO CINP(LOCATION,.RVAL)
+20 ;XWB
IF BROKER="W"
DO WINP(LOCATION,.RVAL)
End DoDot:1
GOTO XVAL
+21 ;
+22 ;Process data in results
+23 IF TYPE="R"
Begin DoDot:1
+24 ;BMXNet
IF BROKER="B"
DO BRES(LOCATION,RPC,.RVAL)
+25 ;CIA
IF BROKER="C"
DO CRES(LOCATION,RPC,.RVAL)
+26 ;XWB
IF BROKER="W"
DO WRES(LOCATION,RPC,.RVAL)
End DoDot:1
GOTO XVAL
XVAL QUIT 1
+1 ;
BINP(LOC,RVAL) ;EP - Return BMXNet input parameter value
+1 SET RVAL=$GET(BUSAP(3,"P",LOC-1))
+2 QUIT
+3 ;
WINP(LOC,RVAL) ;EP - Return XWB input parameter value
+1 SET RVAL=$GET(BUSAP(3,"P",LOC-1))
+2 QUIT
+3 ;
CINP(LOC,RVAL) ;EP - Return CIA input parameter value
+1 SET RVAL=$GET(@("P"_LOC))
+2 QUIT
+3 ;
BRES(LOC,RPC,RVAL) ;EP - Return BMXNet result value
+1 ;
+2 NEW RPCIEN,RTVAL
+3 SET RPCIEN=$ORDER(^XWB(8994,"B",RPC,0))
+4 ;
+5 ;Retrieve global return value
+6 SET RTVAL=$$GET1^DIQ(8994,RPCIEN_",",.04,"I")
+7 ;
+8 ;Global Array
+9 IF RTVAL=4
DO BGARES(LOC,.RVAL)
+10 ;
+11 QUIT
+12 ;
WRES(LOC,RPC,RVAL) ;EP - Return BMXNet result value
+1 ;
+2 NEW RPCIEN,RTVAL
+3 SET RPCIEN=$ORDER(^XWB(8994,"B",RPC,0))
+4 ;
+5 ;Retrieve global return value
+6 SET RTVAL=$$GET1^DIQ(8994,RPCIEN_",",.04,"I")
+7 ;
+8 ;Global Array
+9 IF RTVAL=4
DO WGARES(LOC,.RVAL)
+10 ;
+11 QUIT
+12 ;
CRES(LOC,RPC,RVAL) ;EP - Return CIA result value
+1 ;
+2 ;Handle single value returns
+3 IF XWBPTYPE=1
Begin DoDot:1
+4 SET RVAL(1)=$PIECE($GET(CIAD),U,LOC)
End DoDot:1
QUIT
+5 ;
+6 IF XWBPTYPE=5
Begin DoDot:1
+7 SET RVAL(1)=$PIECE($GET(@CIAD),U,LOC)
End DoDot:1
QUIT
+8 ;
+9 ;Handle Array, Word Processing, Global Array
+10 IF XWBPTYPE=2
DO CROUT("CIAD",LOC,.RVAL)
QUIT
+11 IF XWBPTYPE=3
DO CROUT("CIAD",LOC,.RVAL)
QUIT
+12 IF XWBPTYPE=4
DO CROUT(CIAD,LOC,.RVAL)
QUIT
+13 QUIT
+14 ;
+15 ;Return result information
CROUT(ARY,LOC,RVAL) ;
+1 NEW X,L,K,II
+2 SET K=$EXTRACT(ARY)'="~"
+3 IF 'K
SET ARY=$EXTRACT(ARY,2,999)
+4 IF '$LENGTH(ARY)
QUIT
+5 SET ARY=$NAME(@ARY)
+6 SET X=ARY
SET L=$QLENGTH(ARY)
+7 FOR
SET X=$QUERY(@X)
IF '$LENGTH(X)
QUIT
IF $NAME(@X,L)'=ARY
QUIT
SET II=$GET(II)+1
SET RVAL(II)=$PIECE($GET(@X),U,LOC)
+8 QUIT
+9 ;
BGARES(LOC,RVAL) ;EP - Return BMXNet Global Array Value
+1 ;
+2 NEW BMXIEN,FCOL,COL,FHDR,BMXHDR
+3 ;
+4 ;Pull header row and locate column
+5 SET BMXHDR=@BMXY@(0)
+6 SET FCOL=""
FOR COL=1:1:$LENGTH(BMXHDR,U)
SET FHDR=$TRANSLATE($EXTRACT($PIECE(BMXHDR,U,COL),7,99),$CHAR(30))
IF FHDR=LOC
SET FCOL=COL
+7 ;
+8 ;Find the field
+9 IF FCOL]""
SET BMXIEN=0
FOR
SET BMXIEN=$ORDER(@BMXY@(BMXIEN))
IF BMXIEN=""
QUIT
Begin DoDot:1
+10 ;
+11 NEW VAL
+12 ;
+13 ;Quit on last record
+14 IF $TRANSLATE(@BMXY@(BMXIEN),$CHAR(31))=""
QUIT
+15 ;
+16 ;Pull the column value if populated
+17 SET VAL=$PIECE($GET(@BMXY@(BMXIEN)),U,FCOL)
+18 IF VAL]""
SET RVAL(BMXIEN)=$TRANSLATE(VAL,$CHAR(30))
End DoDot:1
+19 QUIT
+20 ;
WGARES(LOC,RVAL) ;EP - Return XWB Global Array Value
+1 ;
+2 NEW XWBIEN,FCOL,COL,FHDR,XWBHDR
+3 ;
+4 ;Pull header row and locate column
+5 SET XWBHDR=@XWBY@(0)
+6 SET FCOL=""
FOR COL=1:1:$LENGTH(XWBHDR,U)
SET FHDR=$TRANSLATE($EXTRACT($PIECE(XWBHDR,U,COL),7,99),$CHAR(30))
IF FHDR=LOC
SET FCOL=COL
+7 ;
+8 ;Find the field
+9 IF FCOL]""
SET XWBIEN=0
FOR
SET XWBIEN=$ORDER(@XWBY@(XWBIEN))
IF XWBIEN=""
QUIT
Begin DoDot:1
+10 ;
+11 NEW VAL
+12 ;
+13 ;Quit on last record
+14 IF $TRANSLATE(@XWBY@(XWBIEN),$CHAR(31))=""
QUIT
+15 ;
+16 ;Pull the column value if populated
+17 SET VAL=$PIECE($GET(@XWBY@(XWBIEN)),U,FCOL)
+18 IF VAL]""
SET RVAL(XWBIEN)=$TRANSLATE(VAL,$CHAR(30))
End DoDot:1
+19 QUIT
+20 ;
BFILE(BUSAOVAL,BUSADVAL,PIECE,EXE,MULT,MINP) ;EP - BMX: Format and file data detail array
+1 ;
+2 ;Result output filing
+3 IF $GET(MULT)=1
Begin DoDot:1
+4 NEW BMXIEN
+5 SET BMXIEN=0
FOR
SET BMXIEN=$ORDER(@BMXY@(BMXIEN))
IF BMXIEN=""
QUIT
Begin DoDot:2
+6 NEW X,DFN,VIEN
+7 ;
+8 ;Pull DFN/VIEN so they can be used (if populated)
+9 SET DFN=$PIECE($GET(BUSADVAL(BMXIEN)),U)
IF PIECE>2
IF DFN=""
QUIT
+10 SET VIEN=$PIECE($GET(BUSADVAL(BMXIEN)),U,2)
+11 ;
+12 ;Process desired piece
+13 ;Look in variable first
SET X=$GET(BUSAOVAL)
+14 ;Look in array second
IF X=""
SET X=$GET(BUSAOVAL(BMXIEN))
+15 IF $GET(EXE)]""
XECUTE EXE
+16 IF $GET(X)]""
SET $PIECE(BUSADVAL(BMXIEN),U,PIECE)=X
+17 ;
+18 ;If VIEN piece - check if DFN needs filled in
+19 IF PIECE'=2
QUIT
+20 ;
+21 ;Quit if already populated
+22 IF DFN]""
QUIT
+23 ;
+24 ;Plug in DFN
+25 SET DFN=$$GET1^DIQ(9000010,X_",",".05","I")
+26 IF DFN]""
SET $PIECE(BUSADVAL(BMXIEN),U)=DFN
End DoDot:2
End DoDot:1
QUIT
+27 ;
+28 ;Multiple input filing
+29 IF $GET(MINP)=1
Begin DoDot:1
+30 ;
+31 ;DFN/VIEN pieces already processed
+32 IF (PIECE=1)!(PIECE=2)
QUIT
+33 ;
+34 NEW BMXIEN
+35 ;
+36 SET BMXIEN=0
FOR
SET BMXIEN=$ORDER(BUSADVAL(BMXIEN))
IF BMXIEN=""
QUIT
Begin DoDot:2
+37 ;
+38 NEW X,DFN,VIEN
+39 ;
+40 ;Pull populated values
+41 SET DFN=$PIECE(BUSADVAL(BMXIEN),U)
IF PIECE>2
IF DFN=""
QUIT
+42 SET VIEN=$PIECE(BUSADVAL(BMXIEN),U,2)
+43 ;
+44 ;Pull field value
+45 SET X=$PIECE(BUSADVAL(BMXIEN),U,PIECE)
+46 ;
+47 ;Call executable
+48 IF $GET(EXE)]""
XECUTE EXE
+49 ;
+50 ;Save value
+51 IF $GET(X)]""
SET $PIECE(BUSADVAL(BMXIEN),U,PIECE)=X
End DoDot:2
End DoDot:1
QUIT
+52 ;
+53 ;Single record output
+54 ;
+55 NEW X,DFN,VIEN
+56 ;
+57 ;Pull DFN/VIEN so they can be used (if populated)
+58 SET DFN=$PIECE($GET(BUSADVAL(1)),U)
IF PIECE>2
IF DFN=""
QUIT
+59 SET VIEN=$PIECE($GET(BUSADVAL(1)),U,2)
+60 ;
+61 ;Now populate correct piece
+62 SET X=$GET(BUSAOVAL)
IF X=""
SET X=$GET(BUSAOVAL(1))
+63 IF $GET(EXE)]""
XECUTE EXE
+64 IF $GET(X)]""
SET $PIECE(BUSADVAL(1),U,PIECE)=X
+65 ;
+66 ;If VIEN piece - check if DFN needs filled in
+67 IF PIECE'=2
QUIT
+68 ;
+69 ;Quit if already populated
+70 IF DFN]""
QUIT
+71 ;
+72 ;Plug in DFN
+73 SET DFN=$$GET1^DIQ(9000010,X_",",".05","I")
+74 IF DFN]""
SET $PIECE(BUSADVAL(1),U)=DFN
+75 ;
+76 QUIT
+77 ;
WFILE(BUSAOVAL,BUSADVAL,PIECE,EXE,MULT,MINP) ;EP - XWB: Format and file data detail array
+1 ;
+2 ;Result output filing
+3 IF $GET(MULT)=1
Begin DoDot:1
+4 NEW XWBIEN
+5 SET XWBIEN=0
FOR
SET XWBIEN=$ORDER(@BXWB@(XWBIEN))
IF XWBIEN=""
QUIT
Begin DoDot:2
+6 NEW X,DFN,VIEN
+7 ;
+8 ;Pull DFN/VIEN so they can be used (if populated)
+9 SET DFN=$PIECE($GET(BUSADVAL(XWBIEN)),U)
IF PIECE>2
IF DFN=""
QUIT
+10 SET VIEN=$PIECE($GET(BUSADVAL(XWBIEN)),U,2)
+11 ;
+12 ;Process desired piece
+13 ;Look in variable first
SET X=$GET(BUSAOVAL)
+14 ;Look in array second
IF X=""
SET X=$GET(BUSAOVAL(XWBIEN))
+15 IF $GET(EXE)]""
XECUTE EXE
+16 IF $GET(X)]""
SET $PIECE(BUSADVAL(XWBIEN),U,PIECE)=X
+17 ;
+18 ;If VIEN piece - check if DFN needs filled in
+19 IF PIECE'=2
QUIT
+20 ;
+21 ;Quit if already populated
+22 IF DFN]""
QUIT
+23 ;
+24 ;Plug in DFN
+25 SET DFN=$$GET1^DIQ(9000010,X_",",".05","I")
+26 IF DFN]""
SET $PIECE(BUSADVAL(XWBIEN),U)=DFN
End DoDot:2
End DoDot:1
QUIT
+27 ;
+28 ;Multiple input filing
+29 IF $GET(MINP)=1
Begin DoDot:1
+30 ;
+31 ;DFN/VIEN pieces already processed
+32 IF (PIECE=1)!(PIECE=2)
QUIT
+33 ;
+34 NEW XWBIEN
+35 ;
+36 SET XWBIEN=0
FOR
SET XWBIEN=$ORDER(BUSADVAL(XWBIEN))
IF XWBIEN=""
QUIT
Begin DoDot:2
+37 ;
+38 NEW X,DFN,VIEN
+39 ;
+40 ;Pull populated values
+41 SET DFN=$PIECE(BUSADVAL(XWBIEN),U)
IF PIECE>2
IF DFN=""
QUIT
+42 SET VIEN=$PIECE(BUSADVAL(XWBIEN),U,2)
+43 ;
+44 ;Pull field value
+45 SET X=$PIECE(BUSADVAL(XWBIEN),U,PIECE)
+46 ;
+47 ;Call executable
+48 IF $GET(EXE)]""
XECUTE EXE
+49 ;
+50 ;Save value
+51 IF $GET(X)]""
SET $PIECE(BUSADVAL(XWBIEN),U,PIECE)=X
End DoDot:2
End DoDot:1
QUIT
+52 ;
+53 ;Single record output
+54 ;
+55 NEW X,DFN,VIEN
+56 ;
+57 ;Pull DFN/VIEN so they can be used (if populated)
+58 SET DFN=$PIECE($GET(BUSADVAL(1)),U)
IF PIECE>2
IF DFN=""
QUIT
+59 SET VIEN=$PIECE($GET(BUSADVAL(1)),U,2)
+60 ;
+61 ;Now populate correct piece
+62 SET X=$GET(BUSAOVAL)
IF X=""
SET X=$GET(BUSAOVAL(1))
+63 IF $GET(EXE)]""
XECUTE EXE
+64 IF $GET(X)]""
SET $PIECE(BUSADVAL(1),U,PIECE)=X
+65 ;
+66 ;If VIEN piece - check if DFN needs filled in
+67 IF PIECE'=2
QUIT
+68 ;
+69 ;Quit if already populated
+70 IF DFN]""
QUIT
+71 ;
+72 ;Plug in DFN
+73 SET DFN=$$GET1^DIQ(9000010,X_",",".05","I")
+74 IF DFN]""
SET $PIECE(BUSADVAL(1),U)=DFN
+75 ;
+76 QUIT
+77 ;
CFILE(BUSAOVAL,BUSADVAL,PIECE,EXE,MULT,MINP) ;EP - Format and file CIA data detail array
+1 ;
+2 ;Multiple input filing
+3 IF $GET(MINP)=1
Begin DoDot:1
+4 ;
+5 ;DFN/VIEN pieces already processed
+6 IF (PIECE=1)!(PIECE=2)
QUIT
+7 ;
+8 NEW BMXIEN
+9 ;
+10 SET BMXIEN=0
FOR
SET BMXIEN=$ORDER(BUSADVAL(BMXIEN))
IF BMXIEN=""
QUIT
Begin DoDot:2
+11 ;
+12 NEW X,DFN,VIEN
+13 ;
+14 ;Pull populated values
+15 SET DFN=$PIECE(BUSADVAL(BMXIEN),U)
IF PIECE>2
IF DFN=""
QUIT
+16 SET VIEN=$PIECE(BUSADVAL(BMXIEN),U,2)
+17 ;
+18 ;Pull field value
+19 SET X=$PIECE(BUSADVAL(BMXIEN),U,PIECE)
+20 ;
+21 ;Call executable
+22 IF $GET(EXE)]""
XECUTE EXE
+23 ;
+24 ;Save value
+25 IF $GET(X)]""
SET $PIECE(BUSADVAL(BMXIEN),U,PIECE)=X
End DoDot:2
End DoDot:1
QUIT
+26 ;
+27 ;Single return value
+28 ;
+29 IF (XWBPTYPE=1)!(XWBPTYPE=5)!'MULT
Begin DoDot:1
+30 ;
+31 NEW X,DFN,VIEN
+32 ;
+33 ;Pull DFN/VIEN so they can be used (if populated)
+34 SET DFN=$PIECE($GET(BUSADVAL(1)),U)
IF PIECE>2
IF DFN=""
QUIT
+35 SET VIEN=$PIECE($GET(BUSADVAL(1)),U,2)
+36 ;
+37 ;Now populate correct piece
+38 SET X=$GET(BUSAOVAL)
IF X=""
SET X=$GET(BUSAOVAL(1))
+39 IF $GET(EXE)]""
XECUTE EXE
+40 IF $GET(X)]""
SET $PIECE(BUSADVAL(1),U,PIECE)=X
+41 ;
+42 ;If VIEN piece - check if DFN needs filled in
+43 IF PIECE'=2
QUIT
+44 ;
+45 ;Quite if already populated
+46 IF DFN]""
QUIT
+47 ;
+48 ;Plug in DFN
+49 SET DFN=$$GET1^DIQ(9000010,X_",",".05","I")
+50 IF DFN]""
SET $PIECE(BUSADVAL(1),U)=DFN
End DoDot:1
QUIT
+51 ;
+52 ;Multiple return values
+53 ;Handle Array, Word Processing, Global Array Types
+54 IF XWBPTYPE=2
DO CLOOP("CIAD",.BUSAOVAL,.BUSADVAL)
+55 IF XWBPTYPE=3
DO CLOOP("CIAD",.BUSAOVAL,.BUSADVAL)
+56 IF XWBPTYPE=4
DO CLOOP(CIAD,.BUSAOVAL,.BUSADVAL)
+57 QUIT
+58 ;
+59 ;Loop through output and fill in piece
CLOOP(ARY,BUSAOVAL,BUSADVAL) ;
+1 NEW CL,L,K,II
+2 SET K=$EXTRACT(ARY)'="~"
+3 IF 'K
SET ARY=$EXTRACT(ARY,2,999)
+4 IF '$LENGTH(ARY)
QUIT
+5 SET ARY=$NAME(@ARY)
+6 SET CL=ARY
SET L=$QLENGTH(ARY)
+7 FOR
SET CL=$QUERY(@CL)
IF '$LENGTH(CL)
QUIT
IF $NAME(@CL,L)'=ARY
QUIT
Begin DoDot:1
+8 ;
+9 NEW X,DFN,VIEN
+10 SET II=$GET(II)+1
+11 ;
+12 ;Pull DFN/VIEN so they can be used (if populated)
+13 SET DFN=$PIECE($GET(BUSADVAL(II)),U)
IF PIECE>2
IF DFN=""
QUIT
+14 SET VIEN=$PIECE($GET(BUSADVAL(II)),U,2)
+15 ;
+16 ;Pull field value
+17 SET X=$SELECT($GET(BUSAOVAL)]"":BUSAOVAL,1:$GET(BUSAOVAL(II)))
+18 ;
+19 ;Call executable
+20 IF $GET(EXE)]""
XECUTE EXE
+21 ;
+22 ;Save value
+23 IF $GET(X)]""
SET $PIECE(BUSADVAL(II),U,PIECE)=X
+24 ;
+25 ;If VIEN piece - check if DFN needs filled in
+26 IF PIECE'=2
QUIT
+27 ;
+28 ;Quit if already populated
+29 IF DFN]""
QUIT
+30 ;
+31 ;Plug in DFN
+32 SET DFN=$$GET1^DIQ(9000010,X_",",".05","I")
+33 IF DFN]""
SET $PIECE(BUSADVAL(II),U)=DFN
End DoDot:1
+34 ;
+35 QUIT
+36 ;
PNLNAME(USER,PIEN) ;EP - Return the iCare panel name
+1 ;
+2 NEW DA,IENS
+3 ;
+4 SET USER=$GET(USER)
SET PIEN=$GET(PIEN)
+5 ;
+6 IF USER=""!(PIEN="")
QUIT ""
+7 ;
+8 SET DA(1)=USER
SET DA=PIEN
SET IENS=$$IENS^DILF(.DA)
+9 QUIT $$GET1^DIQ(90505.01,IENS,".01","I")
+10 ;
VFETCH(X,DESC) ;EP - Return the visit information
+1 ;
+2 ;Fetch existing visit
+3 SET X=$PIECE(X,";",4)
IF X]""
QUIT X
+4 ;
+5 ;Visit stub
+6 SET X=$$SOUTPUT^BUSAUTIL(6)
+7 IF X=""
SET DESC="EHR: Created new visit stub"
QUIT ""
+8 ;
+9 ;New visit
+10 SET DESC="EHR: Created new visit"
+11 QUIT X
+12 ;
WRAP(OUT,TEXT,RM,IND) ;EP - Wrap the text and insert in array
+1 ;
+2 NEW SP
+3 ;
+4 IF $GET(TEXT)=""
SET OUT(1)=""
QUIT
+5 IF $GET(RM)=""
QUIT
+6 IF $GET(IND)=""
SET IND=0
+7 SET $PIECE(SP," ",80)=" "
+8 ;
+9 ;Strip out $c(10)
+10 SET TEXT=$TRANSLATE(TEXT,$CHAR(10))
+11 ;
+12 FOR
IF $LENGTH(TEXT)>0
Begin DoDot:1
+13 NEW PIECE,SPACE,LINE
+14 SET PIECE=$EXTRACT(TEXT,1,RM)
+15 ;
+16 ;Check if line is less than right margin
+17 IF $LENGTH(PIECE)<RM
SET OUT=$GET(OUT)+1
SET OUT(OUT)=PIECE
SET TEXT=""
QUIT
+18 ;
+19 ;Locate last space in line and handle if no space
+20 FOR SPACE=$LENGTH(PIECE):-1:(IND+1)
IF $EXTRACT(PIECE,SPACE)=" "
QUIT
+21 IF (SPACE=(IND+1))
Begin DoDot:2
+22 SET LINE=PIECE
SET OUT=$GET(OUT)+1
SET OUT(OUT)=LINE
SET TEXT=$$STZ($EXTRACT(TEXT,RM+1,999999999))
End DoDot:2
IF TEXT]""
SET TEXT=$EXTRACT(SP,1,IND)_TEXT
QUIT
+23 ;
+24 ;Handle line with space
+25 SET LINE=$EXTRACT(PIECE,1,SPACE-1)
SET OUT=$GET(OUT)+1
SET OUT(OUT)=LINE
SET TEXT=$$STZ($EXTRACT(TEXT,SPACE+1,999999999))
+26 IF TEXT]""
SET TEXT=$EXTRACT(SP,1,IND)_TEXT
End DoDot:1
IF $LENGTH(TEXT)=0
QUIT
+27 ;
+28 QUIT
+29 ;
STZ(TEXT) ;EP - Strip Leading Spaces
+1 NEW START
+2 FOR START=1:1:$LENGTH(TEXT)
IF $EXTRACT(TEXT,START)'=" "
QUIT
+3 QUIT $EXTRACT(TEXT,START,9999999999)
+4 ;
SEND(BUSAIEN,BUSAXPDA) ;EP - Determine whether to include RPC in KIDS build
+1 ;
+2 ;This function is call by code placed in the 'Screen to Select Data' field
+3 ;in the KIDS File List/Data Export Option
+4 ;
+5 ;Check for needed values
+6 IF '$GET(BUSAIEN)
QUIT 0
+7 IF '$GET(BUSAXPDA)
QUIT 0
+8 ;
+9 NEW TIEN,BIEN
+10 ;
+11 ;First look for RPC in BUSA RPC TRANSPORT LIST
+12 SET TIEN=$ORDER(^BUSATR("B",BUSAIEN,""))
IF TIEN=""
QUIT 0
+13 ;
+14 ;Now see if in build
+15 SET BIEN=$ORDER(^BUSATR(TIEN,1,"B",BUSAXPDA,""))
IF BIEN=""
QUIT 0
+16 ;
+17 ;Send in build
+18 QUIT 1
+19 ;
MINP(BUSALIST,BUSADLM,BUSATYPE,BUSAEXE,BUSADVAL) ;EP - Process Multiple input DFN/VIEN
+1 ;
+2 ;Updates the detail BUSADVAL array
+3 ;
+4 ;Input variables:
+5 ;BUSALIST - Variable containing list of DFNs/VIENs
+6 ;BUSADLM - The list delimiter, in quotes, ex. "^",";","$C(28)",use "U" for "^"
+7 ;BUSATYPE - "D" for DFN list, "V" for VIEN list
+8 ;BUSAEXE - Field executable code
+9 ;BUSADVAL - Array to update
+10 ;
+11 ;Input validation
+12 IF $GET(BUSALIST)=""
QUIT
+13 IF $GET(BUSADLM)=""
QUIT
+14 IF $GET(BUSATYPE)=""
QUIT
+15 ;
+16 NEW PIECE,DETPC,DTCNT,DLM,X
+17 ;
+18 ;Format delimiter
+19 SET DLM=$SELECT(BUSADLM="U":"^",BUSADLM["$C(":$CHAR($PIECE($PIECE(BUSADLM,"(",2),")")),1:BUSADLM)
+20 ;
+21 ;Determine piece to save
+22 SET DETPC=$SELECT(BUSATYPE="D":1,BUSATYPE="V":2,1:"")
IF DETPC=""
QUIT
+23 ;
+24 ;Loop through list and save entry for each
+25 SET DTCNT=0
FOR PIECE=1:1:$LENGTH(BUSALIST,DLM)
SET X=$PIECE(BUSALIST,DLM,PIECE)
Begin DoDot:1
+26 NEW DFN
+27 ;
+28 ;Run executable code
+29 IF $GET(BUSAEXE)]""
XECUTE BUSAEXE
+30 ;
+31 ;Quit if no value
+32 IF X=""
QUIT
+33 ;
+34 ;Value defined - save entry
+35 SET DTCNT=DTCNT+1
+36 SET $PIECE(BUSADVAL(DTCNT),U,DETPC)=X
+37 ;
+38 ;On type VIEN, check if DFN needed
+39 IF BUSATYPE="D"
QUIT
+40 ;
+41 ;Quit if populated
+42 IF $PIECE(BUSADVAL(DTCNT),U)]""
QUIT
+43 ;
+44 ;Plug in DFN
+45 SET DFN=$$GET1^DIQ(9000010,X_",",".05","I")
+46 SET $PIECE(BUSADVAL(DTCNT),U)=DFN
End DoDot:1
+47 ;
+48 QUIT
+49 ;
CHECKAV(BUSAAV) ;EP - Authenticate AC/VC and Return DUZ
+1 ;
+2 ; Input: BUSAAV - ACCESS CODE_";"_VERIFY CODE
+3 ; Output: DUZ value
+4 ;
+5 NEW BUSADUZ,XUF
+6 ;
+7 IF $GET(U)=""
SET U="^"
+8 IF $GET(DT)=""
SET DT=$$DT^XLFDT
+9 ;
+10 SET XUF=0
+11 SET BUSADUZ=$$CHECKAV^XUS(BUSAAV)
+12 IF BUSADUZ=0
QUIT 0
+13 ;
+14 ;Return DUZ if user inactive
+15 IF (+$PIECE($GET(^VA(200,BUSADUZ,0)),U,11)'>0)!(+$PIECE($GET(^VA(200,BUSADUZ,0)),U,11)'<DT)
QUIT BUSADUZ
+16 QUIT 0
+17 ;
AUTH(BUSADUZ) ;EP - Authenticate User for BUSA REPORT Access
+1 ;
+2 ; Input: BUSADUZ - User's DUZ value
+3 ; Output: 0 - No Authorized/1 - Authorized
+4 ;
+5 NEW BUSAKEY
+6 ;
+7 IF $GET(U)=""
SET U="^"
+8 ;
+9 IF $GET(BUSADUZ)<1
QUIT 0
+10 SET BUSAKEY=$ORDER(^DIC(19.1,"B","BUSAZRPT",""))
IF BUSAKEY=""
QUIT 0
+11 IF '$DATA(^VA(200,"AB",BUSAKEY,BUSADUZ,BUSAKEY))
QUIT 0
+12 QUIT 1
