BMXGETS ; IHS/OIT/HMW - BMX REMOTE PROCEDURE CALLS ;
;;4.0;BMX;;JUN 28, 2010
;
;;Horace Whitt
;;Interface to GETS^DIQ
;
;----------
GETS(BMXGBL,BMXFL,BMXIENS,BMXFLDS,BMXFLG,BMXMC,BMXNUM) ;EP
;---> 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 number for lookup.
; 3 - BMXFLDS (req) Fields to return w/each entry in IENS format.
; 4 - BMXFLG (opt) Flags - See GETS^DIQ documentation
; 9 - BMXMC (opt) Mixed Case: 1=mixed case, 0=no change.
; (Converts data in uppercase to mixed case.)
; 6 - BMXNUM (opt) Include IEN as first returned field (1=true)
;
;---> Set variables, kill temp globals.
N BMX31
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
;
I $G(BMXFLDS)="" S BMXFLDS=".01"
;
;---> 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
;
;---> If Return IEN not set, set to No
I '$D(BMXNUM) S BMXNUM=0
S BMXNUM=+BMXNUM
;
;---> Fileman call
D GETS^DIQ(BMXFL,BMXIENS,BMXFLDS,BMXFLG,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,F,ASDX,ASDC,ASDXFNUM,ASDXFNAM
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
I BMXNUM S $P(ASDX,"^",1)="IEN"
;F ASDC=1:1:$L(BMXFLDS,";") D
S ASDC=1
S ASDXFNUM=0
F S ASDXFNUM=$O(^BMXTMP($J,BMXFL,BMXIENS,ASDXFNUM)) Q:'ASDXFNUM D
. ;S ASDXFNUM=$P(BMXFLDS,";",ASDC)
. S ASDXFNAM=$P(^DD(BMXFL,ASDXFNUM,0),"^")
. S:ASDXFNAM="" ASDXFNAM="UNKNOWN"_ASDC
. S $P(ASDX,"^",ASDC+BMXNUM)=ASDXFNAM
. S ASDC=ASDC+1
S ^BMXTEMP($J,1)=ASDX_$C(30)
;---> Write valid results.
AAA ;---> Loop through results global
S I=2,N=0 F S N=$O(^BMXTMP($J,BMXFL,N)) Q:'N D
. S X="",F=0
. I BMXNUM S X=+N
. F S F=$O(^BMXTMP($J,BMXFL,N,F)) Q:'F D
. . S:X'="" X=X_U
. . I $P(^DD(BMXFL,F,0),U,2) D I 1 ;Multiple or WP
. . . ;Get the subfile number into FL1
. . . S FL1=+$P(^DD(BMXFL,F,0),U,2)
. . . S FLD1=$O(^DD(FL1,0))
. . . I $P(^DD(FL1,FLD1,0),U,2)["W" D ;WP
. . . . S WPL=0 F S WPL=$O(^BMXTMP($J,BMXFL,N,F,WPL)) Q:'WPL D
. . . . . S X=X_^BMXTMP($J,BMXFL,N,F,WPL)_" "
. . . . . Q
. . . . Q
. . . D ;It's a multiple. Implement in next phase
. . . . Q ;
. . . Q
. . E D ;Not a multiple
. . . S X=X_^BMXTMP($J,BMXFL,N,F)
. . . Q
. . Q
. ;---> Convert data to mixed case if BMXMC=1.
ZZZ . S:BMXMC X=$$T^BMXTRS(X)
. ;
. ;---> Set data in result global.
. S ^BMXTEMP($J,I)=X_$C(30)
. S I=I+1
;
;---> 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
BMXGETS ; IHS/OIT/HMW - BMX REMOTE PROCEDURE CALLS ;
+1 ;;4.0;BMX;;JUN 28, 2010
+2 ;
+3 ;;Horace Whitt
+4 ;;Interface to GETS^DIQ
+5 ;
+6 ;----------
GETS(BMXGBL,BMXFL,BMXIENS,BMXFLDS,BMXFLG,BMXMC,BMXNUM) ;EP
+1 ;---> The final record (node) contains Error Delimiter,
+2 ; $C(31)_$C(31), followed by error text, if any.
+3 ;
+4 ;---> Parameters:
+5 ; 1 - BMXGBL (ret) Name of result global for Broker.
+6 ; 2 - BMXFL (req) File number for lookup.
+7 ; 3 - BMXFLDS (req) Fields to return w/each entry in IENS format.
+8 ; 4 - BMXFLG (opt) Flags - See GETS^DIQ documentation
+9 ; 9 - BMXMC (opt) Mixed Case: 1=mixed case, 0=no change.
+10 ; (Converts data in uppercase to mixed case.)
+11 ; 6 - BMXNUM (opt) Include IEN as first returned field (1=true)
+12 ;
+13 ;---> Set variables, kill temp globals.
+14 NEW BMX31
+15 SET BMX31=$CHAR(31)_$CHAR(31)
+16 SET BMXGBL="^BMXTEMP("_$JOB_")"
SET BMXERR=""
SET U="^"
+17 KILL ^BMXTMP($JOB),^BMXTEMP($JOB)
+18 ;
+19 ;---> If file number not provided, return error.
+20 IF '$GET(BMXFL)
DO ERROUT("File number not provided.",1)
QUIT
+21 ;
+22 IF $GET(BMXFLDS)=""
SET BMXFLDS=".01"
+23 ;
+24 ;---> Set Target Global for output and errors.
+25 SET BMXG="^BMXTMP($J)"
+26 ;
+27 ;---> If Mixed Case not set, set to No Change.
+28 IF '$DATA(BMXMC)
SET BMXMC=0
+29 ;
+30 ;---> If Return IEN not set, set to No
+31 IF '$DATA(BMXNUM)
SET BMXNUM=0
+32 SET BMXNUM=+BMXNUM
+33 ;
+34 ;---> Fileman call
+35 DO GETS^DIQ(BMXFL,BMXIENS,BMXFLDS,BMXFLG,BMXG,BMXG)
+36 ;
+37 DO WRITE
+38 QUIT
+39 ;
+40 ;
+41 ;----------
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,F,ASDX,ASDC,ASDXFNUM,ASDXFNAM
+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 IF BMXNUM
SET $PIECE(ASDX,"^",1)="IEN"
+17 ;F ASDC=1:1:$L(BMXFLDS,";") D
+18 SET ASDC=1
+19 SET ASDXFNUM=0
+20 FOR
SET ASDXFNUM=$ORDER(^BMXTMP($JOB,BMXFL,BMXIENS,ASDXFNUM))
IF 'ASDXFNUM
QUIT
Begin DoDot:1
+21 ;S ASDXFNUM=$P(BMXFLDS,";",ASDC)
+22 SET ASDXFNAM=$PIECE(^DD(BMXFL,ASDXFNUM,0),"^")
+23 IF ASDXFNAM=""
SET ASDXFNAM="UNKNOWN"_ASDC
+24 SET $PIECE(ASDX,"^",ASDC+BMXNUM)=ASDXFNAM
+25 SET ASDC=ASDC+1
End DoDot:1
+26 SET ^BMXTEMP($JOB,1)=ASDX_$CHAR(30)
+27 ;---> Write valid results.
AAA ;---> Loop through results global
+1 SET I=2
SET N=0
FOR
SET N=$ORDER(^BMXTMP($JOB,BMXFL,N))
IF 'N
QUIT
Begin DoDot:1
+2 SET X=""
SET F=0
+3 IF BMXNUM
SET X=+N
+4 FOR
SET F=$ORDER(^BMXTMP($JOB,BMXFL,N,F))
IF 'F
QUIT
Begin DoDot:2
+5 IF X'=""
SET X=X_U
+6 ;Multiple or WP
IF $PIECE(^DD(BMXFL,F,0),U,2)
Begin DoDot:3
+7 ;Get the subfile number into FL1
+8 SET FL1=+$PIECE(^DD(BMXFL,F,0),U,2)
+9 SET FLD1=$ORDER(^DD(FL1,0))
+10 ;WP
IF $PIECE(^DD(FL1,FLD1,0),U,2)["W"
Begin DoDot:4
+11 SET WPL=0
FOR
SET WPL=$ORDER(^BMXTMP($JOB,BMXFL,N,F,WPL))
IF 'WPL
QUIT
Begin DoDot:5
+12 SET X=X_^BMXTMP($JOB,BMXFL,N,F,WPL)_" "
+13 QUIT
End DoDot:5
+14 QUIT
End DoDot:4
+15 ;It's a multiple. Implement in next phase
Begin DoDot:4
+16 ;
QUIT
End DoDot:4
+17 QUIT
End DoDot:3
IF 1
+18 ;Not a multiple
IF '$TEST
Begin DoDot:3
+19 SET X=X_^BMXTMP($JOB,BMXFL,N,F)
+20 QUIT
End DoDot:3
+21 QUIT
End DoDot:2
+22 ;---> Convert data to mixed case if BMXMC=1.
ZZZ IF BMXMC
SET X=$$T^BMXTRS(X)
+1 ;
+2 ;---> Set data in result global.
+3 SET ^BMXTEMP($JOB,I)=X_$CHAR(30)
+4 SET I=I+1
End DoDot:1
+5 ;
+6 ;---> If no results, report it as an error.
+7 IF '$ORDER(^BMXTEMP($JOB,0))
Begin DoDot:1
+8 IF BMXIN]""
SET BMXERR="No entry matches """_BMXIN_"""."
QUIT
+9 SET BMXERR="Either the lookup file is empty"
+10 SET BMXERR=BMXERR_" or all entries are screened (software error)."
End DoDot:1
+11 ;
+12 ;---> Tack on Error Delimiter and any error.
+13 SET ^BMXTEMP($JOB,I)=BMX31_BMXERR
+14 QUIT
+15 ;
+16 ;
+17 ;----------
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
