BMXRPC ; IHS/OIT/HMW - BMX REMOTE PROCEDURE CALLS ;
;;4.0;BMX;;JUN 28, 2010
;;Stolen from:* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER *
;; GENERIC LOOKUP UTILITY FOR RETURNING MATCHING RECORDS
;; OR TABLES TO RPC'S.
;
; *** NOTE: I have discovered a number of cases where these calls
; produce errors (with error messages to IO) or simply
; do not work correctly. ANY CALL to this utility
; should be thoroughly tested in the M environment
; before being used as an RPC.
;
;----------
LOOKUP(BMXGBL,BMXFL,BMXFLDS,BMXFLG,BMXIN,BMXMX,BMXIX,BMXSCR,BMXMC) ;EP
;---> Places matching records from requested file into a
;---> result global, ^BMXTEMP($J). The exact global name
;---> is returned in the first parameter (BMXGBL).
;---> Records are returned one per node in the result global.
;---> Each record is terminated with a $C(30), for parsing out
;---> on the VB side, since the Broker concatenates all nodes
;---> into a single string when passing the data out of M.
;---> Requested fields within records are delimited by "^".
;---> NOTE: The first "^"-piece of every node is the IEN of
;---> that entry in its file; the requested fields follow.
;---> The final record (node) contains Error Delimiter,
; $C(31)_$C(31), followed by error text, if any.
;
;---> Parameters:
; 1 - BMXGBL (ret) Name of result global for Broker.
; 2 - BMXFL (req) File for lookup.
; 3 - BMXFLDS (opt) Fields to return w/each entry.
; 4 - BMXFLG (opt) Flags in DIC(0); If null, "M" is sent.
; 5 - BMXIN (opt) Input to match on (see Algorithm below).
; 6 - BMXMX (opt) Maximum number of entries to return.
; 7 - BMXIX (opt) Indexes to search.
; 8 - BMXSCR (opt) Screen/filter (M code).
; 9 - BMXMC (opt) Mixed Case: 1=mixed case, 0=no change.
; (Converts data in uppercase to mixed case.)
;
;---> Set variables, kill temp globals.
N (BMXGBL,BMXFL,BMXFLDS,BMXFLG,BMXIN,BMXMX,BMXIX,BMXSCR,BMXMC) ;IHS/OIT/HMW SAC Exemption Applied For
S BMX31=$C(31)_$C(31)
S BMXGBL="^BMXTEMP("_$J_")",BMXERR="",U="^"
K ^BMXTMP($J),^BMXTEMP($J)
;
;---> If file number not provided, return error.
I '$G(BMXFL) D ERROUT("File number not provided.",1) Q
;
;---> If no fields provided, pass .01.
;---> IEN will always be the first piece of data returned.
;---> NOTE: If .01 is NOT included, but the Index to lookup on is
;---> NOT on the .01, then the .01 will be returned
;---> automatically as the second ^-piece of data in the
;---> Result Global.
;---> So it would be: IEN^.01^requested fields...
I $G(BMXFLDS)="" S BMXFLDS=".01"
;
;---> If no index or flag provided, set flag="M".
I $G(BMXFLG)="" D
.I $G(BMXIX)="" S BMXFLG="M" Q
.S BMXFLG=""
;
;---> If no Maximum Number provided, set it to 200.
I '$G(BMXMX) S BMXMX=200
;
;---> Define index and screen.
S:'$D(BMXIX) BMXIX=""
S:'$D(BMXSCR) BMXSCR=""
;
;---> Set Target Global for output and errors.
S BMXG="^BMXTMP($J)"
;
;---> If Mixed Case not set, set to No Change.
I '$D(BMXMC) S BMXMC=0
;
;---> Silent Fileman call.
D
.I $G(BMXIN)="" D Q
..D LIST^DIC(BMXFL,,BMXFLDS,,BMXMX,0,,BMXIX,BMXSCR,,BMXG,BMXG)
.D FIND^DIC(BMXFL,,BMXFLDS,BMXFLG,BMXIN,BMXMX,BMXIX,BMXSCR,,BMXG,BMXG)
;
D WRITE
Q
;
;
;----------
WRITE ;EP
;---> Collect data for matching records and write in result global.
;
;---> First, check for errors.
;---> If errors exist, write them and quit.
N I,N,X
I $D(^BMXTMP($J,"DIERR")) I $O(^("DIERR",0)) D Q
.S N=0,X=""
.F S N=$O(^BMXTMP($J,"DIERR",N)) Q:'N D
..N M S M=0
..F S M=$O(^BMXTMP($J,"DIERR",N,"TEXT",M)) Q:'M D
...S X=X_^BMXTMP($J,"DIERR",N,"TEXT",M)_" "
.D ERROUT(X,1)
;
;
;---> Write Field Names
S $P(ASDX,"^",1)="IEN"
F ASDC=1:1:$L(BMXFLDS,";") D
. S ASDXFNUM=$P(BMXFLDS,";",ASDC)
. S ASDXFNAM=$P(^DD(BMXFL,ASDXFNUM,0),"^")
. S:ASDXFNAM="" ASDXFNAM="UNKNOWN"_ASDC
. S $P(ASDX,"^",ASDC+1)=ASDXFNAM
S ^BMXTEMP($J,1)=ASDX_$C(30)
;---> Write valid results.
;---> Loop through the IEN node (...2,N) of the temp global.
N I,N,X S N=0
F I=2:1 S N=$O(^BMXTMP($J,"DILIST",2,N)) Q:'N D
.;---> Always set first piece of X=IEN of entry.
.S X=^BMXTMP($J,"DILIST",2,N)
.;
.;---> Collect other fields and concatenate to X.
.N M S M=0
.F S M=$O(^BMXTMP($J,"DILIST","ID",N,M)) Q:'M D
..S X=X_U_^BMXTMP($J,"DILIST","ID",N,M)
.;
.;---> Convert data to mixed case if BMXMC=1.
.S:BMXMC X=$$T^BMXTRS(X)
.;
.;---> Set data in result global.
.S ^BMXTEMP($J,I)=X_$C(30)
;
;---> If no results, report it as an error.
D:'$O(^BMXTEMP($J,0))
.I BMXIN]"" S BMXERR="No entry matches """_BMXIN_"""." Q
.S BMXERR="Either the lookup file is empty"
.S BMXERR=BMXERR_" or all entries are screened (software error)."
;
;---> Tack on Error Delimiter and any error.
S ^BMXTEMP($J,I)=BMX31_BMXERR
Q
;
;
;----------
ERROUT(BMXERR,I) ;EP
;---> Save next line for Error Code File if ever used.
;---> If necessary, use I>1 to avoid overwriting valid data.
S:'$G(I) I=1
S ^BMXTEMP($J,I)=BMX31_BMXERR
Q
;
;
PASSERR(BMXGBL,BMXERR) ;EP
;---> If the RPC routine calling the BMX Generic Lookup above
;---> detects a specific error prior to the call and wants to pass
;---> that error in the result global rather than a generic error,
;---> then a call to this function (PASSERR) can be made.
;---> This call will store the error text passed in the result global.
;---> The calling routine should then quit (abort its call to the
;---> BMX Generic Lookup function above).
;
;---> Parameters:
; 1 - BMXGBL (ret) Name of result global for Broker.
; 2 - BMXERR (req) Text of error to be stored in result global.
;
S:$G(BMXERR)="" BMXERR="Error not passed (software error)."
;
N BMX31 S BMX31=$C(31)_$C(31)
K ^BMXTMP($J),^BMXTEMP($J)
S BMXGBL="^BMXTEMP("_$J_")"
S ^BMXTEMP($J,1)=BMX31_BMXERR
Q
BMXRPC ; IHS/OIT/HMW - BMX REMOTE PROCEDURE CALLS ;
+1 ;;4.0;BMX;;JUN 28, 2010
+2 ;;Stolen from:* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER *
+3 ;; GENERIC LOOKUP UTILITY FOR RETURNING MATCHING RECORDS
+4 ;; OR TABLES TO RPC'S.
+5 ;
+6 ; *** NOTE: I have discovered a number of cases where these calls
+7 ; produce errors (with error messages to IO) or simply
+8 ; do not work correctly. ANY CALL to this utility
+9 ; should be thoroughly tested in the M environment
+10 ; before being used as an RPC.
+11 ;
+12 ;----------
LOOKUP(BMXGBL,BMXFL,BMXFLDS,BMXFLG,BMXIN,BMXMX,BMXIX,BMXSCR,BMXMC) ;EP
+1 ;---> Places matching records from requested file into a
+2 ;---> result global, ^BMXTEMP($J). The exact global name
+3 ;---> is returned in the first parameter (BMXGBL).
+4 ;---> Records are returned one per node in the result global.
+5 ;---> Each record is terminated with a $C(30), for parsing out
+6 ;---> on the VB side, since the Broker concatenates all nodes
+7 ;---> into a single string when passing the data out of M.
+8 ;---> Requested fields within records are delimited by "^".
+9 ;---> NOTE: The first "^"-piece of every node is the IEN of
+10 ;---> that entry in its file; the requested fields follow.
+11 ;---> The final record (node) contains Error Delimiter,
+12 ; $C(31)_$C(31), followed by error text, if any.
+13 ;
+14 ;---> Parameters:
+15 ; 1 - BMXGBL (ret) Name of result global for Broker.
+16 ; 2 - BMXFL (req) File for lookup.
+17 ; 3 - BMXFLDS (opt) Fields to return w/each entry.
+18 ; 4 - BMXFLG (opt) Flags in DIC(0); If null, "M" is sent.
+19 ; 5 - BMXIN (opt) Input to match on (see Algorithm below).
+20 ; 6 - BMXMX (opt) Maximum number of entries to return.
+21 ; 7 - BMXIX (opt) Indexes to search.
+22 ; 8 - BMXSCR (opt) Screen/filter (M code).
+23 ; 9 - BMXMC (opt) Mixed Case: 1=mixed case, 0=no change.
+24 ; (Converts data in uppercase to mixed case.)
+25 ;
+26 ;---> Set variables, kill temp globals.
+27 ;IHS/OIT/HMW SAC Exemption Applied For
NEW (BMXGBL,BMXFL,BMXFLDS,BMXFLG,BMXIN,BMXMX,BMXIX,BMXSCR,BMXMC)
+28 SET BMX31=$CHAR(31)_$CHAR(31)
+29 SET BMXGBL="^BMXTEMP("_$JOB_")"
SET BMXERR=""
SET U="^"
+30 KILL ^BMXTMP($JOB),^BMXTEMP($JOB)
+31 ;
+32 ;---> If file number not provided, return error.
+33 IF '$GET(BMXFL)
DO ERROUT("File number not provided.",1)
QUIT
+34 ;
+35 ;---> If no fields provided, pass .01.
+36 ;---> IEN will always be the first piece of data returned.
+37 ;---> NOTE: If .01 is NOT included, but the Index to lookup on is
+38 ;---> NOT on the .01, then the .01 will be returned
+39 ;---> automatically as the second ^-piece of data in the
+40 ;---> Result Global.
+41 ;---> So it would be: IEN^.01^requested fields...
+42 IF $GET(BMXFLDS)=""
SET BMXFLDS=".01"
+43 ;
+44 ;---> If no index or flag provided, set flag="M".
+45 IF $GET(BMXFLG)=""
Begin DoDot:1
+46 IF $GET(BMXIX)=""
SET BMXFLG="M"
QUIT
+47 SET BMXFLG=""
End DoDot:1
+48 ;
+49 ;---> If no Maximum Number provided, set it to 200.
+50 IF '$GET(BMXMX)
SET BMXMX=200
+51 ;
+52 ;---> Define index and screen.
+53 IF '$DATA(BMXIX)
SET BMXIX=""
+54 IF '$DATA(BMXSCR)
SET BMXSCR=""
+55 ;
+56 ;---> Set Target Global for output and errors.
+57 SET BMXG="^BMXTMP($J)"
+58 ;
+59 ;---> If Mixed Case not set, set to No Change.
+60 IF '$DATA(BMXMC)
SET BMXMC=0
+61 ;
+62 ;---> Silent Fileman call.
+63 Begin DoDot:1
+64 IF $GET(BMXIN)=""
Begin DoDot:2
+65 DO LIST^DIC(BMXFL,,BMXFLDS,,BMXMX,0,,BMXIX,BMXSCR,,BMXG,BMXG)
End DoDot:2
QUIT
+66 DO FIND^DIC(BMXFL,,BMXFLDS,BMXFLG,BMXIN,BMXMX,BMXIX,BMXSCR,,BMXG,BMXG)
End DoDot:1
+67 ;
+68 DO WRITE
+69 QUIT
+70 ;
+71 ;
+72 ;----------
WRITE ;EP
+1 ;---> Collect data for matching records and write in result global.
+2 ;
+3 ;---> First, check for errors.
+4 ;---> If errors exist, write them and quit.
+5 NEW I,N,X
+6 IF $DATA(^BMXTMP($JOB,"DIERR"))
IF $ORDER(^("DIERR",0))
Begin DoDot:1
+7 SET N=0
SET X=""
+8 FOR
SET N=$ORDER(^BMXTMP($JOB,"DIERR",N))
IF 'N
QUIT
Begin DoDot:2
+9 NEW M
SET M=0
+10 FOR
SET M=$ORDER(^BMXTMP($JOB,"DIERR",N,"TEXT",M))
IF 'M
QUIT
Begin DoDot:3
+11 SET X=X_^BMXTMP($JOB,"DIERR",N,"TEXT",M)_" "
End DoDot:3
End DoDot:2
+12 DO ERROUT(X,1)
End DoDot:1
QUIT
+13 ;
+14 ;
+15 ;---> Write Field Names
+16 SET $PIECE(ASDX,"^",1)="IEN"
+17 FOR ASDC=1:1:$LENGTH(BMXFLDS,";")
Begin DoDot:1
+18 SET ASDXFNUM=$PIECE(BMXFLDS,";",ASDC)
+19 SET ASDXFNAM=$PIECE(^DD(BMXFL,ASDXFNUM,0),"^")
+20 IF ASDXFNAM=""
SET ASDXFNAM="UNKNOWN"_ASDC
+21 SET $PIECE(ASDX,"^",ASDC+1)=ASDXFNAM
End DoDot:1
+22 SET ^BMXTEMP($JOB,1)=ASDX_$CHAR(30)
+23 ;---> Write valid results.
+24 ;---> Loop through the IEN node (...2,N) of the temp global.
+25 NEW I,N,X
SET N=0
+26 FOR I=2:1
SET N=$ORDER(^BMXTMP($JOB,"DILIST",2,N))
IF 'N
QUIT
Begin DoDot:1
+27 ;---> Always set first piece of X=IEN of entry.
+28 SET X=^BMXTMP($JOB,"DILIST",2,N)
+29 ;
+30 ;---> Collect other fields and concatenate to X.
+31 NEW M
SET M=0
+32 FOR
SET M=$ORDER(^BMXTMP($JOB,"DILIST","ID",N,M))
IF 'M
QUIT
Begin DoDot:2
+33 SET X=X_U_^BMXTMP($JOB,"DILIST","ID",N,M)
End DoDot:2
+34 ;
+35 ;---> Convert data to mixed case if BMXMC=1.
+36 IF BMXMC
SET X=$$T^BMXTRS(X)
+37 ;
+38 ;---> Set data in result global.
+39 SET ^BMXTEMP($JOB,I)=X_$CHAR(30)
End DoDot:1
+40 ;
+41 ;---> If no results, report it as an error.
+42 IF '$ORDER(^BMXTEMP($JOB,0))
Begin DoDot:1
+43 IF BMXIN]""
SET BMXERR="No entry matches """_BMXIN_"""."
QUIT
+44 SET BMXERR="Either the lookup file is empty"
+45 SET BMXERR=BMXERR_" or all entries are screened (software error)."
End DoDot:1
+46 ;
+47 ;---> Tack on Error Delimiter and any error.
+48 SET ^BMXTEMP($JOB,I)=BMX31_BMXERR
+49 QUIT
+50 ;
+51 ;
+52 ;----------
ERROUT(BMXERR,I) ;EP
+1 ;---> Save next line for Error Code File if ever used.
+2 ;---> If necessary, use I>1 to avoid overwriting valid data.
+3 IF '$GET(I)
SET I=1
+4 SET ^BMXTEMP($JOB,I)=BMX31_BMXERR
+5 QUIT
+6 ;
+7 ;
PASSERR(BMXGBL,BMXERR) ;EP
+1 ;---> If the RPC routine calling the BMX Generic Lookup above
+2 ;---> detects a specific error prior to the call and wants to pass
+3 ;---> that error in the result global rather than a generic error,
+4 ;---> then a call to this function (PASSERR) can be made.
+5 ;---> This call will store the error text passed in the result global.
+6 ;---> The calling routine should then quit (abort its call to the
+7 ;---> BMX Generic Lookup function above).
+8 ;
+9 ;---> Parameters:
+10 ; 1 - BMXGBL (ret) Name of result global for Broker.
+11 ; 2 - BMXERR (req) Text of error to be stored in result global.
+12 ;
+13 IF $GET(BMXERR)=""
SET BMXERR="Error not passed (software error)."
+14 ;
+15 NEW BMX31
SET BMX31=$CHAR(31)_$CHAR(31)
+16 KILL ^BMXTMP($JOB),^BMXTEMP($JOB)
+17 SET BMXGBL="^BMXTEMP("_$JOB_")"
+18 SET ^BMXTEMP($JOB,1)=BMX31_BMXERR
+19 QUIT
