- 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
